Added security schemes (#59)

* Security schemes

* Added simple test

openapi-diff.cabal

@@ -134,6 +134,8 @@ library
                   , OpenAPI.Checker.Validate.Header
                   , OpenAPI.Checker.Validate.Link
                   , OpenAPI.Checker.Common
+                  , OpenAPI.Checker.Validate.SecurityScheme
+                  , OpenAPI.Checker.Validate.OAuth2Flows
 
 executable openapi-diff
   import:              common-options

src/OpenAPI/Checker/Behavior.hs

@@ -4,7 +4,8 @@ module OpenAPI.Checker.Behavior
   , Issuable (..)
   , Behavior
   , AnIssue (..)
-  ) where
+  )
+where
 
 import Data.Aeson
 import Data.Kind
@@ -16,6 +17,7 @@ data BehaviorLevel
   = APILevel
   | ServerLevel
   | SecurityRequirementLevel
+  | SecuritySchemeLevel
   | PathLevel
   | OperationLevel
   | PathFragmentLevel
@@ -28,8 +30,10 @@ data BehaviorLevel
   | TypedSchemaLevel
   | LinkLevel
 
-class (Ord (Behave a b), Show (Behave a b))
-  => Behavable (a :: BehaviorLevel) (b :: BehaviorLevel) where
+class
+  (Ord (Behave a b), Show (Behave a b)) =>
+  Behavable (a :: BehaviorLevel) (b :: BehaviorLevel)
+  where
   data Behave a b
 
 class (Ord (Issue l), Show (Issue l)) => Issuable (l :: BehaviorLevel) where
@@ -48,6 +52,7 @@ data AnIssue (l :: BehaviorLevel) where
   AnIssue :: Issuable l => Issue l -> AnIssue l
 
 deriving stock instance Eq (AnIssue l)
+
 deriving stock instance Ord (AnIssue l)
 
 instance ToJSON (AnIssue l) where

src/OpenAPI/Checker/Orphans.hs

@@ -3,25 +3,40 @@
 module OpenAPI.Checker.Orphans () where
 
 import Control.Comonad.Env
-import Data.OpenApi
 import qualified Data.HashMap.Strict.InsOrd as IOHM
+import Data.OpenApi
 
 deriving newtype instance Ord Reference
 
 deriving stock instance Ord a => Ord (Referenced a)
+
 deriving stock instance Ord Schema
+
 deriving stock instance Ord AdditionalProperties
+
 deriving stock instance Ord Discriminator
+
 deriving stock instance Ord Xml
+
 deriving stock instance Ord OpenApiType
+
 deriving stock instance Ord Style
+
 deriving stock instance Ord OpenApiItems
+
 deriving stock instance Ord ParamLocation
 
+deriving stock instance Ord HttpSchemeType
+
+deriving stock instance Ord ApiKeyParams
+
+deriving stock instance Ord ApiKeyLocation
 
 instance (Ord k, Ord v) => Ord (IOHM.InsOrdHashMap k v) where
   compare xs ys = compare (IOHM.toList xs) (IOHM.toList ys)
 
 deriving stock instance (Eq e, Eq (w a)) => Eq (EnvT e w a)
+
 deriving stock instance (Ord e, Ord (w a)) => Ord (EnvT e w a)
+
 deriving stock instance (Show e, Show (w a)) => Show (EnvT e w a)

src/OpenAPI/Checker/References.hs

@@ -3,6 +3,7 @@
 module OpenAPI.Checker.References
   ( Step (..)
   , dereference
+  , Typeable
   )
 where
 

src/OpenAPI/Checker/Subtree.hs

@@ -39,6 +39,7 @@ module OpenAPI.Checker.Subtree
   , ask
   , local
   , step
+  , Typeable
   )
 where
 

src/OpenAPI/Checker/Subtree/Deriving.hs

@@ -0,0 +1,6 @@
+module OpenAPI.Checker.Subtree.Deriving (EqSubtree (..)) where
+
+import Control.Monad
+import OpenAPI.Checker.Subtree
+
+newtype EqSubtree t = EqSubtree t

src/OpenAPI/Checker/Validate/MediaTypeObject.hs

@@ -1,9 +1,10 @@
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module OpenAPI.Checker.Validate.MediaTypeObject
-  ( Issue(..)
-  , Behave(..)
-  ) where
+  ( Issue (..)
+  , Behave (..)
+  )
+where
 
 import Control.Lens
 import Data.Foldable as F
@@ -15,18 +16,18 @@ import Data.Text (Text)
 import Network.HTTP.Media (MediaType, mainType, subType)
 import OpenAPI.Checker.Behavior
 import OpenAPI.Checker.Subtree
+import OpenAPI.Checker.Validate.Header ()
 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)
 
 -- FIXME: This should be done through 'MediaTypeEncodingMapping'
 tracedEncoding :: Traced MediaTypeObject -> InsOrdHashMap Text (Traced Encoding)
-tracedEncoding mto = IOHM.mapWithKey (\k -> traced (ask mto >>> step (MediaTypeParamEncoding k)))
-  $ _mediaTypeObjectEncoding $ extract mto
+tracedEncoding mto =
+  IOHM.mapWithKey (\k -> traced (ask mto >>> step (MediaTypeParamEncoding k))) $
+    _mediaTypeObjectEncoding $ extract mto
 
 instance Issuable 'PayloadLevel where
   data Issue 'PayloadLevel
@@ -47,43 +48,52 @@ instance Behavable 'PayloadLevel 'SchemaLevel where
 
 instance Subtree MediaTypeObject where
   type SubtreeLevel MediaTypeObject = 'PayloadLevel
-  type CheckEnv MediaTypeObject =
-    '[ MediaType
-     , ProdCons (Traced (Definitions Schema))
-     , ProdCons (Traced (Definitions Header))
-     ]
+  type
+    CheckEnv MediaTypeObject =
+      '[ MediaType
+       , ProdCons (Traced (Definitions Schema))
+       , ProdCons (Traced (Definitions Header))
+       ]
   checkStructuralCompatibility env pc = do
     structuralMaybe env $ tracedSchema <$> pc
     structuralEq $ fmap _mediaTypeObjectExample <$> pc
     iohmStructural env $ stepTraced MediaTypeEncodingMapping . fmap _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
-       | otherwise -> pure ()
+    if
+        | "multipart" == mainType mediaType -> checkEncoding
+        | "application" == mainType mediaType
+            && "x-www-form-urlencoded" == subType mediaType ->
+          checkEncoding
+        | otherwise -> pure ()
     -- If consumer requires schema then producer must produce compatible
     -- request
     for_ (tracedSchema c) $ \consRef ->
-        case tracedSchema p of
-          Nothing -> issueAt beh MediaTypeSchemaRequired
-          Just prodRef -> checkCompatibility env (beh >>> step PayloadSchema)
-            $ ProdCons prodRef consRef
+      case tracedSchema p of
+        Nothing -> issueAt beh MediaTypeSchemaRequired
+        Just prodRef ->
+          checkCompatibility env (beh >>> step PayloadSchema) $
+            ProdCons prodRef consRef
     pure ()
     where
       mediaType = getH @MediaType env
       checkEncoding =
-        let
-          -- Parameters of the media type are product-like entities
-          getEncoding mt = M.fromList
-            $ (IOHM.toList $ tracedEncoding mt) <&> \(k, enc) ->
-            ( k
-            , ProductLike
-              { productValue = enc
-              , required = True } )
-          encProdCons = getEncoding <$> prodCons
-        in checkProducts beh MediaEncodingMissing
-           (const $ checkCompatibility env beh) encProdCons
+        let -- Parameters of the media type are product-like entities
+            getEncoding mt =
+              M.fromList $
+                (IOHM.toList $ tracedEncoding mt) <&> \(k, enc) ->
+                  ( k
+                  , ProductLike
+                      { productValue = enc
+                      , required = True
+                      }
+                  )
+            encProdCons = getEncoding <$> prodCons
+         in checkProducts
+              beh
+              MediaEncodingMissing
+              (const $ checkCompatibility env beh)
+              encProdCons
 
 instance Subtree Encoding where
   type SubtreeLevel Encoding = 'PayloadLevel

src/OpenAPI/Checker/Validate/OAuth2Flows.hs

@@ -0,0 +1,132 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module OpenAPI.Checker.Validate.OAuth2Flows
+  ( Step (..)
+  , Issue (..)
+  , Behave (..)
+  )
+where
+
+import Control.Monad
+import Data.Function
+import qualified Data.HashMap.Strict.InsOrd as IOHM
+import Data.OpenApi
+import Data.Proxy
+import Data.Set (Set)
+import qualified Data.Set as S
+import Data.Text (Text)
+import OpenAPI.Checker.Behavior
+import OpenAPI.Checker.Orphans ()
+import OpenAPI.Checker.Subtree
+
+instance Subtree OAuth2Flows where
+  type CheckEnv OAuth2Flows = '[]
+  type SubtreeLevel OAuth2Flows = 'SecuritySchemeLevel
+  checkStructuralCompatibility _ = structuralEq
+  checkSemanticCompatibility env bhv pc = do
+    let supportFlow
+          :: (Subtree t, SubtreeLevel t ~ SubtreeLevel OAuth2Flows, CheckEnv OAuth2Flows ~ CheckEnv t)
+          => Issue 'SecuritySchemeLevel
+          -> ProdCons (Maybe (Traced t))
+          -> SemanticCompatFormula ()
+        supportFlow i x = case x of
+          -- producer will not attempt this flow
+          (ProdCons Nothing _) -> pure ()
+          -- producer can attempt a flow the consumer does not know about
+          (ProdCons (Just _) Nothing) -> issueAt bhv i
+          (ProdCons (Just p) (Just c)) ->
+            checkCompatibility env bhv $ ProdCons p c
+        getFlow
+          :: Typeable x
+          => (OAuth2Flows -> Maybe (OAuth2Flow x))
+          -> Traced OAuth2Flows
+          -> Maybe (Traced (OAuth2Flow x))
+        getFlow f (Traced t a) = Traced (t >>> step (OAuth2FlowsFlow Proxy)) <$> f a
+    supportFlow ConsumerDoesNotSupportImplicitFlow $ getFlow _oAuth2FlowsImplicit <$> pc
+    supportFlow ConsumerDoesNotSupportPasswordFlow $ getFlow _oAuth2FlowsPassword <$> pc
+    supportFlow ConsumerDoesNotSupportClientCridentialsFlow $ getFlow _oAuth2FlowsClientCredentials <$> pc
+    supportFlow ConsumerDoesNotSupportAuthorizationCodeFlow $ getFlow _oAuth2FlowsAuthorizationCode <$> pc
+    pure ()
+
+instance Typeable t => Steppable OAuth2Flows (OAuth2Flow t) where
+  data Step OAuth2Flows (OAuth2Flow t) = OAuth2FlowsFlow (Proxy t)
+    deriving (Eq, Ord, Show)
+
+instance (Typeable t, Subtree t, SubtreeLevel (OAuth2Flow t) ~ SubtreeLevel t) => Subtree (OAuth2Flow t) where
+  type CheckEnv (OAuth2Flow t) = CheckEnv t
+  type SubtreeLevel (OAuth2Flow t) = 'SecuritySchemeLevel
+  checkStructuralCompatibility = undefined
+  checkSemanticCompatibility env bhv prodCons@(ProdCons p c) = do
+    let ProdCons pScopes cScopes = S.fromList . IOHM.keys . _oAuth2Scopes . extract <$> prodCons
+        missingScopes = cScopes S.\\ pScopes
+    unless (S.null missingScopes) (issueAt bhv $ ScopesMissing missingScopes)
+    checkCompatibility env bhv $ retraced (>>> step (OAuth2FlowParamsStep Proxy)) . fmap _oAuth2Params <$> prodCons
+    unless (((==) `on` _oAath2RefreshUrl . extract) p c) $ issueAt bhv RefreshUrlsDontMatch
+    pure ()
+
+instance Typeable t => Steppable (OAuth2Flow t) t where
+  data Step (OAuth2Flow t) t = OAuth2FlowParamsStep (Proxy t)
+    deriving (Eq, Ord, Show)
+
+instance Subtree OAuth2ImplicitFlow where
+  type SubtreeLevel OAuth2ImplicitFlow = 'SecuritySchemeLevel
+  type CheckEnv OAuth2ImplicitFlow = '[]
+  checkStructuralCompatibility = undefined
+  checkSemanticCompatibility _ bhv (ProdCons p c) =
+    unless (extract p == extract c) $ issueAt bhv OAuth2ImplicitFlowNotEqual
+
+instance Subtree OAuth2PasswordFlow where
+  type SubtreeLevel OAuth2PasswordFlow = 'SecuritySchemeLevel
+  type CheckEnv OAuth2PasswordFlow = '[]
+  checkStructuralCompatibility = undefined
+  checkSemanticCompatibility _ bhv (ProdCons p c) =
+    unless (extract p == extract c) $ issueAt bhv OAuth2PasswordFlowNotEqual
+
+instance Subtree OAuth2ClientCredentialsFlow where
+  type SubtreeLevel OAuth2ClientCredentialsFlow = 'SecuritySchemeLevel
+  type CheckEnv OAuth2ClientCredentialsFlow = '[]
+  checkStructuralCompatibility = undefined
+  checkSemanticCompatibility _ bhv (ProdCons p c) =
+    unless (extract p == extract c) $ issueAt bhv OAuth2ClientCredentialsFlowNotEqual
+
+instance Subtree OAuth2AuthorizationCodeFlow where
+  type SubtreeLevel OAuth2AuthorizationCodeFlow = 'SecuritySchemeLevel
+  type CheckEnv OAuth2AuthorizationCodeFlow = '[]
+  checkStructuralCompatibility = undefined
+  checkSemanticCompatibility _ bhv (ProdCons p c) =
+    unless (extract p == extract c) $ issueAt bhv OAuth2AuthorizationCodeFlowNotEqual
+
+instance Issuable 'SecurityRequirementLevel where
+  data Issue 'SecurityRequirementLevel
+    = SecurityRequirementNotMet
+    | UndefinedSecurityScheme Text
+    deriving stock (Eq, Ord, Show)
+  issueIsUnsupported _ = False
+
+instance Issuable 'SecuritySchemeLevel where
+  data Issue 'SecuritySchemeLevel
+    = RefreshUrlsDontMatch
+    | HttpSchemeTypesDontMatch HttpSchemeType HttpSchemeType
+    | ApiKeyParamsDontMatch ApiKeyParams ApiKeyParams
+    | OpenIdConnectUrlsDontMatch URL URL
+    | CustomHttpSchemesDontMatch Text Text
+    | ConsumerDoesNotSupportImplicitFlow
+    | ConsumerDoesNotSupportPasswordFlow
+    | ConsumerDoesNotSupportClientCridentialsFlow
+    | ConsumerDoesNotSupportAuthorizationCodeFlow
+    | SecuritySchemeNotMatched
+    | OAuth2ImplicitFlowNotEqual
+    | OAuth2PasswordFlowNotEqual
+    | OAuth2ClientCredentialsFlowNotEqual
+    | OAuth2AuthorizationCodeFlowNotEqual
+    | ScopesMissing (Set Text)
+    | DifferentSecuritySchemes
+    | CanNotHaveScopes
+    | ScopeNotDefined Text
+    deriving stock (Eq, Ord, Show)
+  issueIsUnsupported _ = False
+
+instance Behavable 'SecurityRequirementLevel 'SecuritySchemeLevel where
+  data Behave 'SecurityRequirementLevel 'SecuritySchemeLevel
+    = SecuritySchemeStep Text
+    deriving stock (Eq, Ord, Show)

src/OpenAPI/Checker/Validate/Operation.hs

@@ -20,10 +20,12 @@ import OpenAPI.Checker.Behavior
 import OpenAPI.Checker.References
 import OpenAPI.Checker.Subtree
 import OpenAPI.Checker.Validate.MediaTypeObject
+import OpenAPI.Checker.Validate.OAuth2Flows
 import OpenAPI.Checker.Validate.PathFragment
 import OpenAPI.Checker.Validate.Products
 import OpenAPI.Checker.Validate.RequestBody ()
 import OpenAPI.Checker.Validate.Responses ()
+import OpenAPI.Checker.Validate.SecurityRequirement ()
 import OpenAPI.Checker.Validate.Server ()
 
 data MatchedOperation = MatchedOperation
@@ -54,9 +56,9 @@ tracedResponses oper =
   traced (ask oper >>> step OperationResponsesStep) $
     _operationResponses . operation $ extract oper
 
-tracedSecurity :: Traced MatchedOperation -> [Traced SecurityRequirement]
+tracedSecurity :: Traced MatchedOperation -> [(Int, Traced SecurityRequirement)]
 tracedSecurity oper =
-  [ traced (ask oper >>> step (OperationSecurityRequirementStep i)) x
+  [ (i, traced (ask oper >>> step (OperationSecurityRequirementStep i)) x)
   | (i, x) <- zip [0 ..] $ _operationSecurity . operation $ extract oper
   ]
 
@@ -81,6 +83,11 @@ instance Behavable 'OperationLevel 'RequestLevel where
     = InRequest
     deriving stock (Eq, Ord, Show)
 
+instance Behavable 'OperationLevel 'SecurityRequirementLevel where
+  data Behave 'OperationLevel 'SecurityRequirementLevel
+    = SecurityRequirementStep Int
+    deriving stock (Eq, Ord, Show)
+
 instance Subtree MatchedOperation where
   type SubtreeLevel MatchedOperation = 'OperationLevel
   type
@@ -116,8 +123,8 @@ instance Subtree MatchedOperation where
       x <- pc
       se <- getH @(ProdCons [Server]) env
       pure $ Traced (ask x >>> step OperationServersStep) (getServers se (extract x))
+    structuralList env $ fmap snd . tracedSecurity <$> pc
     -- TODO: Callbacks
-    -- TODO: Security
     pure ()
   checkSemanticCompatibility env beh prodCons = do
     checkParameters
@@ -211,7 +218,13 @@ instance Subtree MatchedOperation where
       -- 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")
+      checkOperationSecurity = do
+        let ProdCons pSecs cSecs = tracedSecurity <$> prodCons
+        for_ pSecs $ \(i, pSec) -> do
+          let beh' = beh >>> step (SecurityRequirementStep i)
+          anyOfAt beh' SecurityRequirementNotMet $
+            cSecs <&> \(_, cSec) ->
+              checkCompatibility env beh' $ ProdCons pSec cSec
       checkServers =
         checkCompatibility env beh $ do
           x <- prodCons

src/OpenAPI/Checker/Validate/SecurityRequirement.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE PartialTypeSignatures #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module OpenAPI.Checker.Validate.SecurityRequirement
@@ -5,15 +6,25 @@ module OpenAPI.Checker.Validate.SecurityRequirement
   )
 where
 
+import Control.Comonad
+import Control.Monad
+import Control.Monad.Writer
+import Data.Bifunctor
+import Data.Either
+import Data.Foldable
+import Data.Functor
+import Data.HList
+import qualified Data.HashMap.Strict.InsOrd as IOHM
+import qualified Data.List.NonEmpty as NE
 import Data.OpenApi
+import Data.Set (Set)
+import qualified Data.Set as S
+import Data.Text (Text)
+import Data.Traversable
 import OpenAPI.Checker.Behavior
 import OpenAPI.Checker.Subtree
-
-instance Issuable 'SecurityRequirementLevel where
-  data Issue 'SecurityRequirementLevel
-    = SecurityRequirementNotMet
-    deriving stock (Eq, Ord, Show)
-  issueIsUnsupported _ = False
+import OpenAPI.Checker.Validate.OAuth2Flows
+import OpenAPI.Checker.Validate.SecurityScheme ()
 
 instance Subtree SecurityRequirement where
   type SubtreeLevel SecurityRequirement = 'SecurityRequirementLevel
@@ -21,5 +32,79 @@ instance Subtree SecurityRequirement where
     CheckEnv SecurityRequirement =
       '[ ProdCons (Traced (Definitions SecurityScheme))
        ]
-  checkStructuralCompatibility = undefined
-  checkSemanticCompatibility = undefined
+  checkStructuralCompatibility env pc = do
+    let normalized = do
+          sec <- extract <$> pc
+          defs <- getH env
+          -- lookupScheme
+          pure $
+            for (IOHM.toList $ getSecurityRequirement sec) $ \(key, scopes) ->
+              (,scopes) <$> lookupScheme key defs
+    structuralMaybeWith
+      (\pc' -> do
+         let ProdCons pScopes cScopes = fmap snd <$> pc'
+         unless (pScopes == cScopes) structuralIssue
+         structuralList env $ fmap fst <$> pc'
+         pure ())
+      normalized
+    pure ()
+  checkSemanticCompatibility env bhv' pc = do
+    let schemes = getH @(ProdCons (Traced (Definitions SecurityScheme))) env
+        ( ProdCons pErrs cErrs
+          , (ProdCons pSchemes cSchemes)
+              :: ProdCons [(Behavior 'SecuritySchemeLevel, Traced SecurityScheme, [Text])]
+          ) =
+            NE.unzip $
+              partitionEithers <$> do
+                req <- pc
+                scheme <- schemes
+                pure $
+                  let -- [(key, scopes)]
+                      pairs = IOHM.toList . getSecurityRequirement . extract $ req
+                   in pairs <&> \(key, scopes) -> do
+                        case lookupScheme key scheme of
+                          Nothing -> Left $ UndefinedSecurityScheme key
+                          Just x -> Right (bhv' >>> step (SecuritySchemeStep key), x, scopes)
+        lookSimilar :: SecurityScheme -> SecurityScheme -> Bool
+        lookSimilar x y = case (_securitySchemeType x, _securitySchemeType y) of
+          (SecuritySchemeOAuth2 {}, SecuritySchemeOAuth2 {}) -> True
+          (SecuritySchemeHttp {}, SecuritySchemeHttp {}) -> True
+          (SecuritySchemeApiKey {}, SecuritySchemeApiKey {}) -> True
+          (SecuritySchemeOpenIdConnect {}, SecuritySchemeOpenIdConnect {}) -> True
+          _ -> False
+    issueAt bhv' `traverse_` pErrs
+    issueAt bhv' `traverse_` cErrs
+    for_ pSchemes $ \(bhv, pScheme, pScopes) -> do
+      let lookPromising = filter (lookSimilar (extract pScheme) . extract . (\(_, x, _) -> x)) cSchemes
+      anyOfAt bhv SecuritySchemeNotMatched $
+        lookPromising <&> \(_, cScheme, cScopes) -> do
+          let untracedSchemes = join bimap (_securitySchemeType . extract) (pScheme, cScheme)
+              scopedFlow :: Set Text -> OAuth2Flow t -> Writer [Issue 'SecuritySchemeLevel] (OAuth2Flow t)
+              scopedFlow scopes x = do
+                let scopesMap = _oAuth2Scopes x
+                for_ scopes $ \scope -> unless (scope `IOHM.member` scopesMap) $ tell [ScopeNotDefined scope]
+                pure $ x {_oAuth2Scopes = IOHM.filterWithKey (\k _ -> k `S.member` scopes) scopesMap}
+              scopedSchemeType :: [Text] -> SecuritySchemeType -> Writer [Issue 'SecuritySchemeLevel] SecuritySchemeType
+              scopedSchemeType scopes (SecuritySchemeOAuth2 (OAuth2Flows a b c d)) =
+                fmap SecuritySchemeOAuth2 $ OAuth2Flows <$> flow a <*> flow b <*> flow c <*> flow d
+                where
+                  flow :: Maybe (OAuth2Flow t) -> Writer [Issue 'SecuritySchemeLevel] (Maybe (OAuth2Flow t))
+                  flow = traverse $ scopedFlow $ S.fromList scopes
+              scopedSchemeType _ x = pure x
+              scopedScheme scopes x = do
+                sType <- scopedSchemeType scopes $ _securitySchemeType x
+                pure $ x {_securitySchemeType = sType}
+              (pc', errs) = runWriter $ ProdCons <$> scopedScheme pScopes `traverse` pScheme <*> scopedScheme cScopes `traverse` cScheme
+          case untracedSchemes of
+            (SecuritySchemeOpenIdConnect _, SecuritySchemeOpenIdConnect _) -> do
+              let missingScopes = S.fromList cScopes S.\\ S.fromList pScopes
+              unless (S.null missingScopes) $ issueAt bhv (ScopesMissing missingScopes)
+            (SecuritySchemeOAuth2 {}, SecuritySchemeOAuth2 {}) -> pure ()
+            _ -> unless (null pScopes && null cScopes) $ issueAt bhv CanNotHaveScopes
+          for_ errs $ issueAt bhv
+          checkCompatibility env bhv pc'
+          pure ()
+    pure ()
+
+lookupScheme :: Text -> Traced (Definitions SecurityScheme) -> Maybe (Traced SecurityScheme)
+lookupScheme k (Traced t m) = Traced (t >>> step (InsOrdHashMapKeyStep k)) <$> IOHM.lookup k m

src/OpenAPI/Checker/Validate/SecurityScheme.hs

@@ -0,0 +1,43 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module OpenAPI.Checker.Validate.SecurityScheme
+  (
+  )
+where
+
+import Control.Monad
+import Data.OpenApi
+import OpenAPI.Checker.Behavior
+import OpenAPI.Checker.Orphans ()
+import OpenAPI.Checker.Subtree
+import OpenAPI.Checker.Validate.OAuth2Flows
+
+instance Subtree SecurityScheme where
+  type CheckEnv SecurityScheme = '[]
+  type SubtreeLevel SecurityScheme = 'SecuritySchemeLevel
+  checkStructuralCompatibility _ pc = structuralEq $ tracedSecuritySchemaTypes <$> pc
+  checkSemanticCompatibility env bhv pcSecScheme = case tracedSecuritySchemaTypes <$> pcSecScheme of
+    (ProdCons (Traced _ (SecuritySchemeHttp pType)) (Traced _ (SecuritySchemeHttp cType))) -> case (pType, cType) of
+      (HttpSchemeBearer _, HttpSchemeBearer _) -> pure ()
+      (HttpSchemeBasic, HttpSchemeBasic) -> pure ()
+      (HttpSchemeCustom p, HttpSchemeCustom c) ->
+        unless (p == c) (issueAt bhv $ CustomHttpSchemesDontMatch p c)
+      _ -> issueAt bhv $ HttpSchemeTypesDontMatch pType cType
+    (ProdCons (Traced _ (SecuritySchemeApiKey pParams)) (Traced _ (SecuritySchemeApiKey cParams))) -> do
+      unless (pParams == cParams) (issueAt bhv $ ApiKeyParamsDontMatch pParams cParams)
+    (ProdCons (Traced pT (SecuritySchemeOAuth2 pFlows)) (Traced cT (SecuritySchemeOAuth2 cFlows))) -> do
+      checkCompatibility env bhv . fmap (stepTraced SecurityOAuthFlowsStep) $ ProdCons (Traced pT pFlows) (Traced cT cFlows)
+    (ProdCons (Traced _ (SecuritySchemeOpenIdConnect pUrl)) (Traced _ (SecuritySchemeOpenIdConnect cUrl))) -> do
+      unless (pUrl == cUrl) (issueAt bhv $ OpenIdConnectUrlsDontMatch pUrl cUrl)
+    _ -> issueAt bhv DifferentSecuritySchemes
+
+tracedSecuritySchemaTypes :: Traced SecurityScheme -> Traced SecuritySchemeType
+tracedSecuritySchemaTypes (Traced t x) = Traced (t >>> step SecuritySchemeTypeStep) (_securitySchemeType x)
+
+instance Steppable SecurityScheme SecuritySchemeType where
+  data Step SecurityScheme SecuritySchemeType = SecuritySchemeTypeStep
+    deriving (Eq, Ord, Show)
+
+instance Steppable SecuritySchemeType OAuth2Flows where
+  data Step SecuritySchemeType OAuth2Flows = SecurityOAuthFlowsStep
+    deriving (Eq, Ord, Show)

stack.yaml

@@ -1 +1 @@
-resolver: lts-17.11
+resolver: lts-17.12

stack.yaml.lock

@@ -6,7 +6,7 @@
 packages: []
 snapshots:
 - completed:
-    size: 567672
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/17/11.yaml
-    sha256: 03181cdbeb671eb605bbcf6f285bea4d094b6ac7433a0e14a9f1dd54ad995938
-  original: lts-17.11
+    size: 567669
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/17/12.yaml
+    sha256: facf6cac73b22a83ca955b580a98a7a09ed71f8f974c7a55d28e608c23e689a9
+  original: lts-17.12

test/golden/common/security-scheme/a.yaml

@@ -0,0 +1,110 @@
+openapi: 3.0.0
+info:
+  version: ""
+  title: ""
+paths:
+  /oauth/sign_out:
+    get:
+      parameters:
+        - required: false
+          schema:
+            type: string
+          in: query
+          name: redirect
+      responses:
+        "302":
+          content:
+            application/x-www-form-urlencoded: {}
+          headers:
+            Location:
+              schema:
+                type: string
+            set-cookie:
+              schema:
+                type: string
+          description: ""
+        "400":
+          description: Invalid `redirect`
+      security:
+        - sign-out-oauth: []
+        - oauth: []
+  /oauth/authorize:
+    get:
+      responses:
+        "302":
+          content:
+            application/x-www-form-urlencoded: {}
+          headers:
+            Location:
+              schema:
+                type: string
+          description: ""
+      security:
+        - get-oauth: []
+  /oauth/token:
+    post:
+      requestBody:
+        content:
+          application/x-www-form-urlencoded:
+            schema:
+              type: string
+      responses:
+        "200":
+          content:
+            application/json;charset=utf-8:
+              schema:
+                type: string
+          description: ""
+        "400":
+          description: Invalid `body`
+      security:
+        - oauth: []
+  /oauth/check:
+    post:
+      requestBody:
+        content:
+          application/json;charset=utf-8:
+            schema:
+              type: string
+      responses:
+        "200":
+          content:
+            application/json;charset=utf-8:
+              schema:
+                example: []
+                items: {}
+                maxItems: 0
+                type: array
+          description: ""
+        "400":
+          description: Invalid `body`
+      security:
+        - oauth: []
+components:
+  securitySchemes:
+    sign-out-oauth:
+      in: cookie
+      name: _SESSION
+      type: apiKey
+      description: Session cookie
+    get-oauth:
+      in: cookie
+      name: _SESSION
+      type: apiKey
+      description: Session cookie
+    oauth:
+      scheme: Basic
+      type: http
+    oauth-token:
+      scheme: Bearer
+      type: http
+      description: Bearer token
+    oauth-token-client-only:
+      scheme: Bearer
+      type: http
+      description: Bearer token
+    spa-oauth:
+      in: cookie
+      name: _SESSION
+      type: apiKey
+      description: Session cookie

test/golden/common/security-scheme/b.yaml

@@ -0,0 +1,110 @@
+openapi: 3.0.0
+info:
+  version: ""
+  title: ""
+paths:
+  /oauth/sign_out:
+    get:
+      parameters:
+        - required: false
+          schema:
+            type: string
+          in: query
+          name: redirect
+      responses:
+        "302":
+          content:
+            application/x-www-form-urlencoded: {}
+          headers:
+            Location:
+              schema:
+                type: string
+            set-cookie:
+              schema:
+                type: string
+          description: ""
+        "400":
+          description: Invalid `redirect`
+      security:
+        - sign-out-oauth: []
+  /oauth/authorize:
+    get:
+      responses:
+        "302":
+          content:
+            application/x-www-form-urlencoded: {}
+          headers:
+            Location:
+              schema:
+                type: string
+          description: ""
+      security:
+        - get-oauth: []
+        - spa-oauth: []
+  /oauth/token:
+    post:
+      requestBody:
+        content:
+          application/x-www-form-urlencoded:
+            schema:
+              type: string
+      responses:
+        "200":
+          content:
+            application/json;charset=utf-8:
+              schema:
+                type: string
+          description: ""
+        "400":
+          description: Invalid `body`
+      security:
+        - oauth: []
+  /oauth/check:
+    post:
+      requestBody:
+        content:
+          application/json;charset=utf-8:
+            schema:
+              type: string
+      responses:
+        "200":
+          content:
+            application/json;charset=utf-8:
+              schema:
+                example: []
+                items: {}
+                maxItems: 0
+                type: array
+          description: ""
+        "400":
+          description: Invalid `body`
+      security:
+        - spa-oauth: []
+components:
+  securitySchemes:
+    sign-out-oauth:
+      in: cookie
+      name: _SESSION
+      type: apiKey
+      description: Session cookie
+    get-oauth:
+      in: cookie
+      name: _SESSION
+      type: apiKey
+      description: Session cookie
+    oauth:
+      scheme: Basic
+      type: http
+    oauth-token:
+      scheme: Bearer
+      type: http
+      description: Bearer token
+    oauth-token-client-only:
+      scheme: Bearer
+      type: http
+      description: Bearer token
+    spa-oauth:
+      in: cookie
+      name: _SESSION
+      type: apiKey
+      description: Session cookie

test/golden/common/security-scheme/trace-tree.yaml

@@ -0,0 +1,9 @@
+Left:
+  AtPath (ProdCons {producer = "/oauth/check", consumer = "/oauth/check"}):
+    InOperation PostMethod:
+      SecurityRequirementStep 0:
+        SecuritySchemeStep "oauth": SecuritySchemeNotMatched
+  AtPath (ProdCons {producer = "/oauth/sign_out", consumer = "/oauth/sign_out"}):
+    InOperation GetMethod:
+      SecurityRequirementStep 1:
+        SecuritySchemeStep "oauth": SecuritySchemeNotMatched