diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,6 +1,19 @@ Changelog ========= +- [Version 0.8.1.1](https://github.com/zmthy/http-media/releases/tag/v0.8.1.1) + + Fixed a bug when mapping againt a client-side content header where a + match would be overridden by a more specific key earlier in the map. + + The bounds for tasty have been updated to include the latest version. + +- [Version 0.8.1.0](https://github.com/zmthy/http-media/releases/tag/v0.8.1.0) + + Exposed `qualityData` accessor. + + Added `isAcceptable` to allow filtering out unacceptable items. + - [Version 0.8.0.0](https://github.com/zmthy/http-media/releases/tag/v0.8.0.0) Removed official support for GHC 7.8. diff --git a/http-media.cabal b/http-media.cabal --- a/http-media.cabal +++ b/http-media.cabal @@ -1,15 +1,23 @@ name: http-media -version: 0.8.0.0 +version: 0.8.1.1 license: MIT license-file: LICENSE author: Timothy Jones maintainer: Timothy Jones homepage: https://github.com/zmthy/http-media bug-reports: https://github.com/zmthy/http-media/issues -copyright: (c) 2012-2019 Timothy Jones +copyright: (c) 2012-2023 Timothy Jones category: Web build-type: Simple cabal-version: >= 1.10 +tested-with: + GHC == 8.6.5 + , GHC == 8.8.4 + , GHC == 8.10.7 + , GHC == 9.0.2 + , GHC == 9.2.8 + , GHC == 9.4.5 + , GHC == 9.6.2 synopsis: Processing HTTP Content-Type and Accept headers description: This library is intended to be a comprehensive solution to parsing and @@ -71,8 +79,8 @@ Network.HTTP.Media.Utils build-depends: - base >= 4.7 && < 4.13, - bytestring >= 0.10 && < 0.11, + base >= 4.8 && < 5, + bytestring >= 0.10 && < 0.12, case-insensitive >= 1.0 && < 1.3, containers >= 0.5 && < 0.7, utf8-string >= 0.3 && < 1.1 @@ -122,14 +130,14 @@ Network.HTTP.Media.Utils build-depends: - base >= 4.7 && < 4.13, - bytestring >= 0.10 && < 0.11, - case-insensitive >= 1.0 && < 1.3, - containers >= 0.5 && < 0.7, - utf8-string >= 0.3 && < 1.1, - QuickCheck >= 2.8 && < 2.14, - test-framework >= 0.8 && < 0.9, - test-framework-quickcheck2 >= 0.3 && < 0.4 + base >= 4.8 && < 5, + bytestring >= 0.10 && < 0.12, + case-insensitive >= 1.0 && < 1.3, + containers >= 0.5 && < 0.7, + utf8-string >= 0.3 && < 1.1, + QuickCheck >= 2.8 && < 2.15, + tasty >= 0.11 && < 1.6, + tasty-quickcheck >= 0.8 && < 0.11 source-repository head type: git diff --git a/src/Network/HTTP/Media.hs b/src/Network/HTTP/Media.hs --- a/src/Network/HTTP/Media.hs +++ b/src/Network/HTTP/Media.hs @@ -1,84 +1,79 @@ ------------------------------------------------------------------------------- -- | A framework for parsing HTTP media type headers. module Network.HTTP.Media - ( - -- * Media types - MediaType - , (//) - , (/:) - , mainType - , subType - , parameters - , (/?) - , (/.) + ( -- * Media types + MediaType, + (//), + (/:), + mainType, + subType, + parameters, + (/?), + (/.), -- * Charsets - , Charset + Charset, -- * Encodings - , Encoding + Encoding, -- * Languages - , Language - , toParts + Language, + toParts, -- * Accept matching - , matchAccept - , mapAccept - , mapAcceptMedia - , mapAcceptCharset - , mapAcceptEncoding - , mapAcceptLanguage - , mapAcceptBytes + matchAccept, + mapAccept, + mapAcceptMedia, + mapAcceptCharset, + mapAcceptEncoding, + mapAcceptLanguage, + mapAcceptBytes, -- * Content matching - , matchContent - , mapContent - , mapContentMedia - , mapContentCharset - , mapContentEncoding - , mapContentLanguage + matchContent, + mapContent, + mapContentMedia, + mapContentCharset, + mapContentEncoding, + mapContentLanguage, -- * Quality values - , Quality - , quality - , QualityOrder - , qualityOrder - , maxQuality - , minQuality - , parseQuality - , matchQuality - , mapQuality + Quality (qualityData), + quality, + QualityOrder, + qualityOrder, + isAcceptable, + maxQuality, + minQuality, + parseQuality, + matchQuality, + mapQuality, -- * Accept - , Accept (..) + Accept (..), -- * Rendering - , RenderHeader (..) - ) where - -import Control.Applicative ((<|>)) - -import qualified Data.ByteString.Char8 as BS - -import Control.Monad (guard, (>=>)) -import Data.ByteString (ByteString) -import Data.Foldable (foldl', maximumBy) -import Data.Function (on) -import Data.Maybe (fromMaybe) -import Data.Proxy (Proxy (Proxy)) - -import Network.HTTP.Media.Accept as Accept -import Network.HTTP.Media.Charset as Charset -import Network.HTTP.Media.Encoding as Encoding -import Network.HTTP.Media.Language as Language -import Network.HTTP.Media.MediaType as MediaType -import Network.HTTP.Media.Quality -import Network.HTTP.Media.RenderHeader -import Network.HTTP.Media.Utils (trimBS) + RenderHeader (..), + ) +where +import Control.Applicative ((<|>)) +import Control.Monad (guard, (>=>)) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS +import Data.Foldable (find, foldl', maximumBy) +import Data.Function (on) +import Data.Maybe (fromMaybe) +import Data.Proxy (Proxy (Proxy)) +import Network.HTTP.Media.Accept as Accept +import Network.HTTP.Media.Charset as Charset +import Network.HTTP.Media.Encoding as Encoding +import Network.HTTP.Media.Language as Language +import Network.HTTP.Media.MediaType as MediaType +import Network.HTTP.Media.Quality +import Network.HTTP.Media.RenderHeader +import Network.HTTP.Media.Utils (trimBS) ------------------------------------------------------------------------------- -- | Matches a list of server-side resource options against a quality-marked -- list of client-side preferences. A result of 'Nothing' means that nothing -- matched (which should indicate a 406 error). If two or more results arise @@ -92,15 +87,15 @@ -- > matchAccept ["text/html", "application/json"] <$> getHeader -- -- For more information on the matching process see RFC 2616, section 14.1-4. -matchAccept - :: Accept a - => [a] -- ^ The server-side options - -> ByteString -- ^ The client-side header value - -> Maybe a +matchAccept :: + (Accept a) => + -- | The server-side options + [a] -> + -- | The client-side header value + ByteString -> + Maybe a matchAccept = (parseQuality >=>) . matchQuality - ------------------------------------------------------------------------------- -- | The equivalent of 'matchAccept' above, except the resulting choice is -- mapped to another value. Convenient for specifying how to translate the -- resource into each of its available formats. @@ -109,15 +104,15 @@ -- > [ ("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 :: + (Accept a) => + -- | The map of server-side preferences to values + [(a, b)] -> + -- | The client-side header value + ByteString -> + 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. -- @@ -126,13 +121,13 @@ -- > , ("application/json", asJson) -- > ] mapAcceptMedia :: - [(MediaType, b)] -- ^ The map of server-side preferences to values - -> ByteString -- ^ The client-side header value - -> Maybe b + -- | The map of server-side preferences to values + [(MediaType, b)] -> + -- | The client-side header value + ByteString -> + Maybe b mapAcceptMedia = mapAccept - ------------------------------------------------------------------------------- -- | A specialisation of 'mapAccept' that only takes 'Charset' as its input, -- to avoid ambiguous-type errors when using string literal overloading. -- @@ -141,13 +136,13 @@ -- > , ("us-ascii", inAscii) -- > ] mapAcceptCharset :: - [(Charset, b)] -- ^ The map of server-side preferences to values - -> ByteString -- ^ The client-side header value - -> Maybe b + -- | The map of server-side preferences to values + [(Charset, b)] -> + -- | The client-side header value + ByteString -> + Maybe b mapAcceptCharset = mapAccept - ------------------------------------------------------------------------------- -- | A specialisation of 'mapAccept' that only takes 'Encoding' as its input, -- to avoid ambiguous-type errors when using string literal overloading. -- @@ -156,13 +151,13 @@ -- > , ("identity", id) -- > ] mapAcceptEncoding :: - [(Encoding, b)] -- ^ The map of server-side preferences to values - -> ByteString -- ^ The client-side header value - -> Maybe b + -- | The map of server-side preferences to values + [(Encoding, b)] -> + -- | The client-side header value + ByteString -> + Maybe b mapAcceptEncoding = mapAccept - ------------------------------------------------------------------------------- -- | A specialisation of 'mapAccept' that only takes 'Language' as its input, -- to avoid ambiguous-type errors when using string literal overloading. -- @@ -171,13 +166,13 @@ -- > , ("fr", inFrench) -- > ] mapAcceptLanguage :: - [(Language, b)] -- ^ The map of server-side preferences to values - -> ByteString -- ^ The client-side header value - -> Maybe b + -- | The map of server-side preferences to values + [(Language, b)] -> + -- | The client-side header value + ByteString -> + 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. @@ -187,13 +182,13 @@ -- > , ("xyz", xyz) -- > ] mapAcceptBytes :: - [(ByteString, b)] -- ^ The map of server-side preferences to values - -> ByteString -- ^ The client-side header value - -> Maybe b + -- | The map of server-side preferences to values + [(ByteString, b)] -> + -- | The client-side header value + ByteString -> + 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). @@ -201,19 +196,15 @@ -- > matchContent ["application/json", "text/plain"] <$> getContentType -- -- For more information on the matching process see RFC 2616, section 14.17. -matchContent - :: Accept a - => [a] -- ^ The server-side response options - -> ByteString -- ^ The client's request value - -> Maybe a -matchContent options ctype = foldl choose Nothing options - where - choose m server = m <|> do - parseAccept ctype >>= guard . (`matches` server) - Just server - +matchContent :: + (Accept a) => + -- | The server-side response options + [a] -> + -- | The client's request value + ByteString -> + Maybe a +matchContent = findMatch id ------------------------------------------------------------------------------- -- | The equivalent of 'matchContent' above, except the resulting choice is -- mapped to another value. -- @@ -221,16 +212,15 @@ -- > [ ("application" // "json", parseJson) -- > , ("text" // "plain", parseText) -- > ] -mapContent - :: Accept a - => [(a, b)] -- ^ The map of server-side responses - -> ByteString -- ^ The client request's header value - -> Maybe b -mapContent options ctype = - matchContent (map fst options) ctype >>= lookupMatches options - +mapContent :: + (Accept a) => + -- | The map of server-side responses + [(a, b)] -> + -- | The client request's header value + ByteString -> + Maybe b +mapContent options = fmap snd . findMatch fst options ------------------------------------------------------------------------------- -- | A specialisation of 'mapContent' that only takes 'MediaType' as its -- input, to avoid ambiguous-type errors when using string literal -- overloading. @@ -240,14 +230,14 @@ -- > [ ("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 :: + -- | The map of server-side responses + [(MediaType, b)] -> + -- | The client request's header value + ByteString -> + Maybe b mapContentMedia = mapContent - ------------------------------------------------------------------------------- -- | A specialisation of 'mapContent' that only takes 'Charset' as its input, -- to avoid ambiguous-type errors when using string literal overloading. -- @@ -256,14 +246,14 @@ -- > [ ("utf-8", parseUtf8) -- > , ("us-ascii", parseAscii) -- > ] -mapContentCharset - :: [(Charset, b)] -- ^ The map of server-side responses - -> ByteString -- ^ The client request's header value - -> Maybe b +mapContentCharset :: + -- | The map of server-side responses + [(Charset, b)] -> + -- | The client request's header value + ByteString -> + Maybe b mapContentCharset = mapContent - ------------------------------------------------------------------------------- -- | A specialisation of 'mapContent' that only takes 'Encoding' as its input, -- to avoid ambiguous-type errors when using string literal overloading. -- @@ -272,14 +262,14 @@ -- > [ ("compress", decompress) -- > , ("identity", id) -- > ] -mapContentEncoding - :: [(Encoding, b)] -- ^ The map of server-side responses - -> ByteString -- ^ The client request's header value - -> Maybe b +mapContentEncoding :: + -- | The map of server-side responses + [(Encoding, b)] -> + -- | The client request's header value + ByteString -> + Maybe b mapContentEncoding = mapContent - ------------------------------------------------------------------------------- -- | A specialisation of 'mapContent' that only takes 'Language' as its input, -- to avoid ambiguous-type errors when using string literal overloading. -- @@ -288,41 +278,45 @@ -- > [ ("en-gb", parseBritishEnglish) -- > , ("fr", parseFrench) -- > ] -mapContentLanguage - :: [(Language, b)] -- ^ The map of server-side responses - -> ByteString -- ^ The client request's header value - -> Maybe b +mapContentLanguage :: + -- | The map of server-side responses + [(Language, b)] -> + -- | The client request's header value + ByteString -> + Maybe b mapContentLanguage = mapContent - ------------------------------------------------------------------------------- -- | Parses a full Accept header into a list of quality-valued media types. -parseQuality :: Accept a => ByteString -> Maybe [Quality a] +parseQuality :: (Accept a) => ByteString -> Maybe [Quality a] parseQuality = parseQuality' Proxy -parseQuality' :: Accept a => Proxy a -> ByteString -> Maybe [Quality a] -parseQuality' p = (. map trimBS . BS.split ',') . mapM $ \ s -> - let (accept, q) = fromMaybe (s, Nothing) $ if ext then findQ s else getQ s - in maybe (pure maxQuality) (fmap (flip Quality) . readQ) q <*> - parseAccept accept +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) + 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 - + let q = getQ s + (a, m) <- q + maybe (findQ a) (const q) m ------------------------------------------------------------------------------- -- | Matches a list of server-side resource options against a pre-parsed -- quality-marked list of client-side preferences. A result of 'Nothing' means -- that nothing matched (which should indicate a 406 error). If two or more @@ -336,26 +330,15 @@ -- > matchQuality ["text/html", "application/json"] <$> parseQuality header -- -- For more information on the matching process see RFC 2616, section 14.1-4. -matchQuality - :: Accept a - => [a] -- ^ The server-side options - -> [Quality a] -- ^ The pre-parsed client-side header value - -> Maybe a -matchQuality options acceptq = do - guard $ not (null options) - Quality m q <- maximumBy (compare `on` fmap qualityOrder) optionsq - guard $ q /= 0 - return m - where - optionsq = reverse $ map addQuality options - addQuality opt = withQValue opt <$> foldl' (mfold opt) Nothing acceptq - withQValue opt qv = qv { qualityData = opt } - mfold opt cur acq@(Quality acd _) - | opt `matches` acd = mostSpecific acq <$> cur <|> Just acq - | otherwise = cur - +matchQuality :: + (Accept a) => + -- | The server-side options + [a] -> + -- | The pre-parsed client-side header value + [Quality a] -> + Maybe a +matchQuality = findQuality id ------------------------------------------------------------------------------- -- | 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. @@ -364,19 +347,34 @@ -- > [ ("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 +mapQuality :: + (Accept a) => + -- | The map of server-side preferences to values + [(a, b)] -> + -- | The client-side header value + [Quality a] -> + Maybe b +mapQuality options = fmap snd . findQuality fst options +-- | Find a match in a list of options against a ByteString using an 'Accept' +-- instance obtained by mapping the options to another type. +findMatch :: (Accept b) => (a -> b) -> [a] -> ByteString -> Maybe a +findMatch f options bs = do + ctype <- parseAccept bs + find (matches ctype . f) options ------------------------------------------------------------------------------- --- | The equivalent of 'lookupBy matches'. -lookupMatches :: Accept a => [(a, b)] -> a -> Maybe b -lookupMatches ((k, v) : r) a - | Accept.matches k a = Just v - | otherwise = lookupMatches r a -lookupMatches [] _ = Nothing +-- | Find a quality match between a list of options and a quality-marked list +-- of a different type, by mapping the type of the former to the latter. +findQuality :: (Accept a) => (b -> a) -> [b] -> [Quality a] -> Maybe b +findQuality f options acceptq = do + guard $ not (null options) + q <- maximumBy (compare `on` fmap qualityOrder) optionsq + guard $ isAcceptable q + return $ qualityData q + where + optionsq = reverse $ map addQuality options + addQuality opt = withQValue opt <$> foldl' (mfold opt) Nothing acceptq + withQValue opt q = q {qualityData = opt} + mfold opt cur q + | f opt `matches` qualityData q = mostSpecific q <$> cur <|> Just q + | otherwise = cur diff --git a/src/Network/HTTP/Media/Accept.hs b/src/Network/HTTP/Media/Accept.hs --- a/src/Network/HTTP/Media/Accept.hs +++ b/src/Network/HTTP/Media/Accept.hs @@ -1,56 +1,52 @@ ------------------------------------------------------------------------------- -- | Defines the 'Accept' type class, designed to unify types on the matching -- functions in the Media module. module Network.HTTP.Media.Accept - ( Accept (..) - ) where + ( Accept (..), + ) +where +import Data.ByteString (ByteString) import qualified Data.CaseInsensitive as CI - -import Data.ByteString (ByteString) -import Data.Proxy (Proxy) - +import Data.Proxy (Proxy) ------------------------------------------------------------------------------- -- | Defines methods for a type whose values can be matched against each -- other in terms of an HTTP Accept-* header. -- -- This allows functions to work on both the standard Accept header and -- others such as Accept-Language that still may use quality values. -class Show a => Accept a where - - -- | Specifies how to parse an Accept-* header after quality has been - -- handled. - parseAccept :: ByteString -> Maybe a +class (Show a) => Accept a where + -- | Specifies how to parse an Accept-* header after quality has been + -- handled. + parseAccept :: ByteString -> Maybe a - -- | Evaluates whether either the left argument matches the right one. - -- - -- This relation must be a total order, where more specific terms on the - -- left can produce a match, but a less specific term on the left can - -- never produce a match. For instance, when matching against media types - -- it is important that if the client asks for a general type then we can - -- choose a more specific offering from the server, but if a client asks - -- for a specific type and the server only offers a more general form, - -- then we cannot generalise. In this case, the server types will be the - -- left argument, and the client types the right. - -- - -- For types with no concept of specificity, this operation is just - -- equality. - matches :: a -> a -> Bool + -- | Evaluates whether 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 + -- | Evaluates whether the left argument is more specific than the right. + -- + -- This relation must be irreflexive and transitive. For types with no + -- concept of specificity, this is the empty relation (always false). + moreSpecificThan :: a -> a -> Bool - -- | Indicates whether extension parameters are permitted after the weight - -- parameter when this type appears in an Accept header. Defaults to - -- false. - hasExtensionParameters :: Proxy a -> Bool - hasExtensionParameters _ = False + -- | Indicates whether extension parameters are permitted after the weight + -- parameter when this type appears in an Accept header. Defaults to + -- false. + hasExtensionParameters :: Proxy a -> Bool + hasExtensionParameters _ = False instance Accept ByteString where - parseAccept = Just - matches a b = CI.mk a == CI.mk b - moreSpecificThan _ _ = False + parseAccept = Just + matches a b = CI.mk a == CI.mk b + moreSpecificThan _ _ = False diff --git a/src/Network/HTTP/Media/Charset.hs b/src/Network/HTTP/Media/Charset.hs --- a/src/Network/HTTP/Media/Charset.hs +++ b/src/Network/HTTP/Media/Charset.hs @@ -1,7 +1,5 @@ ------------------------------------------------------------------------------- -- | Defines the 'Charset' accept header with an 'Accept' instance for use in -- encoding negotiation. -module Network.HTTP.Media.Charset - ( Charset ) where +module Network.HTTP.Media.Charset (Charset) where -import Network.HTTP.Media.Charset.Internal +import Network.HTTP.Media.Charset.Internal diff --git a/src/Network/HTTP/Media/Charset/Internal.hs b/src/Network/HTTP/Media/Charset/Internal.hs --- a/src/Network/HTTP/Media/Charset/Internal.hs +++ b/src/Network/HTTP/Media/Charset/Internal.hs @@ -1,25 +1,21 @@ ------------------------------------------------------------------------------- -- | Defines the 'Charset' accept header with an 'Accept' instance for use in -- language negotiation. module Network.HTTP.Media.Charset.Internal - ( Charset (..) - ) where - -import qualified Data.ByteString.Char8 as BS -import qualified Data.CaseInsensitive as CI - -import Control.Monad (guard) -import Data.ByteString (ByteString) -import Data.CaseInsensitive (CI, original) -import Data.Maybe (fromMaybe) -import Data.String (IsString (..)) - -import Network.HTTP.Media.Accept (Accept (..)) -import Network.HTTP.Media.RenderHeader (RenderHeader (..)) -import Network.HTTP.Media.Utils (isValidToken) + ( Charset (..), + ) +where +import Control.Monad (guard) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS +import Data.CaseInsensitive (CI, original) +import qualified Data.CaseInsensitive as CI +import Data.Maybe (fromMaybe) +import Data.String (IsString (..)) +import Network.HTTP.Media.Accept (Accept (..)) +import Network.HTTP.Media.RenderHeader (RenderHeader (..)) +import Network.HTTP.Media.Utils (isValidToken) ------------------------------------------------------------------------------- -- | Suitable for HTTP charset as defined in -- . -- @@ -27,25 +23,27 @@ -- -- > charset = token / "*" newtype Charset = Charset (CI ByteString) - deriving (Eq, Ord) + deriving (Eq, Ord) instance Show Charset where - show = BS.unpack . renderHeader + show = BS.unpack . renderHeader instance IsString Charset where - fromString str = flip fromMaybe (parseAccept $ BS.pack str) $ - error $ "Invalid encoding literal " ++ str + fromString str = + flip fromMaybe (parseAccept $ BS.pack str) $ + error $ + "Invalid encoding literal " ++ str instance Accept Charset where - parseAccept bs = do - guard $ isValidToken bs - return $ Charset (CI.mk bs) + parseAccept bs = do + guard $ isValidToken bs + return $ Charset (CI.mk bs) - matches _ (Charset "*") = True - matches a b = a == b + matches _ (Charset "*") = True + matches a b = a == b - moreSpecificThan _ (Charset "*") = True - moreSpecificThan _ _ = False + moreSpecificThan _ (Charset "*") = True + moreSpecificThan _ _ = False instance RenderHeader Charset where - renderHeader (Charset e) = original e + renderHeader (Charset e) = original e diff --git a/src/Network/HTTP/Media/Encoding.hs b/src/Network/HTTP/Media/Encoding.hs --- a/src/Network/HTTP/Media/Encoding.hs +++ b/src/Network/HTTP/Media/Encoding.hs @@ -1,7 +1,5 @@ ------------------------------------------------------------------------------- -- | Defines the 'Encoding' accept header with an 'Accept' instance for use in -- encoding negotiation. -module Network.HTTP.Media.Encoding - ( Encoding ) where +module Network.HTTP.Media.Encoding (Encoding) where -import Network.HTTP.Media.Encoding.Internal +import Network.HTTP.Media.Encoding.Internal diff --git a/src/Network/HTTP/Media/Encoding/Internal.hs b/src/Network/HTTP/Media/Encoding/Internal.hs --- a/src/Network/HTTP/Media/Encoding/Internal.hs +++ b/src/Network/HTTP/Media/Encoding/Internal.hs @@ -1,25 +1,21 @@ ------------------------------------------------------------------------------- -- | Defines the 'Encoding' accept header with an 'Accept' instance for use in -- language negotiation. module Network.HTTP.Media.Encoding.Internal - ( Encoding (..) - ) where - -import qualified Data.ByteString.Char8 as BS -import qualified Data.CaseInsensitive as CI - -import Control.Monad (guard) -import Data.ByteString (ByteString) -import Data.CaseInsensitive (CI, original) -import Data.Maybe (fromMaybe) -import Data.String (IsString (..)) - -import Network.HTTP.Media.Accept (Accept (..)) -import Network.HTTP.Media.RenderHeader (RenderHeader (..)) -import Network.HTTP.Media.Utils (isValidToken) + ( Encoding (..), + ) +where +import Control.Monad (guard) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS +import Data.CaseInsensitive (CI, original) +import qualified Data.CaseInsensitive as CI +import Data.Maybe (fromMaybe) +import Data.String (IsString (..)) +import Network.HTTP.Media.Accept (Accept (..)) +import Network.HTTP.Media.RenderHeader (RenderHeader (..)) +import Network.HTTP.Media.Utils (isValidToken) ------------------------------------------------------------------------------- -- | Suitable for HTTP encoding as defined in -- . -- @@ -27,28 +23,30 @@ -- -- > codings = content-coding / "identity" / "*" newtype Encoding = Encoding (CI ByteString) - deriving (Eq, Ord) + deriving (Eq, Ord) instance Show Encoding where - show = BS.unpack . renderHeader + show = BS.unpack . renderHeader instance IsString Encoding where - fromString str = flip fromMaybe (parseAccept $ BS.pack str) $ - error $ "Invalid encoding literal " ++ str + fromString str = + flip fromMaybe (parseAccept $ BS.pack str) $ + error $ + "Invalid encoding literal " ++ str instance Accept Encoding where - -- This handles the case where the header value is empty, but it also - -- allows technically invalid values such as "compress;q=0.8,;q=0.5". - parseAccept "" = Just $ Encoding "identity" - parseAccept bs = do - guard $ isValidToken bs - return $ Encoding (CI.mk bs) + -- This handles the case where the header value is empty, but it also + -- allows technically invalid values such as "compress;q=0.8,;q=0.5". + parseAccept "" = Just $ Encoding "identity" + parseAccept bs = do + guard $ isValidToken bs + return $ Encoding (CI.mk bs) - matches _ (Encoding "*") = True - matches a b = a == b + matches _ (Encoding "*") = True + matches a b = a == b - moreSpecificThan _ (Encoding "*") = True - moreSpecificThan _ _ = False + moreSpecificThan _ (Encoding "*") = True + moreSpecificThan _ _ = False instance RenderHeader Encoding where - renderHeader (Encoding e) = original e + renderHeader (Encoding e) = original e diff --git a/src/Network/HTTP/Media/Language.hs b/src/Network/HTTP/Media/Language.hs --- a/src/Network/HTTP/Media/Language.hs +++ b/src/Network/HTTP/Media/Language.hs @@ -1,18 +1,15 @@ ------------------------------------------------------------------------------- -- | Defines the 'Language' accept header with an 'Accept' instance for use in -- language negotiation. module Network.HTTP.Media.Language - ( Language - , toParts - ) where - -import Data.ByteString (ByteString) -import Data.CaseInsensitive (CI) - -import Network.HTTP.Media.Language.Internal + ( Language, + toParts, + ) +where +import Data.ByteString (ByteString) +import Data.CaseInsensitive (CI) +import Network.HTTP.Media.Language.Internal ------------------------------------------------------------------------------- -- | Converts 'Language' to a list of its language parts. The wildcard -- produces an empty list. toParts :: Language -> [CI ByteString] diff --git a/src/Network/HTTP/Media/Language/Internal.hs b/src/Network/HTTP/Media/Language/Internal.hs --- a/src/Network/HTTP/Media/Language/Internal.hs +++ b/src/Network/HTTP/Media/Language/Internal.hs @@ -1,26 +1,22 @@ ------------------------------------------------------------------------------- -- | Defines the 'Language' accept header with an 'Accept' instance for use in -- language negotiation. module Network.HTTP.Media.Language.Internal - ( Language (..) - ) where - -import qualified Data.ByteString.Char8 as BS -import qualified Data.CaseInsensitive as CI - -import Control.Monad (guard) -import Data.ByteString (ByteString) -import Data.CaseInsensitive (CI, original) -import Data.Char (isAlpha, isAlphaNum) -import Data.List (isPrefixOf) -import Data.Maybe (fromMaybe) -import Data.String (IsString (..)) - -import Network.HTTP.Media.Accept (Accept (..)) -import Network.HTTP.Media.RenderHeader (RenderHeader (..)) + ( Language (..), + ) +where +import Control.Monad (guard) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS +import Data.CaseInsensitive (CI, original) +import qualified Data.CaseInsensitive as CI +import Data.Char (isAlpha, isAlphaNum) +import Data.List (isPrefixOf) +import Data.Maybe (fromMaybe) +import Data.String (IsString (..)) +import Network.HTTP.Media.Accept (Accept (..)) +import Network.HTTP.Media.RenderHeader (RenderHeader (..)) ------------------------------------------------------------------------------- -- | Suitable for HTTP language-ranges as defined in -- . -- @@ -28,40 +24,44 @@ -- -- > language-range = (1*8ALPHA *("-" 1*8alphanum)) / "*" newtype Language = Language [CI ByteString] - deriving (Eq, Ord) + deriving (Eq, Ord) -- Note that internally, Language [] equates to *. instance Show Language where - show = BS.unpack . renderHeader + show = BS.unpack . renderHeader instance IsString Language where - fromString "*" = Language [] - fromString str = flip fromMaybe (parseAccept $ BS.pack str) $ - error $ "Invalid language literal " ++ str + fromString "*" = Language [] + fromString str = + flip fromMaybe (parseAccept $ BS.pack str) $ + error $ + "Invalid language literal " ++ str instance Accept Language where - parseAccept "*" = Just $ Language [] - parseAccept bs = do - let pieces = BS.split '-' bs - guard $ not (null pieces) - Language <$> mapM check pieces - where - check part = do - let len = BS.length part - guard $ len >= 1 && len <= 8 && - isAlpha (BS.head part) && - BS.all isAlphaNum (BS.tail part) - return (CI.mk part) + parseAccept "*" = Just $ Language [] + parseAccept bs = do + let pieces = BS.split '-' bs + guard $ not (null pieces) + Language <$> mapM check pieces + where + check part = do + let len = BS.length part + guard $ + len >= 1 + && len <= 8 + && isAlpha (BS.head part) + && BS.all isAlphaNum (BS.tail part) + return (CI.mk part) - -- Languages match if the right argument is a prefix of the left. - matches (Language a) (Language b) = b `isPrefixOf` a + -- 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 + -- The left language is more specific than the right if the right + -- arguments is a strict prefix of the left. + moreSpecificThan (Language a) (Language b) = + b `isPrefixOf` a && length a > length b instance RenderHeader Language where - renderHeader (Language []) = "*" - renderHeader (Language l) = BS.intercalate "-" (map original l) + renderHeader (Language []) = "*" + renderHeader (Language l) = BS.intercalate "-" (map original l) diff --git a/src/Network/HTTP/Media/MediaType.hs b/src/Network/HTTP/Media/MediaType.hs --- a/src/Network/HTTP/Media/MediaType.hs +++ b/src/Network/HTTP/Media/MediaType.hs @@ -1,103 +1,86 @@ ------------------------------------------------------------------------------- -- | Defines the 'MediaType' accept header with an 'Accept' instance for use -- in content-type negotiation. module Network.HTTP.Media.MediaType - ( - -- * Type and creation - MediaType - , Parameters - , (//) - , (/:) + ( -- * Type and creation + MediaType, + Parameters, + (//), + (/:), -- * Querying - , mainType - , subType - , parameters - , (/?) - , (/.) - ) where - -import qualified Data.ByteString.Char8 as BS -import qualified Data.CaseInsensitive as CI -import qualified Data.Map as Map - -import Data.ByteString (ByteString) -import Data.CaseInsensitive (CI) -import Data.Map (empty, insert) + mainType, + subType, + parameters, + (/?), + (/.), + ) +where +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI +import Data.Map (empty, insert) +import qualified Data.Map as Map +import Network.HTTP.Media.MediaType.Internal (MediaType (MediaType)) +import Network.HTTP.Media.MediaType.Internal hiding (MediaType (..)) import qualified Network.HTTP.Media.MediaType.Internal as Internal - -import Network.HTTP.Media.MediaType.Internal (MediaType (MediaType)) -import Network.HTTP.Media.MediaType.Internal hiding (MediaType (..)) -import Network.HTTP.Media.Utils - +import Network.HTTP.Media.Utils ------------------------------------------------------------------------------- -- | Retrieves the main type of a 'MediaType'. mainType :: MediaType -> CI ByteString mainType = Internal.mainType - ------------------------------------------------------------------------------- -- | Retrieves the sub type of a 'MediaType'. subType :: MediaType -> CI ByteString subType = Internal.subType - ------------------------------------------------------------------------------- -- | Retrieves the parameters of a 'MediaType'. parameters :: MediaType -> Parameters parameters = Internal.parameters - ------------------------------------------------------------------------------- -- | Builds a 'MediaType' without parameters. Can produce an error if -- either type is invalid. (//) :: ByteString -> ByteString -> MediaType a // b - | a == "*" && b == "*" = MediaType (CI.mk a) (CI.mk b) empty - | b == "*" = MediaType (ensureR a) (CI.mk b) empty - | otherwise = MediaType (ensureR a) (ensureR b) empty - + | a == "*" && b == "*" = MediaType (CI.mk a) (CI.mk b) empty + | b == "*" = MediaType (ensureR a) (CI.mk b) empty + | otherwise = MediaType (ensureR a) (ensureR b) empty ------------------------------------------------------------------------------- -- | Adds a parameter to a 'MediaType'. Can produce an error if either -- string is invalid. (/:) :: MediaType -> (ByteString, ByteString) -> MediaType (MediaType a b p) /: (k, v) = MediaType a b $ insert (ensureR k) (ensureV v) p - ------------------------------------------------------------------------------- -- | Evaluates if a 'MediaType' has a parameter of the given name. (/?) :: MediaType -> ByteString -> Bool (MediaType _ _ p) /? k = Map.member (CI.mk k) p - ------------------------------------------------------------------------------- -- | Retrieves a parameter from a 'MediaType'. (/.) :: MediaType -> ByteString -> Maybe (CI ByteString) (MediaType _ _ p) /. k = Map.lookup (CI.mk k) p - ------------------------------------------------------------------------------- -- | Ensures that the 'ByteString' matches the ABNF for `reg-name` in RFC -- 4288. ensureR :: ByteString -> CI ByteString -ensureR bs = CI.mk $ if l == 0 || l > 127 - then error $ "Invalid length for " ++ show bs else ensure isMediaChar bs - where l = BS.length bs - +ensureR bs = + CI.mk $ + if l == 0 || l > 127 + then error $ "Invalid length for " ++ show bs + else ensure isMediaChar bs + where + l = BS.length bs ------------------------------------------------------------------------------- -- | Ensures that the 'ByteString' does not contain invalid characters for -- a parameter value. RFC 4288 does not specify what characters are valid, so -- here we just disallow parameter and media type breakers, ',' and ';'. ensureV :: ByteString -> CI ByteString ensureV = CI.mk . ensure (`notElem` [',', ';']) - ------------------------------------------------------------------------------- -- | Ensures the predicate matches for every character in the given string. ensure :: (Char -> Bool) -> ByteString -> ByteString -ensure f bs = maybe - (error $ "Invalid character in " ++ show bs) (const bs) (BS.find f bs) +ensure f bs = + maybe + (error $ "Invalid character in " ++ show bs) + (const bs) + (BS.find f bs) diff --git a/src/Network/HTTP/Media/MediaType/Internal.hs b/src/Network/HTTP/Media/MediaType/Internal.hs --- a/src/Network/HTTP/Media/MediaType/Internal.hs +++ b/src/Network/HTTP/Media/MediaType/Internal.hs @@ -1,83 +1,87 @@ ------------------------------------------------------------------------------- -- | Defined to allow the constructor of 'MediaType' to be exposed to tests. module Network.HTTP.Media.MediaType.Internal - ( MediaType (..) - , Parameters - ) where - -import qualified Data.ByteString.Char8 as BS -import qualified Data.CaseInsensitive as CI -import qualified Data.Map as Map - -import Control.Monad (foldM, guard) -import Data.ByteString (ByteString) -import Data.CaseInsensitive (CI, original) -import Data.Map (Map) -import Data.Maybe (fromMaybe) -import Data.Monoid ((<>)) -import Data.String (IsString (..)) - -import Network.HTTP.Media.Accept (Accept (..)) -import Network.HTTP.Media.RenderHeader (RenderHeader (..)) -import Network.HTTP.Media.Utils (breakChar, trimBS) + ( MediaType (..), + Parameters, + ) +where +import Control.Monad (foldM, guard) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS +import Data.CaseInsensitive (CI, original) +import qualified Data.CaseInsensitive as CI +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) +import Data.String (IsString (..)) +import Network.HTTP.Media.Accept (Accept (..)) +import Network.HTTP.Media.RenderHeader (RenderHeader (..)) +import Network.HTTP.Media.Utils (breakChar, trimBS) +import Prelude hiding ((<>)) ------------------------------------------------------------------------------- -- | An HTTP media type, consisting of the type, subtype, and parameters. data MediaType = MediaType - { mainType :: CI ByteString -- ^ The main type of the MediaType - , subType :: CI ByteString -- ^ The sub type of the MediaType - , parameters :: Parameters -- ^ The parameters of the MediaType - } deriving (Eq, Ord) + { -- | The main type of the MediaType + mainType :: CI ByteString, + -- | The sub type of the MediaType + subType :: CI ByteString, + -- | The parameters of the MediaType + parameters :: Parameters + } + deriving (Eq, Ord) instance Show MediaType where - show = BS.unpack . renderHeader + show = BS.unpack . renderHeader instance IsString MediaType where - fromString str = flip fromMaybe (parseAccept $ BS.pack str) $ - error $ "Invalid media type literal " ++ str + fromString str = + flip fromMaybe (parseAccept $ BS.pack str) $ + error $ + "Invalid media type literal " ++ str instance Accept MediaType where - parseAccept bs = do - (s, ps) <- uncons (map trimBS (BS.split ';' bs)) - (a, b) <- breakChar '/' s - guard $ not (BS.null a || BS.null b) && (a /= "*" || b == "*") - ps' <- foldM insert Map.empty ps - return $ MediaType (CI.mk a) (CI.mk b) ps' - where - uncons [] = Nothing - uncons (a : b) = Just (a, b) - both f (a, b) = (f a, f b) - insert ps = - fmap (flip (uncurry Map.insert) ps . both CI.mk) . breakChar '=' + parseAccept bs = do + (s, ps) <- uncons (map trimBS (BS.split ';' bs)) + (a, b) <- breakChar '/' s + guard $ not (BS.null a || BS.null b) && (a /= "*" || b == "*") + ps' <- foldM insert Map.empty ps + return $ MediaType (CI.mk a) (CI.mk b) ps' + where + uncons [] = Nothing + uncons (a : b) = Just (a, b) + both f (a, b) = (f a, f b) + insert ps = + fmap (flip (uncurry Map.insert) ps . both CI.mk) . breakChar '=' - matches a b - | mainType b == "*" = params - | subType b == "*" = mainType a == mainType b && params - | otherwise = main && sub && params - where - main = mainType a == mainType b - sub = subType a == subType b - params = Map.null (parameters b) || parameters a == parameters b + matches a b + | mainType b == "*" = params + | subType b == "*" = mainType a == mainType b && params + | otherwise = main && sub && params + where + main = mainType a == mainType b + sub = subType a == subType b + params = Map.null (parameters b) || parameters a == parameters b - moreSpecificThan a b = (a `matches` b &&) $ - mainType a == "*" && anyB && params || - subType a == "*" && (anyB || subB && params) || - anyB || subB || params - where - anyB = mainType b == "*" - subB = subType b == "*" - params = not (Map.null $ parameters a) && Map.null (parameters b) + moreSpecificThan a b = + (a `matches` b &&) $ + mainType a == "*" && anyB && params + || subType a == "*" && (anyB || subB && params) + || anyB + || subB + || params + where + anyB = mainType b == "*" + subB = subType b == "*" + params = not (Map.null $ parameters a) && Map.null (parameters b) - hasExtensionParameters _ = True + hasExtensionParameters _ = True instance RenderHeader MediaType where - renderHeader (MediaType a b p) = - Map.foldrWithKey f (original a <> "/" <> original b) p - where - f k v = (<> ";" <> original k <> "=" <> original v) - + renderHeader (MediaType a b p) = + Map.foldrWithKey f (original a <> "/" <> original b) p + where + f k v = (<> ";" <> original k <> "=" <> original v) ------------------------------------------------------------------------------- -- | 'MediaType' parameters. type Parameters = Map (CI ByteString) (CI ByteString) diff --git a/src/Network/HTTP/Media/Quality.hs b/src/Network/HTTP/Media/Quality.hs --- a/src/Network/HTTP/Media/Quality.hs +++ b/src/Network/HTTP/Media/Quality.hs @@ -1,130 +1,121 @@ {-# LANGUAGE DeriveFunctor #-} ------------------------------------------------------------------------------- -- | Defines the quality value data type. module Network.HTTP.Media.Quality - ( Quality (..) - , quality - , QualityOrder - , qualityOrder - , maxQuality - , minQuality - , mostSpecific - , showQ - , readQ - ) where - -import qualified Data.ByteString.Char8 as BS - -import Data.ByteString (ByteString) -import Data.ByteString.UTF8 (toString) -import Data.Char (isDigit) -import Data.List (dropWhileEnd) -import Data.Maybe (fromMaybe) -import Data.Monoid ((<>)) -import Data.Word (Word16, Word32) - -import Network.HTTP.Media.Accept (Accept, moreSpecificThan) -import Network.HTTP.Media.RenderHeader (RenderHeader (..)) + ( Quality (..), + quality, + QualityOrder, + qualityOrder, + isAcceptable, + maxQuality, + minQuality, + mostSpecific, + showQ, + readQ, + ) +where +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS +import Data.ByteString.UTF8 (toString) +import Data.Char (isDigit) +import Data.List (dropWhileEnd) +import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) +import Data.Word (Word16, Word32) +import Network.HTTP.Media.Accept (Accept, moreSpecificThan) +import Network.HTTP.Media.RenderHeader (RenderHeader (..)) +import Prelude hiding ((<>)) ------------------------------------------------------------------------------- -- | Attaches a quality value to data. data Quality a = Quality - { qualityData :: a - , qualityValue :: Word16 - } deriving (Eq, Functor, Ord) - -instance RenderHeader a => Show (Quality a) where - show = BS.unpack . renderHeader + { qualityData :: a, + qualityValue :: Word16 + } + deriving (Eq, Functor, Ord) -instance RenderHeader h => RenderHeader (Quality h) where - renderHeader (Quality a q) = renderHeader a <> ";q=" <> showQ q +instance (RenderHeader a) => Show (Quality a) where + show = BS.unpack . renderHeader +instance (RenderHeader h) => RenderHeader (Quality h) where + renderHeader (Quality a q) = renderHeader a <> ";q=" <> showQ q ------------------------------------------------------------------------------- -- | Manually construct a quality value. quality :: a -> ByteString -> Quality a -quality x q = Quality x $ flip fromMaybe (readQ q) $ - error ("Invalid quality value " ++ toString q) - +quality x q = + Quality x $ + flip fromMaybe (readQ q) $ + error ("Invalid quality value " ++ toString q) ------------------------------------------------------------------------------- -- | An opaque ordered representation of quality values without attached data. newtype QualityOrder = QualityOrder Word16 - deriving (Eq, Ord) + deriving (Eq, Ord) +-- | Whether the quality value is greater than zero; otherwise the value +-- should never be accepted, even when no other options are available. +isAcceptable :: Quality a -> Bool +isAcceptable (Quality _ 0) = False +isAcceptable (Quality _ _) = True ------------------------------------------------------------------------------- -- | Remove the attached data from a quality value, retaining only the -- priority of the quality parameter. qualityOrder :: Quality a -> QualityOrder qualityOrder = QualityOrder . qualityValue - ------------------------------------------------------------------------------- -- | Attaches the quality value '1'. maxQuality :: a -> Quality a maxQuality = flip Quality 1000 - ------------------------------------------------------------------------------- -- | Attaches the quality value '0'. minQuality :: a -> Quality a minQuality = flip Quality 0 - ------------------------------------------------------------------------------- -- | Combines quality values by specificity. Selects the more specific of the -- two arguments, but if they are the same returns the data of the left -- argument with the two quality values of both arguments combined. -mostSpecific :: Accept a => Quality a -> Quality a -> Quality a +mostSpecific :: (Accept a) => Quality a -> Quality a -> Quality a mostSpecific (Quality a q) (Quality b r) - | a `moreSpecificThan` b = Quality a q - | b `moreSpecificThan` a = Quality b r - | otherwise = Quality a q' + | a `moreSpecificThan` b = Quality a q + | b `moreSpecificThan` a = Quality b r + | otherwise = Quality a q' where q' = fromIntegral (fromIntegral q * fromIntegral r `div` 1000 :: Word32) - ------------------------------------------------------------------------------- -- | Converts the integral value into its standard quality representation. showQ :: Word16 -> ByteString showQ 1000 = "1" -showQ 0 = "0" -showQ q = "0." <> BS.replicate (3 - length s) '0' <> b +showQ 0 = "0" +showQ q = "0." <> BS.replicate (3 - length s) '0' <> b where s = show q b = BS.pack (dropWhileEnd (== '0') s) - ------------------------------------------------------------------------------- -- | Reads the standard quality representation into an integral value. readQ :: ByteString -> Maybe Word16 readQ bs - | BS.null bs = Nothing - | h == '1' = read1 t - | h == '0' = read0 t - | otherwise = Nothing + | 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 + | 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 + | 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 diff --git a/src/Network/HTTP/Media/RenderHeader.hs b/src/Network/HTTP/Media/RenderHeader.hs --- a/src/Network/HTTP/Media/RenderHeader.hs +++ b/src/Network/HTTP/Media/RenderHeader.hs @@ -1,27 +1,24 @@ ------------------------------------------------------------------------------- -- | Defines the 'RenderHeader' type class, with the 'renderHeader' method. -- 'renderHeader' can be used to render basic header values (acting as -- identity on 'ByteString's), but it will also work on lists of quality -- values, which provides the necessary interface for rendering the full -- possibilities of Accept headers. module Network.HTTP.Media.RenderHeader - ( RenderHeader (..) - ) where - -import Data.ByteString (ByteString, intercalate) + ( RenderHeader (..), + ) +where +import Data.ByteString (ByteString, intercalate) ------------------------------------------------------------------------------- -- | A class for header values, so they may be rendered to their 'ByteString' -- representation. Lists of header values and quality-marked header values -- will render appropriately. class RenderHeader h where - - -- | Render a header value to a UTF-8 'ByteString'. - renderHeader :: h -> ByteString + -- | Render a header value to a UTF-8 'ByteString'. + renderHeader :: h -> ByteString instance RenderHeader ByteString where - renderHeader = id + renderHeader = id -instance RenderHeader h => RenderHeader [h] where - renderHeader = intercalate "," . map renderHeader +instance (RenderHeader h) => RenderHeader [h] where + renderHeader = intercalate "," . map renderHeader diff --git a/src/Network/HTTP/Media/Utils.hs b/src/Network/HTTP/Media/Utils.hs --- a/src/Network/HTTP/Media/Utils.hs +++ b/src/Network/HTTP/Media/Utils.hs @@ -1,73 +1,73 @@ ------------------------------------------------------------------------------ -- | Common utilities. module Network.HTTP.Media.Utils - ( breakChar - , trimBS - - , mediaChars - , isMediaChar - - , tokenChars - , isTokenChar - , isValidToken - ) where + ( breakChar, + trimBS, + mediaChars, + isMediaChar, + tokenChars, + isTokenChar, + isValidToken, + ) +where +import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS - -import Data.ByteString (ByteString) -import Data.Char (isControl) - +import Data.Char (isControl) ------------------------------------------------------------------------------- -- | Equivalent to 'Data.ByteString.break' (on equality against the given -- character), but leaves out the byte that the string is broken on. breakChar :: Char -> ByteString -> Maybe (ByteString, ByteString) breakChar c = safeTail . BS.break (== c) where safeTail (a, b) - | BS.null b = Nothing - | otherwise = Just (a, BS.tail b) - + | BS.null b = Nothing + | otherwise = Just (a, BS.tail b) ------------------------------------------------------------------------------- -- | Trims tab and space characters from both ends of a ByteString. trimBS :: ByteString -> ByteString trimBS = fst . BS.spanEnd isLWS . BS.dropWhile isLWS where isLWS c = c == ' ' || c == '\t' - ------------------------------------------------------------------------------- -- | List of the valid characters for a media-type `reg-name` as per RFC 4288. mediaChars :: [Char] -mediaChars = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "!#$&.+-^_" - +mediaChars = ['A' .. 'Z'] ++ ['a' .. 'z'] ++ ['0' .. '9'] ++ "!#$&.+-^_" ------------------------------------------------------------------------------- -- | Evaluates whether the given character is valid in a media type `reg-name` -- as per RFC 4288. isMediaChar :: Char -> Bool isMediaChar = (`elem` mediaChars) - ------------------------------------------------------------------------------- -- | Evaluates whether the given character is valid in an HTTP header token as -- per RFC 2616. isTokenChar :: Char -> Bool isTokenChar = (||) <$> not . isControl <*> (`notElem` separators) where - separators = [ '(', ')', '<', '>', '@', ',', ';', ':', '\\' - , '"', '/', '[', ']', '?', '=', '{', '}', ' ' - ] - + separators = + [ '(', + ')', + '<', + '>', + '@', + ',', + ';', + ':', + '\\', + '"', + '/', + '[', + ']', + '?', + '=', + '{', + '}', + ' ' + ] ------------------------------------------------------------------------------- -- | HTTP header token characters as per RFC 2616. tokenChars :: [Char] -tokenChars = filter isTokenChar ['\0'..'\127'] - +tokenChars = filter isTokenChar ['\0' .. '\127'] ------------------------------------------------------------------------------- -- | Evaluates whether the given ASCII string is valid as an HTTP header token -- as per RFC 2616. isValidToken :: ByteString -> Bool diff --git a/test/Network/HTTP/Media/Accept/Tests.hs b/test/Network/HTTP/Media/Accept/Tests.hs --- a/test/Network/HTTP/Media/Accept/Tests.hs +++ b/test/Network/HTTP/Media/Accept/Tests.hs @@ -1,37 +1,32 @@ ------------------------------------------------------------------------------- module Network.HTTP.Media.Accept.Tests (tests) where -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.QuickCheck2 (testProperty) - -import Network.HTTP.Media.Accept -import Network.HTTP.Media.Gen - +import Network.HTTP.Media.Accept +import Network.HTTP.Media.Gen +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) ------------------------------------------------------------------------------- -tests :: [Test] +tests :: [TestTree] tests = - [ testMatches - , testMoreSpecificThan - ] - + [ testMatches, + testMoreSpecificThan + ] ------------------------------------------------------------------------------- -testMatches :: Test -testMatches = testGroup "matches" +testMatches :: TestTree +testMatches = + testGroup + "matches" [ testProperty "Does match" $ do string <- genByteString - return $ matches string string - , testProperty "Doesn't 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" $ +testMoreSpecificThan :: TestTree +testMoreSpecificThan = + testProperty "moreSpecificThan" $ (not .) . moreSpecificThan <$> genByteString <*> genByteString diff --git a/test/Network/HTTP/Media/Charset/Gen.hs b/test/Network/HTTP/Media/Charset/Gen.hs --- a/test/Network/HTTP/Media/Charset/Gen.hs +++ b/test/Network/HTTP/Media/Charset/Gen.hs @@ -1,49 +1,37 @@ {-# LANGUAGE TupleSections #-} ------------------------------------------------------------------------------- -- | Contains definitions for generating 'Charset's. module Network.HTTP.Media.Charset.Gen - ( anything - , genCharset - , genConcreteCharset - , genDiffCharset - , genDiffConcreteCharsets - ) where - -import Test.QuickCheck.Gen - -import Network.HTTP.Media.Gen (genDiffWith, genToken) - -import Network.HTTP.Media.Charset.Internal + ( anything, + genCharset, + genConcreteCharset, + genDiffCharset, + genDiffConcreteCharsets, + ) +where +import Network.HTTP.Media.Charset.Internal +import Network.HTTP.Media.Gen (genDiffWith, genToken) +import Test.QuickCheck.Gen ------------------------------------------------------------------------------- -- | The Charset that matches anything. anything :: Charset anything = Charset "*" - ------------------------------------------------------------------------------- -- | Generates any kind of Charset. genCharset :: Gen Charset genCharset = Charset <$> genToken - ------------------------------------------------------------------------------- -- | Generates an Charset that does not match everything. genConcreteCharset :: Gen Charset genConcreteCharset = genDiffWith genCharset anything - ------------------------------------------------------------------------------- -- | Generates a different Charset to the given one. genDiffCharset :: Charset -> Gen Charset genDiffCharset = genDiffWith genCharset - ------------------------------------------------------------------------------- -- | Generates two different concrete Charsets. genDiffConcreteCharsets :: Gen (Charset, Charset) genDiffConcreteCharsets = do - enc <- genConcreteCharset - (enc,) <$> genDiffWith genConcreteCharset enc + enc <- genConcreteCharset + (enc,) <$> genDiffWith genConcreteCharset enc diff --git a/test/Network/HTTP/Media/Charset/Tests.hs b/test/Network/HTTP/Media/Charset/Tests.hs --- a/test/Network/HTTP/Media/Charset/Tests.hs +++ b/test/Network/HTTP/Media/Charset/Tests.hs @@ -1,92 +1,83 @@ ------------------------------------------------------------------------------- module Network.HTTP.Media.Charset.Tests (tests) where -import qualified Data.ByteString.Char8 as BS - -import Control.Monad (join) -import Data.String (fromString) -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.QuickCheck ((===)) - -import Network.HTTP.Media.Accept -import Network.HTTP.Media.Charset (Charset) -import Network.HTTP.Media.Charset.Gen -import Network.HTTP.Media.RenderHeader - +import Control.Monad (join) +import qualified Data.ByteString.Char8 as BS +import Data.String (fromString) +import Network.HTTP.Media.Accept +import Network.HTTP.Media.Charset (Charset) +import Network.HTTP.Media.Charset.Gen +import Network.HTTP.Media.RenderHeader +import Test.QuickCheck ((===)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) ------------------------------------------------------------------------------- -tests :: [Test] +tests :: [TestTree] tests = - [ testEq - , testShow - , testFromString - , testMatches - , testMoreSpecific - , testParseAccept - ] - + [ testEq, + testShow, + testFromString, + testMatches, + testMoreSpecific, + testParseAccept + ] ------------------------------------------------------------------------------- -- Equality is derived, but we test it here to get 100% coverage. -testEq :: Test -testEq = testGroup "Eq" +testEq :: TestTree +testEq = + testGroup + "Eq" [ testProperty "==" $ do enc <- genCharset - return $ enc === enc - , testProperty "/=" $ do - enc <- genCharset + return $ enc === enc, + testProperty "/=" $ do + enc <- genCharset enc' <- genDiffCharset enc return $ enc /= enc' ] - ------------------------------------------------------------------------------- -testShow :: Test +testShow :: TestTree testShow = testProperty "show" $ do - enc <- genCharset - return $ parseAccept (BS.pack $ show enc) === Just enc - + enc <- genCharset + return $ parseAccept (BS.pack $ show enc) === Just enc ------------------------------------------------------------------------------- -testFromString :: Test +testFromString :: TestTree testFromString = testProperty "fromString" $ do - enc <- genCharset - return $ enc === fromString (show enc) - + enc <- genCharset + return $ enc === fromString (show enc) ------------------------------------------------------------------------------- -testMatches :: Test -testMatches = testGroup "matches" +testMatches :: TestTree +testMatches = + testGroup + "matches" [ testProperty "Equal values match" $ - join matches <$> genCharset - , testProperty "* matches anything" $ - flip matches anything <$> genCharset - , testProperty "No concrete encoding matches *" $ + join matches <$> genCharset, + testProperty "* matches anything" $ + flip matches anything <$> genCharset, + testProperty "No concrete encoding matches *" $ not . matches anything <$> genConcreteCharset ] - ------------------------------------------------------------------------------- -testMoreSpecific :: Test -testMoreSpecific = testGroup "moreSpecificThan" +testMoreSpecific :: TestTree +testMoreSpecific = + testGroup + "moreSpecificThan" [ testProperty "Against *" $ - flip moreSpecificThan anything <$> genConcreteCharset - , testProperty "With *" $ - not . moreSpecificThan anything <$> genConcreteCharset - , testProperty "Unrelated encodings" $ + flip moreSpecificThan anything <$> genConcreteCharset, + testProperty "With *" $ + not . moreSpecificThan anything <$> genConcreteCharset, + testProperty "Unrelated encodings" $ not . uncurry moreSpecificThan <$> genDiffConcreteCharsets ] - ------------------------------------------------------------------------------- -testParseAccept :: Test -testParseAccept = testGroup "parseAccept" +testParseAccept :: TestTree +testParseAccept = + testGroup + "parseAccept" [ testProperty "Empty" $ - parseAccept "" === (Nothing :: Maybe Charset) - , testProperty "Wildcard" $ - parseAccept "*" === Just anything - , testProperty "Valid parse" $ do + parseAccept "" === (Nothing :: Maybe Charset), + testProperty "Wildcard" $ + parseAccept "*" === Just anything, + testProperty "Valid parse" $ do enc <- genCharset return $ parseAccept (renderHeader enc) === Just enc ] diff --git a/test/Network/HTTP/Media/Encoding/Gen.hs b/test/Network/HTTP/Media/Encoding/Gen.hs --- a/test/Network/HTTP/Media/Encoding/Gen.hs +++ b/test/Network/HTTP/Media/Encoding/Gen.hs @@ -1,55 +1,42 @@ {-# LANGUAGE TupleSections #-} ------------------------------------------------------------------------------- -- | Contains definitions for generating 'Encoding's. module Network.HTTP.Media.Encoding.Gen - ( anything - , identity - , genEncoding - , genConcreteEncoding - , genDiffEncoding - , genDiffConcreteEncodings - ) where - -import Test.QuickCheck.Gen - -import Network.HTTP.Media.Encoding.Internal -import Network.HTTP.Media.Gen (genDiffWith, genToken) + ( anything, + identity, + genEncoding, + genConcreteEncoding, + genDiffEncoding, + genDiffConcreteEncodings, + ) +where +import Network.HTTP.Media.Encoding.Internal +import Network.HTTP.Media.Gen (genDiffWith, genToken) +import Test.QuickCheck.Gen ------------------------------------------------------------------------------- -- | The Encoding that matches anything. anything :: Encoding anything = Encoding "*" - ------------------------------------------------------------------------------- -- | The default Encoding. identity :: Encoding identity = Encoding "identity" - ------------------------------------------------------------------------------- -- | Generates any kind of Encoding. genEncoding :: Gen Encoding genEncoding = Encoding <$> genToken - ------------------------------------------------------------------------------- -- | Generates an Encoding that does not match everything. genConcreteEncoding :: Gen Encoding genConcreteEncoding = genDiffWith genEncoding anything - ------------------------------------------------------------------------------- -- | Generates a different Encoding to the given one. genDiffEncoding :: Encoding -> Gen Encoding genDiffEncoding = genDiffWith genEncoding - ------------------------------------------------------------------------------- -- | Generates two different concrete Encodings. genDiffConcreteEncodings :: Gen (Encoding, Encoding) genDiffConcreteEncodings = do - enc <- genConcreteEncoding - (enc,) <$> genDiffWith genConcreteEncoding enc + enc <- genConcreteEncoding + (enc,) <$> genDiffWith genConcreteEncoding enc diff --git a/test/Network/HTTP/Media/Encoding/Tests.hs b/test/Network/HTTP/Media/Encoding/Tests.hs --- a/test/Network/HTTP/Media/Encoding/Tests.hs +++ b/test/Network/HTTP/Media/Encoding/Tests.hs @@ -1,91 +1,82 @@ ------------------------------------------------------------------------------- module Network.HTTP.Media.Encoding.Tests (tests) where -import qualified Data.ByteString.Char8 as BS - -import Control.Monad (join) -import Data.String (fromString) -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.QuickCheck ((===)) - -import Network.HTTP.Media.Accept -import Network.HTTP.Media.Encoding.Gen -import Network.HTTP.Media.RenderHeader - +import Control.Monad (join) +import qualified Data.ByteString.Char8 as BS +import Data.String (fromString) +import Network.HTTP.Media.Accept +import Network.HTTP.Media.Encoding.Gen +import Network.HTTP.Media.RenderHeader +import Test.QuickCheck ((===)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) ------------------------------------------------------------------------------- -tests :: [Test] +tests :: [TestTree] tests = - [ testEq - , testShow - , testFromString - , testMatches - , testMoreSpecific - , testParseAccept - ] - + [ testEq, + testShow, + testFromString, + testMatches, + testMoreSpecific, + testParseAccept + ] ------------------------------------------------------------------------------- -- Equality is derived, but we test it here to get 100% coverage. -testEq :: Test -testEq = testGroup "Eq" +testEq :: TestTree +testEq = + testGroup + "Eq" [ testProperty "==" $ do enc <- genEncoding - return $ enc === enc - , testProperty "/=" $ do - enc <- genEncoding + return $ enc === enc, + testProperty "/=" $ do + enc <- genEncoding enc' <- genDiffEncoding enc return $ enc /= enc' ] - ------------------------------------------------------------------------------- -testShow :: Test +testShow :: TestTree testShow = testProperty "show" $ do - enc <- genEncoding - return $ parseAccept (BS.pack $ show enc) === Just enc - + enc <- genEncoding + return $ parseAccept (BS.pack $ show enc) === Just enc ------------------------------------------------------------------------------- -testFromString :: Test +testFromString :: TestTree testFromString = testProperty "fromString" $ do - enc <- genEncoding - return $ enc === fromString (show enc) - + enc <- genEncoding + return $ enc === fromString (show enc) ------------------------------------------------------------------------------- -testMatches :: Test -testMatches = testGroup "matches" +testMatches :: TestTree +testMatches = + testGroup + "matches" [ testProperty "Equal values match" $ - join matches <$> genEncoding - , testProperty "* matches anything" $ - flip matches anything <$> genEncoding - , testProperty "No concrete encoding matches *" $ + join matches <$> genEncoding, + testProperty "* matches anything" $ + flip matches anything <$> genEncoding, + testProperty "No concrete encoding matches *" $ not . matches anything <$> genConcreteEncoding ] - ------------------------------------------------------------------------------- -testMoreSpecific :: Test -testMoreSpecific = testGroup "moreSpecificThan" +testMoreSpecific :: TestTree +testMoreSpecific = + testGroup + "moreSpecificThan" [ testProperty "Against *" $ - flip moreSpecificThan anything <$> genConcreteEncoding - , testProperty "With *" $ - not . moreSpecificThan anything <$> genConcreteEncoding - , testProperty "Unrelated encodings" $ + flip moreSpecificThan anything <$> genConcreteEncoding, + testProperty "With *" $ + not . moreSpecificThan anything <$> genConcreteEncoding, + testProperty "Unrelated encodings" $ not . uncurry moreSpecificThan <$> genDiffConcreteEncodings ] - ------------------------------------------------------------------------------- -testParseAccept :: Test -testParseAccept = testGroup "parseAccept" +testParseAccept :: TestTree +testParseAccept = + testGroup + "parseAccept" [ testProperty "Empty" $ - parseAccept "" === Just identity - , testProperty "Wildcard" $ - parseAccept "*" === Just anything - , testProperty "Valid parse" $ do + parseAccept "" === Just identity, + testProperty "Wildcard" $ + parseAccept "*" === Just anything, + testProperty "Valid parse" $ do enc <- genEncoding return $ parseAccept (renderHeader enc) === Just enc ] diff --git a/test/Network/HTTP/Media/Gen.hs b/test/Network/HTTP/Media/Gen.hs --- a/test/Network/HTTP/Media/Gen.hs +++ b/test/Network/HTTP/Media/Gen.hs @@ -1,91 +1,72 @@ ------------------------------------------------------------------------------- -- | Contains definitions for generating 'ByteString's. module Network.HTTP.Media.Gen - ( genToken - - , genByteStringFrom - , genCIByteStringFrom - , genByteString - , genCIByteString - , genDiffWith - , genDiffByteString - , genDiffCIByteString - - , padString - ) where - -import qualified Data.ByteString.Char8 as BS -import qualified Data.CaseInsensitive as CI -import qualified Test.QuickCheck.Gen as Gen + ( genToken, + genByteStringFrom, + genCIByteStringFrom, + genByteString, + genCIByteString, + genDiffWith, + genDiffByteString, + genDiffCIByteString, + padString, + ) +where +import Control.Monad (join, liftM2) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS +import Data.CaseInsensitive (CI, original) +import qualified Data.CaseInsensitive as CI +import Data.Monoid ((<>)) import qualified Network.HTTP.Media.Utils as Utils - -import Control.Monad (join, liftM2) -import Data.ByteString (ByteString) -import Data.CaseInsensitive (CI, original) -import Data.Monoid ((<>)) -import Test.QuickCheck.Gen (Gen) - +import Test.QuickCheck.Gen (Gen) +import qualified Test.QuickCheck.Gen as Gen +import Prelude hiding ((<>)) ------------------------------------------------------------------------------- -- | Generates a valid header token. genToken :: Gen (CI ByteString) genToken = genCIByteStringFrom Utils.tokenChars - ------------------------------------------------------------------------------- -- | Produces a non-empty ByteString of random characters from the given set. genByteStringFrom :: String -> Gen ByteString genByteStringFrom = fmap BS.pack . Gen.listOf1 . Gen.elements - ------------------------------------------------------------------------------- genCIByteStringFrom :: String -> Gen (CI ByteString) genCIByteStringFrom = fmap CI.mk . genByteStringFrom - ------------------------------------------------------------------------------- -- | Produces a non-empty ByteString of random alphanumeric characters with a -- non-numeric head. genByteString :: Gen ByteString -genByteString = fmap BS.pack . (:) +genByteString = + fmap BS.pack . (:) <$> Gen.elements alpha <*> Gen.scale (max 0 . pred) (Gen.listOf (Gen.elements alphaNum)) where - alpha = ['a'..'z'] ++ ['A'..'Z'] - alphaNum = alpha ++ ['0'..'9'] - + alpha = ['a' .. 'z'] ++ ['A' .. 'Z'] + alphaNum = alpha ++ ['0' .. '9'] ------------------------------------------------------------------------------- -- | Produces a non-empty case-insensitive ByteString of random alphanumeric -- characters with a non-numeric head. genCIByteString :: Gen (CI ByteString) genCIByteString = fmap CI.mk genByteString - ------------------------------------------------------------------------------- -- | Produces a non-empty ByteString different to the given one using the -- given generator. -genDiffWith :: Eq a => Gen a -> a -> Gen a +genDiffWith :: (Eq a) => Gen a -> a -> Gen a genDiffWith gen = Gen.suchThat gen . (/=) - ------------------------------------------------------------------------------- -- | Produces a non-empty ByteString of random alphanumeric characters that -- is case-insensitively different to the given one. genDiffByteString :: ByteString -> Gen ByteString genDiffByteString = fmap original . genDiffCIByteString . CI.mk - ------------------------------------------------------------------------------- -- | Produces a non-empty case-insensitive ByteString of random alphanumeric -- characters that is different to the given one. genDiffCIByteString :: CI ByteString -> Gen (CI ByteString) genDiffCIByteString = genDiffWith genCIByteString - ------------------------------------------------------------------------------- -- | Pad a 'ByteString' with a random amount of tab and space characters. padString :: ByteString -> Gen ByteString padString c = join (liftM2 pad) (BS.pack <$> Gen.listOf (Gen.elements " \t")) - where pad a b = a <> c <> b + where + pad a b = a <> c <> b diff --git a/test/Network/HTTP/Media/Language/Gen.hs b/test/Network/HTTP/Media/Language/Gen.hs --- a/test/Network/HTTP/Media/Language/Gen.hs +++ b/test/Network/HTTP/Media/Language/Gen.hs @@ -1,113 +1,84 @@ {-# LANGUAGE TupleSections #-} ------------------------------------------------------------------------------- -- | Contains definitions for generating 'Language's. module Network.HTTP.Media.Language.Gen - ( - -- * Generating Languages - anything - , genLanguage - , genConcreteLanguage - , genDiffLanguage - , genMatchingLanguage - , genDiffMatchingLanguage - , genNonMatchingLanguage - , genMatchingLanguages - , genDiffMatchingLanguages - , genNonMatchingLanguages - ) where - -import Data.ByteString (ByteString) -import Data.CaseInsensitive (CI) -import Test.QuickCheck.Gen - -import qualified Network.HTTP.Media.Gen as Gen - -import Network.HTTP.Media.Language.Internal + ( -- * Generating Languages + anything, + genLanguage, + genConcreteLanguage, + genDiffLanguage, + genMatchingLanguage, + genDiffMatchingLanguage, + genNonMatchingLanguage, + genMatchingLanguages, + genDiffMatchingLanguages, + genNonMatchingLanguages, + ) +where +import Data.ByteString (ByteString) +import Data.CaseInsensitive (CI) +import qualified Network.HTTP.Media.Gen as Gen +import Network.HTTP.Media.Language.Internal +import Test.QuickCheck.Gen ------------------------------------------------------------------------------- -- | The Language that matches anything. anything :: Language anything = Language [] - ------------------------------------------------------------------------------- -- | Generates any kind of Language. genLanguage :: Gen Language genLanguage = Language <$> listOf genCIByteString - ------------------------------------------------------------------------------- -- | Generates a Language that does not match everything. genConcreteLanguage :: Gen Language genConcreteLanguage = Language <$> listOf1 genCIByteString - ------------------------------------------------------------------------------- -- | Generates a different Language to the given one. genDiffLanguage :: Language -> Gen Language genDiffLanguage (Language []) = genConcreteLanguage -genDiffLanguage l = Gen.genDiffWith genLanguage l - +genDiffLanguage l = Gen.genDiffWith genLanguage l ------------------------------------------------------------------------------- -- | Generate a Language that has the given language as a prefix. genMatchingLanguage :: Language -> Gen Language genMatchingLanguage (Language pre) = - (Language . (pre ++)) <$> listOf genCIByteString - + Language . (pre ++) <$> listOf genCIByteString ------------------------------------------------------------------------------- -- | Generate a Language that has the given language as a proper prefix. genDiffMatchingLanguage :: Language -> Gen Language genDiffMatchingLanguage (Language pre) = - (Language . (pre ++)) <$> listOf1 genCIByteString - + Language . (pre ++) <$> listOf1 genCIByteString ------------------------------------------------------------------------------- -- | Generate a Language that does not have the given language as a prefix. genNonMatchingLanguage :: Language -> Gen Language -genNonMatchingLanguage (Language []) = genConcreteLanguage +genNonMatchingLanguage (Language []) = genConcreteLanguage genNonMatchingLanguage (Language (pre : _)) = do - pre' <- genDiffCIByteString pre - genMatchingLanguage $ Language [pre'] - + pre' <- genDiffCIByteString pre + genMatchingLanguage $ Language [pre'] ------------------------------------------------------------------------------- -- | A private definition for generating pairs of languagues. genLanguages :: (Language -> Gen Language) -> Gen (Language, Language) genLanguages gen = do - pre <- genLanguage - (pre,) <$> gen pre - + 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 - + pre <- genConcreteLanguage + (pre,) <$> genNonMatchingLanguage pre ------------------------------------------------------------------------------- genCIByteString :: Gen (CI ByteString) -genCIByteString = resize 8 $ Gen.genCIByteString - +genCIByteString = resize 8 Gen.genCIByteString ------------------------------------------------------------------------------- genDiffCIByteString :: CI ByteString -> Gen (CI ByteString) genDiffCIByteString = Gen.genDiffWith genCIByteString diff --git a/test/Network/HTTP/Media/Language/Tests.hs b/test/Network/HTTP/Media/Language/Tests.hs --- a/test/Network/HTTP/Media/Language/Tests.hs +++ b/test/Network/HTTP/Media/Language/Tests.hs @@ -1,100 +1,92 @@ ------------------------------------------------------------------------------- module Network.HTTP.Media.Language.Tests (tests) where -import qualified Data.ByteString.Char8 as BS - -import Control.Monad (join) -import Data.Monoid ((<>)) -import Data.String (fromString) -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.QuickCheck ((===)) - -import Network.HTTP.Media.Accept -import Network.HTTP.Media.Language -import Network.HTTP.Media.Language.Gen -import Network.HTTP.Media.RenderHeader - +import Control.Monad (join) +import qualified Data.ByteString.Char8 as BS +import Data.Monoid ((<>)) +import Data.String (fromString) +import Network.HTTP.Media.Accept +import Network.HTTP.Media.Language +import Network.HTTP.Media.Language.Gen +import Network.HTTP.Media.RenderHeader +import Test.QuickCheck ((===)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) +import Prelude hiding ((<>)) ------------------------------------------------------------------------------- -tests :: [Test] +tests :: [TestTree] tests = - [ testEq - , testShow - , testFromString - , testMatches - , testMoreSpecific - , testParseAccept - ] - + [ testEq, + testShow, + testFromString, + testMatches, + testMoreSpecific, + testParseAccept + ] ------------------------------------------------------------------------------- -- Equality is derived, but we test it here to get 100% coverage. -testEq :: Test -testEq = testGroup "Eq" +testEq :: TestTree +testEq = + testGroup + "Eq" [ testProperty "==" $ do lang <- genLanguage - return $ lang === lang - , testProperty "/=" $ do - lang <- genLanguage + return $ lang === lang, + testProperty "/=" $ do + lang <- genLanguage lang' <- genDiffLanguage lang return $ lang /= lang' ] - ------------------------------------------------------------------------------- -testShow :: Test +testShow :: TestTree testShow = testProperty "show" $ do - lang <- genLanguage - return $ parseAccept (BS.pack $ show lang) === Just lang - + lang <- genLanguage + return $ parseAccept (BS.pack $ show lang) === Just lang ------------------------------------------------------------------------------- -testFromString :: Test +testFromString :: TestTree testFromString = testProperty "fromString" $ do - lang <- genLanguage - return $ lang === fromString (show lang) - + lang <- genLanguage + return $ lang === fromString (show lang) ------------------------------------------------------------------------------- -testMatches :: Test -testMatches = testGroup "matches" +testMatches :: TestTree +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 *" $ + 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" +testMoreSpecific :: TestTree +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" $ + flip moreSpecificThan anything <$> genConcreteLanguage, + testProperty "With *" $ + not . moreSpecificThan anything <$> genLanguage, + testProperty "Proper prefix lhs" $ + not . uncurry moreSpecificThan <$> genDiffMatchingLanguages, + testProperty "Proper prefix rhs" $ + uncurry (flip moreSpecificThan) <$> genDiffMatchingLanguages, + testProperty "Unrelated languages" $ not . uncurry moreSpecificThan <$> genNonMatchingLanguages ] - ------------------------------------------------------------------------------- -testParseAccept :: Test -testParseAccept = testGroup "parseAccept" - [ testProperty "Valid parse"$ do +testParseAccept :: TestTree +testParseAccept = + testGroup + "parseAccept" + [ testProperty "Valid parse" $ do lang <- genLanguage - return $ parseAccept (renderHeader lang) === Just lang - , testProperty "Trailing hyphen" $ do + return $ parseAccept (renderHeader lang) === Just lang, + testProperty "Trailing hyphen" $ do bs <- renderHeader <$> genLanguage return $ (parseAccept $ bs <> "-" :: Maybe Language) === Nothing ] diff --git a/test/Network/HTTP/Media/MediaType/Gen.hs b/test/Network/HTTP/Media/MediaType/Gen.hs --- a/test/Network/HTTP/Media/MediaType/Gen.hs +++ b/test/Network/HTTP/Media/MediaType/Gen.hs @@ -1,213 +1,170 @@ ------------------------------------------------------------------------------- -- | Contains definitions for generating 'MediaType's. module Network.HTTP.Media.MediaType.Gen - ( - -- * Generating MediaTypes - anything - , genMediaType - , genSubStar - , genMaybeSubStar - , subStarOf - , genConcreteMediaType - , genWithoutParams - , genWithParams - , stripParams - , genDiffMediaTypesWith - , genDiffMediaTypeWith - , genDiffMediaTypes - , genDiffMediaType - , genMatchingPair + ( -- * Generating MediaTypes + anything, + genMediaType, + genSubStar, + genMaybeSubStar, + subStarOf, + genConcreteMediaType, + genWithoutParams, + genWithParams, + stripParams, + genDiffMediaTypesWith, + genDiffMediaTypeWith, + genDiffMediaTypes, + genDiffMediaType, + genMatchingPair, -- * Generating Parameters - , genParameters - , genMaybeParameters - , genDiffParameters + genParameters, + genMaybeParameters, + genDiffParameters, -- * Rendering Parameters - , renderParameters - ) where - -import qualified Data.Map as Map - -import Control.Monad (filterM, liftM, liftM2) -import Data.ByteString (ByteString) -import Data.CaseInsensitive (CI, original) -import Data.Foldable (foldlM) -import Data.Map (fromList) -import Data.Monoid ((<>)) -import Test.QuickCheck.Gen - -import Network.HTTP.Media.Gen -import Network.HTTP.Media.MediaType.Internal + renderParameters, + ) +where +import Control.Monad (filterM, liftM2) +import Data.ByteString (ByteString) +import Data.CaseInsensitive (CI, original) +import Data.Foldable (foldlM) +import Data.Map (fromList) +import qualified Data.Map as Map +import Data.Monoid ((<>)) +import Network.HTTP.Media.Gen +import Network.HTTP.Media.MediaType.Internal +import Test.QuickCheck.Gen +import Prelude hiding ((<>)) ------------------------------------------------------------------------------- -- | Parameter entry for testing. type ParamEntry = (CI ByteString, CI ByteString) - ------------------------------------------------------------------------------- -- | The MediaType that matches anything. anything :: MediaType anything = MediaType "*" "*" Map.empty - ------------------------------------------------------------------------------- -- | Generates any kind of MediaType. genMediaType :: Gen MediaType genMediaType = oneof [return anything, genSubStar, genConcreteMediaType] - ------------------------------------------------------------------------------- -- | Generates a MediaType with just a concrete main type. genSubStar :: Gen MediaType genSubStar = do - main <- genCIByteString - return $ MediaType main "*" Map.empty - + main <- genCIByteString + return $ MediaType main "*" Map.empty ------------------------------------------------------------------------------- -- | Generates a MediaType whose sub type might be *. genMaybeSubStar :: Gen MediaType genMaybeSubStar = oneof [genSubStar, genConcreteMediaType] - ------------------------------------------------------------------------------- -- | Strips the sub type and parameters from a MediaType. subStarOf :: MediaType -> MediaType -subStarOf media = media { subType = "*", parameters = Map.empty } - +subStarOf media = media {subType = "*", parameters = Map.empty} ------------------------------------------------------------------------------- -- | Generates a concrete MediaType which may have parameters. genConcreteMediaType :: Gen MediaType genConcreteMediaType = do - main <- genCIByteString - sub <- genCIByteString - params <- oneof [return Map.empty, genParameters] - return $ MediaType main sub params - + main <- genCIByteString + sub <- genCIByteString + params <- oneof [return Map.empty, genParameters] + return $ MediaType main sub params ------------------------------------------------------------------------------- -- | Generates a concrete MediaType with no parameters. genWithoutParams :: Gen MediaType genWithoutParams = do - main <- genCIByteString - sub <- genCIByteString - return $ MediaType main sub Map.empty - + main <- genCIByteString + sub <- genCIByteString + return $ MediaType main sub Map.empty ------------------------------------------------------------------------------- -- | Generates a MediaType with at least one parameter. genWithParams :: Gen MediaType genWithParams = do - main <- genCIByteString - sub <- genCIByteString - params <- genParameters - return $ MediaType main sub params - + main <- genCIByteString + sub <- genCIByteString + MediaType main sub <$> genParameters ------------------------------------------------------------------------------- -- | Strips the parameters from the given MediaType. stripParams :: MediaType -> MediaType -stripParams media = media { parameters = Map.empty } - +stripParams media = media {parameters = Map.empty} ------------------------------------------------------------------------------- -- | Generates a different MediaType to the ones in the given list, using the -- given generator. genDiffMediaTypesWith :: Gen MediaType -> [MediaType] -> Gen MediaType genDiffMediaTypesWith gen media = do - media' <- gen - if media' `elem` media - then genDiffMediaTypesWith gen media - else return media' - + media' <- gen + if media' `elem` media + then genDiffMediaTypesWith gen media + else return media' ------------------------------------------------------------------------------- -- | Generates a different MediaType to the given one, using the given -- generator. genDiffMediaTypeWith :: Gen MediaType -> MediaType -> Gen MediaType genDiffMediaTypeWith gen = genDiffMediaTypesWith gen . (: []) - ------------------------------------------------------------------------------- -- | Generates a different MediaType to the ones in the given list. genDiffMediaTypes :: [MediaType] -> Gen MediaType genDiffMediaTypes = genDiffMediaTypesWith genMediaType - ------------------------------------------------------------------------------- -- | Generates a different MediaType to the given one. genDiffMediaType :: MediaType -> Gen MediaType genDiffMediaType = genDiffMediaTypes . (: []) - ------------------------------------------------------------------------------- -- | Reuse for 'mayParams' and 'someParams'. mkGenParams :: (Gen ParamEntry -> Gen [ParamEntry]) -> Gen Parameters -mkGenParams = liftM fromList . - ($ liftM2 (,) (genDiffCIByteString "q") genCIByteString) - +mkGenParams = + fmap fromList + . ($ liftM2 (,) (genDiffCIByteString "q") genCIByteString) ------------------------------------------------------------------------------- -- | Generates some sort of parameters. genMaybeParameters :: Gen Parameters genMaybeParameters = mkGenParams listOf - ------------------------------------------------------------------------------- -- | Generates at least one parameter. genParameters :: Gen Parameters genParameters = mkGenParams listOf1 - ------------------------------------------------------------------------------- -- | Generates a set of parameters that is not a submap of the given -- parameters (but not necessarily vice versa). genDiffParameters :: Parameters -> Gen Parameters genDiffParameters params = do - params' <- genParameters - if params' `Map.isSubmapOf` params - then genDiffParameters params - else return params' - + params' <- genParameters + if params' `Map.isSubmapOf` params + then genDiffParameters params + else return params' ------------------------------------------------------------------------------- -- | Generates a set of parameters that is a strict submap of the given -- parameters. genSubParameters :: Parameters -> Gen (Maybe Parameters) genSubParameters params - | Map.null params = return Nothing - | otherwise = Just . Map.fromList <$> genStrictSublist + | Map.null params = return Nothing + | otherwise = Just . Map.fromList <$> genStrictSublist where list = Map.toList params genStrictSublist = do - sublist <- filterM (const $ choose (False, True)) list - if sublist == list - then genStrictSublist - else return sublist - + sublist <- filterM (const $ choose (False, True)) list + if sublist == list + then genStrictSublist + else return sublist ------------------------------------------------------------------------------- -- | Generates a pair of non-equal MediaType values that are in a 'matches' -- relation, with the more specific value on the left. genMatchingPair :: Gen (MediaType, MediaType) genMatchingPair = do - a <- oneof [genSubStar, genConcreteMediaType] - b <- if subType a == "*" - then return anything - else oneof $ withSubParameters a : map return [subStarOf a, anything] - return (a, b) + a <- oneof [genSubStar, genConcreteMediaType] + b <- + if subType a == "*" + then return anything + else oneof $ withSubParameters a : map return [subStarOf a, anything] + return (a, b) where withSubParameters a = do - params <- genSubParameters (parameters a) - return $ case params of - Just sub -> a { parameters = sub } - Nothing -> subStarOf a - + params <- genSubParameters (parameters a) + return $ case params of + Just sub -> a {parameters = sub} + Nothing -> subStarOf a ------------------------------------------------------------------------------- -- | Render parameters with a generated amount of whitespace between the -- semicolons. Note that there is a leading semicolon in front of the -- parameters, as it is expected that this will always be attached to @@ -216,4 +173,4 @@ renderParameters params = foldlM pad "" (Map.toList params) where pad s (k, v) = - (s <>) . (<> original k <> "=" <> original v) <$> padString ";" + (s <>) . (<> original k <> "=" <> original v) <$> padString ";" diff --git a/test/Network/HTTP/Media/MediaType/Tests.hs b/test/Network/HTTP/Media/MediaType/Tests.hs --- a/test/Network/HTTP/Media/MediaType/Tests.hs +++ b/test/Network/HTTP/Media/MediaType/Tests.hs @@ -1,202 +1,198 @@ ------------------------------------------------------------------------------- module Network.HTTP.Media.MediaType.Tests (tests) where -import qualified Data.ByteString.Char8 as BS -import qualified Data.Map as Map - -import Control.Monad (join, liftM) -import Data.ByteString (ByteString) -import Data.CaseInsensitive (foldedCase) -import Data.Monoid ((<>)) -import Data.String (fromString) -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.QuickCheck (property, (.&&.), (===)) -import Test.QuickCheck.Gen (Gen) - -import Network.HTTP.Media.Accept -import Network.HTTP.Media.Gen -import Network.HTTP.Media.MediaType ((/.), (/?)) -import Network.HTTP.Media.MediaType.Gen -import Network.HTTP.Media.MediaType.Internal -import Network.HTTP.Media.RenderHeader (renderHeader) - +import Control.Monad (join) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS +import Data.CaseInsensitive (foldedCase) +import qualified Data.Map as Map +import Data.Monoid ((<>)) +import Data.String (fromString) +import Network.HTTP.Media.Accept +import Network.HTTP.Media.Gen +import Network.HTTP.Media.MediaType ((/.), (/?)) +import Network.HTTP.Media.MediaType.Gen +import Network.HTTP.Media.MediaType.Internal +import Network.HTTP.Media.RenderHeader (renderHeader) +import Test.QuickCheck (property, (.&&.), (===)) +import Test.QuickCheck.Gen (Gen) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) +import Prelude hiding ((<>)) ------------------------------------------------------------------------------- -tests :: [Test] +tests :: [TestTree] tests = - [ testEq - , testShow - , testFromString - , testHas - , testGet - , testMatches - , testMoreSpecificThan - , testParseAccept - ] - + [ testEq, + testShow, + testFromString, + testHas, + testGet, + testMatches, + testMoreSpecificThan, + testParseAccept + ] ------------------------------------------------------------------------------- -- Equality is derived, but we test it here to get 100% coverage. -testEq :: Test -testEq = testGroup "Eq" +testEq :: TestTree +testEq = + testGroup + "Eq" [ testProperty "==" $ do media <- genMediaType - return $ media === media - , testProperty "/=" $ do - media <- genMediaType + return $ media === media, + testProperty "/=" $ do + media <- genMediaType media' <- genDiffMediaType media return $ media /= media' ] - ------------------------------------------------------------------------------- -testShow :: Test +testShow :: TestTree testShow = testProperty "show" $ do - media <- genMediaType - return $ parseAccept (BS.pack $ show media) === Just media - + media <- genMediaType + return $ parseAccept (BS.pack $ show media) === Just media ------------------------------------------------------------------------------- -testFromString :: Test +testFromString :: TestTree testFromString = testProperty "fromString" $ do - media <- genMediaType - return $ media === fromString (show media) - + media <- genMediaType + return $ media === fromString (show media) ------------------------------------------------------------------------------- -testHas :: Test -testHas = testGroup "(/?)" +testHas :: TestTree +testHas = + testGroup + "(/?)" [ testProperty "True for property it has" $ do media <- genWithParams - return $ all ((media /?) . foldedCase) (Map.keys $ parameters media) - , testProperty "False for property it doesn't have" $ do + return $ all ((media /?) . foldedCase) (Map.keys $ parameters media), + testProperty "False for property it doesn't have" $ do media <- genWithParams - return $ all (not . (stripParams media /?) . foldedCase) + return . not $ + any + ((stripParams media /?) . foldedCase) (Map.keys $ parameters media) ] - ------------------------------------------------------------------------------- -testGet :: Test -testGet = testGroup "(/.)" +testGet :: TestTree +testGet = + testGroup + "(/.)" [ testProperty "Retrieves property it has" $ do - media <- genWithParams + media <- genWithParams let is n v = (.&&. media /. foldedCase n === Just v) - return $ Map.foldrWithKey is (property True) $ parameters media - , testProperty "Nothing for property it doesn't have" $ do + return $ Map.foldrWithKey is (property True) $ parameters media, + testProperty "Nothing for property it doesn't have" $ do media <- genWithParams let is n _ = (.&&. stripParams media /. foldedCase n === Nothing) return $ Map.foldrWithKey is (property True) $ parameters media ] - ------------------------------------------------------------------------------- -testMatches :: Test -testMatches = testGroup "matches" +testMatches :: TestTree +testMatches = + testGroup + "matches" [ testProperty "Equal values match" $ do media <- genMediaType - return $ matches media media - , testProperty "Same sub but different main don't match" $ do + return $ matches media media, + testProperty "Same sub but different main don't match" $ do media <- genMaybeSubStar - main <- genDiffCIByteString $ mainType media - return $ not (matches media media { mainType = main }) && - not (matches media { mainType = main } media) - , testProperty "Same main but different sub don't match" $ do + main <- genDiffCIByteString $ mainType media + return $ + not (matches media media {mainType = main}) + && not (matches media {mainType = main} media), + testProperty "Same main but different sub don't match" $ do media <- genConcreteMediaType - sub <- genDiffCIByteString $ subType media - return . not $ matches media media { subType = sub } || - matches media { subType = sub } media - , testProperty "Different parameters don't match" $ - liftM (not . dotJoin matches stripParams) genWithParams - , testProperty "Missing parameters match" $ do + sub <- genDiffCIByteString $ subType media + return . not $ + matches media media {subType = sub} + || matches media {subType = sub} media, + testProperty "Different parameters don't match" $ + not . dotJoin matches stripParams <$> genWithParams, + testProperty "Missing parameters match" $ do media <- genWithParams let media' = stripParams media - return $ matches media media' && not (matches media' media) - , testGroup "*/*" - [ testProperty "Matches itself" $ matches anything anything - , testProperty "Matches anything on the right" $ - liftM (`matches` anything) genMediaType - , testProperty "Doesn't match more specific on the left" $ - liftM (not . matches anything) genMaybeSubStar - ] - , testGroup "type/*" - [ testProperty "Matches itself" $ liftM (join matches) genSubStar - , testProperty "Matches on the right" $ - liftM (dotJoin (flip matches) subStarOf) genConcreteMediaType - , testProperty "Doesn't match on the left" $ - liftM (not . dotJoin matches subStarOf) genConcreteMediaType + return $ matches media media' && not (matches media' media), + testGroup + "*/*" + [ testProperty "Matches itself" $ matches anything anything, + testProperty "Matches anything on the right" $ + (`matches` anything) <$> genMediaType, + testProperty "Doesn't match more specific on the left" $ + not . (anything `matches`) <$> genMaybeSubStar + ], + testGroup + "type/*" + [ testProperty "Matches itself" $ join matches <$> genSubStar, + testProperty "Matches on the right" $ + dotJoin (flip matches) subStarOf <$> genConcreteMediaType, + testProperty "Doesn't match on the left" $ + not . dotJoin matches subStarOf <$> genConcreteMediaType ] ] - ------------------------------------------------------------------------------- -testMoreSpecificThan :: Test -testMoreSpecificThan = testGroup "moreSpecificThan" +testMoreSpecificThan :: TestTree +testMoreSpecificThan = + testGroup + "moreSpecificThan" [ testProperty "Against */*" $ - liftM (`moreSpecificThan` anything) genMaybeSubStar - , testProperty "With */*" $ - liftM (not . moreSpecificThan anything) genMaybeSubStar - , testProperty "Against type/*" $ - liftM (dotJoin (flip moreSpecificThan) subStarOf) genConcreteMediaType - , testProperty "With type/*" $ - liftM (not . dotJoin moreSpecificThan subStarOf) genConcreteMediaType - , testProperty "With parameters" $ - liftM (dotJoin (flip moreSpecificThan) stripParams) genWithParams - , testProperty "Different types" $ do - media <- genWithoutParams + (`moreSpecificThan` anything) <$> genMaybeSubStar, + testProperty "With */*" $ + not . (anything `moreSpecificThan`) <$> genMaybeSubStar, + testProperty "Against type/*" $ + dotJoin (flip moreSpecificThan) subStarOf <$> genConcreteMediaType, + testProperty "With type/*" $ + not . dotJoin moreSpecificThan subStarOf <$> genConcreteMediaType, + testProperty "With parameters" $ + dotJoin (flip moreSpecificThan) stripParams <$> genWithParams, + testProperty "Different types" $ do + media <- genWithoutParams media' <- genDiffMediaTypeWith genWithoutParams media return . not $ - moreSpecificThan media media' || moreSpecificThan media' media - , testProperty "Different parameters" $ do - media <- genWithParams + moreSpecificThan media media' || moreSpecificThan media' media, + testProperty "Different parameters" $ do + media <- genWithParams params <- genDiffParameters $ parameters media - return . not $ moreSpecificThan media media { parameters = params } + return . not $ moreSpecificThan media media {parameters = params} ] - ------------------------------------------------------------------------------- -testParseAccept :: Test -testParseAccept = testGroup "parseAccept" +testParseAccept :: TestTree +testParseAccept = + testGroup + "parseAccept" [ testProperty "Valid parse" $ do media <- genMediaType let main = mainType media - sub = subType media + sub = subType media params <- renderParameters (parameters media) let parsed = parseAccept $ foldedCase (main <> "/" <> sub) <> params - return $ parsed === Just media - , testProperty "No sub" $ do + return $ parsed === Just media, + testProperty "No sub" $ do bs <- genByteString - return $ (parseAccept bs :: Maybe MediaType) === Nothing - , testProperty "Empty main" $ do + return $ (parseAccept bs :: Maybe MediaType) === Nothing, + testProperty "Empty main" $ do sep <- padString "/" - bs <- (sep <>) <$> genByteString - return $ (parseAccept bs :: Maybe MediaType) === Nothing - , testProperty "Empty sub" $ do + bs <- (sep <>) <$> genByteString + return $ (parseAccept bs :: Maybe MediaType) === Nothing, + testProperty "Empty sub" $ do sep <- padString "/" - bs <- (<> sep) <$> genByteString - return $ (parseAccept bs :: Maybe MediaType) === Nothing - , testProperty "Empty parameters" $ do + bs <- (<> sep) <$> genByteString + return $ (parseAccept bs :: Maybe MediaType) === Nothing, + testProperty "Empty parameters" $ do sep <- padString ";" - bs <- renderHeader <$> genWithoutParams - return $ (parseAccept (bs <> sep) :: Maybe MediaType) === Nothing - , testProperty "No value" $ - (=== Nothing) <$> genMediaNameAndParams "" - , testProperty "Empty value" $ do + bs <- renderHeader <$> genWithoutParams + return $ (parseAccept (bs <> sep) :: Maybe MediaType) === Nothing, + testProperty "No value" $ + (=== Nothing) <$> genMediaNameAndParams "", + testProperty "Empty value" $ do eq <- padString "=" (=== Nothing) <$> genMediaNameAndParams eq ] genMediaNameAndParams :: ByteString -> Gen (Maybe MediaType) genMediaNameAndParams eq = do - sep <- padString ";" - bs <- renderHeader <$> genByteString - name <- genByteString - ps <- genMaybeParameters >>= renderParameters - return $ parseAccept (bs <> sep <> name <> eq <> sep <> ps) - + sep <- padString ";" + bs <- renderHeader <$> genByteString + name <- genByteString + ps <- genMaybeParameters >>= renderParameters + return $ parseAccept (bs <> sep <> name <> eq <> sep <> ps) ------------------------------------------------------------------------------- -- | Like 'join', but applies the given function to the first argument. dotJoin :: (a -> a -> b) -> (a -> a) -> a -> b dotJoin f g a = f (g a) a diff --git a/test/Network/HTTP/Media/Tests.hs b/test/Network/HTTP/Media/Tests.hs --- a/test/Network/HTTP/Media/Tests.hs +++ b/test/Network/HTTP/Media/Tests.hs @@ -1,51 +1,52 @@ ------------------------------------------------------------------------------- -module Network.HTTP.Media.Tests (tests) where - -import Control.Monad (join, replicateM, (>=>)) -import Data.Foldable (foldlM) -import Data.Function (on) -import Data.List (nubBy) -import Data.Map (empty) -import Data.Monoid ((<>)) -import Data.Word (Word16) -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.QuickCheck +{-# LANGUAGE TupleSections #-} -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 +module Network.HTTP.Media.Tests (tests) where +import Control.Monad (join, replicateM, (>=>)) +import Data.Foldable (foldlM) +import Data.Function (on) +import Data.List (nubBy) +import Data.Map (empty) +import Data.Monoid ((<>)) +import Data.Word (Word16) +import 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 +import Test.QuickCheck +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) +import Prelude hiding ((<>)) ------------------------------------------------------------------------------- -tests :: [Test] +tests :: [TestTree] tests = - [ testParse - , testMatchAccept - , testMapAccept - , testMatchContent - , testMapContent - , testMatchQuality - , testMapQuality - ] - + [ testParse, + testMatchAccept, + testMapAccept, + testMatchContent, + testMapContent, + testMatchQuality, + testMapQuality + ] ------------------------------------------------------------------------------- -testParse :: Test -testParse = testGroup "parseQuality" +testParse :: TestTree +testParse = + testGroup + "parseQuality" [ testProperty "Without quality" $ do - media <- medias + media <- medias rendered <- padConcat (return . renderHeader) media - return $ parseQuality rendered === Just (map maxQuality media) - , testProperty "With quality" $ do - media <- qualities + return $ parseQuality rendered === Just (map maxQuality media), + testProperty "With quality" $ do + media <- qualities rendered <- padConcat padQuality media - return $ parseQuality rendered === Just media - , testProperty "With extensions" $ do - media <- qualities + return $ parseQuality rendered === Just media, + testProperty "With extensions" $ do + media <- qualities rendered <- padConcat (padQuality >=> padExtensions) media return $ parseQuality rendered === Just media ] @@ -55,194 +56,190 @@ 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 + semi <- padString ";" + let d = renderHeader (qualityData qMedia) + v = showQ (qualityValue qMedia) + return $ d <> semi <> "q=" <> v padExtensions s = genParameters >>= fmap (s <>) . renderParameters pad a s b = a <> s <> b - ------------------------------------------------------------------------------- -testMatchAccept :: Test +testMatchAccept :: TestTree testMatchAccept = testMatch "Accept" matchAccept renderHeader - ------------------------------------------------------------------------------- -testMapAccept :: Test +testMapAccept :: TestTree testMapAccept = testMap "Accept" mapAccept renderHeader - ------------------------------------------------------------------------------- -testMatchContent :: Test -testMatchContent = testGroup "matchContent" +testMatchContent :: TestTree +testMatchContent = + testGroup + "matchContent" [ testProperty "Matches" $ do media <- genMediaType - return $ matchContent [media] (renderHeader media) === Just media - , testProperty "Nothing" $ do + return $ matchContent [media] (renderHeader media) === Just media, + testProperty "Nothing" $ do content <- genMediaType parsers <- filter (not . matches content) <$> genServer - return $ matchContent parsers (renderHeader content) === Nothing - , testProperty "Against */*" $ do + return $ matchContent parsers (renderHeader content) === Nothing, + testProperty "Against */*" $ do media <- genMediaType return $ - matchContent [anything] (renderHeader media) === Just anything - , testProperty "Against type/*" $ do + matchContent [anything] (renderHeader media) === Just anything, + testProperty "Against type/*" $ do media <- genMediaType let sub = subStarOf media return $ matchContent [sub] (renderHeader media) === Just sub ] - ------------------------------------------------------------------------------- -testMapContent :: Test -testMapContent = testGroup "mapContent" +testMapContent :: TestTree +testMapContent = + testGroup + "mapContent" [ testProperty "Matches" $ do media <- genMediaType - return $ mapContent [(media, ())] (renderHeader media) === Just () - , testProperty "Nothing" $ do + return $ mapContent [(media, ())] (renderHeader media) === Just (), + testProperty "Nothing" $ do content <- genMediaType parsers <- join zip . filter (not . matches content) <$> genServer - return $ mapContent parsers (renderHeader content) === Nothing + return $ mapContent parsers (renderHeader content) === Nothing, + testProperty "Overlapping keys" $ do + (a, b) <- genMatchingPair + return $ mapContent [(a, False), (b, True)] (renderHeader b) ] - ------------------------------------------------------------------------------- -testMatchQuality :: Test +testMatchQuality :: TestTree testMatchQuality = testMatch "Quality" matchQuality id - ------------------------------------------------------------------------------- -testMapQuality :: Test +testMapQuality :: TestTree testMapQuality = testMap "Quality" mapQuality id - ------------------------------------------------------------------------------- -testMatch - :: String - -> ([MediaType] -> a -> Maybe MediaType) - -> ([Quality MediaType] -> a) - -> Test -testMatch name match qToI = testGroup ("match" ++ name) +testMatch :: + String -> + ([MediaType] -> a -> Maybe MediaType) -> + ([Quality MediaType] -> a) -> + TestTree +testMatch name match qToI = + testGroup + ("match" ++ name) [ testProperty "Most specific" $ do media <- genConcreteMediaType - let client = qToI $ map maxQuality - [ MediaType "*" "*" empty - , media { subType = "*" } - , media { parameters = empty } - , media - ] - return $ match [media] client === Just media - , testProperty "Nothing" $ do + let client = + qToI $ + map + maxQuality + [ MediaType "*" "*" empty, + media {subType = "*"}, + media {parameters = empty}, + media + ] + return $ match [media] client === Just media, + testProperty "Nothing" $ do client <- listOf1 genConcreteMediaType server <- filter (not . flip any client . matches) <$> genServer - return $ match server (qToI $ map maxQuality client) === Nothing - , testProperty "Left biased" $ do + return $ match server (qToI $ map maxQuality client) === Nothing, + testProperty "Left biased" $ do server <- genNubServer let client = qToI $ map maxQuality server - return $ match server client === Just (head server) - , testProperty "Against */*" $ do + return $ match server client === Just (head server), + testProperty "Against */*" $ do server <- genNubServer let stars = "*/*" :: MediaType - return $ match server (qToI [maxQuality stars]) === - Just (head server) - , testProperty "Against type/*" $ do + return $ + match server (qToI [maxQuality stars]) + === Just (head server), + testProperty "Against type/*" $ do server <- genNubServer let client = qToI [maxQuality (subStarOf $ head server)] - return $ match server client === Just (head server) - , testQuality match qToI + return $ match server client === Just (head server), + testQuality match qToI ] - ------------------------------------------------------------------------------- -testQuality - :: ([MediaType] -> a -> Maybe MediaType) - -> ([Quality MediaType] -> a) - -> Test -testQuality match qToI = testGroup "Quality" +testQuality :: + ([MediaType] -> a -> Maybe MediaType) -> + ([Quality MediaType] -> a) -> + TestTree +testQuality match qToI = + testGroup + "Quality" [ testProperty "Highest quality" $ do server <- genServer - qs <- replicateM (length server) $ choose (1, 1000) + qs <- replicateM (length server) $ choose (1, 1000) let client = zipWith Quality server qs qmax v q = if qualityValue q > qualityValue v then q else v - return $ match server (qToI client) === - Just (qualityData $ foldr1 qmax client) - , testProperty "Most specific quality" $ do + return $ + match server (qToI client) + === Just (qualityData $ foldr1 qmax client), + testProperty "Most specific quality" $ do (a, b) <- genMatchingPair - c <- genDiffMediaType a + c <- genDiffMediaType a let client = qToI [quality a "0.5", maxQuality b, maxQuality c] - return $ match [a, c] client === Just c - , testQ0 match qToI + return $ match [a, c] client === Just c, + testQ0 match qToI ] - ------------------------------------------------------------------------------- -testQ0 - :: ([MediaType] -> a -> Maybe MediaType) - -> ([Quality MediaType] -> a) - -> Test -testQ0 match qToI = testGroup "q=0" +testQ0 :: + ([MediaType] -> a -> Maybe MediaType) -> + ([Quality MediaType] -> a) -> + TestTree +testQ0 match qToI = + testGroup + "q=0" [ testProperty "Does not choose a q=0" $ do server <- genConcreteMediaType - return $ match [server] (qToI [minQuality server]) === Nothing - , testProperty "Does not choose any q=0" $ do + return $ match [server] (qToI [minQuality server]) === Nothing, + testProperty "Does not choose any q=0" $ do server <- genServer - return $ match server (qToI $ map minQuality server) === Nothing - , testProperty "Does not choose q=0 with less specific type" $ do + return $ match server (qToI $ map minQuality server) === Nothing, + testProperty "Does not choose q=0 with less specific type" $ do (a, b) <- genMatchingPair let client = qToI [minQuality a, maxQuality b] - return $ match [a] client === Nothing - , testProperty "Does choose type with q=0 on less specific type" $ do + return $ match [a] client === Nothing, + testProperty "Does choose type with q=0 on less specific type" $ do (a, b) <- genMatchingPair let client = qToI [minQuality b, maxQuality a] - return $ match [a] client === Just a - , testProperty "Does not choose q=0 when followed by same type" $ do + return $ match [a] client === Just a, + testProperty "Does not choose q=0 when followed by same type" $ do server <- genConcreteMediaType let client = qToI [minQuality server, maxQuality server] - return $ match [server] client === Nothing - , testProperty "Does not choose q=0 when preceded by same type" $ do + return $ match [server] client === Nothing, + testProperty "Does not choose q=0 when preceded by same type" $ do server <- genConcreteMediaType let client = qToI [maxQuality server, minQuality server] return $ match [server] client === Nothing ] - ------------------------------------------------------------------------------- -testMap - :: String - -> ([(MediaType, MediaType)] -> a -> Maybe MediaType) - -> ([Quality MediaType] -> a) - -> Test -testMap name mapf qToI = testGroup ("map" ++ name) +testMap :: + String -> + ([(MediaType, MediaType)] -> a -> Maybe MediaType) -> + ([Quality MediaType] -> a) -> + TestTree +testMap name mapf qToI = + testGroup + ("map" ++ name) [ testProperty "Matches" $ do server <- genServer - qs <- replicateM (length server) $ choose (1, 1000 :: Word16) + qs <- replicateM (length server) $ choose (1, 1000 :: Word16) let client = zipWith Quality server qs qmax q v = if qualityValue q >= qualityValue v then q else v zipped = zip server server - return $ mapf zipped (qToI client) === - Just (qualityData $ foldr1 qmax client) - , testProperty "Nothing" $ do + return $ + mapf zipped (qToI client) + === Just (qualityData $ foldr1 qmax client), + testProperty "Nothing" $ do (server, client) <- genServerAndClient - let zipped = zip server $ repeat "*/*" + let zipped = map (,"*/*") server return $ mapf zipped (qToI $ map maxQuality client) === Nothing ] - ------------------------------------------------------------------------------- genServer :: Gen [MediaType] genServer = listOf1 genConcreteMediaType - ------------------------------------------------------------------------------- genNubServer :: Gen [MediaType] genNubServer = nubBy (on (==) stripParams) <$> genServer - ------------------------------------------------------------------------------- genServerAndClient :: Gen ([MediaType], [MediaType]) genServerAndClient = do - server <- genServer - client <- filter (not . flip any server . flip matches) <$> - listOf1 (genDiffMediaTypesWith genConcreteMediaType server) - return (server, client) + server <- genServer + client <- + filter (not . flip any server . flip matches) + <$> listOf1 (genDiffMediaTypesWith genConcreteMediaType server) + return (server, client) diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -1,23 +1,22 @@ ------------------------------------------------------------------------------- module Main (main) where -import Test.Framework (defaultMain, testGroup) - -import qualified Network.HTTP.Media.Accept.Tests as Accept -import qualified Network.HTTP.Media.Charset.Tests as Charset -import qualified Network.HTTP.Media.Encoding.Tests as Encoding -import qualified Network.HTTP.Media.Language.Tests as Language +import qualified Network.HTTP.Media.Accept.Tests as Accept +import qualified Network.HTTP.Media.Charset.Tests as Charset +import qualified Network.HTTP.Media.Encoding.Tests as Encoding +import qualified Network.HTTP.Media.Language.Tests as Language import qualified Network.HTTP.Media.MediaType.Tests as MediaType -import qualified Network.HTTP.Media.Tests as Media - +import qualified Network.HTTP.Media.Tests as Media +import Test.Tasty (defaultMain, testGroup) ------------------------------------------------------------------------------- main :: IO () -main = defaultMain - [ testGroup "Accept" Accept.tests - , testGroup "Charset" Charset.tests - , testGroup "Encoding" Encoding.tests - , testGroup "Language" Language.tests - , testGroup "MediaType" MediaType.tests - , testGroup "Media" Media.tests - ] +main = + defaultMain $ + testGroup + "http-media" + [ testGroup "Accept" Accept.tests, + testGroup "Charset" Charset.tests, + testGroup "Encoding" Encoding.tests, + testGroup "Language" Language.tests, + testGroup "MediaType" MediaType.tests, + testGroup "Media" Media.tests + ]