http-media 0.4.0 → 0.5.0

raw patch · 19 files changed

+303/−217 lines, 19 filesdep +case-insensitivedep −utf8-stringdep ~Cabaldep ~basedep ~bytestringsetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: case-insensitive

Dependencies removed: utf8-string

Dependency ranges changed: Cabal, base, bytestring, cabal-test-quickcheck, containers

API changes (from Hackage documentation)

Files

• LICENSE +1/−2
• Setup.hs +0/−1
• http-media.cabal +16/−18
• src/Network/HTTP/Media.hs +26/−10
• src/Network/HTTP/Media/Accept.hs +16/−1
• src/Network/HTTP/Media/Language.hs +3/−3
• src/Network/HTTP/Media/Language/Internal.hs +16/−16
• src/Network/HTTP/Media/MediaType.hs +16/−16
• src/Network/HTTP/Media/MediaType/Internal.hs +29/−24
• src/Network/HTTP/Media/Quality.hs +34/−18
• src/Network/HTTP/Media/RenderHeader.hs +0/−1
• src/Network/HTTP/Media/Utils.hs +13/−39
• test/Network/HTTP/Media/Accept/Tests.hs +0/−1
• test/Network/HTTP/Media/Gen.hs +49/−15
• test/Network/HTTP/Media/Language/Gen.hs +14/−15
• test/Network/HTTP/Media/Language/Tests.hs +2/−3
• test/Network/HTTP/Media/MediaType/Gen.hs +30/−12
• test/Network/HTTP/Media/MediaType/Tests.hs +13/−14
• test/Network/HTTP/Media/Tests.hs +25/−8

@@ -1,4 +1,4 @@-Copyright (c) 2012-2014 Timothy Jones+Copyright (c) 2012-2015 Timothy Jones  Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in@@ -17,4 +17,3 @@ 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.-

@@ -4,4 +4,3 @@  main :: IO () main = defaultMain-

@@ -1,13 +1,13 @@ name:          http-media-version:       0.4.0+version:       0.5.0 license:       MIT license-file:  LICENSE author:        Timothy Jones maintainer:    Timothy Jones <git@zmthy.io>-homepage:      http://github.com/zmthy/http-media-bug-reports:   http://github.com/zmthy/http-media/issues+homepage:      https://github.com/zmthy/http-media+bug-reports:   https://github.com/zmthy/http-media/issues+copyright:     (c) 2012-2015 Timothy Jones category:      Web-copyright:     (c) 2012-2014 Timothy Jones build-type:    Simple cabal-version: >= 1.10 synopsis:      Processing HTTP Content-Type and Accept headers@@ -38,7 +38,6 @@   .   The API is agnostic to your choice of server. - library   hs-source-dirs: src @@ -60,10 +59,10 @@     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+    base             >= 4.6  && < 5.0,+    bytestring       >= 0.10 && < 0.11,+    case-insensitive >= 1.0  && < 1.3,+    containers       >= 0.5  && < 0.6  test-suite test-http-media   type:           detailed-0.9@@ -92,18 +91,17 @@     Network.HTTP.Media.Tests     Network.HTTP.Media.Utils -  ghc-options: -Wall -fhpc+  ghc-options: -Wall -Werror    build-depends:-    base                  >= 4.6.0  && < 5.0,-    bytestring            >= 0.10.0 && < 0.11,-    Cabal                 >= 1.18.0 && < 1.21,-    cabal-test-quickcheck >= 0.1.0  && < 0.2,-    containers            >= 0.5.0  && < 0.6,-    QuickCheck            >= 2.6    && < 2.9,-    utf8-string           >= 0.3.7  && < 0.4+    base                  >= 4.6  && < 5.0,+    bytestring            >= 0.10 && < 0.11,+    Cabal                 >= 1.19 && < 1.23,+    cabal-test-quickcheck >= 0.1  && < 0.2,+    case-insensitive      >= 1.0  && < 1.3,+    containers            >= 0.5  && < 0.6,+    QuickCheck            >= 2.6  && < 2.9  source-repository head   type:     git   location: git://github.com/zmthy/http-media.git-

@@ -43,13 +43,13 @@     ) where  -------------------------------------------------------------------------------import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS  ------------------------------------------------------------------------------ import Control.Applicative  (pure, (<$>), (<*>), (<|>)) import Control.Monad        (guard, (>=>))-import Data.ByteString      (ByteString, split)-import Data.ByteString.UTF8 (toString)+import Data.ByteString      (ByteString)+import Data.Maybe           (fromMaybe)  ------------------------------------------------------------------------------ import Network.HTTP.Media.Accept       as Accept@@ -57,7 +57,7 @@ import Network.HTTP.Media.Language     as Language import Network.HTTP.Media.MediaType    as MediaType import Network.HTTP.Media.Quality-import Network.HTTP.Media.Utils+import Network.HTTP.Media.Utils        (trimBS)   ------------------------------------------------------------------------------@@ -218,13 +218,30 @@ ------------------------------------------------------------------------------ -- | 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)+parseQuality = parseQuality' Proxy +parseQuality' :: Accept a => Proxy a -> ByteString -> Maybe [Quality a]+parseQuality' p = (. map trimBS . BS.split ',') . mapM $ \ s ->+    let (accept, q) = fromMaybe (s, Nothing) $ if ext then findQ s else getQ s+    in maybe (pure maxQuality) (fmap (flip Quality) . readQ) q <*>+        parseAccept accept+  where+    ext = hasExtensionParameters p +    -- Split on ';', and check if a quality value is there. A value of Nothing+    -- indicates there was no parameter, whereas a value of Nothing in the+    -- pair indicates the parameter was not a quality value.+    getQ s = let (a, b) = trimBS <$> BS.breakEnd (== ';') s in+        if BS.null a then Nothing else Just (BS.init a,+            if BS.isPrefixOf "q=" b then Just (BS.drop 2 b) else Nothing)++    -- Trawl backwards through the string, ignoring extension parameters.+    findQ s = do+        let q = getQ s+        (a, m) <- q+        maybe (findQ a) (const q) m++ ------------------------------------------------------------------------------ -- | Matches a list of server-side resource options against a pre-parsed -- quality-marked list of client-side preferences. A result of 'Nothing' means@@ -283,4 +300,3 @@     | Accept.matches k a = Just v     | otherwise         = lookupMatches r a lookupMatches [] _ = Nothing-

@@ -4,9 +4,13 @@ module Network.HTTP.Media.Accept     ( Accept (..)     , mostSpecific+    , Proxy (..)     ) where  ------------------------------------------------------------------------------+import qualified Data.CaseInsensitive as CI++------------------------------------------------------------------------------ import Data.ByteString (ByteString)  @@ -43,9 +47,15 @@     -- concept of specificity, this is the empty relation (always false).     moreSpecificThan :: a -> a -> Bool +    -- | Indicates whether extension parameters are permitted after the weight+    -- parameter when this type appears in an Accept header. Defaults to+    -- false.+    hasExtensionParameters :: Proxy a -> Bool+    hasExtensionParameters _ = False+ instance Accept ByteString where     parseAccept = Just-    matches = (==)+    matches a b = CI.mk a == CI.mk b     moreSpecificThan _ _ = False  @@ -56,3 +66,8 @@     | b `moreSpecificThan` a = b     | otherwise              = a ++------------------------------------------------------------------------------+-- | Serves the same purpose as the Proxy type in base, but redefined here in+-- a basic form for older versions of base that do not include it.+data Proxy a = Proxy

@@ -7,7 +7,8 @@     ) where  -------------------------------------------------------------------------------import Data.ByteString (ByteString)+import Data.ByteString      (ByteString)+import Data.CaseInsensitive (CI)  ------------------------------------------------------------------------------ import Network.HTTP.Media.Language.Internal@@ -16,6 +17,5 @@ ------------------------------------------------------------------------------ -- | Converts 'Language' to a list of its language parts. The wildcard -- produces an empty list.-toParts :: Language -> [ByteString]+toParts :: Language -> [CI ByteString] toParts (Language l) = l-

@@ -6,21 +6,22 @@     ) where  -------------------------------------------------------------------------------import qualified Data.ByteString      as BS-import qualified Data.ByteString.UTF8 as BS hiding (length)+import qualified Data.ByteString.Char8 as BS+import qualified Data.CaseInsensitive  as CI  -------------------------------------------------------------------------------import Control.Monad   (guard)-import Data.ByteString (ByteString)-import Data.Functor    ((<$>))-import Data.List       (isPrefixOf)-import Data.Maybe      (fromMaybe)-import Data.String     (IsString (..))+import Control.Monad        (guard)+import Data.ByteString      (ByteString)+import Data.CaseInsensitive (CI, original)+import Data.Char            (isAlpha)+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.RenderHeader (RenderHeader (..))-import Network.HTTP.Media.Utils        (hyphen, isAlpha)   ------------------------------------------------------------------------------@@ -30,30 +31,30 @@ -- Specifically: -- -- > language-range = ( ( 1*8ALPHA *( "-" 1*8ALPHA ) ) | "*" )-newtype Language = Language [ByteString]+newtype Language = Language [CI ByteString]     deriving (Eq)  -- Note that internally, Language [] equates to *.  instance Show Language where-    show = BS.toString . renderHeader+    show = BS.unpack . renderHeader  instance IsString Language where     fromString "*" = Language []-    fromString str = flip fromMaybe (parseAccept $ BS.fromString str) $+    fromString str = flip fromMaybe (parseAccept $ BS.pack str) $         error $ "Invalid language literal " ++ str  instance Accept Language where     parseAccept "*" = Just $ Language []     parseAccept bs = do-        let pieces = BS.split hyphen bs+        let pieces = BS.split '-' bs         guard $ not (null pieces)         Language <$> mapM check pieces       where         check part = do             let len = BS.length part             guard $ len >= 1 && len <= 8 && BS.all isAlpha part-            return part+            return (CI.mk part)      -- Languages match if the right argument is a prefix of the left.     matches (Language a) (Language b)  = b `isPrefixOf` a@@ -65,5 +66,4 @@  instance RenderHeader Language where     renderHeader (Language []) = "*"-    renderHeader (Language l)  = BS.intercalate "-" l-+    renderHeader (Language l)  = BS.intercalate "-" (map original l)

@@ -18,13 +18,14 @@     ) where  -------------------------------------------------------------------------------import qualified Data.ByteString as BS-import qualified Data.Map        as Map+import qualified Data.ByteString.Char8 as BS+import qualified Data.CaseInsensitive  as CI+import qualified Data.Map              as Map  -------------------------------------------------------------------------------import Data.ByteString (ByteString)-import Data.Map        (empty, insert)-import Data.Word       (Word8)+import Data.ByteString      (ByteString)+import Data.CaseInsensitive (CI)+import Data.Map             (empty, insert)  ------------------------------------------------------------------------------ import qualified Network.HTTP.Media.MediaType.Internal as Internal@@ -37,13 +38,13 @@  ------------------------------------------------------------------------------ -- | Retrieves the main type of a 'MediaType'.-mainType :: MediaType -> ByteString+mainType :: MediaType -> CI ByteString mainType = Internal.mainType   ------------------------------------------------------------------------------ -- | Retrieves the sub type of a 'MediaType'.-subType :: MediaType -> ByteString+subType :: MediaType -> CI ByteString subType = Internal.subType  @@ -70,20 +71,20 @@ ------------------------------------------------------------------------------ -- | Evaluates if a 'MediaType' has a parameter of the given name. (/?) :: MediaType -> ByteString -> Bool-(MediaType _ _ p) /? k = Map.member k p+(MediaType _ _ p) /? k = Map.member (CI.mk k) p   ------------------------------------------------------------------------------ -- | Retrieves a parameter from a 'MediaType'.-(/.) :: MediaType -> ByteString -> Maybe ByteString-(MediaType _ _ p) /. k = Map.lookup k p+(/.) :: MediaType -> ByteString -> Maybe (CI ByteString)+(MediaType _ _ p) /. k = Map.lookup (CI.mk k) p   ------------------------------------------------------------------------------ -- | Ensures that the 'ByteString' matches the ABNF for `reg-name` in RFC -- 4288.-ensureR :: ByteString -> ByteString-ensureR bs = if l == 0 || l > 127+ensureR :: ByteString -> CI ByteString+ensureR bs = CI.mk $ if l == 0 || l > 127     then error $ "Invalid length for " ++ show bs else ensure isValidChar bs   where l = BS.length bs @@ -92,13 +93,12 @@ -- | 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])+ensureV :: ByteString -> CI ByteString+ensureV = CI.mk . ensure (`notElem` ",;")   ------------------------------------------------------------------------------ -- | Ensures the predicate matches for every character in the given string.-ensure :: (Word8 -> Bool) -> ByteString -> ByteString+ensure :: (Char -> Bool) -> ByteString -> ByteString ensure f bs = maybe     (error $ "Invalid character in " ++ show bs) (const bs) (BS.find f bs)-

@@ -6,48 +6,51 @@     ) where  -------------------------------------------------------------------------------import qualified Data.ByteString      as BS-import qualified Data.ByteString.UTF8 as BS-import qualified Data.Map             as Map+import qualified Data.ByteString.Char8 as BS+import qualified Data.CaseInsensitive  as CI+import qualified Data.Map              as Map  -------------------------------------------------------------------------------import Control.Monad   (guard)-import Data.ByteString (ByteString)-import Data.String     (IsString (..))-import Data.Map        (Map)-import Data.Maybe      (fromMaybe)-import Data.Monoid     ((<>))+import Control.Monad        (guard)+import Data.ByteString      (ByteString)+import Data.CaseInsensitive (CI, original)+import Data.String          (IsString (..))+import Data.Map             (Map)+import Data.Maybe           (fromMaybe)+import Data.Monoid          ((<>))  ------------------------------------------------------------------------------ import Network.HTTP.Media.Accept       (Accept (..)) import Network.HTTP.Media.RenderHeader (RenderHeader (..))-import Network.HTTP.Media.Utils+import Network.HTTP.Media.Utils        (breakChar, trimBS)   ------------------------------------------------------------------------------ -- | 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+    { mainType   :: CI ByteString  -- ^ The main type of the MediaType+    , subType    :: CI ByteString  -- ^ The sub type of the MediaType+    , parameters :: Parameters     -- ^ The parameters of the MediaType     } deriving (Eq)  instance Show MediaType where-    show = BS.toString . renderHeader+    show = BS.unpack . renderHeader  instance IsString MediaType where-    fromString str = flip fromMaybe (parseAccept $ BS.fromString str) $+    fromString str = flip fromMaybe (parseAccept $ BS.pack str) $         error $ "Invalid media type literal " ++ str  instance Accept MediaType where     parseAccept bs = do-        let pieces = BS.split semi bs+        let pieces = map trimBS $ BS.split ';' 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+            (a, b)   = both CI.mk (breakChar '/' m)+        guard $ BS.elem '/' m && (a /= "*" || b == "*")+        return $ MediaType a b (foldr insert Map.empty ps)+      where+        both f (a, b) = (f a, f b)+        insert = uncurry Map.insert . both CI.mk . breakChar '='      matches a b         | mainType b == "*" = params@@ -67,13 +70,15 @@         subB = subType b == "*"         params = not (Map.null $ parameters a) && Map.null (parameters b) +    hasExtensionParameters _ = True+ instance RenderHeader MediaType where-    renderHeader (MediaType a b p) = Map.foldrWithKey f (a <> "/" <> b) p+    renderHeader (MediaType a b p) =+        Map.foldrWithKey f (original a <> "/" <> original b) p       where-        f k v = (<> ";" <> k <> "=" <> v)+        f k v = (<> ";" <> original k <> "=" <> original v)   ------------------------------------------------------------------------------ -- | 'MediaType' parameters.-type Parameters = Map ByteString ByteString-+type Parameters = Map (CI ByteString) (CI ByteString)

@@ -4,23 +4,22 @@     ( Quality (..)     , maxQuality     , minQuality+    , showQ     , readQ     ) where  -------------------------------------------------------------------------------import qualified Data.ByteString      as BS-import qualified Data.ByteString.UTF8 as BS+import qualified Data.ByteString.Char8 as BS  ------------------------------------------------------------------------------ import Data.ByteString (ByteString)+import Data.Char       (isDigit) import Data.List       (dropWhileEnd)-import Data.Maybe      (listToMaybe) import Data.Monoid     ((<>)) import Data.Word       (Word16)  ------------------------------------------------------------------------------ import Network.HTTP.Media.RenderHeader (RenderHeader (..))-import Network.HTTP.Media.Utils        (zero)  ------------------------------------------------------------------------------ -- | Attaches a quality value to data.@@ -30,7 +29,7 @@     } deriving (Eq)  instance RenderHeader a => Show (Quality a) where-    show = BS.toString . renderHeader+    show = BS.unpack . renderHeader  instance RenderHeader h => RenderHeader (Quality h) where     renderHeader (Quality a q) = renderHeader a <> ";q=" <> showQ q@@ -53,23 +52,40 @@ showQ :: Word16 -> ByteString showQ 1000 = "1" showQ 0    = "0"-showQ q    = "0." <> BS.replicate (3 - length s) zero <> b+showQ q    = "0." <> BS.replicate (3 - length s) '0' <> b   where     s = show q-    b = BS.fromString (dropWhileEnd (== '0') s)+    b = BS.pack (dropWhileEnd (== '0') s)   ------------------------------------------------------------------------------ -- | Reads the standard quality representation into an integral value.-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+readQ :: ByteString -> Maybe Word16+readQ bs+    | BS.null bs = Nothing+    | h == '1'   = read1 t+    | h == '0'   = read0 t+    | otherwise  = Nothing+  where+    h = BS.head bs+    t = BS.tail bs +read1 :: ByteString -> Maybe Word16+read1 bs+    | BS.null bs || h == '.' && BS.length t < 4 && BS.all (== '0') t+                = Just 1000+    | otherwise = Nothing+  where+    h = BS.head bs+    t = BS.tail bs++read0 :: ByteString -> Maybe Word16+read0 bs+    | BS.null bs = Just 0+    | h == '.' && BS.length t < 4 && BS.all isDigit t+                = Just (toWord (t <> BS.replicate (3 - BS.length t) '0'))+    | otherwise = Nothing+  where+    h = BS.head bs+    t = BS.tail bs+    toWord = read . BS.unpack

@@ -26,4 +26,3 @@  instance RenderHeader h => RenderHeader [h] where     renderHeader = intercalate "," . map renderHeader-

@@ -1,69 +1,43 @@ ----------------------------------------------------------------------------- -- | Common utilities. module Network.HTTP.Media.Utils-    ( breakByte+    ( breakChar     , trimBS -    , isAlpha     , validChars     , isValidChar--    , slash-    , semi-    , comma-    , space-    , equal-    , hyphen-    , zero     ) where  -------------------------------------------------------------------------------import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 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+-- | Equivalent to 'Data.ByteString.break' (on equality against the given+-- character), but leaves out the byte that the string is broken on.+breakChar :: Char -> ByteString -> (ByteString, ByteString)+breakChar c = fmap BS.tail . BS.break (== c)   --------------------------------------------------------------------------------- | Trims space characters from both ends of a ByteString.+-- | Trims tab and space characters from both ends of a ByteString. trimBS :: ByteString -> ByteString-trimBS = BS.reverse . dropSpace . BS.reverse . dropSpace+trimBS = fst . BS.spanEnd isLWS . BS.dropWhile isLWS   where-    dropSpace = BS.dropWhile (== space)------------------------------------------------------------------------------------ | Evaluates whether the given character is in the standard ASCII alphabet.-isAlpha :: Word8 -> Bool-isAlpha c = c >= 65 && c <= 90 || c >= 97 && c <= 122+    isLWS c = c == ' ' || c == '\t'   ------------------------------------------------------------------------------ -- | 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]+validChars :: [Char]+validChars = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "!#$&.+-^_"   ------------------------------------------------------------------------------ -- | Evaluates whether the given character is valid in a media type `reg-name` -- as per RFC 4288.-isValidChar :: 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, hyphen, zero :: Word8-[slash, semi, comma, space, equal, hyphen, zero] =-    [47, 59, 44, 32, 61, 45, 48]-+isValidChar :: Char -> Bool+isValidChar = (`elem` validChars)

@@ -45,4 +45,3 @@ testMostSpecific = testProperty "mostSpecific" $ do     string <- genByteString     liftM ((== string) . mostSpecific string) genByteString-

@@ -2,42 +2,76 @@ -- | Contains definitions for generating 'ByteString's. module Network.HTTP.Media.Gen     ( genByteStringFrom+    , genCIByteStringFrom     , genByteString-    , genDiffByteStringWith+    , genCIByteString+    , genDiffWith     , genDiffByteString+    , genDiffCIByteString++    , padString     ) where  -------------------------------------------------------------------------------import Control.Applicative ((<$>))-import Data.ByteString     (ByteString, pack)-import Data.Word           (Word8)-import Test.QuickCheck.Gen (Gen, elements, listOf1)+import qualified Data.ByteString.Char8 as BS+import qualified Data.CaseInsensitive  as CI +------------------------------------------------------------------------------+import Control.Applicative  ((<$>))+import Control.Monad        (liftM2, join)+import Data.ByteString      (ByteString)+import Data.CaseInsensitive (CI, original)+import Data.Monoid          ((<>))+import Test.QuickCheck.Gen  (Gen, elements, listOf, listOf1) + ------------------------------------------------------------------------------ -- | Produces a non-empty ByteString of random characters from the given set.-genByteStringFrom :: [Word8] -> Gen ByteString-genByteStringFrom validChars = pack <$> listOf1 (elements validChars)+genByteStringFrom :: [Char] -> Gen ByteString+genByteStringFrom = fmap BS.pack . listOf1 . elements   ------------------------------------------------------------------------------+genCIByteStringFrom :: [Char] -> Gen (CI ByteString)+genCIByteStringFrom = fmap CI.mk . genByteStringFrom+++------------------------------------------------------------------------------ -- | Produces a non-empty ByteString of random alphanumeric characters. genByteString :: Gen ByteString-genByteString = genByteStringFrom $ [48..57] ++ [65..90] ++ [97..122]+genByteString = genByteStringFrom (['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'])   ------------------------------------------------------------------------------+genCIByteString :: Gen (CI ByteString)+genCIByteString = fmap CI.mk genByteString+++------------------------------------------------------------------------------ -- | Produces a non-empty ByteString different to the given one using the -- given generator.-genDiffByteStringWith :: Gen ByteString -> ByteString -> Gen ByteString-genDiffByteStringWith gen bs = do-    bs' <- gen-    if bs == bs' then genDiffByteStringWith gen bs else return bs'+genDiffWith :: Eq a => Gen a -> a -> Gen a+genDiffWith gen a = do+    b <- gen+    if a == b then genDiffWith gen a else return b   --------------------------------------------------------------------------------- | Produces a non-empty ByteString of random alphanumeric characters--- different to the given one.+-- | Produces a non-empty ByteString of random alphanumeric characters that+-- is case-insensitively different to the given one. genDiffByteString :: ByteString -> Gen ByteString-genDiffByteString = genDiffByteStringWith genByteString+genDiffByteString = fmap original . genDiffCIByteString . CI.mk ++------------------------------------------------------------------------------+-- | Produces a non-empty case-insensitive ByteString of random alphanumeric+-- characters that is different to the given one.+genDiffCIByteString :: CI ByteString -> Gen (CI ByteString)+genDiffCIByteString = genDiffWith genCIByteString+++------------------------------------------------------------------------------+-- | Pad a 'ByteString' with a random amount of tab and space characters.+padString :: ByteString -> Gen ByteString+padString c = join (liftM2 pad) (BS.pack <$> listOf (elements " \t"))+  where pad a b = a <> c <> b

@@ -18,8 +18,9 @@     ) where  -------------------------------------------------------------------------------import Control.Applicative ((<$>))-import Data.ByteString     (ByteString)+import Control.Applicative  ((<$>))+import Data.ByteString      (ByteString)+import Data.CaseInsensitive (CI) import Test.QuickCheck.Gen  ------------------------------------------------------------------------------@@ -38,36 +39,34 @@ ------------------------------------------------------------------------------ -- | Generates any kind of Language. genLanguage :: Gen Language-genLanguage = Language <$> listOf genByteString+genLanguage = Language <$> listOf genCIByteString   ------------------------------------------------------------------------------ -- | Generates a Language that does not match everything. genConcreteLanguage :: Gen Language-genConcreteLanguage = Language <$> listOf1 genByteString+genConcreteLanguage = Language <$> listOf1 genCIByteString   ------------------------------------------------------------------------------ -- | 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'+genDiffLanguage l             = Gen.genDiffWith genLanguage l   ------------------------------------------------------------------------------ -- | Generate a Language that has the given language as a prefix. genMatchingLanguage :: Language -> Gen Language genMatchingLanguage (Language pre) =-    (Language . (pre ++)) <$> listOf genByteString+    (Language . (pre ++)) <$> listOf genCIByteString   ------------------------------------------------------------------------------ -- | Generate a Language that has the given language as a proper prefix. genDiffMatchingLanguage :: Language -> Gen Language genDiffMatchingLanguage (Language pre) =-    (Language . (pre ++)) <$> listOf1 genByteString+    (Language . (pre ++)) <$> listOf1 genCIByteString   ------------------------------------------------------------------------------@@ -75,7 +74,7 @@ genNonMatchingLanguage :: Language -> Gen Language genNonMatchingLanguage (Language [])        = genConcreteLanguage genNonMatchingLanguage (Language (pre : _)) = do-    pre' <- genDiffByteString pre+    pre' <- genDiffCIByteString pre     genMatchingLanguage $ Language [pre']  @@ -109,11 +108,11 @@   -------------------------------------------------------------------------------genByteString :: Gen ByteString-genByteString = resize 8 $ Gen.genByteStringFrom ([65..90] ++ [97..122])+genCIByteString :: Gen (CI ByteString)+genCIByteString =+    resize 8 $ Gen.genCIByteStringFrom (['a'..'z'] ++ ['A'..'Z'])   -------------------------------------------------------------------------------genDiffByteString :: ByteString -> Gen ByteString-genDiffByteString = Gen.genDiffByteStringWith genByteString-+genDiffCIByteString :: CI ByteString -> Gen (CI ByteString)+genDiffCIByteString = Gen.genDiffWith genCIByteString

@@ -2,7 +2,7 @@ module Network.HTTP.Media.Language.Tests (tests) where  -------------------------------------------------------------------------------import qualified Data.ByteString.UTF8 as BS+import qualified Data.ByteString.Char8 as BS  ------------------------------------------------------------------------------ import Control.Applicative               ((<$>))@@ -47,7 +47,7 @@ testShow :: Test testShow = testProperty "show" $ do     lang <- genLanguage-    return $ parseAccept (BS.fromString $ show lang) == Just lang+    return $ parseAccept (BS.pack $ show lang) == Just lang   ------------------------------------------------------------------------------@@ -112,4 +112,3 @@ testParseAccept = testProperty "parseAccept" $ do     lang <- genLanguage     return $ parseAccept (renderHeader lang) == Just lang-

@@ -21,15 +21,22 @@     , genParameters     , genMaybeParameters     , genDiffParameters++    -- * Rendering Parameters+    , renderParameters     ) where  ------------------------------------------------------------------------------ import qualified Data.Map as Map  -------------------------------------------------------------------------------import Control.Monad       (liftM, liftM2)-import Data.ByteString     (ByteString)-import Data.Map            (fromList)+import Control.Applicative  ((<$>))+import Control.Monad        (liftM, liftM2)+import Data.ByteString      (ByteString)+import Data.CaseInsensitive (CI, original)+import Data.Foldable        (foldlM)+import Data.Map             (fromList)+import Data.Monoid          ((<>)) import Test.QuickCheck.Gen  ------------------------------------------------------------------------------@@ -39,7 +46,7 @@  ------------------------------------------------------------------------------ -- | Parameter entry for testing.-type ParamEntry = (ByteString, ByteString)+type ParamEntry = (CI ByteString, CI ByteString)   ------------------------------------------------------------------------------@@ -58,7 +65,7 @@ -- | Generates a MediaType with just a concrete main type. genSubStar :: Gen MediaType genSubStar = do-    main <- genByteString+    main <- genCIByteString     return $ MediaType main "*" Map.empty  @@ -78,8 +85,8 @@ -- | Generates a concrete MediaType which may have parameters. genConcreteMediaType :: Gen MediaType genConcreteMediaType = do-    main <- genByteString-    sub  <- genByteString+    main <- genCIByteString+    sub  <- genCIByteString     params <- oneof [return Map.empty, genParameters]     return $ MediaType main sub params @@ -88,8 +95,8 @@ -- | Generates a concrete MediaType with no parameters. genWithoutParams :: Gen MediaType genWithoutParams = do-    main <- genByteString-    sub  <- genByteString+    main <- genCIByteString+    sub  <- genCIByteString     return $ MediaType main sub Map.empty  @@ -97,8 +104,8 @@ -- | Generates a MediaType with at least one parameter. genWithParams :: Gen MediaType genWithParams = do-    main   <- genByteString-    sub    <- genByteString+    main   <- genCIByteString+    sub    <- genCIByteString     params <- genParameters     return $ MediaType main sub params @@ -143,7 +150,7 @@ -- | Reuse for 'mayParams' and 'someParams'. mkGenParams :: (Gen ParamEntry -> Gen [ParamEntry]) -> Gen Parameters mkGenParams = liftM fromList .-    ($ liftM2 (,) (genDiffByteString "q") genByteString)+    ($ liftM2 (,) (genDiffCIByteString "q") genCIByteString)   ------------------------------------------------------------------------------@@ -168,3 +175,14 @@         then genDiffParameters params         else return params' ++------------------------------------------------------------------------------+-- | Render parameters with a generated amount of whitespace between the+-- semicolons. Note that there is a leading semicolon in front of the+-- parameters, as it is expected that this will always be attached to+-- a preceding 'MediaType' rendering.+renderParameters :: Parameters -> Gen ByteString+renderParameters params = foldlM pad "" (Map.toList params)+  where+    pad s (k, v) =+        (s <>) . (<> original k <> "=" <> original v) <$> padString ";"

@@ -2,14 +2,15 @@ module Network.HTTP.Media.MediaType.Tests (tests) where  -------------------------------------------------------------------------------import qualified Data.ByteString.UTF8 as BS-import qualified Data.Map             as Map+import qualified Data.ByteString.Char8 as BS+import qualified Data.Map              as Map  ------------------------------------------------------------------------------ import Control.Monad                     (join, liftM)+import Data.CaseInsensitive              (foldedCase) import Data.String                       (fromString) import Data.Maybe                        (isNothing)-import Data.Monoid                       ((<>), mconcat)+import Data.Monoid                       ((<>)) import Distribution.TestSuite.QuickCheck  ------------------------------------------------------------------------------@@ -53,7 +54,7 @@ testShow :: Test testShow = testProperty "show" $ do     media <- genMediaType-    return $ parseAccept (BS.fromString $ show media) == Just media+    return $ parseAccept (BS.pack $ show media) == Just media   ------------------------------------------------------------------------------@@ -68,10 +69,10 @@ testHas = testGroup "(/?)"     [ testProperty "True for property it has" $ do         media <- genWithParams-        return $ all (media /?) (Map.keys $ parameters media)+        return $ all ((media /?) . foldedCase) (Map.keys $ parameters media)     , testProperty "False for property it doesn't have" $ do         media <- genWithParams-        return $ all (not . (stripParams media /?))+        return $ all (not . (stripParams media /?) . foldedCase)             (Map.keys $ parameters media)     ] @@ -81,11 +82,11 @@ testGet = testGroup "(/.)"     [ testProperty "Retrieves property it has" $ do         media  <- genWithParams-        let is n v = (&& media /. n == Just v)+        let is n v = (&& media /. foldedCase 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))+        let is n _ = (&& isNothing (stripParams media /. foldedCase n))         return $ Map.foldrWithKey is True $ parameters media     ] @@ -98,12 +99,12 @@         return $ matches media media     , testProperty "Same sub but different main don't match" $ do         media <- genMaybeSubStar-        main  <- genDiffByteString $ mainType media+        main  <- genDiffCIByteString $ mainType media         return $ not (matches media media { mainType = main }) &&             not (matches media { mainType = main } media)     , testProperty "Same main but different sub don't match" $ do         media <- genConcreteMediaType-        sub   <- genDiffByteString $ subType media+        sub   <- genDiffCIByteString $ subType media         return . not $ matches media media { subType = sub } ||             matches media { subType = sub } media     , testProperty "Different parameters don't match" $@@ -192,9 +193,8 @@     media <- genMediaType     let main   = mainType media         sub    = subType media-        params = parameters media-        parsed = parseAccept $ main <> "/" <> sub <> mconcat-            (map (uncurry ((<>) . (<> "=") . (";" <>))) $ Map.toList params)+    params <- renderParameters (parameters media)+    let parsed = parseAccept $ foldedCase (main <> "/" <> sub) <> params     return $ parsed == Just media  @@ -202,4 +202,3 @@ -- | 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-

@@ -2,21 +2,24 @@ module Network.HTTP.Media.Tests (tests) where  -------------------------------------------------------------------------------import Control.Monad                     (replicateM)+import Control.Applicative               ((<$>), (<*>))+import Control.Monad                     ((>=>), replicateM) import Data.ByteString                   (ByteString)+import Data.Foldable                     (foldlM) import Data.Map                          (empty) import Data.Maybe                        (isNothing, listToMaybe)+import Data.Monoid                       ((<>)) import Data.Word                         (Word16) import Distribution.TestSuite.QuickCheck import Test.QuickCheck  ------------------------------------------------------------------------------ import Network.HTTP.Media                    hiding (parameters, subType)+import Network.HTTP.Media.Gen                (padString) import Network.HTTP.Media.MediaType.Gen import Network.HTTP.Media.MediaType.Internal import Network.HTTP.Media.Quality - ------------------------------------------------------------------------------ tests :: [Test] tests =@@ -34,15 +37,30 @@ testParse :: Test testParse = testGroup "parseQuality"     [ testProperty "Without quality" $ do-        media <- medias-        return $-            parseQuality (renderHeader media) == Just (map maxQuality media)+        media    <- medias+        rendered <- padConcat (return . renderHeader) media+        return $ parseQuality rendered == Just (map maxQuality media)     , testProperty "With quality" $ do-        media <- medias >>= mapM (flip fmap (choose (0, 1000)) . Quality)-        return $ parseQuality (renderHeader media) == Just media+        media    <- qualities+        rendered <- padConcat padQuality media+        return $ parseQuality rendered == Just media+    , testProperty "With extensions" $ do+        media    <- qualities+        rendered <- padConcat (padQuality >=> padExtensions) media+        return $ parseQuality rendered == Just media     ]   where     medias = listOf1 genMediaType+    qualities = medias >>= mapM (flip fmap (choose (0, 1000)) . Quality)+    padConcat f l = flip (foldlM (padComma f)) (tail l) =<< f (head l)+    padComma f a b = pad a <$> padString "," <*> f b+    padQuality qMedia = do+        semi <- padString ";"+        let d = renderHeader (qualityData qMedia)+            v = showQ (qualityValue qMedia)+        return $ d <> semi <> "q=" <> v+    padExtensions s = genParameters >>= fmap (s <>) . renderParameters+    pad a s b = a <> s <> b   ------------------------------------------------------------------------------@@ -194,4 +212,3 @@     server <- genServer     client <- listOf1 $ genDiffMediaTypesWith genConcreteMediaType server     return (server, client)-