@@ -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)