Structural compatibility (#49)

* First very rough draft of structural compatibility * Horrible schema hack * absurdIssue -> structuralIssue * Added some structural comparing * Added yet more structural comparisons * dropped ProdConsEqHList * Bumped resolver * Nonrecursive schema
2024-09-11 06:25:40 +03:00 · 2021-05-17 17:38:59 +03:00 · 2021-05-17 17:38:59 +03:00 · cbfeeedc1e
commit cbfeeedc1e
parent 8687e5fbac
21 changed files with 601 additions and 248 deletions
--- a/openapi-diff.cabal
+++ b/openapi-diff.cabal
@ -53,6 +53,7 @@ common common-options
                     , unordered-containers
                     , vector
                     , yaml
+                     , hashable

  default-extensions: ApplicativeDo
                    , BangPatterns
@ -93,6 +94,7 @@ common common-options
                    , UndecidableInstances
                    , ViewPatterns
                    , QuantifiedConstraints
+                    , DefaultSignatures

 library
  import:              common-options
@ -121,6 +123,9 @@ library
                  , OpenAPI.Checker.Validate.SecurityRequirement
                  , OpenAPI.Checker.Validate.Server
                  , OpenAPI.Checker.Validate.Sums
+                  , OpenAPI.Checker.Validate.Header
+                  , OpenAPI.Checker.Validate.Link
+                  , OpenAPI.Checker.Common

 executable openapi-diff
  import:              common-options
--- a/src/Data/HList.hs
+++ b/src/Data/HList.hs
@ -43,3 +43,9 @@ instance

 singletonH :: a -> HList '[a]
 singletonH a = a `HCons` HNil
+
+instance Eq (HList '[]) where
+  HNil == HNil = True
+
+instance (Eq x, Eq (HList xs)) => Eq (HList (x ': xs)) where
+  (HCons x xs) == (HCons y ys) = x == y && xs == ys
--- a/src/OpenAPI/Checker/Behavior.hs
+++ b/src/OpenAPI/Checker/Behavior.hs
@ -26,6 +26,7 @@ data BehaviorLevel
    PayloadLevel
  | SchemaLevel
  | TypedSchemaLevel
+  | LinkLevel

 class (Ord (Behave a b), Show (Behave a b))
  => Behavable (a :: BehaviorLevel) (b :: BehaviorLevel) where
--- a/src/OpenAPI/Checker/Common.hs
+++ b/src/OpenAPI/Checker/Common.hs
@ -0,0 +1,10 @@
+module OpenAPI.Checker.Common
+  ( zipAll
+  )
+where
+
+zipAll :: [a] -> [b] -> Maybe [(a, b)]
+zipAll [] [] = Just []
+zipAll (x : xs) (y : ys) = ((x, y) :) <$> zipAll xs ys
+zipAll (_ : _) [] = Nothing
+zipAll [] (_ : _) = Nothing
--- a/src/OpenAPI/Checker/References.hs
+++ b/src/OpenAPI/Checker/References.hs
@ -1,13 +1,16 @@
 {-# OPTIONS_GHC -Wno-orphans #-}
+
 module OpenAPI.Checker.References
  ( Step (..)
  , dereference
  )
 where

+import Data.HList
 import qualified Data.HashMap.Strict.InsOrd as IOHM
 import Data.Maybe
 import Data.OpenApi
+import qualified Data.OpenApi.Schema.Generator as G
 import Data.Typeable
 import OpenAPI.Checker.Orphans ()
 import OpenAPI.Checker.Subtree
@ -26,7 +29,25 @@ dereference
  -> Traced (Referenced a)
  -> Traced a
 dereference defs x = case extract x of
-  Inline a
-    -> traced (ask x >>> step InlineStep) a
-  Ref r@(Reference ref)
-    -> traced (ask defs >>> step (ReferencedStep r)) (fromJust $ IOHM.lookup ref $ extract defs)
+  Inline a ->
+    traced (ask x >>> step InlineStep) a
+  Ref r@(Reference ref) ->
+    traced (ask defs >>> step (ReferencedStep r)) (fromJust $ IOHM.lookup ref $ extract defs)
+
+instance Subtree a => Subtree (Referenced a) where
+  type CheckEnv (Referenced a) = ProdCons (Traced (Definitions a)) ': CheckEnv a
+  type SubtreeLevel (Referenced a) = SubtreeLevel a
+
+  checkStructuralCompatibility env pc' = do
+    let pc = do
+          x <- pc'
+          defs <- extract <$> getH @(ProdCons (Traced (Definitions a))) env
+          pure (G.dereference defs x)
+    checkStructuralCompatibility env pc
+
+  checkSemanticCompatibility env bhv pc' = do
+    let pc = do
+          x <- pc'
+          defs <- getH @(ProdCons (Traced (Definitions a))) env
+          pure (dereference defs x)
+    checkCompatibility env bhv pc
--- a/src/OpenAPI/Checker/Subtree.hs
+++ b/src/OpenAPI/Checker/Subtree.hs
@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
 module OpenAPI.Checker.Subtree
  ( Steppable (..)
  , Trace
@ -6,17 +8,27 @@ module OpenAPI.Checker.Subtree
  , pattern Traced
  , traced
  , Subtree (..)
+  , checkCompatibility
  , CompatM (..)
  , CompatFormula'
-  , CompatFormula
+  , SemanticCompatFormula
  , ProdCons (..)
  , HasUnsupportedFeature (..)
  , swapProdCons
  , runCompatFormula
  , issueAt
  , anyOfAt
+  , structuralIssue
  , memo

+    -- * Structural helpers
+  , structuralMaybe
+  , structuralMaybeWith
+  , structuralEq
+  , iohmStructural
+  , iohmStructuralWith
+  , structuralList
+
    -- * Reexports
  , (>>>)
  , (<<<)
@ -30,11 +42,15 @@ where
 import Control.Comonad.Env
 import Control.Monad.Identity
 import Control.Monad.State
+import Data.Foldable
 import Data.Functor.Compose
 import Data.HList
+import qualified Data.HashMap.Strict.InsOrd as IOHM
+import Data.Hashable
 import Data.Kind
 import Data.Monoid
 import Data.OpenApi
+import qualified Data.Set as S
 import Data.Typeable
 import OpenAPI.Checker.Behavior
 import OpenAPI.Checker.Formula
@ -89,18 +105,97 @@ newtype CompatM a = CompatM

 type CompatFormula' q f r = Compose CompatM (FormulaF q f r)

-type CompatFormula = CompatFormula' Behave AnIssue 'APILevel
+type SemanticCompatFormula = CompatFormula' Behave AnIssue 'APILevel
+
+type StructuralCompatFormula = CompatFormula' UnitQuiver Proxy ()
+
+data UnitQuiver a b where
+  UnitQuiver :: UnitQuiver () ()
+
+deriving stock instance Eq (UnitQuiver a b)
+
+deriving stock instance Ord (UnitQuiver a b)
+
+deriving stock instance Show (UnitQuiver a b)

 class (Typeable t, Issuable (SubtreeLevel t)) => Subtree (t :: Type) where
  type CheckEnv t :: [Type]
  type SubtreeLevel t :: BehaviorLevel

-  checkCompatibility
-    :: HasAll (CheckEnv t) xs
+  checkStructuralCompatibility
+    :: (HasAll (CheckEnv t) xs)
+    => HList xs
+    -> ProdCons t
+    -> StructuralCompatFormula ()
+
+  checkSemanticCompatibility
+    :: (HasAll (CheckEnv t) xs)
    => HList xs
    -> Behavior (SubtreeLevel t)
    -> ProdCons (Traced t)
-    -> CompatFormula ()
+    -> SemanticCompatFormula ()
+
+checkCompatibility
+  :: (HasAll (CheckEnv t) xs, Subtree t)
+  => HList xs
+  -> Behavior (SubtreeLevel t)
+  -> ProdCons (Traced t)
+  -> SemanticCompatFormula ()
+checkCompatibility e bhv pc =
+  case runCompatFormula $ checkStructuralCompatibility e $ fmap extract pc of
+    Left _ -> checkSemanticCompatibility e bhv pc
+    Right () -> pure ()
+
+structuralMaybe
+  :: (Subtree a, HasAll (CheckEnv a) xs)
+  => HList xs
+  -> ProdCons (Maybe a)
+  -> StructuralCompatFormula ()
+structuralMaybe e = structuralMaybeWith (checkStructuralCompatibility e)
+
+structuralMaybeWith
+  :: (ProdCons a -> StructuralCompatFormula ())
+  -> ProdCons (Maybe a)
+  -> StructuralCompatFormula ()
+structuralMaybeWith f (ProdCons (Just a) (Just b)) = f $ ProdCons a b
+structuralMaybeWith _ (ProdCons Nothing Nothing) = pure ()
+structuralMaybeWith _ _ = structuralIssue
+
+structuralList
+  :: (Subtree a, HasAll (CheckEnv a) xs)
+  => HList xs -> ProdCons [a] -> StructuralCompatFormula ()
+structuralList _ (ProdCons [] []) = pure ()
+structuralList e (ProdCons (a:aa) (b:bb)) = do
+  checkStructuralCompatibility e $ ProdCons a b
+  structuralList e $ ProdCons aa bb
+  pure ()
+structuralList _ _ = structuralIssue
+
+structuralEq :: Eq a => ProdCons a -> StructuralCompatFormula ()
+structuralEq (ProdCons a b) = if a == b then pure () else structuralIssue
+
+iohmStructural
+  :: (HasAll (CheckEnv v) (k ': xs), Ord k, Subtree v, Hashable k)
+  => HList xs
+  -> ProdCons (IOHM.InsOrdHashMap k v)
+  -> StructuralCompatFormula ()
+iohmStructural e =
+  iohmStructuralWith (\k -> checkStructuralCompatibility (k `HCons` e))
+
+iohmStructuralWith
+  :: (Ord k, Hashable k)
+  => (k -> ProdCons v -> StructuralCompatFormula ())
+  -> ProdCons (IOHM.InsOrdHashMap k v)
+  -> StructuralCompatFormula ()
+iohmStructuralWith f pc = do
+  let ProdCons pEKeys cEKeys = S.fromList . IOHM.keys <$> pc
+  if pEKeys == cEKeys
+    then
+      for_
+        pEKeys
+        (\eKey ->
+           f eKey $ IOHM.lookupDefault (error "impossible") eKey <$> pc)
+    else structuralIssue

 class HasUnsupportedFeature x where
  hasUnsupportedFeature :: x -> Bool
@ -137,6 +232,9 @@ runCompatFormula (Compose f) =
 issueAt :: Issuable l => Paths q r l -> Issue l -> CompatFormula' q AnIssue r a
 issueAt xs issue = Compose $ pure $ anError $ AnItem xs $ AnIssue issue

+structuralIssue :: StructuralCompatFormula a
+structuralIssue = Compose $ pure $ anError $ AnItem (step UnitQuiver) Proxy
+
 anyOfAt
  :: Issuable l
  => Paths q r l
--- a/src/OpenAPI/Checker/Validate/Header.hs
+++ b/src/OpenAPI/Checker/Validate/Header.hs
@ -0,0 +1,57 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module OpenAPI.Checker.Validate.Header
+  (
+  )
+where
+
+import Data.Foldable
+import Data.Functor
+import Data.Maybe
+import Data.OpenApi
+import OpenAPI.Checker.Behavior
+import OpenAPI.Checker.References ()
+import OpenAPI.Checker.Subtree
+import OpenAPI.Checker.Validate.Schema ()
+
+instance Subtree Header where
+  type SubtreeLevel Header = 'HeaderLevel
+  type CheckEnv Header = '[ProdCons (Traced (Definitions Schema))]
+  checkStructuralCompatibility env pc = do
+    structuralEq $ _headerRequired <$> pc
+    structuralEq $ _headerAllowEmptyValue <$> pc
+    structuralEq $ _headerExplode <$> pc
+    structuralMaybe env $ _headerSchema <$> pc
+    pure ()
+  checkSemanticCompatibility env beh (ProdCons p c) = do
+    if (fromMaybe False $ _headerRequired $ extract c) && not (fromMaybe False $ _headerRequired $ extract p)
+      then issueAt beh RequiredHeaderMissing
+      else pure ()
+    if not (fromMaybe False $ _headerAllowEmptyValue $ extract c) && (fromMaybe False $ _headerAllowEmptyValue $ extract p)
+      then issueAt beh NonEmptyHeaderRequired
+      else pure ()
+    for_ (tracedSchema c) $ \consRef ->
+      case tracedSchema p of
+        Nothing -> issueAt beh HeaderSchemaRequired
+        Just prodRef -> checkCompatibility env (beh >>> step InSchema) (ProdCons prodRef consRef)
+    pure ()
+
+instance Steppable Header (Referenced Schema) where
+  data Step Header (Referenced Schema) = HeaderSchema
+    deriving stock (Eq, Ord, Show)
+
+tracedSchema :: Traced Header -> Maybe (Traced (Referenced Schema))
+tracedSchema hdr = _headerSchema (extract hdr) <&> traced (ask hdr >>> step HeaderSchema)
+
+instance Issuable 'HeaderLevel where
+  data Issue 'HeaderLevel
+    = RequiredHeaderMissing
+    | NonEmptyHeaderRequired
+    | HeaderSchemaRequired
+    deriving stock (Eq, Ord, Show)
+  issueIsUnsupported _ = False
+
+instance Behavable 'HeaderLevel 'SchemaLevel where
+  data Behave 'HeaderLevel 'SchemaLevel
+    = InSchema
+    deriving stock (Eq, Ord, Show)
--- a/src/OpenAPI/Checker/Validate/Link.hs
+++ b/src/OpenAPI/Checker/Validate/Link.hs
@ -0,0 +1,20 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module OpenAPI.Checker.Validate.Link () where
+
+import Data.OpenApi
+import OpenAPI.Checker.Behavior
+import OpenAPI.Checker.Subtree
+
+instance Subtree Link where
+  type SubtreeLevel Link = 'LinkLevel
+  type CheckEnv Link = '[]
+  checkStructuralCompatibility _ _ = structuralIssue
+  checkSemanticCompatibility _ bhv _ = issueAt bhv LinksUnsupported
+
+instance Issuable 'LinkLevel where
+  data Issue 'LinkLevel
+    = LinksUnsupported
+    deriving (Eq, Ord, Show)
+  issueIsUnsupported = \case
+    LinksUnsupported -> True
--- a/src/OpenAPI/Checker/Validate/MediaTypeObject.hs
+++ b/src/OpenAPI/Checker/Validate/MediaTypeObject.hs
@ -17,6 +17,8 @@ import OpenAPI.Checker.Behavior
 import OpenAPI.Checker.Subtree
 import OpenAPI.Checker.Validate.Products
 import OpenAPI.Checker.Validate.Schema ()
+import OpenAPI.Checker.Validate.Header ()
+

 tracedSchema :: Traced MediaTypeObject -> Maybe (Traced (Referenced Schema))
 tracedSchema mto = _mediaTypeObjectSchema (extract mto) <&> traced (ask mto >>> step MediaTypeSchema)
@ -47,8 +49,14 @@ instance Subtree MediaTypeObject where
  type CheckEnv MediaTypeObject =
    '[ MediaType
     , ProdCons (Traced (Definitions Schema))
+     , ProdCons (Traced (Definitions Header))
     ]
-  checkCompatibility env beh prodCons@(ProdCons p c) = do
+  checkStructuralCompatibility env pc = do
+    structuralMaybe env $ _mediaTypeObjectSchema <$> pc
+    structuralEq $ _mediaTypeObjectExample <$> pc
+    iohmStructural env $ _mediaTypeObjectEncoding <$> pc
+    pure ()
+  checkSemanticCompatibility env beh prodCons@(ProdCons p c) = do
    if | "multipart" == mainType mediaType -> checkEncoding
       | "application" == mainType mediaType &&
         "x-www-form-urlencoded" == subType mediaType -> checkEncoding
@ -74,14 +82,27 @@ instance Subtree MediaTypeObject where
              , required = True } )
          encProdCons = getEncoding <$> prodCons
        in checkProducts beh MediaEncodingMissing
-           (const $ checkCompatibility HNil beh) encProdCons
+           (const $ checkCompatibility env beh) encProdCons

 instance Subtree Encoding where
  type SubtreeLevel Encoding = 'PayloadLevel
-  type CheckEnv Encoding = '[]
-    --  FIXME: Support only JSON body for now. Then Encoding is checked only for
-    --  multipart/form-url-encoded
-  checkCompatibility _env beh _pc =
+  type
+    CheckEnv Encoding =
+      '[ ProdCons (Traced (Definitions Header))
+       , ProdCons (Traced (Definitions Schema))
+       ]
+  checkStructuralCompatibility env pc = do
+    structuralEq $ _encodingContentType <$> pc
+    iohmStructural env $ _encodingHeaders <$> pc
+    structuralEq $ _encodingStyle <$> pc
+    structuralEq $ _encodingExplode <$> pc
+    structuralEq $ _encodingAllowReserved <$> pc
+    pure ()
+
+  --  FIXME: Support only JSON body for now. Then Encoding is checked only for
+  --  multipart/form-url-encoded
+  --  https://github.com/typeable/openapi-diff/issues/54
+  checkSemanticCompatibility _env beh _pc =
    issueAt beh EncodingNotSupported

 instance Steppable MediaTypeObject (Referenced Schema) where
--- a/src/OpenAPI/Checker/Validate/OpenApi.hs
+++ b/src/OpenAPI/Checker/Validate/OpenApi.hs
@ -43,10 +43,16 @@ tracedSchemas :: Traced OpenApi -> Traced (Definitions Schema)
 tracedSchemas oa = traced (ask oa >>> step ComponentsSchema)
  (_componentsSchemas . _openApiComponents . extract $ oa)

+tracedLinks :: Traced OpenApi -> Traced (Definitions Link)
+tracedLinks oa = traced (ask oa >>> step ComponentsLink)
+  (_componentsLinks . _openApiComponents . extract $ oa)
+
 instance Subtree OpenApi where
  type SubtreeLevel OpenApi = 'APILevel
  type CheckEnv OpenApi = '[]
-  checkCompatibility _ beh prodCons = do
+  -- There is no real reason to do a proper implementation
+  checkStructuralCompatibility _ _ = structuralIssue
+  checkSemanticCompatibility _ beh prodCons = do
    checkCompatibility @ProcessedPathItems
      ((tracedRequestBodies <$> prodCons)
         `HCons` (tracedParameters <$> prodCons)
@ -55,6 +61,7 @@ instance Subtree OpenApi where
         `HCons` (tracedHeaders <$> prodCons)
         `HCons` (tracedSchemas <$> prodCons)
         `HCons` (_openApiServers . extract <$> prodCons)
+         `HCons` (tracedLinks <$> prodCons)
         `HCons` HNil)
      beh (tracedPaths <$> prodCons)

@ -85,3 +92,7 @@ instance Steppable OpenApi (Definitions Header) where
 instance Steppable OpenApi (Definitions Schema) where
  data Step OpenApi (Definitions Schema) = ComponentsSchema
    deriving (Eq, Ord, Show)
+
+instance Steppable OpenApi (Definitions Link) where
+  data Step OpenApi (Definitions Link) = ComponentsLink
+    deriving (Eq, Ord, Show)
--- a/src/OpenAPI/Checker/Validate/Operation.hs
+++ b/src/OpenAPI/Checker/Validate/Operation.hs
@ -1,12 +1,12 @@
-{-# OPTIONS_GHC -Wno-orphans #-}
 {-# OPTIONS_GHC -Wno-name-shadowing #-}
+{-# OPTIONS_GHC -Wno-orphans #-}

 module OpenAPI.Checker.Validate.Operation
  ( MatchedOperation (..)
-  , OperationMethod(..)
+  , OperationMethod (..)
  , pathItemMethod
-  ) where
-
+  )
+where

 import Data.Foldable as F
 import Data.Functor
@ -15,8 +15,10 @@ import qualified Data.List as L
 import Data.Map.Strict as M
 import Data.Maybe
 import Data.OpenApi
+import qualified Data.OpenApi.Schema.Generator as G
 import Data.Text (Text)
 import OpenAPI.Checker.Behavior
+import OpenAPI.Checker.Common
 import OpenAPI.Checker.References
 import OpenAPI.Checker.Subtree
 import OpenAPI.Checker.Validate.MediaTypeObject
@ -28,11 +30,11 @@ import OpenAPI.Checker.Validate.Server ()

 data MatchedOperation = MatchedOperation
  { operation :: !Operation
-  , pathParams :: ![Traced Param]
-  -- ^ Params from the PathItem
-  , getPathFragments :: !([Traced Param] -> [Traced PathFragmentParam])
-  -- ^ Path fragments traced from PathItem. Takes full list of
-  -- operation-specific parameters
+  , -- | Params from the PathItem
+    pathParams :: ![Traced Param]
+  , -- | Path fragments traced from PathItem. Takes full list of
+    -- operation-specific parameters
+    getPathFragments :: !([Traced Param] -> [Traced PathFragmentParam])
  }

 type ParamKey = (ParamLocation, Text)
@ -43,32 +45,32 @@ paramKey param = (_paramIn param, _paramName param)
 tracedParameters :: Traced MatchedOperation -> [Traced (Referenced Param)]
 tracedParameters oper =
  [ traced (ask oper >>> step (OperationParamsStep i)) x
-  | (i, x) <- zip [0..] $ _operationParameters . operation $ extract oper
+  | (i, x) <- zip [0 ..] $ _operationParameters . operation $ extract oper
  ]

 tracedRequestBody :: Traced MatchedOperation -> Maybe (Traced (Referenced RequestBody))
 tracedRequestBody oper = _operationRequestBody (operation $ extract oper) <&> traced (ask oper >>> step OperationRequestBodyStep)

 tracedResponses :: Traced MatchedOperation -> Traced Responses
-tracedResponses oper = traced (ask oper >>> step OperationResponsesStep)
-  $ _operationResponses . operation $ extract oper
+tracedResponses oper =
+  traced (ask oper >>> step OperationResponsesStep) $
+    _operationResponses . operation $ extract oper

 tracedSecurity :: Traced MatchedOperation -> [Traced SecurityRequirement]
 tracedSecurity oper =
  [ traced (ask oper >>> step (OperationSecurityRequirementStep i)) x
-  | (i, x) <- zip [0..] $ _operationSecurity . operation $ extract oper
+  | (i, x) <- zip [0 ..] $ _operationSecurity . operation $ extract oper
  ]

 -- FIXME: https://github.com/typeable/openapi-diff/issues/28
-tracedServers
+getServers
  :: [Server] -- ^ Servers from env
-  -> Traced MatchedOperation
-  -> Traced [Server]
-tracedServers env oper =
-  traced (ask oper >>> step OperationServersStep) $
-    case _operationServers . operation $ extract oper of
-      [] -> env
-      ss -> ss
+  -> MatchedOperation
+  -> [Server]
+getServers env oper =
+  case _operationServers . operation $ oper of
+    [] -> env
+    ss -> ss

 instance Behavable 'OperationLevel 'PathFragmentLevel where
  data Behave 'OperationLevel 'PathFragmentLevel
@ -83,16 +85,42 @@ instance Behavable 'OperationLevel 'RequestLevel where

 instance Subtree MatchedOperation where
  type SubtreeLevel MatchedOperation = 'OperationLevel
-  type CheckEnv MatchedOperation =
-    '[ ProdCons (Traced (Definitions Param))
-     , ProdCons (Traced (Definitions RequestBody))
-     , ProdCons (Traced (Definitions SecurityScheme))
-     , ProdCons (Traced (Definitions Response))
-     , ProdCons (Traced (Definitions Header))
-     , ProdCons (Traced (Definitions Schema))
-     , ProdCons [Server]
-     ]
-  checkCompatibility env beh prodCons = do
+  type
+    CheckEnv MatchedOperation =
+      '[ ProdCons (Traced (Definitions Param))
+       , ProdCons (Traced (Definitions RequestBody))
+       , ProdCons (Traced (Definitions SecurityScheme))
+       , ProdCons (Traced (Definitions Response))
+       , ProdCons (Traced (Definitions Header))
+       , ProdCons (Traced (Definitions Schema))
+       , ProdCons [Server]
+       , ProdCons (Traced (Definitions Link))
+       ]
+  checkStructuralCompatibility env pc = do
+    let pParams :: ProdCons [Param]
+        pParams = do
+          defs <- extract <$> getH @(ProdCons (Traced (Definitions Param))) env
+          op' <- _operationParameters . operation <$> pc
+          pp <- fmap extract . pathParams <$> pc
+          pure $
+            let o = M.fromList $ do
+                  param <- G.dereference defs <$> op'
+                  let key = paramKey param
+                  pure (key, param)
+                p = M.fromList $ do
+                  param <- pp
+                  pure (paramKey param, param)
+             in M.elems $ o <> p
+    case zipAll (producer pParams) (consumer pParams) of
+      Nothing -> structuralIssue
+      Just xs -> for_ xs $ \(p, c) -> checkStructuralCompatibility env $ ProdCons p c
+    structuralMaybe env $ _operationRequestBody . operation <$> pc
+    checkStructuralCompatibility env $ _operationResponses . operation <$> pc
+    checkStructuralCompatibility env $ getServers <$> getH env <*> pc
+    -- TODO: Callbacks
+    -- TODO: Security
+    pure ()
+  checkSemanticCompatibility env beh prodCons = do
    checkParameters
    checkRequestBodies
    checkResponses
@ -102,97 +130,103 @@ instance Subtree MatchedOperation where
    pure ()
    where
      checkParameters = do
-        let
-          -- Merged parameters got from Operation and PathItem in one
-          -- place. First element is path params, second is non-path params
-          tracedParams :: ProdCons ([Traced Param], [Traced Param])
-          tracedParams = getParams <$> paramDefs <*> prodCons
-          getParams defs mp =
-            let
-              operationParamsMap :: Map ParamKey (Traced Param)
-              operationParamsMap = M.fromList $ do
-                paramRef <- tracedParameters mp
-                let
-                  param = dereference defs paramRef
-                  key = paramKey . extract $ param
-                pure (key, param)
-              pathParamsMap :: Map ParamKey (Traced Param)
-              pathParamsMap = M.fromList $ do
-                param <- pathParams . extract $ mp
-                pure (paramKey . extract $ param, param)
-              params = M.elems $ M.union operationParamsMap pathParamsMap -- We prefer params from Operation
-              splitted = L.partition
-                (\p -> (_paramIn . extract $ p) == ParamPath) params
-            in splitted
+        let -- Merged parameters got from Operation and PathItem in one
+            -- place. First element is path params, second is non-path params
+            tracedParams :: ProdCons ([Traced Param], [Traced Param])
+            tracedParams = getParams <$> paramDefs <*> prodCons
+            getParams defs mp =
+              let operationParamsMap :: Map ParamKey (Traced Param)
+                  operationParamsMap = M.fromList $ do
+                    paramRef <- tracedParameters mp
+                    let param = dereference defs paramRef
+                        key = paramKey . extract $ param
+                    pure (key, param)
+                  pathParamsMap :: Map ParamKey (Traced Param)
+                  pathParamsMap = M.fromList $ do
+                    param <- pathParams . extract $ mp
+                    pure (paramKey . extract $ param, param)
+                  params = M.elems $ M.union operationParamsMap pathParamsMap -- We prefer params from Operation
+                  splitted =
+                    L.partition
+                      (\p -> (_paramIn . extract $ p) == ParamPath)
+                      params
+               in splitted
        checkNonPathParams $ snd <$> tracedParams
        checkPathParams $ fst <$> tracedParams
        pure ()
-      checkNonPathParams :: ProdCons [Traced Param] -> CompatFormula ()
+      checkNonPathParams :: ProdCons [Traced Param] -> SemanticCompatFormula ()
      checkNonPathParams params = do
-        let
-          elements = getEls <$> params
-          getEls params = M.fromList $ do
-            p <- params
-            let
-              k = (_paramIn . extract $ p, _paramName . extract $ p)
-              v = ProductLike
-                { productValue = p
-                , required = fromMaybe False . _paramRequired . extract $ p
-                }
-            pure (k, v)
-          check (_, name) param = do
-            checkCompatibility @Param (singletonH schemaDefs) (beh >>> step (InParam name)) param
+        let elements = getEls <$> params
+            getEls params = M.fromList $ do
+              p <- params
+              let k = (_paramIn . extract $ p, _paramName . extract $ p)
+                  v =
+                    ProductLike
+                      { productValue = p
+                      , required = fromMaybe False . _paramRequired . extract $ p
+                      }
+              pure (k, v)
+            check (_, name) param = do
+              checkCompatibility @Param (singletonH schemaDefs) (beh >>> step (InParam name)) param
        checkProducts beh (ParamNotMatched . snd) check elements
-      checkPathParams :: ProdCons [Traced Param] -> CompatFormula ()
+      checkPathParams :: ProdCons [Traced Param] -> SemanticCompatFormula ()
      checkPathParams pathParams = do
-        let
-          fragments :: ProdCons [Traced PathFragmentParam]
-          fragments = getFragments <$> pathParams <*> prodCons
-          getFragments params mop = getPathFragments (extract mop) params
-          -- Feed path parameters to the fragments getter
-          check idx frags = checkCompatibility @PathFragmentParam env (beh >>> step (InFragment idx)) frags
-          elements = fragments <&> \frags -> M.fromList $ zip [0 :: Int ..] $ do
-            frag <- frags
-            pure $ ProductLike
-              { productValue = frag
-              , required = True }
+        let fragments :: ProdCons [Traced PathFragmentParam]
+            fragments = getFragments <$> pathParams <*> prodCons
+            getFragments params mop = getPathFragments (extract mop) params
+            -- Feed path parameters to the fragments getter
+            check idx frags = checkCompatibility @PathFragmentParam env (beh >>> step (InFragment idx)) frags
+            elements =
+              fragments <&> \frags -> M.fromList $
+                zip [0 :: Int ..] $ do
+                  frag <- frags
+                  pure $
+                    ProductLike
+                      { productValue = frag
+                      , required = True
+                      }
        checkProducts beh PathFragmentNotMatched check elements
      checkRequestBodies = do
-        let
-          check reqBody = checkCompatibility @RequestBody env (beh >>> step InRequest) reqBody
-          elements = getReqBody <$> bodyDefs <*> prodCons
-          getReqBody bodyDef mop = M.fromList $ do
-            bodyRef <- F.toList . tracedRequestBody $ mop
-            let
-              body = dereference bodyDef bodyRef
-            -- Single element map
-            pure ((), ProductLike
-              { productValue = body
-              , required = fromMaybe False . _requestBodyRequired . extract $ body
-              })
+        let check reqBody = checkCompatibility @RequestBody env (beh >>> step InRequest) reqBody
+            elements = getReqBody <$> bodyDefs <*> prodCons
+            getReqBody bodyDef mop = M.fromList $ do
+              bodyRef <- F.toList . tracedRequestBody $ mop
+              let body = dereference bodyDef bodyRef
+              -- Single element map
+              pure
+                ( ()
+                , ProductLike
+                    { productValue = body
+                    , required = fromMaybe False . _requestBodyRequired . extract $ body
+                    }
+                )
        checkProducts beh (const NoRequestBody) (const check) elements
      checkResponses = do
-        let
-          respEnv = HCons (swapProdCons respDefs)
-            $ HCons (swapProdCons headerDefs)
-            $ HCons (swapProdCons schemaDefs) HNil
-          resps = tracedResponses <$> prodCons
+        let respEnv =
+              HCons (swapProdCons respDefs) $
+                HCons (swapProdCons headerDefs) $
+                  HCons (swapProdCons schemaDefs) $
+                    HCons (swapProdCons linkDefs) HNil
+            resps = tracedResponses <$> prodCons
        checkCompatibility respEnv beh $ swapProdCons resps
      -- FIXME: https://github.com/typeable/openapi-diff/issues/27
      checkCallbacks = pure () -- (error "FIXME: not implemented")
      -- FIXME: https://github.com/typeable/openapi-diff/issues/28
      checkOperationSecurity = pure () -- (error "FIXME: not implemented")
      checkServers =
-        checkCompatibility env beh $
-          tracedServers <$> getH @(ProdCons [Server]) env <*> prodCons
+        checkCompatibility env beh $ do
+          x <- prodCons
+          se <- getH @(ProdCons [Server]) env
+          pure $ Traced (ask x >>> step OperationServersStep) (getServers se (extract x))
      bodyDefs = getH @(ProdCons (Traced (Definitions RequestBody))) env
      respDefs = getH @(ProdCons (Traced (Definitions Response))) env
-      headerDefs =  getH @(ProdCons (Traced (Definitions Header))) env
+      headerDefs = getH @(ProdCons (Traced (Definitions Header))) env
      schemaDefs = getH @(ProdCons (Traced (Definitions Schema))) env
      paramDefs = getH @(ProdCons (Traced (Definitions Param))) env
+      linkDefs = getH @(ProdCons (Traced (Definitions Link))) env

-data OperationMethod =
-  GetMethod
+data OperationMethod
+  = GetMethod
  | PutMethod
  | PostMethod
  | DeleteMethod
--- a/src/OpenAPI/Checker/Validate/Param.hs
+++ b/src/OpenAPI/Checker/Validate/Param.hs
@ -71,7 +71,17 @@ instance Behavable 'PathFragmentLevel 'SchemaLevel where
 instance Subtree Param where
  type SubtreeLevel Param = 'PathFragmentLevel
  type CheckEnv Param = '[ProdCons (Traced (Definitions Schema))]
-  checkCompatibility env beh pc@(ProdCons p c) = do
+  checkStructuralCompatibility env pc = do
+    structuralEq $ _paramName <$> pc
+    structuralEq $ _paramRequired <$> pc
+    structuralEq $ _paramIn <$> pc
+    structuralEq $ _paramAllowEmptyValue <$> pc
+    structuralEq $ _paramAllowReserved <$> pc
+    structuralMaybe env $ _paramSchema <$> pc
+    structuralEq $ _paramStyle <$> pc
+    structuralEq $ _paramExplode <$> pc
+    pure ()
+  checkSemanticCompatibility env beh pc@(ProdCons p c) = do
    when (_paramName (extract p) /= _paramName (extract c))
      $ issueAt beh ParamNameMismatch
    when ((fromMaybe False . _paramRequired . extract $ c) &&
--- a/src/OpenAPI/Checker/Validate/PathFragment.hs
+++ b/src/OpenAPI/Checker/Validate/PathFragment.hs
@ -63,10 +63,12 @@ instance Subtree PathFragmentParam where
  type SubtreeLevel PathFragmentParam = 'PathFragmentLevel
  type CheckEnv PathFragmentParam =
    '[ ProdCons (Traced (Definitions Schema)) ]
+  -- Not much to compare at this level
+  checkStructuralCompatibility _ _ = structuralIssue 
  -- This case isn't strictly needed. It is here for optimization.
-  checkCompatibility _ beh (ProdCons (extract -> StaticPath x) (extract -> StaticPath y))
+  checkSemanticCompatibility _ beh (ProdCons (extract -> StaticPath x) (extract -> StaticPath y))
    = if x == y
      then pure ()
      else issueAt beh (PathFragmentsDontMatch x y)
-  checkCompatibility env beh prodCons = do
+  checkSemanticCompatibility env beh prodCons = do
    checkCompatibility env beh (tracedPathFragmentParam <$> prodCons)
--- a/src/OpenAPI/Checker/Validate/ProcessedPathItem.hs
+++ b/src/OpenAPI/Checker/Validate/ProcessedPathItem.hs
@ -33,13 +33,14 @@ import OpenAPI.Checker.Validate.Sums
 data ProcessedPathItem = ProcessedPathItem
  { path :: FilePath
  , item :: PathItem
-  }
+  } deriving stock (Eq, Show)

 processPathItems :: [(FilePath, PathItem)] -> ProcessedPathItems
 processPathItems = ProcessedPathItems . fmap (uncurry ProcessedPathItem)

 newtype ProcessedPathItems =
  ProcessedPathItems {unProcessedPathItems :: [ProcessedPathItem]}
+  deriving newtype (Eq, Show)

 instance Issuable 'APILevel where
  data Issue 'APILevel
@ -65,8 +66,11 @@ instance Subtree ProcessedPathItems where
       , ProdCons (Traced (Definitions Header))
       , ProdCons (Traced (Definitions Schema))
       , ProdCons [Server]
+       , ProdCons (Traced (Definitions Link))
       ]
-  checkCompatibility env beh pc@(ProdCons p c) = do
+  -- No real way to check it at this level
+  checkStructuralCompatibility _ _ = structuralIssue
+  checkSemanticCompatibility env beh pc@(ProdCons p c) = do
    -- Each path generated by producer must be handled by consumer with exactly
    -- one way
    for_ (unProcessedPathItems . extract $ p) $ \ prodItem -> do
@ -74,8 +78,7 @@ instance Subtree ProcessedPathItems where
        prodPath = path prodItem
        matchedItems = do
          consItem <- unProcessedPathItems . extract $ c
-          matched <- F.toList $ matchingPathItems $ ProdCons prodItem consItem
-          return matched
+          F.toList $ matchingPathItems $ ProdCons prodItem consItem
      case matchedItems of
        [] -> issueAt beh $ NoPathsMatched prodPath
        [match] -> checkCompatibility env (beh >>> step (AtPath $ matchedPath <$> match)) (retraced <$> pc <*> match)
@ -116,7 +119,7 @@ data MatchedPathItem = MatchedPathItem
  , matchedPath :: !FilePath
  , pathFragments :: ![PathFragment Text]
  -- ^ Pre-parsed path from PathItem
-  }
+  } deriving stock (Eq)

 tracedParameters :: Traced MatchedPathItem -> [Traced (Referenced Param)]
 tracedParameters mpi =
@ -158,8 +161,10 @@ instance Subtree MatchedPathItem where
     , ProdCons (Traced (Definitions Header))
     , ProdCons (Traced (Definitions Schema))
     , ProdCons [Server]
+     , ProdCons (Traced (Definitions Link))
     ]
-  checkCompatibility env beh prodCons = do
+  checkStructuralCompatibility _ _ = structuralIssue
+  checkSemanticCompatibility env beh prodCons = do
    let
      paramDefs = getH @(ProdCons (Traced (Definitions Param))) env
      pathTracedParams = getPathParams <$> paramDefs <*> prodCons
--- a/src/OpenAPI/Checker/Validate/RequestBody.hs
+++ b/src/OpenAPI/Checker/Validate/RequestBody.hs
@ -17,8 +17,9 @@ import OpenAPI.Checker.Validate.MediaTypeObject
 import OpenAPI.Checker.Validate.Sums

 tracedContent :: Traced RequestBody -> IOHM.InsOrdHashMap MediaType (Traced MediaTypeObject)
-tracedContent resp = IOHM.mapWithKey (\k -> traced (ask resp >>> step (RequestMediaTypeObject k)))
-  $ _requestBodyContent $ extract resp
+tracedContent resp =
+  IOHM.mapWithKey (\k -> traced (ask resp >>> step (RequestMediaTypeObject k))) $
+    _requestBodyContent $ extract resp

 instance Issuable 'RequestLevel where
  data Issue 'RequestLevel
@ -34,19 +35,25 @@ instance Behavable 'RequestLevel 'PayloadLevel where

 instance Subtree RequestBody where
  type SubtreeLevel RequestBody = 'RequestLevel
-  type CheckEnv RequestBody =
-    '[ ProdCons (Traced (Definitions Schema)) ]
-  checkCompatibility env beh prodCons@(ProdCons p c) =
+  type
+    CheckEnv RequestBody =
+      '[ ProdCons (Traced (Definitions Schema))
+       , ProdCons (Traced (Definitions Header))
+       ]
+  checkStructuralCompatibility env pc = do
+    structuralEq $ _requestBodyRequired <$> pc
+    iohmStructural env $ _requestBodyContent <$> pc
+    pure ()
+  checkSemanticCompatibility env beh prodCons@(ProdCons p c) =
    if not (fromMaybe False . _requestBodyRequired . extract $ p)
-        && (fromMaybe False . _requestBodyRequired . extract $ c)
-    then issueAt beh RequestBodyRequired
-    else
-      -- Media type object are sums-like entities.
-      let
-        check mediaType pc = checkCompatibility @MediaTypeObject (HCons mediaType env) (beh >>> step InPayload) pc
-        sumElts = getSum <$> prodCons
-        getSum rb = M.fromList . IOHM.toList $ tracedContent rb
-      in checkSums beh RequestMediaTypeNotFound check sumElts
+      && (fromMaybe False . _requestBodyRequired . extract $ c)
+      then issueAt beh RequestBodyRequired
+      else -- Media type object are sums-like entities.
+
+        let check mediaType pc = checkCompatibility @MediaTypeObject (HCons mediaType env) (beh >>> step InPayload) pc
+            sumElts = getSum <$> prodCons
+            getSum rb = M.fromList . IOHM.toList $ tracedContent rb
+         in checkSums beh RequestMediaTypeNotFound check sumElts

 instance Steppable RequestBody MediaTypeObject where
  data Step RequestBody MediaTypeObject = RequestMediaTypeObject MediaType
--- a/src/OpenAPI/Checker/Validate/Responses.hs
+++ b/src/OpenAPI/Checker/Validate/Responses.hs
@ -6,8 +6,6 @@ module OpenAPI.Checker.Validate.Responses
  )
 where

-import Control.Lens
-import Data.Foldable
 import Data.HList
 import Data.HashMap.Strict.InsOrd as IOHM
 import Data.Map.Strict as M
@ -17,42 +15,54 @@ import Network.HTTP.Media (MediaType)
 import OpenAPI.Checker.Behavior
 import OpenAPI.Checker.References
 import OpenAPI.Checker.Subtree
+import OpenAPI.Checker.Validate.Header ()
+import OpenAPI.Checker.Validate.Link ()
 import OpenAPI.Checker.Validate.MediaTypeObject
 import OpenAPI.Checker.Validate.Products
 import OpenAPI.Checker.Validate.Schema ()
 import OpenAPI.Checker.Validate.Sums

 tracedResponses :: Traced Responses -> IOHM.InsOrdHashMap HttpStatusCode (Traced (Referenced Response))
-tracedResponses resp = IOHM.mapWithKey (\k -> traced (ask resp >>> step (ResponseCodeStep k)))
-  $ _responsesResponses $ extract resp
+tracedResponses resp =
+  IOHM.mapWithKey (\k -> traced (ask resp >>> step (ResponseCodeStep k))) $
+    _responsesResponses $ extract resp

 instance Subtree Responses where
  type SubtreeLevel Responses = 'OperationLevel
-  type CheckEnv Responses =
-    '[ ProdCons (Traced (Definitions Response))
-     , ProdCons (Traced (Definitions Header))
-     , ProdCons (Traced (Definitions Schema))
-     ]
+  type
+    CheckEnv Responses =
+      '[ ProdCons (Traced (Definitions Response))
+       , ProdCons (Traced (Definitions Header))
+       , ProdCons (Traced (Definitions Schema))
+       , ProdCons (Traced (Definitions Link))
+       ]
+
+  checkStructuralCompatibility env pc = do
+    structuralMaybe env $ _responsesDefault <$> pc
+    iohmStructural env $ _responsesResponses <$> pc
+    pure ()
+
  -- Roles are already swapped. Producer is a server and consumer is a
  -- client. Response codes are sum-like entity because we can answer with only
  -- one element
-  checkCompatibility env beh prodCons = do
-    let
-      defs = getH @(ProdCons (Traced (Definitions Response))) env
-      check code resps = checkCompatibility @Response env (beh >>> step (WithStatusCode code)) resps
-      elements = getEls <$> defs <*> prodCons
-      getEls respDef resps = M.fromList $ do
-        (code, respRef) <- IOHM.toList $ tracedResponses resps
-        pure (code, dereference respDef respRef)
+  checkSemanticCompatibility env beh prodCons = do
+    let defs = getH @(ProdCons (Traced (Definitions Response))) env
+        check code resps = checkCompatibility @Response env (beh >>> step (WithStatusCode code)) resps
+        elements = getEls <$> defs <*> prodCons
+        getEls respDef resps = M.fromList $ do
+          (code, respRef) <- IOHM.toList $ tracedResponses resps
+          pure (code, dereference respDef respRef)
    checkSums beh ResponseCodeNotFound check elements

 tracedContent :: Traced Response -> IOHM.InsOrdHashMap MediaType (Traced MediaTypeObject)
-tracedContent resp = IOHM.mapWithKey (\k -> traced (ask resp >>> step (ResponseMediaObject k)))
-  $ _responseContent $ extract resp
+tracedContent resp =
+  IOHM.mapWithKey (\k -> traced (ask resp >>> step (ResponseMediaObject k))) $
+    _responseContent $ extract resp

 tracedHeaders :: Traced Response -> IOHM.InsOrdHashMap HeaderName (Traced (Referenced Header))
-tracedHeaders resp = IOHM.mapWithKey (\k -> traced (ask resp >>> step (ResponseHeader k)))
-  $ _responseHeaders $ extract resp
+tracedHeaders resp =
+  IOHM.mapWithKey (\k -> traced (ask resp >>> step (ResponseHeader k))) $
+    _responseHeaders $ extract resp

 instance Issuable 'ResponseLevel where
  data Issue 'ResponseLevel
@ -73,11 +83,18 @@ instance Behavable 'ResponseLevel 'HeaderLevel where

 instance Subtree Response where
  type SubtreeLevel Response = 'ResponseLevel
-  type CheckEnv Response =
-    '[ ProdCons (Traced (Definitions Header))
-     , ProdCons (Traced (Definitions Schema))
-     ]
-  checkCompatibility env beh prodCons = do
+  type
+    CheckEnv Response =
+      '[ ProdCons (Traced (Definitions Header))
+       , ProdCons (Traced (Definitions Schema))
+       , ProdCons (Traced (Definitions Link))
+       ]
+  checkStructuralCompatibility env pc = do
+    iohmStructural env $ _responseContent <$> pc
+    iohmStructural env $ _responseHeaders <$> pc
+    iohmStructural env $ _responseLinks <$> pc
+    pure ()
+  checkSemanticCompatibility env beh prodCons = do
    -- Roles are already swapped. Producer is a server and consumer is a client
    checkMediaTypes
    checkHeaders
@ -85,71 +102,38 @@ instance Subtree Response where
    where
      checkMediaTypes = do
        -- Media types are sum-like entity
-        let
-          check mediaType mtObj =
-            let mtEnv = HCons mediaType $ env
-            in checkCompatibility @MediaTypeObject mtEnv (beh >>> step ResponsePayload) mtObj
-          elements = getEls <$> prodCons
-          getEls resp = M.fromList . IOHM.toList $ tracedContent resp
+        let check mediaType mtObj =
+              let mtEnv = HCons mediaType $ env
+               in checkCompatibility @MediaTypeObject mtEnv (beh >>> step ResponsePayload) mtObj
+            elements = getEls <$> prodCons
+            getEls resp = M.fromList . IOHM.toList $ tracedContent resp
        checkSums beh ResponseMediaTypeMissing check elements

      checkHeaders = do
        -- Headers are product-like entities
-        let
-          check name hdrs = checkCompatibility @Header env (beh >>> step (InHeader name)) hdrs
-          elements = getEls <$> headerDefs <*> prodCons
-          getEls headerDef resp = M.fromList $ do
-            (hname, headerRef) <- IOHM.toList $ tracedHeaders resp
-            let header = dereference headerDef headerRef
-            pure (hname, ProductLike
-              { productValue = header
-              , required = fromMaybe False . _headerRequired . extract $ header
-              })
+        let check name hdrs = checkCompatibility @Header env (beh >>> step (InHeader name)) hdrs
+            elements = getEls <$> headerDefs <*> prodCons
+            getEls headerDef resp = M.fromList $ do
+              (hname, headerRef) <- IOHM.toList $ tracedHeaders resp
+              let header = dereference headerDef headerRef
+              pure
+                ( hname
+                , ProductLike
+                    { productValue = header
+                    , required = fromMaybe False . _headerRequired . extract $ header
+                    }
+                )
        checkProducts beh ResponseHeaderMissing check elements
      headerDefs = getH @(ProdCons (Traced (Definitions Header))) env

-tracedSchema :: Traced Header -> Maybe (Traced (Referenced Schema))
-tracedSchema hdr = _headerSchema (extract hdr) <&> traced (ask hdr >>> step HeaderSchema)
-
-instance Issuable 'HeaderLevel where
-  data Issue 'HeaderLevel
-    = RequiredHeaderMissing
-    | NonEmptyHeaderRequired
-    | HeaderSchemaRequired
-    deriving stock (Eq, Ord, Show)
-  issueIsUnsupported _ = False
-
-instance Behavable 'HeaderLevel 'SchemaLevel where
-  data Behave 'HeaderLevel 'SchemaLevel
-    = InSchema
-    deriving stock (Eq, Ord, Show)
-
-instance Subtree Header where
-  type SubtreeLevel Header = 'HeaderLevel
-  type CheckEnv Header = '[ProdCons (Traced (Definitions Schema))]
-  checkCompatibility env beh (ProdCons p c) = do
-    if (fromMaybe False $ _headerRequired $ extract c) && not (fromMaybe False $ _headerRequired $ extract p)
-      then issueAt beh RequiredHeaderMissing else pure ()
-    if not (fromMaybe False $ _headerAllowEmptyValue $ extract c) && (fromMaybe False $ _headerAllowEmptyValue $ extract p)
-      then issueAt beh NonEmptyHeaderRequired else pure ()
-    for_ (tracedSchema c) $ \consRef ->
-      case tracedSchema p of
-        Nothing -> issueAt beh HeaderSchemaRequired
-        Just prodRef -> checkCompatibility env (beh >>> step InSchema) (ProdCons prodRef consRef)
-    pure ()
-
 instance Steppable Responses (Referenced Response) where
  data Step Responses (Referenced Response) = ResponseCodeStep HttpStatusCode
    deriving stock (Eq, Ord, Show)

-instance Steppable Header (Referenced Schema) where
-  data Step Header (Referenced Schema) = HeaderSchema
+instance Steppable Response MediaTypeObject where
+  data Step Response MediaTypeObject = ResponseMediaObject MediaType
    deriving stock (Eq, Ord, Show)

 instance Steppable Response (Referenced Header) where
  data Step Response (Referenced Header) = ResponseHeader HeaderName
    deriving stock (Eq, Ord, Show)
-
-instance Steppable Response MediaTypeObject where
-  data Step Response MediaTypeObject = ResponseMediaObject MediaType
-    deriving stock (Eq, Ord, Show)
--- a/src/OpenAPI/Checker/Validate/Schema.hs
+++ b/src/OpenAPI/Checker/Validate/Schema.hs
@ -38,6 +38,7 @@ import Data.Scientific
 import qualified Data.Set as S
 import Data.Text (Text)
 import qualified Data.Text as T hiding (singleton)
+import qualified Data.Text.Encoding as T
 import Data.Typeable
 import OpenAPI.Checker.Behavior
 import OpenAPI.Checker.Orphans ()
@ -45,6 +46,7 @@ import OpenAPI.Checker.References
 import OpenAPI.Checker.Paths
 import qualified OpenAPI.Checker.PathsPrefixTree as P
 import OpenAPI.Checker.Subtree
+import Debug.Trace

 -- | Type of a JSON value
 data JsonType
@ -598,11 +600,11 @@ schemaToFormula
 schemaToFormula defs rs = runWriter . (`runReaderT` defs) $ processSchema rs

 checkFormulas
-  :: HasAll (CheckEnv Schema) xs
+  :: (HasAll (CheckEnv Schema) xs)
  => HList xs
  -> Behavior 'SchemaLevel
  -> ProdCons (ForeachType JsonFormula, P.PathsPrefixTree Behave AnIssue 'SchemaLevel)
-  -> CompatFormula ()
+  -> SemanticCompatFormula ()
 checkFormulas env beh (ProdCons (fp, ep) (fc, ec)) =
  case P.toList ep ++ P.toList ec of
    issues@(_:_) -> F.for_ issues $ \(AnItem t (AnIssue e)) -> issueAt (beh >>> t) e
@ -647,7 +649,7 @@ checkFormulas env beh (ProdCons (fp, ep) (fc, ec)) =
 checkContradiction
  :: Behavior 'TypedSchemaLevel
  -> [Condition t]
-  -> CompatFormula ()
+  -> SemanticCompatFormula ()
 checkContradiction beh _ = issueAt beh NoContradiction -- TODO

 checkImplication
@ -656,7 +658,7 @@ checkImplication
  -> Behavior 'TypedSchemaLevel
  -> [Condition t]
  -> Condition t
-  -> CompatFormula ()
+  -> SemanticCompatFormula ()
 checkImplication env beh prods cons = case findExactly prods of
  Just e
    | all (satisfiesTyped e) prods ->
@ -803,15 +805,62 @@ instance Behavable 'TypedSchemaLevel 'SchemaLevel where
 instance Subtree Schema where
  type SubtreeLevel Schema = 'SchemaLevel
  type CheckEnv Schema = '[ProdCons (Traced (Definitions Schema))]
-  checkCompatibility env beh schs = do
+  checkStructuralCompatibility env pc = do
+    traceShowM pc
+    structuralEq $ _schemaRequired <$> pc
+    structuralMaybeWith structuralEq $ _schemaNullable <$> pc
+    structuralMaybeWith (structuralList env) $ _schemaAllOf <$> pc
+    structuralMaybeWith (structuralList env) $ _schemaOneOf <$> pc
+    structuralMaybe env $ _schemaNot <$> pc
+    structuralMaybeWith (structuralList env) $ _schemaAnyOf <$> pc
+    iohmStructural env $ _schemaProperties <$> pc
+    structuralMaybeWith structuralAdditionalProperties $ _schemaAdditionalProperties <$> pc
+    structuralMaybeWith structuralDiscriminator $ _schemaDiscriminator <$> pc
+    structuralEq $ _schemaReadOnly <$> pc
+    structuralEq $ _schemaWriteOnly <$> pc
+    structuralEq $ _schemaXml <$> pc
+    structuralEq $ _schemaMaxProperties <$> pc
+    structuralEq $ _schemaMinProperties <$> pc
+    structuralEq $ _schemaDefault <$> pc
+    structuralEq $ _schemaType <$> pc
+    structuralEq $ _schemaFormat <$> pc
+    structuralMaybeWith structuralItems $ _schemaItems <$> pc
+    structuralEq $ _schemaMaximum <$> pc
+    structuralEq $ _schemaExclusiveMaximum <$> pc
+    structuralEq $ _schemaMinimum <$> pc
+    structuralEq $ _schemaExclusiveMinimum <$> pc
+    structuralEq $ _schemaMaxLength <$> pc
+    structuralEq $ _schemaMinLength <$> pc
+    structuralEq $ _schemaPattern <$> pc
+    structuralEq $ _schemaMaxItems <$> pc
+    structuralEq $ _schemaMinItems <$> pc
+    structuralEq $ _schemaUniqueItems <$> pc
+    structuralEq $ _schemaEnum <$> pc
+    structuralEq $ _schemaMultipleOf <$> pc
+    pure ()
+    where
+      structuralAdditionalProperties
+        (ProdCons (AdditionalPropertiesAllowed x) (AdditionalPropertiesAllowed y)) =
+          structuralEq $ ProdCons x y
+      structuralAdditionalProperties
+        (ProdCons (AdditionalPropertiesSchema x) (AdditionalPropertiesSchema y)) =
+          checkStructuralCompatibility env $ ProdCons x y
+      structuralAdditionalProperties _ = structuralIssue
+      structuralDiscriminator pc' = do
+        structuralEq $ _discriminatorPropertyName <$> pc'
+        iohmStructuralWith
+          (\_ mappingPC -> case A.decodeStrict @(Referenced Schema) . T.encodeUtf8 <$> mappingPC of
+            ProdCons (Just a) (Just b) -> checkStructuralCompatibility env $ ProdCons a b
+            ProdCons Nothing Nothing -> structuralEq mappingPC
+            _ -> structuralIssue
+          )
+          (_discriminatorMapping <$> pc')
+        pure ()
+      structuralItems (ProdCons (OpenApiItemsObject a) (OpenApiItemsObject b)) =
+        checkStructuralCompatibility env $ ProdCons a b
+      structuralItems (ProdCons (OpenApiItemsArray a) (OpenApiItemsArray b)) =
+        structuralList env $ ProdCons a b
+      structuralItems _ = structuralIssue
+  checkSemanticCompatibility env beh schs = do
    let defs = getH env
    checkFormulas env beh $ schemaToFormula <$> defs <*> schs
-
-instance Subtree (Referenced Schema) where
-  type SubtreeLevel (Referenced Schema) = 'SchemaLevel
-  type CheckEnv (Referenced Schema) = CheckEnv Schema
-  checkCompatibility env beh refs = do
-    let
-      defs = getH env
-      schs = dereference <$> defs <*> refs
-    checkFormulas env beh $ schemaToFormula <$> defs <*> schs
--- a/src/OpenAPI/Checker/Validate/SecurityRequirement.hs
+++ b/src/OpenAPI/Checker/Validate/SecurityRequirement.hs
@ -2,7 +2,8 @@

 module OpenAPI.Checker.Validate.SecurityRequirement
  ( Issue (..)
-  ) where
+  )
+where

 import Data.OpenApi
 import OpenAPI.Checker.Behavior
@ -20,4 +21,5 @@ instance Subtree SecurityRequirement where
    CheckEnv SecurityRequirement =
      '[ ProdCons (Traced (Definitions SecurityScheme))
       ]
-  checkCompatibility = undefined
+  checkStructuralCompatibility = undefined
+  checkSemanticCompatibility = undefined
--- a/src/OpenAPI/Checker/Validate/Server.hs
+++ b/src/OpenAPI/Checker/Validate/Server.hs
@ -6,6 +6,7 @@ module OpenAPI.Checker.Validate.Server
 where

 import Control.Applicative
+import Control.Arrow ((&&&))
 import Control.Comonad
 import Control.Monad
 import Data.Attoparsec.Text
@ -14,13 +15,16 @@ import Data.Foldable
 import Data.Function
 import Data.Functor
 import Data.HashMap.Strict.InsOrd as IOHM
+import qualified Data.HashSet.InsOrd as IOHM
 import qualified Data.HashSet.InsOrd as IOHS
 import Data.Maybe
 import Data.OpenApi
+import qualified Data.Set as S
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Traversable
 import OpenAPI.Checker.Behavior
+import OpenAPI.Checker.Common
 import OpenAPI.Checker.Paths
 import OpenAPI.Checker.Subtree
 import OpenAPI.Checker.Validate.MediaTypeObject
@ -44,7 +48,14 @@ instance Behavable 'OperationLevel 'ServerLevel where
 instance Subtree [Server] where
  type SubtreeLevel [Server] = 'OperationLevel
  type CheckEnv [Server] = '[]
-  checkCompatibility env beh pcServer = do
+  checkStructuralCompatibility _ pc =
+    structuralEq $ S.fromList . fmap reduceServer <$> pc
+    where
+      reducerServerVariable =
+        fmap IOHM.toHashSet . _serverVariableEnum &&& _serverVariableDefault
+      reduceServer =
+        _serverUrl &&& fmap reducerServerVariable . IOHM.toHashMap . _serverVariables
+  checkSemanticCompatibility env beh pcServer = do
    let (ProdCons (pErrs, pUrls) (cErrs, cUrls)) =
          pcServer
            <&> partitionEithers
@ -74,12 +85,6 @@ unifyPart :: ServerUrlPart ServerVariable -> Maybe (IOHS.InsOrdHashSet Text)
 unifyPart (ServerUrlVariable v) = _serverVariableEnum v
 unifyPart (ServerUrlConstant c) = Just $ IOHS.singleton c

-zipAll :: [a] -> [b] -> Maybe [(a, b)]
-zipAll [] [] = Just []
-zipAll (x : xs) (y : ys) = ((x, y) :) <$> zipAll xs ys
-zipAll (_ : _) [] = Nothing
-zipAll [] (_ : _) = Nothing
-
 staticCompatiblePart :: ServerUrlPart x -> ServerUrlPart x -> Bool
 staticCompatiblePart (ServerUrlConstant x) (ServerUrlConstant y) = x == y
 staticCompatiblePart _ _ = True
@ -90,7 +95,7 @@ staticCompatible a b = maybe False (all $ uncurry staticCompatiblePart) $ zipAll
 data ServerUrlPart var
  = ServerUrlVariable var
  | ServerUrlConstant Text
-  deriving stock (Show, Functor, Foldable, Traversable)
+  deriving stock (Eq, Show, Functor, Foldable, Traversable)

 -- | This is super rough. Things like @{a|b}c@ will not match @ac@.
 -- FIXME: https://github.com/typeable/openapi-diff/issues/46
@ -130,7 +135,12 @@ instance Issuable 'ServerLevel where
 instance Subtree ProcessedServer where
  type SubtreeLevel ProcessedServer = 'ServerLevel
  type CheckEnv ProcessedServer = '[]
-  checkCompatibility _ beh pc =
+  checkStructuralCompatibility _ pc =
+    structuralEq $ (fmap . fmap . fmap) reducerServerVariable pc
+    where
+      reducerServerVariable =
+        fmap IOHM.toHashSet . _serverVariableEnum &&& _serverVariableDefault
+  checkSemanticCompatibility _ beh pc =
    -- traversing here is fine because we have already filtered for length
    for_ (zip [0 ..] $ zipProdCons . fmap (fmap unifyPart . extract) $ pc) $ \(i, pcPart) -> case pcPart of
      (Just x, Just y) -> for_ x $ \v -> unless (v `IOHS.member` y) (issueAt beh $ EnumValueNotConsumed i v)
--- a/stack.yaml
+++ b/stack.yaml
@ -1 +1 @@
-resolver: lts-17.4
+resolver: lts-17.11
--- a/stack.yaml.lock
+++ b/stack.yaml.lock
@ -6,7 +6,7 @@
 packages: []
 snapshots:
 - completed:
-    size: 563103
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/17/4.yaml
-    sha256: f11e2153044f5f71ea7b1c9398f4721f517c9bd37642ed769647b896564021f3
-  original: lts-17.4
+    size: 567672
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/17/11.yaml
+    sha256: 03181cdbeb671eb605bbcf6f285bea4d094b6ac7433a0e14a9f1dd54ad995938
+  original: lts-17.11