Fixups (#38)

Fix some logic in request/response stuff

src/OpenAPI/Checker/Validate/MediaTypeObject.hs

@@ -10,7 +10,7 @@ import Data.Text (Text)
 import Network.HTTP.Media (MediaType, mainType, subType)
 import OpenAPI.Checker.Subtree
 import OpenAPI.Checker.Trace
-import OpenAPI.Checker.Validate.Schema
+import OpenAPI.Checker.Validate.Schema ()
 
 instance Subtree MediaTypeObject where
   type CheckEnv MediaTypeObject =
@@ -34,12 +34,16 @@ instance Subtree MediaTypeObject where
              "x-www-form-urlencoded" == subType mediaType -> checkEncoding
            | otherwise -> pure ()
         where
-          checkEncoding = for_ (IOHM.toList $ _mediaTypeObjectEncoding c) $ \(paramName, consEncoding) ->
-            case IOHM.lookup paramName $ _mediaTypeObjectEncoding p of
-              Nothing -> issueAt producer MediaEncodingMissing
-              Just prodEncoding -> localStep (MediaTypeParamEncoding paramName)
+          -- Each parameter encoded by the producer must be parsed by the
+          -- consumer
+          checkEncoding = for_ (IOHM.toList $ _mediaTypeObjectEncoding p) $ \(paramName, prodEncoding) ->
+            case IOHM.lookup paramName $ _mediaTypeObjectEncoding c of
+              Nothing -> issueAt consumer MediaEncodingMissing
+              Just consEncoding -> localStep (MediaTypeParamEncoding paramName)
                 $ checkCompatibility HNil
                 $ ProdCons prodEncoding consEncoding
+      -- If consumer requires schema then producer must produce compatible
+      -- request
       checkSchema = for_ (_mediaTypeObjectSchema c) $ \consRef ->
         case _mediaTypeObjectSchema p of
           Nothing -> issueAt producer MediaTypeSchemaRequired

src/OpenAPI/Checker/Validate/RequestBody.hs

@@ -20,19 +20,19 @@ instance Subtree RequestBody where
     '[ ProdCons (Definitions Schema) ]
   data CheckIssue RequestBody
     = RequestBodyRequired
-    | RequestMediaTypeNotFound
+    | RequestMediaTypeNotFound MediaType
     deriving (Eq, Ord, Show)
   checkCompatibility env (ProdCons p c) =
     if not (fromMaybe False $ _requestBodyRequired p)
         && (fromMaybe False $ _requestBodyRequired c)
     then issueAt producer RequestBodyRequired
     else
-      -- For each consumer we must find at least one compatible producer media
-      -- type
-      for_ (IOHM.toList $ _requestBodyContent c) $ \(mediaType, consMedia) ->
-      case IOHM.lookup mediaType $ _requestBodyContent p of
-        Nothing -> issueAt producer RequestMediaTypeNotFound
-        Just prodMedia -> localStep (MediaTypeStep mediaType) $
+      -- Each media type generated by the producer must be parsed by the
+      -- consumer
+      for_ (IOHM.toList $ _requestBodyContent p) $ \(mediaType, prodMedia) ->
+      case IOHM.lookup mediaType $ _requestBodyContent c of
+        Nothing -> issueAt consumer (RequestMediaTypeNotFound mediaType)
+        Just consMedia -> localStep (MediaTypeStep mediaType) $
           checkCompatibility (HCons mediaType env) (ProdCons prodMedia consMedia)
 
 instance Steppable RequestBody MediaTypeObject where

src/OpenAPI/Checker/Validate/Responses.hs

@@ -30,10 +30,10 @@ instance Subtree Responses where
   -- it. So, the logic is swapped.
   checkCompatibility env (ProdCons p c) = do
     let defs = getH @(ProdCons (Definitions Response)) env
-    for_ (IOHM.toList $  _responsesResponses p) $ \ (prodStatus, prodRef) ->
-      case IOHM.lookup prodStatus $ _responsesResponses c of
-        Nothing -> issueAt consumer $ ResponseCodeNotFound prodStatus
-        Just consRef -> do
+    for_ (IOHM.toList $  _responsesResponses c) $ \(prodStatus, consRef) ->
+      case IOHM.lookup prodStatus $ _responsesResponses p of
+        Nothing -> issueAt producer $ ResponseCodeNotFound prodStatus
+        Just prodRef -> do
           let tracedRefs = dereference <$> defs <*> ProdCons prodRef consRef
           localStep (ResponseCodeStep prodStatus)
             $ checkProdCons env tracedRefs
@@ -56,16 +56,18 @@ instance Subtree Response where
     checkHeaders
     pure ()
     where
-      -- Each response type expected by producer must be in the consumer (logic
-      -- is swapped)
+      -- Each response type, generated by the consumer must be parseable by the
+      -- producer
       checkMediaTypes = do
-        for_ (IOHM.toList $ _responseContent p) $ \ (mediaType, prodMediaObject) ->
-          case IOHM.lookup mediaType $ _responseContent c of
-            Nothing -> issueAt consumer $ ResponseMediaTypeMissing mediaType
-            Just consMediaObject -> localStep (ResponseMediaObject mediaType)
+        for_ (IOHM.toList $ _responseContent c) $ \ (mediaType, consMediaObject) ->
+          case IOHM.lookup mediaType $ _responseContent p of
+            Nothing -> issueAt producer $ ResponseMediaTypeMissing mediaType
+            Just prodMediaObject -> localStep (ResponseMediaObject mediaType)
               $ swapRoles
               $ checkCompatibility @MediaTypeObject (mediaType `HCons` swapProdCons schemaRefs `HCons` HNil)
               $ ProdCons consMediaObject prodMediaObject
+      -- Each header expected by the producer must be provided by the
+      -- consumer. Assume, that extra consumer headers are ignored.
       checkHeaders = do
         for_ (IOHM.toList $ _responseHeaders p) $ \ (hname, prodRef) ->
           case IOHM.lookup hname $ _responseHeaders c of