git.iko.soy/typeable/compaREST
on master help sign in
Added security schemes (#59)
b76f48diko
openapi-diff.cabal+2
compare with master
unifiedsplit
@@ -134,6 +134,8 @@ library
134 , OpenAPI.Checker.Validate.Header
134 , OpenAPI.Checker.Validate.Header
135 , OpenAPI.Checker.Validate.Link
135 , OpenAPI.Checker.Validate.Link
136 , OpenAPI.Checker.Common
136 , OpenAPI.Checker.Common
137+ , OpenAPI.Checker.Validate.SecurityScheme
138+ , OpenAPI.Checker.Validate.OAuth2Flows
137
139
138executable openapi-diff
140executable openapi-diff
139 import: common-options
141 import: common-options
src/OpenAPI/Checker/Behavior.hs+8−3
@@ -4,7 +4,8 @@ module OpenAPI.Checker.Behavior
4 , Issuable (..)
4 , Issuable (..)
5 , Behavior
5 , Behavior
6 , AnIssue (..)
6 , AnIssue (..)
7+ )
7− ) where
8+where
8
9
9import Data.Aeson
10import Data.Aeson
10import Data.Kind
11import Data.Kind
@@ -16,6 +17,7 @@ data BehaviorLevel
16 = APILevel
17 = APILevel
17 | ServerLevel
18 | ServerLevel
18 | SecurityRequirementLevel
19 | SecurityRequirementLevel
20+ | SecuritySchemeLevel
19 | PathLevel
21 | PathLevel
20 | OperationLevel
22 | OperationLevel
21 | PathFragmentLevel
23 | PathFragmentLevel
@@ -28,8 +30,10 @@ data BehaviorLevel
28 | TypedSchemaLevel
30 | TypedSchemaLevel
29 | LinkLevel
31 | LinkLevel
30
32
33+class
31−class (Ord (Behave a b), Show (Behave a b))
34+ (Ord (Behave a b), Show (Behave a b)) =>
32− => Behavable (a :: BehaviorLevel) (b :: BehaviorLevel) where
35+ Behavable (a :: BehaviorLevel) (b :: BehaviorLevel)
36+ where
33 data Behave a b
37 data Behave a b
34
38
35class (Ord (Issue l), Show (Issue l)) => Issuable (l :: BehaviorLevel) where
39class (Ord (Issue l), Show (Issue l)) => Issuable (l :: BehaviorLevel) where
@@ -48,6 +52,7 @@ data AnIssue (l :: BehaviorLevel) where
48 AnIssue :: Issuable l => Issue l -> AnIssue l
52 AnIssue :: Issuable l => Issue l -> AnIssue l
49
53
50deriving stock instance Eq (AnIssue l)
54deriving stock instance Eq (AnIssue l)
55+
51deriving stock instance Ord (AnIssue l)
56deriving stock instance Ord (AnIssue l)
52
57
53instance ToJSON (AnIssue l) where
58instance ToJSON (AnIssue l) where
src/OpenAPI/Checker/Orphans.hs+16−1
@@ -3,25 +3,40 @@
3module OpenAPI.Checker.Orphans () where
3module OpenAPI.Checker.Orphans () where
4
4
5import Control.Comonad.Env
5import Control.Comonad.Env
6−import Data.OpenApi
7import qualified Data.HashMap.Strict.InsOrd as IOHM
6import qualified Data.HashMap.Strict.InsOrd as IOHM
7+import Data.OpenApi
8
8
9deriving newtype instance Ord Reference
9deriving newtype instance Ord Reference
10
10
11deriving stock instance Ord a => Ord (Referenced a)
11deriving stock instance Ord a => Ord (Referenced a)
12+
12deriving stock instance Ord Schema
13deriving stock instance Ord Schema
14+
13deriving stock instance Ord AdditionalProperties
15deriving stock instance Ord AdditionalProperties
16+
14deriving stock instance Ord Discriminator
17deriving stock instance Ord Discriminator
18+
15deriving stock instance Ord Xml
19deriving stock instance Ord Xml
20+
16deriving stock instance Ord OpenApiType
21deriving stock instance Ord OpenApiType
22+
17deriving stock instance Ord Style
23deriving stock instance Ord Style
24+
18deriving stock instance Ord OpenApiItems
25deriving stock instance Ord OpenApiItems
26+
19deriving stock instance Ord ParamLocation
27deriving stock instance Ord ParamLocation
20
28
29+deriving stock instance Ord HttpSchemeType
30+
31+deriving stock instance Ord ApiKeyParams
32+
33+deriving stock instance Ord ApiKeyLocation
21
34
22instance (Ord k, Ord v) => Ord (IOHM.InsOrdHashMap k v) where
35instance (Ord k, Ord v) => Ord (IOHM.InsOrdHashMap k v) where
23 compare xs ys = compare (IOHM.toList xs) (IOHM.toList ys)
36 compare xs ys = compare (IOHM.toList xs) (IOHM.toList ys)
24
37
25deriving stock instance (Eq e, Eq (w a)) => Eq (EnvT e w a)
38deriving stock instance (Eq e, Eq (w a)) => Eq (EnvT e w a)
39+
26deriving stock instance (Ord e, Ord (w a)) => Ord (EnvT e w a)
40deriving stock instance (Ord e, Ord (w a)) => Ord (EnvT e w a)
41+
27deriving stock instance (Show e, Show (w a)) => Show (EnvT e w a)
42deriving stock instance (Show e, Show (w a)) => Show (EnvT e w a)
src/OpenAPI/Checker/References.hs+1
@@ -3,6 +3,7 @@
3module OpenAPI.Checker.References
3module OpenAPI.Checker.References
4 ( Step (..)
4 ( Step (..)
5 , dereference
5 , dereference
6+ , Typeable
6 )
7 )
7where
8where
8
9
src/OpenAPI/Checker/Subtree.hs+1
@@ -39,6 +39,7 @@ module OpenAPI.Checker.Subtree
39 , ask
39 , ask
40 , local
40 , local
41 , step
41 , step
42+ , Typeable
42 )
43 )
43where
44where
44
45
src/OpenAPI/Checker/Subtree/Deriving.hsnew file+6
@@ -0,0 +1,6 @@
1+module OpenAPI.Checker.Subtree.Deriving (EqSubtree (..)) where
2+
3+import Control.Monad
4+import OpenAPI.Checker.Subtree
5+
6+newtype EqSubtree t = EqSubtree t
src/OpenAPI/Checker/Validate/MediaTypeObject.hs+41−31
@@ -1,9 +1,10 @@
1{-# OPTIONS_GHC -Wno-orphans #-}
1{-# OPTIONS_GHC -Wno-orphans #-}
2
2
3module OpenAPI.Checker.Validate.MediaTypeObject
3module OpenAPI.Checker.Validate.MediaTypeObject
4− ( Issue(..)
4+ ( Issue (..)
5− , Behave(..)
5+ , Behave (..)
6+ )
6− ) where
7+where
7
8
8import Control.Lens
9import Control.Lens
9import Data.Foldable as F
10import Data.Foldable as F
@@ -15,18 +16,18 @@ import Data.Text (Text)
15import Network.HTTP.Media (MediaType, mainType, subType)
16import Network.HTTP.Media (MediaType, mainType, subType)
16import OpenAPI.Checker.Behavior
17import OpenAPI.Checker.Behavior
17import OpenAPI.Checker.Subtree
18import OpenAPI.Checker.Subtree
19+import OpenAPI.Checker.Validate.Header ()
18import OpenAPI.Checker.Validate.Products
20import OpenAPI.Checker.Validate.Products
19import OpenAPI.Checker.Validate.Schema ()
21import OpenAPI.Checker.Validate.Schema ()
20−import OpenAPI.Checker.Validate.Header ()
21−
22
22
23tracedSchema :: Traced MediaTypeObject -> Maybe (Traced (Referenced Schema))
23tracedSchema :: Traced MediaTypeObject -> Maybe (Traced (Referenced Schema))
24tracedSchema mto = _mediaTypeObjectSchema (extract mto) <&> traced (ask mto >>> step MediaTypeSchema)
24tracedSchema mto = _mediaTypeObjectSchema (extract mto) <&> traced (ask mto >>> step MediaTypeSchema)
25
25
26-- FIXME: This should be done through 'MediaTypeEncodingMapping'
26-- FIXME: This should be done through 'MediaTypeEncodingMapping'
27tracedEncoding :: Traced MediaTypeObject -> InsOrdHashMap Text (Traced Encoding)
27tracedEncoding :: Traced MediaTypeObject -> InsOrdHashMap Text (Traced Encoding)
28+tracedEncoding mto =
28−tracedEncoding mto = IOHM.mapWithKey (\k -> traced (ask mto >>> step (MediaTypeParamEncoding k)))
29+ IOHM.mapWithKey (\k -> traced (ask mto >>> step (MediaTypeParamEncoding k))) $
29− $ _mediaTypeObjectEncoding $ extract mto
30+ _mediaTypeObjectEncoding $ extract mto
30
31
31instance Issuable 'PayloadLevel where
32instance Issuable 'PayloadLevel where
32 data Issue 'PayloadLevel
33 data Issue 'PayloadLevel
@@ -47,43 +48,52 @@ instance Behavable 'PayloadLevel 'SchemaLevel where
47
48
48instance Subtree MediaTypeObject where
49instance Subtree MediaTypeObject where
49 type SubtreeLevel MediaTypeObject = 'PayloadLevel
50 type SubtreeLevel MediaTypeObject = 'PayloadLevel
51+ type
50− type CheckEnv MediaTypeObject =
52+ CheckEnv MediaTypeObject =
51− '[ MediaType
53+ '[ MediaType
52− , ProdCons (Traced (Definitions Schema))
54+ , ProdCons (Traced (Definitions Schema))
53− , ProdCons (Traced (Definitions Header))
55+ , ProdCons (Traced (Definitions Header))
54− ]
56+ ]
55 checkStructuralCompatibility env pc = do
57 checkStructuralCompatibility env pc = do
56 structuralMaybe env $ tracedSchema <$> pc
58 structuralMaybe env $ tracedSchema <$> pc
57 structuralEq $ fmap _mediaTypeObjectExample <$> pc
59 structuralEq $ fmap _mediaTypeObjectExample <$> pc
58 iohmStructural env $ stepTraced MediaTypeEncodingMapping . fmap _mediaTypeObjectEncoding <$> pc
60 iohmStructural env $ stepTraced MediaTypeEncodingMapping . fmap _mediaTypeObjectEncoding <$> pc
59 pure ()
61 pure ()
60 checkSemanticCompatibility env beh prodCons@(ProdCons p c) = do
62 checkSemanticCompatibility env beh prodCons@(ProdCons p c) = do
63+ if
61− if | "multipart" == mainType mediaType -> checkEncoding
64+ | "multipart" == mainType mediaType -> checkEncoding
62− | "application" == mainType mediaType &&
65+ | "application" == mainType mediaType
63− "x-www-form-urlencoded" == subType mediaType -> checkEncoding
66+ && "x-www-form-urlencoded" == subType mediaType ->
67+ checkEncoding
64− | otherwise -> pure ()
68+ | otherwise -> pure ()
65 -- If consumer requires schema then producer must produce compatible
69 -- If consumer requires schema then producer must produce compatible
66 -- request
70 -- request
67 for_ (tracedSchema c) $ \consRef ->
71 for_ (tracedSchema c) $ \consRef ->
68− case tracedSchema p of
72+ case tracedSchema p of
69− Nothing -> issueAt beh MediaTypeSchemaRequired
73+ Nothing -> issueAt beh MediaTypeSchemaRequired
74+ Just prodRef ->
70− Just prodRef -> checkCompatibility env (beh >>> step PayloadSchema)
75+ checkCompatibility env (beh >>> step PayloadSchema) $
71− $ ProdCons prodRef consRef
76+ ProdCons prodRef consRef
72 pure ()
77 pure ()
73 where
78 where
74 mediaType = getH @MediaType env
79 mediaType = getH @MediaType env
75 checkEncoding =
80 checkEncoding =
76− let
77− -- Parameters of the media type are product-like entities
81+ let -- Parameters of the media type are product-like entities
78− getEncoding mt = M.fromList
82+ getEncoding mt =
83+ M.fromList $
79− $ (IOHM.toList $ tracedEncoding mt) <&> \(k, enc) ->
84+ (IOHM.toList $ tracedEncoding mt) <&> \(k, enc) ->
80− ( k
85+ ( k
81− , ProductLike
86+ , ProductLike
82− { productValue = enc
87+ { productValue = enc
83− , required = True } )
88+ , required = True
89+ }
90+ )
84− encProdCons = getEncoding <$> prodCons
91+ encProdCons = getEncoding <$> prodCons
92+ in checkProducts
93+ beh
85− in checkProducts beh MediaEncodingMissing
94+ MediaEncodingMissing
86− (const $ checkCompatibility env beh) encProdCons
95+ (const $ checkCompatibility env beh)
96+ encProdCons
87
97
88instance Subtree Encoding where
98instance Subtree Encoding where
89 type SubtreeLevel Encoding = 'PayloadLevel
99 type SubtreeLevel Encoding = 'PayloadLevel
src/OpenAPI/Checker/Validate/OAuth2Flows.hsnew file+132
@@ -0,0 +1,132 @@
1+{-# OPTIONS_GHC -Wno-orphans #-}
2+
3+module OpenAPI.Checker.Validate.OAuth2Flows
4+ ( Step (..)
5+ , Issue (..)
6+ , Behave (..)
7+ )
8+where
9+
10+import Control.Monad
11+import Data.Function
12+import qualified Data.HashMap.Strict.InsOrd as IOHM
13+import Data.OpenApi
14+import Data.Proxy
15+import Data.Set (Set)
16+import qualified Data.Set as S
17+import Data.Text (Text)
18+import OpenAPI.Checker.Behavior
19+import OpenAPI.Checker.Orphans ()
20+import OpenAPI.Checker.Subtree
21+
22+instance Subtree OAuth2Flows where
23+ type CheckEnv OAuth2Flows = '[]
24+ type SubtreeLevel OAuth2Flows = 'SecuritySchemeLevel
25+ checkStructuralCompatibility _ = structuralEq
26+ checkSemanticCompatibility env bhv pc = do
27+ let supportFlow
28+ :: (Subtree t, SubtreeLevel t ~ SubtreeLevel OAuth2Flows, CheckEnv OAuth2Flows ~ CheckEnv t)
29+ => Issue 'SecuritySchemeLevel
30+ -> ProdCons (Maybe (Traced t))
31+ -> SemanticCompatFormula ()
32+ supportFlow i x = case x of
33+ -- producer will not attempt this flow
34+ (ProdCons Nothing _) -> pure ()
35+ -- producer can attempt a flow the consumer does not know about
36+ (ProdCons (Just _) Nothing) -> issueAt bhv i
37+ (ProdCons (Just p) (Just c)) ->
38+ checkCompatibility env bhv $ ProdCons p c
39+ getFlow
40+ :: Typeable x
41+ => (OAuth2Flows -> Maybe (OAuth2Flow x))
42+ -> Traced OAuth2Flows
43+ -> Maybe (Traced (OAuth2Flow x))
44+ getFlow f (Traced t a) = Traced (t >>> step (OAuth2FlowsFlow Proxy)) <$> f a
45+ supportFlow ConsumerDoesNotSupportImplicitFlow $ getFlow _oAuth2FlowsImplicit <$> pc
46+ supportFlow ConsumerDoesNotSupportPasswordFlow $ getFlow _oAuth2FlowsPassword <$> pc
47+ supportFlow ConsumerDoesNotSupportClientCridentialsFlow $ getFlow _oAuth2FlowsClientCredentials <$> pc
48+ supportFlow ConsumerDoesNotSupportAuthorizationCodeFlow $ getFlow _oAuth2FlowsAuthorizationCode <$> pc
49+ pure ()
50+
51+instance Typeable t => Steppable OAuth2Flows (OAuth2Flow t) where
52+ data Step OAuth2Flows (OAuth2Flow t) = OAuth2FlowsFlow (Proxy t)
53+ deriving (Eq, Ord, Show)
54+
55+instance (Typeable t, Subtree t, SubtreeLevel (OAuth2Flow t) ~ SubtreeLevel t) => Subtree (OAuth2Flow t) where
56+ type CheckEnv (OAuth2Flow t) = CheckEnv t
57+ type SubtreeLevel (OAuth2Flow t) = 'SecuritySchemeLevel
58+ checkStructuralCompatibility = undefined
59+ checkSemanticCompatibility env bhv prodCons@(ProdCons p c) = do
60+ let ProdCons pScopes cScopes = S.fromList . IOHM.keys . _oAuth2Scopes . extract <$> prodCons
61+ missingScopes = cScopes S.\\ pScopes
62+ unless (S.null missingScopes) (issueAt bhv $ ScopesMissing missingScopes)
63+ checkCompatibility env bhv $ retraced (>>> step (OAuth2FlowParamsStep Proxy)) . fmap _oAuth2Params <$> prodCons
64+ unless (((==) `on` _oAath2RefreshUrl . extract) p c) $ issueAt bhv RefreshUrlsDontMatch
65+ pure ()
66+
67+instance Typeable t => Steppable (OAuth2Flow t) t where
68+ data Step (OAuth2Flow t) t = OAuth2FlowParamsStep (Proxy t)
69+ deriving (Eq, Ord, Show)
70+
71+instance Subtree OAuth2ImplicitFlow where
72+ type SubtreeLevel OAuth2ImplicitFlow = 'SecuritySchemeLevel
73+ type CheckEnv OAuth2ImplicitFlow = '[]
74+ checkStructuralCompatibility = undefined
75+ checkSemanticCompatibility _ bhv (ProdCons p c) =
76+ unless (extract p == extract c) $ issueAt bhv OAuth2ImplicitFlowNotEqual
77+
78+instance Subtree OAuth2PasswordFlow where
79+ type SubtreeLevel OAuth2PasswordFlow = 'SecuritySchemeLevel
80+ type CheckEnv OAuth2PasswordFlow = '[]
81+ checkStructuralCompatibility = undefined
82+ checkSemanticCompatibility _ bhv (ProdCons p c) =
83+ unless (extract p == extract c) $ issueAt bhv OAuth2PasswordFlowNotEqual
84+
85+instance Subtree OAuth2ClientCredentialsFlow where
86+ type SubtreeLevel OAuth2ClientCredentialsFlow = 'SecuritySchemeLevel
87+ type CheckEnv OAuth2ClientCredentialsFlow = '[]
88+ checkStructuralCompatibility = undefined
89+ checkSemanticCompatibility _ bhv (ProdCons p c) =
90+ unless (extract p == extract c) $ issueAt bhv OAuth2ClientCredentialsFlowNotEqual
91+
92+instance Subtree OAuth2AuthorizationCodeFlow where
93+ type SubtreeLevel OAuth2AuthorizationCodeFlow = 'SecuritySchemeLevel
94+ type CheckEnv OAuth2AuthorizationCodeFlow = '[]
95+ checkStructuralCompatibility = undefined
96+ checkSemanticCompatibility _ bhv (ProdCons p c) =
97+ unless (extract p == extract c) $ issueAt bhv OAuth2AuthorizationCodeFlowNotEqual
98+
99+instance Issuable 'SecurityRequirementLevel where
100+ data Issue 'SecurityRequirementLevel
101+ = SecurityRequirementNotMet
102+ | UndefinedSecurityScheme Text
103+ deriving stock (Eq, Ord, Show)
104+ issueIsUnsupported _ = False
105+
106+instance Issuable 'SecuritySchemeLevel where
107+ data Issue 'SecuritySchemeLevel
108+ = RefreshUrlsDontMatch
109+ | HttpSchemeTypesDontMatch HttpSchemeType HttpSchemeType
110+ | ApiKeyParamsDontMatch ApiKeyParams ApiKeyParams
111+ | OpenIdConnectUrlsDontMatch URL URL
112+ | CustomHttpSchemesDontMatch Text Text
113+ | ConsumerDoesNotSupportImplicitFlow
114+ | ConsumerDoesNotSupportPasswordFlow
115+ | ConsumerDoesNotSupportClientCridentialsFlow
116+ | ConsumerDoesNotSupportAuthorizationCodeFlow
117+ | SecuritySchemeNotMatched
118+ | OAuth2ImplicitFlowNotEqual
119+ | OAuth2PasswordFlowNotEqual
120+ | OAuth2ClientCredentialsFlowNotEqual
121+ | OAuth2AuthorizationCodeFlowNotEqual
122+ | ScopesMissing (Set Text)
123+ | DifferentSecuritySchemes
124+ | CanNotHaveScopes
125+ | ScopeNotDefined Text
126+ deriving stock (Eq, Ord, Show)
127+ issueIsUnsupported _ = False
128+
129+instance Behavable 'SecurityRequirementLevel 'SecuritySchemeLevel where
130+ data Behave 'SecurityRequirementLevel 'SecuritySchemeLevel
131+ = SecuritySchemeStep Text
132+ deriving stock (Eq, Ord, Show)
src/OpenAPI/Checker/Validate/Operation.hs+17−4
@@ -20,10 +20,12 @@ import OpenAPI.Checker.Behavior
20import OpenAPI.Checker.References
20import OpenAPI.Checker.References
21import OpenAPI.Checker.Subtree
21import OpenAPI.Checker.Subtree
22import OpenAPI.Checker.Validate.MediaTypeObject
22import OpenAPI.Checker.Validate.MediaTypeObject
23+import OpenAPI.Checker.Validate.OAuth2Flows
23import OpenAPI.Checker.Validate.PathFragment
24import OpenAPI.Checker.Validate.PathFragment
24import OpenAPI.Checker.Validate.Products
25import OpenAPI.Checker.Validate.Products
25import OpenAPI.Checker.Validate.RequestBody ()
26import OpenAPI.Checker.Validate.RequestBody ()
26import OpenAPI.Checker.Validate.Responses ()
27import OpenAPI.Checker.Validate.Responses ()
28+import OpenAPI.Checker.Validate.SecurityRequirement ()
27import OpenAPI.Checker.Validate.Server ()
29import OpenAPI.Checker.Validate.Server ()
28
30
29data MatchedOperation = MatchedOperation
31data MatchedOperation = MatchedOperation
@@ -54,9 +56,9 @@ tracedResponses oper =
54 traced (ask oper >>> step OperationResponsesStep) $
56 traced (ask oper >>> step OperationResponsesStep) $
55 _operationResponses . operation $ extract oper
57 _operationResponses . operation $ extract oper
56
58
57−tracedSecurity :: Traced MatchedOperation -> [Traced SecurityRequirement]
59+tracedSecurity :: Traced MatchedOperation -> [(Int, Traced SecurityRequirement)]
58tracedSecurity oper =
60tracedSecurity oper =
59− [ traced (ask oper >>> step (OperationSecurityRequirementStep i)) x
61+ [ (i, traced (ask oper >>> step (OperationSecurityRequirementStep i)) x)
60 | (i, x) <- zip [0 ..] $ _operationSecurity . operation $ extract oper
62 | (i, x) <- zip [0 ..] $ _operationSecurity . operation $ extract oper
61 ]
63 ]
62
64
@@ -81,6 +83,11 @@ instance Behavable 'OperationLevel 'RequestLevel where
81 = InRequest
83 = InRequest
82 deriving stock (Eq, Ord, Show)
84 deriving stock (Eq, Ord, Show)
83
85
86+instance Behavable 'OperationLevel 'SecurityRequirementLevel where
87+ data Behave 'OperationLevel 'SecurityRequirementLevel
88+ = SecurityRequirementStep Int
89+ deriving stock (Eq, Ord, Show)
90+
84instance Subtree MatchedOperation where
91instance Subtree MatchedOperation where
85 type SubtreeLevel MatchedOperation = 'OperationLevel
92 type SubtreeLevel MatchedOperation = 'OperationLevel
86 type
93 type
@@ -116,8 +123,8 @@ instance Subtree MatchedOperation where
116 x <- pc
123 x <- pc
117 se <- getH @(ProdCons [Server]) env
124 se <- getH @(ProdCons [Server]) env
118 pure $ Traced (ask x >>> step OperationServersStep) (getServers se (extract x))
125 pure $ Traced (ask x >>> step OperationServersStep) (getServers se (extract x))
126+ structuralList env $ fmap snd . tracedSecurity <$> pc
119 -- TODO: Callbacks
127 -- TODO: Callbacks
120− -- TODO: Security
121 pure ()
128 pure ()
122 checkSemanticCompatibility env beh prodCons = do
129 checkSemanticCompatibility env beh prodCons = do
123 checkParameters
130 checkParameters
@@ -211,7 +218,13 @@ instance Subtree MatchedOperation where
211 -- FIXME: https://github.com/typeable/openapi-diff/issues/27
218 -- FIXME: https://github.com/typeable/openapi-diff/issues/27
212 checkCallbacks = pure () -- (error "FIXME: not implemented")
219 checkCallbacks = pure () -- (error "FIXME: not implemented")
213 -- FIXME: https://github.com/typeable/openapi-diff/issues/28
220 -- FIXME: https://github.com/typeable/openapi-diff/issues/28
214− checkOperationSecurity = pure () -- (error "FIXME: not implemented")
221+ checkOperationSecurity = do
222+ let ProdCons pSecs cSecs = tracedSecurity <$> prodCons
223+ for_ pSecs $ \(i, pSec) -> do
224+ let beh' = beh >>> step (SecurityRequirementStep i)
225+ anyOfAt beh' SecurityRequirementNotMet $
226+ cSecs <&> \(_, cSec) ->
227+ checkCompatibility env beh' $ ProdCons pSec cSec
215 checkServers =
228 checkServers =
216 checkCompatibility env beh $ do
229 checkCompatibility env beh $ do
217 x <- prodCons
230 x <- prodCons
src/OpenAPI/Checker/Validate/SecurityRequirement.hs+93−8
@@ -1,3 +1,4 @@
1+{-# LANGUAGE PartialTypeSignatures #-}
1{-# OPTIONS_GHC -Wno-orphans #-}
2{-# OPTIONS_GHC -Wno-orphans #-}
2
3
3module OpenAPI.Checker.Validate.SecurityRequirement
4module OpenAPI.Checker.Validate.SecurityRequirement
@@ -5,15 +6,25 @@ module OpenAPI.Checker.Validate.SecurityRequirement
5 )
6 )
6where
7where
7
8
9+import Control.Comonad
10+import Control.Monad
11+import Control.Monad.Writer
12+import Data.Bifunctor
13+import Data.Either
14+import Data.Foldable
15+import Data.Functor
16+import Data.HList
17+import qualified Data.HashMap.Strict.InsOrd as IOHM
18+import qualified Data.List.NonEmpty as NE
8import Data.OpenApi
19import Data.OpenApi
20+import Data.Set (Set)
21+import qualified Data.Set as S
22+import Data.Text (Text)
23+import Data.Traversable
9import OpenAPI.Checker.Behavior
24import OpenAPI.Checker.Behavior
10import OpenAPI.Checker.Subtree
25import OpenAPI.Checker.Subtree
11−
26+import OpenAPI.Checker.Validate.OAuth2Flows
12−instance Issuable 'SecurityRequirementLevel where
27+import OpenAPI.Checker.Validate.SecurityScheme ()
13− data Issue 'SecurityRequirementLevel
14− = SecurityRequirementNotMet
15− deriving stock (Eq, Ord, Show)
16− issueIsUnsupported _ = False
17
28
18instance Subtree SecurityRequirement where
29instance Subtree SecurityRequirement where
19 type SubtreeLevel SecurityRequirement = 'SecurityRequirementLevel
30 type SubtreeLevel SecurityRequirement = 'SecurityRequirementLevel
@@ -21,5 +32,79 @@ instance Subtree SecurityRequirement where
21 CheckEnv SecurityRequirement =
32 CheckEnv SecurityRequirement =
22 '[ ProdCons (Traced (Definitions SecurityScheme))
33 '[ ProdCons (Traced (Definitions SecurityScheme))
23 ]
34 ]
24− checkStructuralCompatibility = undefined
35+ checkStructuralCompatibility env pc = do
36+ let normalized = do
37+ sec <- extract <$> pc
38+ defs <- getH env
39+ -- lookupScheme
40+ pure $
41+ for (IOHM.toList $ getSecurityRequirement sec) $ \(key, scopes) ->
42+ (,scopes) <$> lookupScheme key defs
43+ structuralMaybeWith
44+ (\pc' -> do
45+ let ProdCons pScopes cScopes = fmap snd <$> pc'
46+ unless (pScopes == cScopes) structuralIssue
47+ structuralList env $ fmap fst <$> pc'
48+ pure ())
49+ normalized
50+ pure ()
25− checkSemanticCompatibility = undefined
51+ checkSemanticCompatibility env bhv' pc = do
52+ let schemes = getH @(ProdCons (Traced (Definitions SecurityScheme))) env
53+ ( ProdCons pErrs cErrs
54+ , (ProdCons pSchemes cSchemes)
55+ :: ProdCons [(Behavior 'SecuritySchemeLevel, Traced SecurityScheme, [Text])]
56+ ) =
57+ NE.unzip $
58+ partitionEithers <$> do
59+ req <- pc
60+ scheme <- schemes
61+ pure $
62+ let -- [(key, scopes)]
63+ pairs = IOHM.toList . getSecurityRequirement . extract $ req
64+ in pairs <&> \(key, scopes) -> do
65+ case lookupScheme key scheme of
66+ Nothing -> Left $ UndefinedSecurityScheme key
67+ Just x -> Right (bhv' >>> step (SecuritySchemeStep key), x, scopes)
68+ lookSimilar :: SecurityScheme -> SecurityScheme -> Bool
69+ lookSimilar x y = case (_securitySchemeType x, _securitySchemeType y) of
70+ (SecuritySchemeOAuth2 {}, SecuritySchemeOAuth2 {}) -> True
71+ (SecuritySchemeHttp {}, SecuritySchemeHttp {}) -> True
72+ (SecuritySchemeApiKey {}, SecuritySchemeApiKey {}) -> True
73+ (SecuritySchemeOpenIdConnect {}, SecuritySchemeOpenIdConnect {}) -> True
74+ _ -> False
75+ issueAt bhv' `traverse_` pErrs
76+ issueAt bhv' `traverse_` cErrs
77+ for_ pSchemes $ \(bhv, pScheme, pScopes) -> do
78+ let lookPromising = filter (lookSimilar (extract pScheme) . extract . (\(_, x, _) -> x)) cSchemes
79+ anyOfAt bhv SecuritySchemeNotMatched $
80+ lookPromising <&> \(_, cScheme, cScopes) -> do
81+ let untracedSchemes = join bimap (_securitySchemeType . extract) (pScheme, cScheme)
82+ scopedFlow :: Set Text -> OAuth2Flow t -> Writer [Issue 'SecuritySchemeLevel] (OAuth2Flow t)
83+ scopedFlow scopes x = do
84+ let scopesMap = _oAuth2Scopes x
85+ for_ scopes $ \scope -> unless (scope `IOHM.member` scopesMap) $ tell [ScopeNotDefined scope]
86+ pure $ x {_oAuth2Scopes = IOHM.filterWithKey (\k _ -> k `S.member` scopes) scopesMap}
87+ scopedSchemeType :: [Text] -> SecuritySchemeType -> Writer [Issue 'SecuritySchemeLevel] SecuritySchemeType
88+ scopedSchemeType scopes (SecuritySchemeOAuth2 (OAuth2Flows a b c d)) =
89+ fmap SecuritySchemeOAuth2 $ OAuth2Flows <$> flow a <*> flow b <*> flow c <*> flow d
90+ where
91+ flow :: Maybe (OAuth2Flow t) -> Writer [Issue 'SecuritySchemeLevel] (Maybe (OAuth2Flow t))
92+ flow = traverse $ scopedFlow $ S.fromList scopes
93+ scopedSchemeType _ x = pure x
94+ scopedScheme scopes x = do
95+ sType <- scopedSchemeType scopes $ _securitySchemeType x
96+ pure $ x {_securitySchemeType = sType}
97+ (pc', errs) = runWriter $ ProdCons <$> scopedScheme pScopes `traverse` pScheme <*> scopedScheme cScopes `traverse` cScheme
98+ case untracedSchemes of
99+ (SecuritySchemeOpenIdConnect _, SecuritySchemeOpenIdConnect _) -> do
100+ let missingScopes = S.fromList cScopes S.\\ S.fromList pScopes
101+ unless (S.null missingScopes) $ issueAt bhv (ScopesMissing missingScopes)
102+ (SecuritySchemeOAuth2 {}, SecuritySchemeOAuth2 {}) -> pure ()
103+ _ -> unless (null pScopes && null cScopes) $ issueAt bhv CanNotHaveScopes
104+ for_ errs $ issueAt bhv
105+ checkCompatibility env bhv pc'
106+ pure ()
107+ pure ()
108+
109+lookupScheme :: Text -> Traced (Definitions SecurityScheme) -> Maybe (Traced SecurityScheme)
110+lookupScheme k (Traced t m) = Traced (t >>> step (InsOrdHashMapKeyStep k)) <$> IOHM.lookup k m
src/OpenAPI/Checker/Validate/SecurityScheme.hsnew file+43
@@ -0,0 +1,43 @@
1+{-# OPTIONS_GHC -Wno-orphans #-}
2+
3+module OpenAPI.Checker.Validate.SecurityScheme
4+ (
5+ )
6+where
7+
8+import Control.Monad
9+import Data.OpenApi
10+import OpenAPI.Checker.Behavior
11+import OpenAPI.Checker.Orphans ()
12+import OpenAPI.Checker.Subtree
13+import OpenAPI.Checker.Validate.OAuth2Flows
14+
15+instance Subtree SecurityScheme where
16+ type CheckEnv SecurityScheme = '[]
17+ type SubtreeLevel SecurityScheme = 'SecuritySchemeLevel
18+ checkStructuralCompatibility _ pc = structuralEq $ tracedSecuritySchemaTypes <$> pc
19+ checkSemanticCompatibility env bhv pcSecScheme = case tracedSecuritySchemaTypes <$> pcSecScheme of
20+ (ProdCons (Traced _ (SecuritySchemeHttp pType)) (Traced _ (SecuritySchemeHttp cType))) -> case (pType, cType) of
21+ (HttpSchemeBearer _, HttpSchemeBearer _) -> pure ()
22+ (HttpSchemeBasic, HttpSchemeBasic) -> pure ()
23+ (HttpSchemeCustom p, HttpSchemeCustom c) ->
24+ unless (p == c) (issueAt bhv $ CustomHttpSchemesDontMatch p c)
25+ _ -> issueAt bhv $ HttpSchemeTypesDontMatch pType cType
26+ (ProdCons (Traced _ (SecuritySchemeApiKey pParams)) (Traced _ (SecuritySchemeApiKey cParams))) -> do
27+ unless (pParams == cParams) (issueAt bhv $ ApiKeyParamsDontMatch pParams cParams)
28+ (ProdCons (Traced pT (SecuritySchemeOAuth2 pFlows)) (Traced cT (SecuritySchemeOAuth2 cFlows))) -> do
29+ checkCompatibility env bhv . fmap (stepTraced SecurityOAuthFlowsStep) $ ProdCons (Traced pT pFlows) (Traced cT cFlows)
30+ (ProdCons (Traced _ (SecuritySchemeOpenIdConnect pUrl)) (Traced _ (SecuritySchemeOpenIdConnect cUrl))) -> do
31+ unless (pUrl == cUrl) (issueAt bhv $ OpenIdConnectUrlsDontMatch pUrl cUrl)
32+ _ -> issueAt bhv DifferentSecuritySchemes
33+
34+tracedSecuritySchemaTypes :: Traced SecurityScheme -> Traced SecuritySchemeType
35+tracedSecuritySchemaTypes (Traced t x) = Traced (t >>> step SecuritySchemeTypeStep) (_securitySchemeType x)
36+
37+instance Steppable SecurityScheme SecuritySchemeType where
38+ data Step SecurityScheme SecuritySchemeType = SecuritySchemeTypeStep
39+ deriving (Eq, Ord, Show)
40+
41+instance Steppable SecuritySchemeType OAuth2Flows where
42+ data Step SecuritySchemeType OAuth2Flows = SecurityOAuthFlowsStep
43+ deriving (Eq, Ord, Show)
stack.yaml+1−1
@@ -1 +1 @@
1−resolver: lts-17.11
1+resolver: lts-17.12
stack.yaml.lock+4−4
@@ -6,7 +6,7 @@
6packages: []
6packages: []
7snapshots:
7snapshots:
8- completed:
8- completed:
9− size: 567672
9+ size: 567669
10− url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/17/11.yaml
10+ url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/17/12.yaml
11− sha256: 03181cdbeb671eb605bbcf6f285bea4d094b6ac7433a0e14a9f1dd54ad995938
11+ sha256: facf6cac73b22a83ca955b580a98a7a09ed71f8f974c7a55d28e608c23e689a9
12− original: lts-17.11
12+ original: lts-17.12
test/golden/common/security-scheme/a.yamlnew file+110
@@ -0,0 +1,110 @@
1+openapi: 3.0.0
2+info:
3+ version: ""
4+ title: ""
5+paths:
6+ /oauth/sign_out:
7+ get:
8+ parameters:
9+ - required: false
10+ schema:
11+ type: string
12+ in: query
13+ name: redirect
14+ responses:
15+ "302":
16+ content:
17+ application/x-www-form-urlencoded: {}
18+ headers:
19+ Location:
20+ schema:
21+ type: string
22+ set-cookie:
23+ schema:
24+ type: string
25+ description: ""
26+ "400":
27+ description: Invalid `redirect`
28+ security:
29+ - sign-out-oauth: []
30+ - oauth: []
31+ /oauth/authorize:
32+ get:
33+ responses:
34+ "302":
35+ content:
36+ application/x-www-form-urlencoded: {}
37+ headers:
38+ Location:
39+ schema:
40+ type: string
41+ description: ""
42+ security:
43+ - get-oauth: []
44+ /oauth/token:
45+ post:
46+ requestBody:
47+ content:
48+ application/x-www-form-urlencoded:
49+ schema:
50+ type: string
51+ responses:
52+ "200":
53+ content:
54+ application/json;charset=utf-8:
55+ schema:
56+ type: string
57+ description: ""
58+ "400":
59+ description: Invalid `body`
60+ security:
61+ - oauth: []
62+ /oauth/check:
63+ post:
64+ requestBody:
65+ content:
66+ application/json;charset=utf-8:
67+ schema:
68+ type: string
69+ responses:
70+ "200":
71+ content:
72+ application/json;charset=utf-8:
73+ schema:
74+ example: []
75+ items: {}
76+ maxItems: 0
77+ type: array
78+ description: ""
79+ "400":
80+ description: Invalid `body`
81+ security:
82+ - oauth: []
83+components:
84+ securitySchemes:
85+ sign-out-oauth:
86+ in: cookie
87+ name: _SESSION
88+ type: apiKey
89+ description: Session cookie
90+ get-oauth:
91+ in: cookie
92+ name: _SESSION
93+ type: apiKey
94+ description: Session cookie
95+ oauth:
96+ scheme: Basic
97+ type: http
98+ oauth-token:
99+ scheme: Bearer
100+ type: http
101+ description: Bearer token
102+ oauth-token-client-only:
103+ scheme: Bearer
104+ type: http
105+ description: Bearer token
106+ spa-oauth:
107+ in: cookie
108+ name: _SESSION
109+ type: apiKey
110+ description: Session cookie
test/golden/common/security-scheme/b.yamlnew file+110
@@ -0,0 +1,110 @@
1+openapi: 3.0.0
2+info:
3+ version: ""
4+ title: ""
5+paths:
6+ /oauth/sign_out:
7+ get:
8+ parameters:
9+ - required: false
10+ schema:
11+ type: string
12+ in: query
13+ name: redirect
14+ responses:
15+ "302":
16+ content:
17+ application/x-www-form-urlencoded: {}
18+ headers:
19+ Location:
20+ schema:
21+ type: string
22+ set-cookie:
23+ schema:
24+ type: string
25+ description: ""
26+ "400":
27+ description: Invalid `redirect`
28+ security:
29+ - sign-out-oauth: []
30+ /oauth/authorize:
31+ get:
32+ responses:
33+ "302":
34+ content:
35+ application/x-www-form-urlencoded: {}
36+ headers:
37+ Location:
38+ schema:
39+ type: string
40+ description: ""
41+ security:
42+ - get-oauth: []
43+ - spa-oauth: []
44+ /oauth/token:
45+ post:
46+ requestBody:
47+ content:
48+ application/x-www-form-urlencoded:
49+ schema:
50+ type: string
51+ responses:
52+ "200":
53+ content:
54+ application/json;charset=utf-8:
55+ schema:
56+ type: string
57+ description: ""
58+ "400":
59+ description: Invalid `body`
60+ security:
61+ - oauth: []
62+ /oauth/check:
63+ post:
64+ requestBody:
65+ content:
66+ application/json;charset=utf-8:
67+ schema:
68+ type: string
69+ responses:
70+ "200":
71+ content:
72+ application/json;charset=utf-8:
73+ schema:
74+ example: []
75+ items: {}
76+ maxItems: 0
77+ type: array
78+ description: ""
79+ "400":
80+ description: Invalid `body`
81+ security:
82+ - spa-oauth: []
83+components:
84+ securitySchemes:
85+ sign-out-oauth:
86+ in: cookie
87+ name: _SESSION
88+ type: apiKey
89+ description: Session cookie
90+ get-oauth:
91+ in: cookie
92+ name: _SESSION
93+ type: apiKey
94+ description: Session cookie
95+ oauth:
96+ scheme: Basic
97+ type: http
98+ oauth-token:
99+ scheme: Bearer
100+ type: http
101+ description: Bearer token
102+ oauth-token-client-only:
103+ scheme: Bearer
104+ type: http
105+ description: Bearer token
106+ spa-oauth:
107+ in: cookie
108+ name: _SESSION
109+ type: apiKey
110+ description: Session cookie
test/golden/common/security-scheme/trace-tree.yamlnew file+9
@@ -0,0 +1,9 @@
1+Left:
2+ AtPath (ProdCons {producer = "/oauth/check", consumer = "/oauth/check"}):
3+ InOperation PostMethod:
4+ SecurityRequirementStep 0:
5+ SecuritySchemeStep "oauth": SecuritySchemeNotMatched
6+ AtPath (ProdCons {producer = "/oauth/sign_out", consumer = "/oauth/sign_out"}):
7+ InOperation GetMethod:
8+ SecurityRequirementStep 1:
9+ SecuritySchemeStep "oauth": SecuritySchemeNotMatched