mirror of
https://github.com/ilyakooo0/compaREST.git
synced 2024-09-11 06:25:40 +03:00
parent
e0ffc455ff
commit
b76f48dc5a
@ -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
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -3,6 +3,7 @@
|
||||
module OpenAPI.Checker.References
|
||||
( Step (..)
|
||||
, dereference
|
||||
, Typeable
|
||||
)
|
||||
where
|
||||
|
||||
|
@ -39,6 +39,7 @@ module OpenAPI.Checker.Subtree
|
||||
, ask
|
||||
, local
|
||||
, step
|
||||
, Typeable
|
||||
)
|
||||
where
|
||||
|
||||
|
6
src/OpenAPI/Checker/Subtree/Deriving.hs
Normal file
6
src/OpenAPI/Checker/Subtree/Deriving.hs
Normal file
@ -0,0 +1,6 @@
|
||||
module OpenAPI.Checker.Subtree.Deriving (EqSubtree (..)) where
|
||||
|
||||
import Control.Monad
|
||||
import OpenAPI.Checker.Subtree
|
||||
|
||||
newtype EqSubtree t = EqSubtree t
|
@ -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
|
||||
|
132
src/OpenAPI/Checker/Validate/OAuth2Flows.hs
Normal file
132
src/OpenAPI/Checker/Validate/OAuth2Flows.hs
Normal file
@ -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)
|
@ -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
|
||||
|
@ -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
|
||||
|
43
src/OpenAPI/Checker/Validate/SecurityScheme.hs
Normal file
43
src/OpenAPI/Checker/Validate/SecurityScheme.hs
Normal file
@ -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)
|
@ -1 +1 @@
|
||||
resolver: lts-17.11
|
||||
resolver: lts-17.12
|
||||
|
@ -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
|
||||
|
110
test/golden/common/security-scheme/a.yaml
Normal file
110
test/golden/common/security-scheme/a.yaml
Normal file
@ -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
|
110
test/golden/common/security-scheme/b.yaml
Normal file
110
test/golden/common/security-scheme/b.yaml
Normal file
@ -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
|
9
test/golden/common/security-scheme/trace-tree.yaml
Normal file
9
test/golden/common/security-scheme/trace-tree.yaml
Normal file
@ -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
|
Loading…
Reference in New Issue
Block a user