packages feed

http-media 0.3.0 → 0.4.0

raw patch · 12 files changed

+119/−97 lines, 12 files

Files

http-media.cabal view
@@ -1,5 +1,5 @@ name:          http-media-version:       0.3.0+version:       0.4.0 license:       MIT license-file:  LICENSE author:        Timothy Jones@@ -51,11 +51,12 @@   exposed-modules:     Network.HTTP.Media     Network.HTTP.Media.Accept-    Network.HTTP.Media.MediaType     Network.HTTP.Media.Language+    Network.HTTP.Media.MediaType+    Network.HTTP.Media.RenderHeader   other-modules:-    Network.HTTP.Media.MediaType.Internal     Network.HTTP.Media.Language.Internal+    Network.HTTP.Media.MediaType.Internal     Network.HTTP.Media.Quality     Network.HTTP.Media.Utils   build-depends:@@ -78,15 +79,16 @@     Network.HTTP.Media.Accept     Network.HTTP.Media.Accept.Tests     Network.HTTP.Media.Gen-    Network.HTTP.Media.MediaType-    Network.HTTP.Media.MediaType.Gen-    Network.HTTP.Media.MediaType.Internal-    Network.HTTP.Media.MediaType.Tests     Network.HTTP.Media.Language     Network.HTTP.Media.Language.Gen     Network.HTTP.Media.Language.Internal     Network.HTTP.Media.Language.Tests+    Network.HTTP.Media.MediaType+    Network.HTTP.Media.MediaType.Gen+    Network.HTTP.Media.MediaType.Internal+    Network.HTTP.Media.MediaType.Tests     Network.HTTP.Media.Quality+    Network.HTTP.Media.RenderHeader     Network.HTTP.Media.Tests     Network.HTTP.Media.Utils
src/Network/HTTP/Media.hs view
@@ -14,6 +14,7 @@      -- * Languages     , Language+    , toParts      -- * Accept matching     , matchAccept@@ -36,6 +37,9 @@      -- * Accept     , Accept (..)++    -- * Rendering+    , RenderHeader (..)     ) where  ------------------------------------------------------------------------------@@ -48,9 +52,10 @@ import Data.ByteString.UTF8 (toString)  -------------------------------------------------------------------------------import Network.HTTP.Media.Accept    as Accept-import Network.HTTP.Media.Language  as Language-import Network.HTTP.Media.MediaType as MediaType+import Network.HTTP.Media.Accept       as Accept+import Network.HTTP.Media.RenderHeader+import Network.HTTP.Media.Language     as Language+import Network.HTTP.Media.MediaType    as MediaType import Network.HTTP.Media.Quality import Network.HTTP.Media.Utils
src/Network/HTTP/Media/Accept.hs view
@@ -7,8 +7,7 @@     ) where  -------------------------------------------------------------------------------import Data.ByteString-import Data.ByteString.UTF8 (toString)+import Data.ByteString (ByteString)   ------------------------------------------------------------------------------@@ -23,14 +22,6 @@     -- handled.     parseAccept :: ByteString -> Maybe a -    -- | Specifies how to show an Accept-* header. Defaults to the standard-    -- show method.-    ---    -- Mostly useful just for avoiding quotes when rendering 'ByteString's-    -- with accompanying quality.-    showAccept :: a -> String-    showAccept = show-     -- | Evaluates whether either the left argument matches the right one.     --     -- This relation must be a total order, where more specific terms on the@@ -54,7 +45,6 @@  instance Accept ByteString where     parseAccept = Just-    showAccept = toString     matches = (==)     moreSpecificThan _ _ = False
src/Network/HTTP/Media/Language.hs view
@@ -3,10 +3,19 @@ -- language negotiation. module Network.HTTP.Media.Language     ( Language-    , toList-    , toByteString+    , toParts     ) where  ------------------------------------------------------------------------------+import Data.ByteString (ByteString)++------------------------------------------------------------------------------ import Network.HTTP.Media.Language.Internal+++------------------------------------------------------------------------------+-- | Converts 'Language' to a list of its language parts. The wildcard+-- produces an empty list.+toParts :: Language -> [ByteString]+toParts (Language l) = l
src/Network/HTTP/Media/Language/Internal.hs view
@@ -3,8 +3,6 @@ -- language negotiation. module Network.HTTP.Media.Language.Internal     ( Language (..)-    , toList-    , toByteString     ) where  ------------------------------------------------------------------------------@@ -20,8 +18,9 @@ import Data.String     (IsString (..))  -------------------------------------------------------------------------------import Network.HTTP.Media.Accept (Accept (..))-import Network.HTTP.Media.Utils  (hyphen, isAlpha)+import Network.HTTP.Media.Accept       (Accept (..))+import Network.HTTP.Media.RenderHeader (RenderHeader (..))+import Network.HTTP.Media.Utils        (hyphen, isAlpha)   ------------------------------------------------------------------------------@@ -37,7 +36,7 @@ -- Note that internally, Language [] equates to *.  instance Show Language where-    show = BS.toString . toByteString+    show = BS.toString . renderHeader  instance IsString Language where     fromString "*" = Language []@@ -64,17 +63,7 @@     moreSpecificThan (Language a) (Language b) =         b `isPrefixOf` a && length a > length b ----------------------------------------------------------------------------------- | Converts 'Language' to a list of its language parts. The wildcard--- produces an empty list.-toList :: Language -> [ByteString]-toList (Language l) = l------------------------------------------------------------------------------------ | Converts 'Language' to 'ByteString'.-toByteString :: Language -> ByteString-toByteString (Language []) = "*"-toByteString (Language l)  = BS.intercalate "-" l+instance RenderHeader Language where+    renderHeader (Language []) = "*"+    renderHeader (Language l)  = BS.intercalate "-" l
src/Network/HTTP/Media/MediaType.hs view
@@ -8,7 +8,6 @@     , Parameters     , (//)     , (/:)-    , toByteString      -- * Querying     , mainType
src/Network/HTTP/Media/MediaType/Internal.hs view
@@ -3,7 +3,6 @@ module Network.HTTP.Media.MediaType.Internal     ( MediaType (..)     , Parameters-    , toByteString     ) where  ------------------------------------------------------------------------------@@ -12,15 +11,16 @@ import qualified Data.Map             as Map  -------------------------------------------------------------------------------import Control.Monad        (guard)-import Data.ByteString      (ByteString)-import Data.String          (IsString (..))-import Data.Map             (Map)-import Data.Maybe           (fromMaybe)-import Data.Monoid          ((<>))+import Control.Monad   (guard)+import Data.ByteString (ByteString)+import Data.String     (IsString (..))+import Data.Map        (Map)+import Data.Maybe      (fromMaybe)+import Data.Monoid     ((<>))  -------------------------------------------------------------------------------import Network.HTTP.Media.Accept (Accept (..))+import Network.HTTP.Media.Accept       (Accept (..))+import Network.HTTP.Media.RenderHeader (RenderHeader (..)) import Network.HTTP.Media.Utils  @@ -33,10 +33,7 @@     } deriving (Eq)  instance Show MediaType where-    show (MediaType a b p) =-        Map.foldrWithKey f (BS.toString a ++ '/' : BS.toString b) p-      where-        f k v = (++ ';' : BS.toString k ++ '=' : BS.toString v)+    show = BS.toString . renderHeader  instance IsString MediaType where     fromString str = flip fromMaybe (parseAccept $ BS.fromString str) $@@ -70,16 +67,13 @@         subB = subType b == "*"         params = not (Map.null $ parameters a) && Map.null (parameters b) +instance RenderHeader MediaType where+    renderHeader (MediaType a b p) = Map.foldrWithKey f (a <> "/" <> b) p+      where+        f k v = (<> ";" <> k <> "=" <> v) + ------------------------------------------------------------------------------ -- | 'MediaType' parameters. type Parameters = Map ByteString ByteString------------------------------------------------------------------------------------ | Converts 'MediaType' to 'ByteString'.-toByteString :: MediaType -> ByteString-toByteString (MediaType a b p) = Map.foldrWithKey f (a <> "/" <> b) p-  where-    f k v = (<> ";" <> k <> "=" <> v)
src/Network/HTTP/Media/Quality.hs view
@@ -8,23 +8,34 @@     ) where  -------------------------------------------------------------------------------import Data.Maybe (listToMaybe)-import Data.Word  (Word16)+import qualified Data.ByteString      as BS+import qualified Data.ByteString.UTF8 as BS  -------------------------------------------------------------------------------import Network.HTTP.Media.Accept+import Data.ByteString (ByteString)+import Data.List       (dropWhileEnd)+import Data.Maybe      (listToMaybe)+import Data.Monoid     ((<>))+import Data.Word       (Word16)  ------------------------------------------------------------------------------+import Network.HTTP.Media.RenderHeader (RenderHeader (..))+import Network.HTTP.Media.Utils        (zero)++------------------------------------------------------------------------------ -- | Attaches a quality value to data. data Quality a = Quality     { qualityData  :: a     , qualityValue :: Word16     } deriving (Eq) -instance Accept a => Show (Quality a) where-    show (Quality a q) = showAccept a ++ ";q=" ++ showQ q+instance RenderHeader a => Show (Quality a) where+    show = BS.toString . renderHeader +instance RenderHeader h => RenderHeader (Quality h) where+    renderHeader (Quality a q) = renderHeader a <> ";q=" <> showQ q + ------------------------------------------------------------------------------ -- | Attaches the quality value '1'. maxQuality :: a -> Quality a@@ -39,10 +50,13 @@  ------------------------------------------------------------------------------ -- | Converts the integral value into its standard quality representation.-showQ :: Word16 -> String+showQ :: Word16 -> ByteString showQ 1000 = "1" showQ 0    = "0"-showQ q    = '0' : '.' : let s = show q in replicate (3 - length s) '0' ++ s+showQ q    = "0." <> BS.replicate (3 - length s) zero <> b+  where+    s = show q+    b = BS.fromString (dropWhileEnd (== '0') s)   ------------------------------------------------------------------------------
+ src/Network/HTTP/Media/RenderHeader.hs view
@@ -0,0 +1,29 @@+------------------------------------------------------------------------------+-- | 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)+++------------------------------------------------------------------------------+-- | 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++instance RenderHeader ByteString where+    renderHeader = id++instance RenderHeader h => RenderHeader [h] where+    renderHeader = intercalate "," . map renderHeader+
src/Network/HTTP/Media/Utils.hs view
@@ -14,6 +14,7 @@     , space     , equal     , hyphen+    , zero     ) where  ------------------------------------------------------------------------------@@ -62,6 +63,7 @@  ------------------------------------------------------------------------------ -- | 'ByteString' compatible characters.-slash, semi, comma, space, equal, hyphen :: Word8-[slash, semi, comma, space, equal, hyphen] = [47, 59, 44, 32, 61, 45]+slash, semi, comma, space, equal, hyphen, zero :: Word8+[slash, semi, comma, space, equal, hyphen, zero] =+    [47, 59, 44, 32, 61, 45, 48]
test/Network/HTTP/Media/Language/Tests.hs view
@@ -12,7 +12,7 @@  ------------------------------------------------------------------------------ import Network.HTTP.Media.Accept-import Network.HTTP.Media.Language+import Network.HTTP.Media.RenderHeader import Network.HTTP.Media.Language.Gen  @@ -111,5 +111,5 @@ testParseAccept :: Test testParseAccept = testProperty "parseAccept" $ do     lang <- genLanguage-    return $ parseAccept (toByteString lang) == Just lang+    return $ parseAccept (renderHeader lang) == Just lang
test/Network/HTTP/Media/Tests.hs view
@@ -4,8 +4,6 @@ ------------------------------------------------------------------------------ import Control.Monad                     (replicateM) import Data.ByteString                   (ByteString)-import Data.ByteString.UTF8              (fromString)-import Data.List                         (intercalate) import Data.Map                          (empty) import Data.Maybe                        (isNothing, listToMaybe) import Data.Word                         (Word16)@@ -38,24 +36,23 @@     [ testProperty "Without quality" $ do         media <- medias         return $-            parseQuality (group media) == Just (map maxQuality media)+            parseQuality (renderHeader media) == Just (map maxQuality media)     , testProperty "With quality" $ do         media <- medias >>= mapM (flip fmap (choose (0, 1000)) . Quality)-        return $ parseQuality (group media) == Just media+        return $ parseQuality (renderHeader media) == Just media     ]   where     medias = listOf1 genMediaType-    group media = fromString $ intercalate "," (map show media)   ------------------------------------------------------------------------------ testMatchAccept :: Test-testMatchAccept = testMatch "Accept" matchAccept qToBS+testMatchAccept = testMatch "Accept" matchAccept renderHeader   ------------------------------------------------------------------------------ testMapAccept :: Test-testMapAccept = testMap "Accept" mapAccept qToBS+testMapAccept = testMap "Accept" mapAccept renderHeader   ------------------------------------------------------------------------------@@ -63,7 +60,7 @@ testMatchContent = testGroup "matchContent"     [ testProperty "Most specific" $ do         media <- genConcreteMediaType-        let client = toBS+        let client = renderHeader                 [ MediaType "*" "*" empty                 , media { subType = "*" }                 , media { parameters = empty }@@ -73,17 +70,19 @@     , testProperty "Nothing" $ do         (server, client) <- genServerAndClient         let client' = filter (not . flip any server . matches) client-        return . isNothing $ matchAccept server (toBS client')+        return . isNothing $ matchAccept server (renderHeader client')     , testProperty "Left biased" $ do         server <- genServer-        return $ matchAccept server (toBS server) == Just (head server)+        return $+            matchAccept server (renderHeader server) == Just (head server)     , testProperty "Against */*" $ do         server <- genServer         let stars = "*/*" :: ByteString-        return $ matchAccept server (toBS [stars]) == Just (head server)+        return $+            matchAccept server (renderHeader [stars]) == Just (head server)     , testProperty "Against type/*" $ do         server <- genServer-        let client = toBS [subStarOf $ head server]+        let client = renderHeader [subStarOf $ head server]         return $ matchAccept server client == Just (head server)     ] @@ -94,12 +93,12 @@     [ testProperty "Matches" $ do         server <- genServer         let zipped = zip server server-        return $ mapAccept zipped (toBS server) == listToMaybe server+        return $ mapAccept zipped (renderHeader server) == listToMaybe server     , testProperty "Nothing" $ do         server <- genServer         client <- listOf1 $ genDiffMediaTypesWith genConcreteMediaType server         let zipped = zip server $ repeat ()-        return . isNothing $ mapAccept zipped (toBS client)+        return . isNothing $ mapAccept zipped (renderHeader client)     ]  @@ -195,14 +194,4 @@     server <- genServer     client <- listOf1 $ genDiffMediaTypesWith genConcreteMediaType server     return (server, client)----------------------------------------------------------------------------------toBS :: Accept a => [a] -> ByteString-toBS = fromString . intercalate "," . map showAccept----------------------------------------------------------------------------------qToBS :: Accept a => [Quality a] -> ByteString-qToBS = fromString . intercalate "," . map show