http-media 0.8.0.0 → 0.8.1.1
raw patch · 27 files changed
Files
- CHANGES.md +13/−0
- http-media.cabal +20/−12
- src/Network/HTTP/Media.hs +190/−192
- src/Network/HTTP/Media/Accept.hs +36/−40
- src/Network/HTTP/Media/Charset.hs +2/−4
- src/Network/HTTP/Media/Charset/Internal.hs +27/−29
- src/Network/HTTP/Media/Encoding.hs +2/−4
- src/Network/HTTP/Media/Encoding/Internal.hs +30/−32
- src/Network/HTTP/Media/Language.hs +7/−10
- src/Network/HTTP/Media/Language/Internal.hs +43/−43
- src/Network/HTTP/Media/MediaType.hs +36/−53
- src/Network/HTTP/Media/MediaType/Internal.hs +67/−63
- src/Network/HTTP/Media/Quality.hs +58/−67
- src/Network/HTTP/Media/RenderHeader.hs +9/−12
- src/Network/HTTP/Media/Utils.hs +35/−35
- test/Network/HTTP/Media/Accept/Tests.hs +18/−23
- test/Network/HTTP/Media/Charset/Gen.hs +12/−24
- test/Network/HTTP/Media/Charset/Tests.hs +55/−64
- test/Network/HTTP/Media/Encoding/Gen.hs +13/−26
- test/Network/HTTP/Media/Encoding/Tests.hs +54/−63
- test/Network/HTTP/Media/Gen.hs +27/−46
- test/Network/HTTP/Media/Language/Gen.hs +29/−58
- test/Network/HTTP/Media/Language/Tests.hs +64/−72
- test/Network/HTTP/Media/MediaType/Gen.hs +74/−117
- test/Network/HTTP/Media/MediaType/Tests.hs +135/−139
- test/Network/HTTP/Media/Tests.hs +149/−152
- test/Test.hs +17/−18
CHANGES.md view
@@ -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.
http-media.cabal view
@@ -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 <tim@zmthy.net> 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
src/Network/HTTP/Media.hs view
@@ -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
src/Network/HTTP/Media/Accept.hs view
@@ -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
src/Network/HTTP/Media/Charset.hs view
@@ -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
src/Network/HTTP/Media/Charset/Internal.hs view
@@ -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 -- <https://tools.ietf.org/html/rfc7231#section-5.3.3 RFC7231>. --@@ -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
src/Network/HTTP/Media/Encoding.hs view
@@ -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
src/Network/HTTP/Media/Encoding/Internal.hs view
@@ -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 -- <https://tools.ietf.org/html/rfc7231#section-5.3.4 RFC7231>. --@@ -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
src/Network/HTTP/Media/Language.hs view
@@ -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]
src/Network/HTTP/Media/Language/Internal.hs view
@@ -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 -- <https://tools.ietf.org/html/rfc4647#section-2.1 RFC4647>. --@@ -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)
src/Network/HTTP/Media/MediaType.hs view
@@ -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)
src/Network/HTTP/Media/MediaType/Internal.hs view
@@ -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)
src/Network/HTTP/Media/Quality.hs view
@@ -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
src/Network/HTTP/Media/RenderHeader.hs view
@@ -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
src/Network/HTTP/Media/Utils.hs view
@@ -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
test/Network/HTTP/Media/Accept/Tests.hs view
@@ -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
test/Network/HTTP/Media/Charset/Gen.hs view
@@ -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
test/Network/HTTP/Media/Charset/Tests.hs view
@@ -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 ]
test/Network/HTTP/Media/Encoding/Gen.hs view
@@ -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
test/Network/HTTP/Media/Encoding/Tests.hs view
@@ -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 ]
test/Network/HTTP/Media/Gen.hs view
@@ -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
test/Network/HTTP/Media/Language/Gen.hs view
@@ -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
test/Network/HTTP/Media/Language/Tests.hs view
@@ -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 ]
test/Network/HTTP/Media/MediaType/Gen.hs view
@@ -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 ";"
test/Network/HTTP/Media/MediaType/Tests.hs view
@@ -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
test/Network/HTTP/Media/Tests.hs view
@@ -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)
test/Test.hs view
@@ -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+ ]