Structured syntax suffixes

CHANGES.md

@@ -1,6 +1,11 @@
 Changelog
 =========
 
+- Unreleased(minor)
+
+  Added support for parsing structured syntax suffixes on media types,
+  as described in [RFC 6839](https://www.rfc-editor.org/rfc/rfc6839).
+
 - [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

src/Network/HTTP/Media.hs

@@ -4,8 +4,10 @@ module Network.HTTP.Media
     MediaType,
     (//),
     (/:),
+    (/+),
     mainType,
     subType,
+    structuredSyntaxSuffix,
     parameters,
     (/?),
     (/.),

src/Network/HTTP/Media/MediaType.hs

@@ -6,10 +6,12 @@ module Network.HTTP.Media.MediaType
     Parameters,
     (//),
     (/:),
+    (/+),
 
     -- * Querying
     mainType,
     subType,
+    structuredSyntaxSuffix,
     parameters,
     (/?),
     (/.),
@@ -35,6 +37,12 @@ mainType = Internal.mainType
 subType :: MediaType -> CI ByteString
 subType = Internal.subType
 
+-- | Retrieves the structured syntax suffix (if any) of a 'MediaType'.
+--
+-- /See:/ [RFC 6839](https://www.rfc-editor.org/rfc/rfc6839)
+structuredSyntaxSuffix :: MediaType -> Maybe ByteString
+structuredSyntaxSuffix = Internal.structuredSyntaxSuffix
+
 -- | Retrieves the parameters of a 'MediaType'.
 parameters :: MediaType -> Parameters
 parameters = Internal.parameters
@@ -43,22 +51,29 @@ parameters = Internal.parameters
 -- 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) Nothing empty
+  | b == "*" = MediaType (ensureR a) (CI.mk b) Nothing empty
+  | otherwise = MediaType (ensureR a) (ensureR b) Nothing 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
+m@MediaType {Internal.parameters = ps} /: (k, v) =
+  m {Internal.parameters = insert (ensureR k) (ensureV v) ps}
+
+-- | Adds/replaces a structured syntax suffix (like @+json@) on a 'MediaType'.
+--
+-- /See:/ [RFC 6839](https://www.rfc-editor.org/rfc/rfc6839)
+(/+) :: MediaType -> ByteString -> MediaType
+m /+ s = m {Internal.structuredSyntaxSuffix = Just s}
 
 -- | Evaluates if a 'MediaType' has a parameter of the given name.
 (/?) :: MediaType -> ByteString -> Bool
-(MediaType _ _ p) /? k = Map.member (CI.mk k) p
+m /? k = Map.member (CI.mk k) $ parameters m
 
 -- | Retrieves a parameter from a 'MediaType'.
 (/.) :: MediaType -> ByteString -> Maybe (CI ByteString)
-(MediaType _ _ p) /. k = Map.lookup (CI.mk k) p
+m /. k = Map.lookup (CI.mk k) $ parameters m
 
 -- | Ensures that the 'ByteString' matches the ABNF for `reg-name` in RFC
 -- 4288.

src/Network/HTTP/Media/MediaType/Internal.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE NamedFieldPuns #-}
+
 -- | Defined to allow the constructor of 'MediaType' to be exposed to tests.
 module Network.HTTP.Media.MediaType.Internal
   ( MediaType (..),
@@ -10,6 +12,7 @@ import Data.ByteString (ByteString)
 import qualified Data.ByteString.Char8 as BS
 import Data.CaseInsensitive (CI, original)
 import qualified Data.CaseInsensitive as CI
+import Data.List (uncons)
 import Data.Map (Map)
 import qualified Data.Map as Map
 import Data.Maybe (fromMaybe)
@@ -26,6 +29,8 @@ data MediaType = MediaType
     mainType :: CI ByteString,
     -- | The sub type of the MediaType
     subType :: CI ByteString,
+    -- | Structured syntax suffix (e.g., @+json@), see RFC 6839
+    structuredSyntaxSuffix :: Maybe ByteString,
     -- | The parameters of the MediaType
     parameters :: Parameters
   }
@@ -43,24 +48,40 @@ instance IsString MediaType where
 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'
+    (mainType, rest) <- breakChar '/' s
+    let (subType, structuredSyntaxSuffix) = case breakChar '+' rest of
+          Nothing -> (rest, Nothing)
+          Just (sub, suf) -> (sub, Just suf)
+    guard $ not (BS.null mainType || BS.null subType) && (mainType /= "*" || subType == "*")
+    parameters <- foldM insert Map.empty ps
+    pure $
+      MediaType
+        { mainType = CI.mk mainType,
+          subType = CI.mk subType,
+          structuredSyntaxSuffix,
+          parameters
+        }
     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
+    | mainType b == "*" = suffix && params
+    | subType b == "*" = main && suffix && params
+    | otherwise = main && sub && suffix && params
     where
       main = mainType a == mainType b
       sub = subType a == subType b
+      suffix = case (structuredSyntaxSuffix a, structuredSyntaxSuffix b) of
+        (Nothing, Nothing) -> True
+        (Just sa, Just sb) -> sa == sb
+        -- Allow a suffix on the matchee only if our pattern matches any
+        -- subtype. This ensures */* will still match everything.
+        (Just _, Nothing) -> subType b == "*"
+        -- If the pattern specifies a suffix, it must be present on
+        -- the matchee.
+        (Nothing, Just _) -> False
       params = Map.null (parameters b) || parameters a == parameters b
 
   moreSpecificThan a b =
@@ -78,9 +99,18 @@ instance Accept MediaType where
   hasExtensionParameters _ = True
 
 instance RenderHeader MediaType where
-  renderHeader (MediaType a b p) =
-    Map.foldrWithKey f (original a <> "/" <> original b) p
+  renderHeader MediaType {mainType, subType, parameters, structuredSyntaxSuffix} =
+    Map.foldrWithKey f type_ parameters
     where
+      type_ =
+        mconcat $
+          [ original mainType,
+            "/",
+            original subType,
+            case structuredSyntaxSuffix of
+              Nothing -> mempty
+              Just s -> "+" <> s
+          ]
       f k v = (<> ";" <> original k <> "=" <> original v)
 
 -- | 'MediaType' parameters.

test/Network/HTTP/Media/MediaType/Gen.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE NamedFieldPuns #-}
+
 -- | Contains definitions for generating 'MediaType's.
 module Network.HTTP.Media.MediaType.Gen
   ( -- * Generating MediaTypes
@@ -43,7 +45,13 @@ type ParamEntry = (CI ByteString, CI ByteString)
 
 -- | The MediaType that matches anything.
 anything :: MediaType
-anything = MediaType "*" "*" Map.empty
+anything =
+  MediaType
+    { mainType = "*",
+      subType = "*",
+      structuredSyntaxSuffix = Nothing,
+      parameters = Map.empty
+    }
 
 -- | Generates any kind of MediaType.
 genMediaType :: Gen MediaType
@@ -53,7 +61,13 @@ genMediaType = oneof [return anything, genSubStar, genConcreteMediaType]
 genSubStar :: Gen MediaType
 genSubStar = do
   main <- genCIByteString
-  return $ MediaType main "*" Map.empty
+  pure
+    MediaType
+      { mainType = main,
+        subType = "*",
+        structuredSyntaxSuffix = Nothing,
+        parameters = Map.empty
+      }
 
 -- | Generates a MediaType whose sub type might be *.
 genMaybeSubStar :: Gen MediaType
@@ -66,24 +80,28 @@ 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
+  mainType <- genCIByteString
+  subType <- genCIByteString
+  structuredSyntaxSuffix <- genStructuredSuffix
+  parameters <- oneof [pure Map.empty, genParameters]
+  pure MediaType {mainType, subType, structuredSyntaxSuffix, parameters}
 
 -- | Generates a concrete MediaType with no parameters.
 genWithoutParams :: Gen MediaType
 genWithoutParams = do
-  main <- genCIByteString
-  sub <- genCIByteString
-  return $ MediaType main sub Map.empty
+  mainType <- genCIByteString
+  subType <- genCIByteString
+  structuredSyntaxSuffix <- genStructuredSuffix
+  pure MediaType {mainType, subType, structuredSyntaxSuffix, parameters = Map.empty}
 
 -- | Generates a MediaType with at least one parameter.
 genWithParams :: Gen MediaType
 genWithParams = do
-  main <- genCIByteString
-  sub <- genCIByteString
-  MediaType main sub <$> genParameters
+  mainType <- genCIByteString
+  subType <- genCIByteString
+  structuredSyntaxSuffix <- genStructuredSuffix
+  parameters <- genParameters
+  pure MediaType {mainType, subType, structuredSyntaxSuffix, parameters}
 
 -- | Strips the parameters from the given MediaType.
 stripParams :: MediaType -> MediaType
@@ -111,6 +129,15 @@ genDiffMediaTypes = genDiffMediaTypesWith genMediaType
 genDiffMediaType :: MediaType -> Gen MediaType
 genDiffMediaType = genDiffMediaTypes . (: [])
 
+-- | Sometimes generate a structured suffix from the list in RFC 6839,
+-- plus @"xml"@.
+genStructuredSuffix :: Gen (Maybe ByteString)
+genStructuredSuffix =
+  oneof
+    [ pure Nothing,
+      Just <$> elements ["json", "ber", "der", "fastinfoset", "wbxml", "xml", "zip"]
+    ]
+
 -- | Reuse for 'mayParams' and 'someParams'.
 mkGenParams :: (Gen ParamEntry -> Gen [ParamEntry]) -> Gen Parameters
 mkGenParams =

test/Network/HTTP/Media/MediaType/Tests.hs

@@ -160,8 +160,10 @@ testParseAccept =
         media <- genMediaType
         let main = mainType media
             sub = subType media
+            suffix = maybe "" ("+" <>) $ structuredSyntaxSuffix media
         params <- renderParameters (parameters media)
-        let parsed = parseAccept $ foldedCase (main <> "/" <> sub) <> params
+        let parsed =
+              parseAccept $ foldedCase (main <> "/" <> sub) <> suffix <> params
         return $ parsed === Just media,
       testProperty "No sub" $ do
         bs <- genByteString

test/Network/HTTP/Media/Tests.hs

@@ -126,7 +126,7 @@ testMatch name match qToI =
               qToI $
                 map
                   maxQuality
-                  [ MediaType "*" "*" empty,
+                  [ MediaType "*" "*" Nothing empty,
                     media {subType = "*"},
                     media {parameters = empty},
                     media