http-media 0.2.0 → 0.3.0

raw patch · 14 files changed

+449/−42 lines, 14 files

Files

• http-media.cabal +17/−10
• src/Network/HTTP/Media.hs +43/−4
• src/Network/HTTP/Media/Accept.hs +16/−2
• src/Network/HTTP/Media/Language.hs +12/−0
• src/Network/HTTP/Media/Language/Internal.hs +80/−0
• src/Network/HTTP/Media/MediaType.hs +2/−1
• src/Network/HTTP/Media/MediaType/Internal.hs +2/−3
• src/Network/HTTP/Media/Utils.hs +10/−2
• test/Network/HTTP/Media/Gen.hs +26/−11
• test/Network/HTTP/Media/Language/Gen.hs +119/−0
• test/Network/HTTP/Media/Language/Tests.hs +115/−0
• test/Network/HTTP/Media/MediaType/Gen.hs +1/−5
• test/Network/HTTP/Media/MediaType/Tests.hs +4/−3
• test/Tests.hs +2/−1

@@ -1,5 +1,5 @@ name:          http-media-version:       0.2.0+version:       0.3.0 license:       MIT license-file:  LICENSE author:        Timothy Jones@@ -12,15 +12,16 @@ 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.+  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:+  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)@@ -28,7 +29,7 @@   >     ]   .   Similarly, the Content-Type header can be used to produce a parser for request-  bodies based on the given content type:+  bodies based on the given content type with 'mapContentMedia':   .   > getContentType >>= maybe send415Error readRequestBodyWith . mapContentMedia   >     [ ("application/json", parseJson)@@ -51,8 +52,10 @@     Network.HTTP.Media     Network.HTTP.Media.Accept     Network.HTTP.Media.MediaType+    Network.HTTP.Media.Language   other-modules:     Network.HTTP.Media.MediaType.Internal+    Network.HTTP.Media.Language.Internal     Network.HTTP.Media.Quality     Network.HTTP.Media.Utils   build-depends:@@ -79,6 +82,10 @@     Network.HTTP.Media.MediaType.Gen     Network.HTTP.Media.MediaType.Internal     Network.HTTP.Media.MediaType.Tests+    Network.HTTP.Media.Language+    Network.HTTP.Media.Language.Gen+    Network.HTTP.Media.Language.Internal+    Network.HTTP.Media.Language.Tests     Network.HTTP.Media.Quality     Network.HTTP.Media.Tests     Network.HTTP.Media.Utils

@@ -12,16 +12,21 @@     , (/?)     , (/.) +    -- * Languages+    , Language+     -- * Accept matching     , matchAccept     , mapAccept     , mapAcceptMedia+    , mapAcceptLanguage     , mapAcceptBytes      -- * Content matching     , matchContent     , mapContent     , mapContentMedia+    , mapContentLanguage      -- * Quality values     , Quality@@ -44,6 +49,7 @@  ------------------------------------------------------------------------------ import Network.HTTP.Media.Accept    as Accept+import Network.HTTP.Media.Language  as Language import Network.HTTP.Media.MediaType as MediaType import Network.HTTP.Media.Quality import Network.HTTP.Media.Utils@@ -89,7 +95,7 @@   --------------------------------------------------------------------------------- | A specialisation of 'mapAccept' that only takes MediaType as its input,+-- | 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@@ -104,9 +110,25 @@   --------------------------------------------------------------------------------- | A specialisation of 'mapAccept' that only takes ByteString as its input,+-- | A specialisation of 'mapAccept' that only takes 'Language' as its input, -- to avoid ambiguous-type errors when using string literal overloading. --+-- > getHeader >>= maybe render406Error renderResource . mapAcceptLanguage+-- >     [ ("text/html",        asHtml)+-- >     , ("application/json", asJson)+-- >     ]+mapAcceptLanguage ::+    [(Language, b)]  -- ^ The map of server-side preferences to values+    -> ByteString    -- ^ The client-side header value+    -> Maybe b+mapAcceptLanguage = mapAccept+++------------------------------------------------------------------------------+-- | A specialisation of 'mapAccept' that only takes 'ByteString' as its+-- input, to avoid ambiguous-type errors when using string literal+-- overloading.+-- -- > getHeader >>= maybe render406Error encodeResourceWith . mapAcceptBytes -- >     [ ("compress", compress) -- >     , ("gzip",     gzip)@@ -156,8 +178,9 @@   --------------------------------------------------------------------------------- | A specialisation of 'mapContent' that only takes MediaType as its input,--- to avoid ambiguous-type errors when using string literal overloading.+-- | 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@@ -169,6 +192,22 @@     -> ByteString        -- ^ The client request's header value     -> Maybe b mapContentMedia = mapContent+++------------------------------------------------------------------------------+-- | A specialisation of 'mapContent' that only takes 'Language' as its input,+-- to avoid ambiguous-type errors when using string literal overloading.+--+-- > getContentType >>=+-- >     maybe send415Error readRequestBodyWith . mapContentLanguage+-- >         [ ("application/json", parseJson)+-- >         , ("text/plain",       parseText)+-- >         ]+mapContentLanguage+    :: [(Language, b)]  -- ^ The map of server-side responses+    -> ByteString        -- ^ The client request's header value+    -> Maybe b+mapContentLanguage = mapContent   ------------------------------------------------------------------------------

@@ -31,11 +31,25 @@     showAccept :: a -> String     showAccept = show -    -- | Evaluates whether either the left argument matches the right one-    -- (order may be important).+    -- | 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  instance Accept ByteString where

@@ -0,0 +1,12 @@+------------------------------------------------------------------------------+-- | Defines the 'Language' accept header with an 'Accept' instance for use in+-- language negotiation.+module Network.HTTP.Media.Language+    ( Language+    , toList+    , toByteString+    ) where++------------------------------------------------------------------------------+import Network.HTTP.Media.Language.Internal+

@@ -0,0 +1,80 @@+------------------------------------------------------------------------------+-- | Defines the 'Language' accept header with an 'Accept' instance for use in+-- language negotiation.+module Network.HTTP.Media.Language.Internal+    ( Language (..)+    , toList+    , toByteString+    ) where++------------------------------------------------------------------------------+import qualified Data.ByteString      as BS+import qualified Data.ByteString.UTF8 as BS hiding (length)++------------------------------------------------------------------------------+import Control.Monad   (guard)+import Data.ByteString (ByteString)+import Data.Functor    ((<$>))+import Data.List       (isPrefixOf)+import Data.Maybe      (fromMaybe)+import Data.String     (IsString (..))++------------------------------------------------------------------------------+import Network.HTTP.Media.Accept (Accept (..))+import Network.HTTP.Media.Utils  (hyphen, isAlpha)+++------------------------------------------------------------------------------+-- | Suitable for HTTP language-ranges as defined in+-- <http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html#sec14.4 RFC2616>.+--+-- Specifically:+--+-- > language-range = ( ( 1*8ALPHA *( "-" 1*8ALPHA ) ) | "*" )+newtype Language = Language [ByteString]+    deriving (Eq)++-- Note that internally, Language [] equates to *.++instance Show Language where+    show = BS.toString . toByteString++instance IsString Language where+    fromString "*" = Language []+    fromString str = flip fromMaybe (parseAccept $ BS.fromString str) $+        error $ "Invalid language literal " ++ str++instance Accept Language where+    parseAccept "*" = Just $ Language []+    parseAccept bs = do+        let pieces = BS.split hyphen bs+        guard $ not (null pieces)+        Language <$> mapM check pieces+      where+        check part = do+            let len = BS.length part+            guard $ len >= 1 && len <= 8 && BS.all isAlpha part+            return 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+++------------------------------------------------------------------------------+-- | Converts 'Language' to a list of its language parts. The wildcard+-- produces an empty list.+toList :: Language -> [ByteString]+toList (Language l) = l+++------------------------------------------------------------------------------+-- | Converts 'Language' to 'ByteString'.+toByteString :: Language -> ByteString+toByteString (Language []) = "*"+toByteString (Language l)  = BS.intercalate "-" l+

@@ -1,5 +1,6 @@ --------------------------------------------------------------------------------- | Defines the media type types and functions.+-- | Defines the 'MediaType' accept header with an 'Accept' instance for use+-- in content-type negotiation. module Network.HTTP.Media.MediaType     (     -- * Type and creation

@@ -14,7 +14,6 @@ ------------------------------------------------------------------------------ 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)@@ -35,9 +34,9 @@  instance Show MediaType where     show (MediaType a b p) =-        Map.foldrWithKey f (toString a ++ '/' : toString b) p+        Map.foldrWithKey f (BS.toString a ++ '/' : BS.toString b) p       where-        f k v = (++ ';' : toString k ++ '=' : toString v)+        f k v = (++ ';' : BS.toString k ++ '=' : BS.toString v)  instance IsString MediaType where     fromString str = flip fromMaybe (parseAccept $ BS.fromString str) $

@@ -4,6 +4,7 @@     ( breakByte     , trimBS +    , isAlpha     , validChars     , isValidChar @@ -12,6 +13,7 @@     , comma     , space     , equal+    , hyphen     ) where  ------------------------------------------------------------------------------@@ -38,6 +40,12 @@   ------------------------------------------------------------------------------+-- | Evaluates whether the given character is in the standard ASCII alphabet.+isAlpha :: Word8 -> Bool+isAlpha c = c >= 65 && c <= 90 || c >= 97 && c <= 122+++------------------------------------------------------------------------------ -- | List of the valid characters for a media-type `reg-name` as per RFC 4288. validChars :: [Word8] validChars =@@ -54,6 +62,6 @@  ------------------------------------------------------------------------------ -- | 'ByteString' compatible characters.-slash, semi, comma, space, equal :: Word8-[slash, semi, comma, space, equal] = [47, 59, 44, 32, 61]+slash, semi, comma, space, equal, hyphen :: Word8+[slash, semi, comma, space, equal, hyphen] = [47, 59, 44, 32, 61, 45] 

@@ -1,28 +1,43 @@ ------------------------------------------------------------------------------ -- | Contains definitions for generating 'ByteString's. module Network.HTTP.Media.Gen-    ( genByteString+    ( genByteStringFrom+    , genByteString+    , genDiffByteStringWith     , genDiffByteString     ) where  -------------------------------------------------------------------------------import Control.Monad       (liftM)+import Control.Applicative ((<$>)) import Data.ByteString     (ByteString, pack)-import Test.QuickCheck.Gen (Gen, listOf1, oneof)+import Data.Word           (Word8)+import Test.QuickCheck.Gen (Gen, elements, listOf1)   --------------------------------------------------------------------------------- | Produces a ByteString of random alpha characters.+-- | Produces a non-empty ByteString of random characters from the given set.+genByteStringFrom :: [Word8] -> Gen ByteString+genByteStringFrom validChars = pack <$> listOf1 (elements validChars)+++------------------------------------------------------------------------------+-- | Produces a non-empty ByteString of random alphanumeric characters. genByteString :: Gen ByteString-genByteString = liftM pack $ listOf1 (oneof $ map return validChars)-  where-    validChars = [48..57] ++ [65..90] ++ [97..122]+genByteString = genByteStringFrom $ [48..57] ++ [65..90] ++ [97..122]   --------------------------------------------------------------------------------- | Produces a random ByteString different to the given one.+-- | Produces a non-empty ByteString different to the given one using the+-- given generator.+genDiffByteStringWith :: Gen ByteString -> ByteString -> Gen ByteString+genDiffByteStringWith gen bs = do+    bs' <- gen+    if bs == bs' then genDiffByteStringWith gen bs else return bs'+++------------------------------------------------------------------------------+-- | Produces a non-empty ByteString of random alphanumeric characters+-- different to the given one. genDiffByteString :: ByteString -> Gen ByteString-genDiffByteString bs = do-    bs' <- genByteString-    if bs == bs' then genDiffByteString bs else return bs'+genDiffByteString = genDiffByteStringWith genByteString 

@@ -0,0 +1,119 @@+{-# 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 Control.Applicative ((<$>))+import Data.ByteString     (ByteString)+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 genByteString+++------------------------------------------------------------------------------+-- | Generates a Language that does not match everything.+genConcreteLanguage :: Gen Language+genConcreteLanguage = Language <$> listOf1 genByteString+++------------------------------------------------------------------------------+-- | Generates a different Language to the given one.+genDiffLanguage :: Language -> Gen Language+genDiffLanguage (Language []) = genConcreteLanguage+genDiffLanguage lang           = do+    lang' <- genLanguage+    if lang == lang' then genDiffLanguage lang else return lang'+++------------------------------------------------------------------------------+-- | Generate a Language that has the given language as a prefix.+genMatchingLanguage :: Language -> Gen Language+genMatchingLanguage (Language pre) =+    (Language . (pre ++)) <$> listOf genByteString+++------------------------------------------------------------------------------+-- | Generate a Language that has the given language as a proper prefix.+genDiffMatchingLanguage :: Language -> Gen Language+genDiffMatchingLanguage (Language pre) =+    (Language . (pre ++)) <$> listOf1 genByteString+++------------------------------------------------------------------------------+-- | 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' <- genDiffByteString 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+++------------------------------------------------------------------------------+genByteString :: Gen ByteString+genByteString = resize 8 $ Gen.genByteStringFrom ([65..90] ++ [97..122])+++------------------------------------------------------------------------------+genDiffByteString :: ByteString -> Gen ByteString+genDiffByteString = Gen.genDiffByteStringWith genByteString+

@@ -0,0 +1,115 @@+------------------------------------------------------------------------------+module Network.HTTP.Media.Language.Tests (tests) where++------------------------------------------------------------------------------+import qualified Data.ByteString.UTF8 as BS++------------------------------------------------------------------------------+import Control.Applicative               ((<$>))+import Control.Monad                     (join)+import Data.String                       (fromString)+import Distribution.TestSuite.QuickCheck++------------------------------------------------------------------------------+import Network.HTTP.Media.Accept+import Network.HTTP.Media.Language+import Network.HTTP.Media.Language.Gen+++------------------------------------------------------------------------------+tests :: [Test]+tests =+    [ testEq+    , testShow+    , testFromString+    , testMatches+    , testMoreSpecific+    , testMostSpecific+    , testParseAccept+    ]+++------------------------------------------------------------------------------+-- Equality is derived, but we test it here to get 100% coverage.+testEq :: Test+testEq = testGroup "Eq"+    [ testProperty "==" $ do+        lang <- genLanguage+        return $ lang == lang+    , testProperty "/=" $ do+        lang  <- genLanguage+        lang' <- genDiffLanguage lang+        return $ lang /= lang'+    ]+++------------------------------------------------------------------------------+testShow :: Test+testShow = testProperty "show" $ do+    lang <- genLanguage+    return $ parseAccept (BS.fromString $ show lang) == Just lang+++------------------------------------------------------------------------------+testFromString :: Test+testFromString = testProperty "fromString" $ do+    lang <- genLanguage+    return $ lang == fromString (show lang)+++------------------------------------------------------------------------------+testMatches :: Test+testMatches = testGroup "matches"+    [ testProperty "Equal values match" $+        join matches <$> genLanguage+    , testProperty "Right prefix matches left" $+        uncurry (flip matches) <$> genMatchingLanguages+    , testProperty "Left prefix does not match right" $+        not . uncurry matches <$> genDiffMatchingLanguages+    , testProperty "* matches anything" $+        flip matches anything <$> genLanguage+    , testProperty "No concrete language matches *" $+        not . matches anything <$> genConcreteLanguage+    ]+++------------------------------------------------------------------------------+testMoreSpecific :: Test+testMoreSpecific = testGroup "moreSpecificThan"+    [ testProperty "Against *" $+        flip moreSpecificThan anything <$> genConcreteLanguage+    , testProperty "With *" $+        not . moreSpecificThan anything <$> genLanguage+    , testProperty "Proper prefix lhs" $+        not . uncurry moreSpecificThan <$> genDiffMatchingLanguages+    , testProperty "Proper prefix rhs" $+        uncurry (flip moreSpecificThan) <$> genDiffMatchingLanguages+    , testProperty "Unrelated languages" $+        not . uncurry moreSpecificThan <$> genNonMatchingLanguages+    ]+++------------------------------------------------------------------------------+testMostSpecific :: Test+testMostSpecific = testGroup "mostSpecific"+    [ testProperty "With *" $ do+        lang <- genLanguage+        return $ mostSpecific lang anything == lang &&+            mostSpecific anything lang == lang+    , testProperty "Proper prefix" $ do+        (pre, lang) <- genMatchingLanguages+        return $ mostSpecific lang pre == lang &&+            mostSpecific pre lang == lang+    , testProperty "Left biased" $ do+        (lang, lang') <- genNonMatchingLanguages+        return $ mostSpecific lang lang' == lang &&+            mostSpecific lang' lang == lang'+    ]+++------------------------------------------------------------------------------+testParseAccept :: Test+testParseAccept = testProperty "parseAccept" $ do+    lang <- genLanguage+    return $ parseAccept (toByteString lang) == Just lang+

@@ -2,12 +2,8 @@ -- | Contains definitions for generating 'MediaType's. module Network.HTTP.Media.MediaType.Gen     (-    -- * Generating ByteStrings-      genByteString-    , genDiffByteString-     -- * Generating MediaTypes-    , anything+      anything     , genMediaType     , genSubStar     , genMaybeSubStar

@@ -14,6 +14,7 @@  ------------------------------------------------------------------------------ import Network.HTTP.Media.Accept+import Network.HTTP.Media.Gen import Network.HTTP.Media.MediaType          ((/?), (/.)) import Network.HTTP.Media.MediaType.Internal import Network.HTTP.Media.MediaType.Gen@@ -130,7 +131,7 @@  ------------------------------------------------------------------------------ testMoreSpecificThan :: Test-testMoreSpecificThan = testGroup "isMoreSpecific"+testMoreSpecificThan = testGroup "moreSpecificThan"     [ testProperty "Against */*" $         liftM (`moreSpecificThan` anything) genMaybeSubStar     , testProperty "With */*" $@@ -192,9 +193,9 @@     let main   = mainType media         sub    = subType media         params = parameters media-    let (Just parsed) = parseAccept $ main <> "/" <> sub <> mconcat+        parsed = parseAccept $ main <> "/" <> sub <> mconcat             (map (uncurry ((<>) . (<> "=") . (";" <>))) $ Map.toList params)-    return $ parsed == media+    return $ parsed == Just media   ------------------------------------------------------------------------------

@@ -8,6 +8,7 @@ import qualified Network.HTTP.Media.Tests           as Media import qualified Network.HTTP.Media.Accept.Tests    as Accept import qualified Network.HTTP.Media.MediaType.Tests as MediaType+import qualified Network.HTTP.Media.Language.Tests  as Language   ------------------------------------------------------------------------------@@ -16,5 +17,5 @@     [ testGroup "MediaType" MediaType.tests     , testGroup "Accept"    Accept.tests     , testGroup "Media"     Media.tests+    , testGroup "Language"  Language.tests     ]-