@@ -1,12 +1,12 @@
1−{-# OPTIONS_GHC -Wno-orphans #-}
21{-# OPTIONS_GHC -Wno-name-shadowing #-}
2+{-# OPTIONS_GHC -Wno-orphans #-}
33
44module OpenAPI.Checker.Validate.Operation
55 ( MatchedOperation (..)
6− , OperationMethod(..)
6+ , OperationMethod (..)
77 , pathItemMethod
8− ) where
9−
8+ )
9+where
1010
1111import Data.Foldable as F
1212import Data.Functor
@@ -15,8 +15,10 @@ import qualified Data.List as L
1515import Data.Map.Strict as M
1616import Data.Maybe
1717import Data.OpenApi
18+import qualified Data.OpenApi.Schema.Generator as G
1819import Data.Text (Text)
1920import OpenAPI.Checker.Behavior
21+import OpenAPI.Checker.Common
2022import OpenAPI.Checker.References
2123import OpenAPI.Checker.Subtree
2224import OpenAPI.Checker.Validate.MediaTypeObject
@@ -28,11 +30,11 @@ import OpenAPI.Checker.Validate.Server ()
2830
2931data MatchedOperation = MatchedOperation
3032 { operation :: !Operation
31− , pathParams :: ![Traced Param]
32− -- ^ Params from the PathItem
33− , getPathFragments :: !([Traced Param] -> [Traced PathFragmentParam])
34− -- ^ Path fragments traced from PathItem. Takes full list of
35− -- operation-specific parameters
33+ , -- | Params from the PathItem
34+ pathParams :: ![Traced Param]
35+ , -- | Path fragments traced from PathItem. Takes full list of
36+ -- operation-specific parameters
37+ getPathFragments :: !([Traced Param] -> [Traced PathFragmentParam])
3638 }
3739
3840type ParamKey = (ParamLocation, Text)
@@ -43,32 +45,32 @@ paramKey param = (_paramIn param, _paramName param)
4345tracedParameters :: Traced MatchedOperation -> [Traced (Referenced Param)]
4446tracedParameters oper =
4547 [ traced (ask oper >>> step (OperationParamsStep i)) x
46− | (i, x) <- zip [0..] $ _operationParameters . operation $ extract oper
48+ | (i, x) <- zip [0 ..] $ _operationParameters . operation $ extract oper
4749 ]
4850
4951tracedRequestBody :: Traced MatchedOperation -> Maybe (Traced (Referenced RequestBody))
5052tracedRequestBody oper = _operationRequestBody (operation $ extract oper) <&> traced (ask oper >>> step OperationRequestBodyStep)
5153
5254tracedResponses :: Traced MatchedOperation -> Traced Responses
53−tracedResponses oper = traced (ask oper >>> step OperationResponsesStep)
54− $ _operationResponses . operation $ extract oper
55+tracedResponses oper =
56+ traced (ask oper >>> step OperationResponsesStep) $
57+ _operationResponses . operation $ extract oper
5558
5659tracedSecurity :: Traced MatchedOperation -> [Traced SecurityRequirement]
5760tracedSecurity oper =
5861 [ traced (ask oper >>> step (OperationSecurityRequirementStep i)) x
59− | (i, x) <- zip [0..] $ _operationSecurity . operation $ extract oper
62+ | (i, x) <- zip [0 ..] $ _operationSecurity . operation $ extract oper
6063 ]
6164
6265-- FIXME: https://github.com/typeable/openapi-diff/issues/28
63−tracedServers
66+getServers
6467 :: [Server] -- ^ Servers from env
65− -> Traced MatchedOperation
66− -> Traced [Server]
67−tracedServers env oper =
68− traced (ask oper >>> step OperationServersStep) $
69− case _operationServers . operation $ extract oper of
70− [] -> env
71− ss -> ss
68+ -> MatchedOperation
69+ -> [Server]
70+getServers env oper =
71+ case _operationServers . operation $ oper of
72+ [] -> env
73+ ss -> ss
7274
7375instance Behavable 'OperationLevel 'PathFragmentLevel where
7476 data Behave 'OperationLevel 'PathFragmentLevel
@@ -83,16 +85,42 @@ instance Behavable 'OperationLevel 'RequestLevel where
8385
8486instance Subtree MatchedOperation where
8587 type SubtreeLevel MatchedOperation = 'OperationLevel
86− type CheckEnv MatchedOperation =
87− '[ ProdCons (Traced (Definitions Param))
88− , ProdCons (Traced (Definitions RequestBody))
89− , ProdCons (Traced (Definitions SecurityScheme))
90− , ProdCons (Traced (Definitions Response))
91− , ProdCons (Traced (Definitions Header))
92− , ProdCons (Traced (Definitions Schema))
93− , ProdCons [Server]
94− ]
95− checkCompatibility env beh prodCons = do
88+ type
89+ CheckEnv MatchedOperation =
90+ '[ ProdCons (Traced (Definitions Param))
91+ , ProdCons (Traced (Definitions RequestBody))
92+ , ProdCons (Traced (Definitions SecurityScheme))
93+ , ProdCons (Traced (Definitions Response))
94+ , ProdCons (Traced (Definitions Header))
95+ , ProdCons (Traced (Definitions Schema))
96+ , ProdCons [Server]
97+ , ProdCons (Traced (Definitions Link))
98+ ]
99+ checkStructuralCompatibility env pc = do
100+ let pParams :: ProdCons [Param]
101+ pParams = do
102+ defs <- extract <$> getH @(ProdCons (Traced (Definitions Param))) env
103+ op' <- _operationParameters . operation <$> pc
104+ pp <- fmap extract . pathParams <$> pc
105+ pure $
106+ let o = M.fromList $ do
107+ param <- G.dereference defs <$> op'
108+ let key = paramKey param
109+ pure (key, param)
110+ p = M.fromList $ do
111+ param <- pp
112+ pure (paramKey param, param)
113+ in M.elems $ o <> p
114+ case zipAll (producer pParams) (consumer pParams) of
115+ Nothing -> structuralIssue
116+ Just xs -> for_ xs $ \(p, c) -> checkStructuralCompatibility env $ ProdCons p c
117+ structuralMaybe env $ _operationRequestBody . operation <$> pc
118+ checkStructuralCompatibility env $ _operationResponses . operation <$> pc
119+ checkStructuralCompatibility env $ getServers <$> getH env <*> pc
120+ -- TODO: Callbacks
121+ -- TODO: Security
122+ pure ()
123+ checkSemanticCompatibility env beh prodCons = do
96124 checkParameters
97125 checkRequestBodies
98126 checkResponses
@@ -102,97 +130,103 @@ instance Subtree MatchedOperation where
102130 pure ()
103131 where
104132 checkParameters = do
105− let
106− -- Merged parameters got from Operation and PathItem in one
107− -- place. First element is path params, second is non-path params
108− tracedParams :: ProdCons ([Traced Param], [Traced Param])
109− tracedParams = getParams <$> paramDefs <*> prodCons
110− getParams defs mp =
111− let
112− operationParamsMap :: Map ParamKey (Traced Param)
113− operationParamsMap = M.fromList $ do
114− paramRef <- tracedParameters mp
115− let
116− param = dereference defs paramRef
117− key = paramKey . extract $ param
118− pure (key, param)
119− pathParamsMap :: Map ParamKey (Traced Param)
120− pathParamsMap = M.fromList $ do
121− param <- pathParams . extract $ mp
122− pure (paramKey . extract $ param, param)
123− params = M.elems $ M.union operationParamsMap pathParamsMap -- We prefer params from Operation
124− splitted = L.partition
125− (\p -> (_paramIn . extract $ p) == ParamPath) params
126− in splitted
133+ let -- Merged parameters got from Operation and PathItem in one
134+ -- place. First element is path params, second is non-path params
135+ tracedParams :: ProdCons ([Traced Param], [Traced Param])
136+ tracedParams = getParams <$> paramDefs <*> prodCons
137+ getParams defs mp =
138+ let operationParamsMap :: Map ParamKey (Traced Param)
139+ operationParamsMap = M.fromList $ do
140+ paramRef <- tracedParameters mp
141+ let param = dereference defs paramRef
142+ key = paramKey . extract $ param
143+ pure (key, param)
144+ pathParamsMap :: Map ParamKey (Traced Param)
145+ pathParamsMap = M.fromList $ do
146+ param <- pathParams . extract $ mp
147+ pure (paramKey . extract $ param, param)
148+ params = M.elems $ M.union operationParamsMap pathParamsMap -- We prefer params from Operation
149+ splitted =
150+ L.partition
151+ (\p -> (_paramIn . extract $ p) == ParamPath)
152+ params
153+ in splitted
127154 checkNonPathParams $ snd <$> tracedParams
128155 checkPathParams $ fst <$> tracedParams
129156 pure ()
130− checkNonPathParams :: ProdCons [Traced Param] -> CompatFormula ()
157+ checkNonPathParams :: ProdCons [Traced Param] -> SemanticCompatFormula ()
131158 checkNonPathParams params = do
132− let
133− elements = getEls <$> params
134− getEls params = M.fromList $ do
135− p <- params
136− let
137− k = (_paramIn . extract $ p, _paramName . extract $ p)
138− v = ProductLike
139− { productValue = p
140− , required = fromMaybe False . _paramRequired . extract $ p
141− }
142− pure (k, v)
143− check (_, name) param = do
144− checkCompatibility @Param (singletonH schemaDefs) (beh >>> step (InParam name)) param
159+ let elements = getEls <$> params
160+ getEls params = M.fromList $ do
161+ p <- params
162+ let k = (_paramIn . extract $ p, _paramName . extract $ p)
163+ v =
164+ ProductLike
165+ { productValue = p
166+ , required = fromMaybe False . _paramRequired . extract $ p
167+ }
168+ pure (k, v)
169+ check (_, name) param = do
170+ checkCompatibility @Param (singletonH schemaDefs) (beh >>> step (InParam name)) param
145171 checkProducts beh (ParamNotMatched . snd) check elements
146− checkPathParams :: ProdCons [Traced Param] -> CompatFormula ()
172+ checkPathParams :: ProdCons [Traced Param] -> SemanticCompatFormula ()
147173 checkPathParams pathParams = do
148− let
149− fragments :: ProdCons [Traced PathFragmentParam]
150− fragments = getFragments <$> pathParams <*> prodCons
151− getFragments params mop = getPathFragments (extract mop) params
152− -- Feed path parameters to the fragments getter
153− check idx frags = checkCompatibility @PathFragmentParam env (beh >>> step (InFragment idx)) frags
154− elements = fragments <&> \frags -> M.fromList $ zip [0 :: Int ..] $ do
155− frag <- frags
156− pure $ ProductLike
157− { productValue = frag
158− , required = True }
174+ let fragments :: ProdCons [Traced PathFragmentParam]
175+ fragments = getFragments <$> pathParams <*> prodCons
176+ getFragments params mop = getPathFragments (extract mop) params
177+ -- Feed path parameters to the fragments getter
178+ check idx frags = checkCompatibility @PathFragmentParam env (beh >>> step (InFragment idx)) frags
179+ elements =
180+ fragments <&> \frags -> M.fromList $
181+ zip [0 :: Int ..] $ do
182+ frag <- frags
183+ pure $
184+ ProductLike
185+ { productValue = frag
186+ , required = True
187+ }
159188 checkProducts beh PathFragmentNotMatched check elements
160189 checkRequestBodies = do
161− let
162− check reqBody = checkCompatibility @RequestBody env (beh >>> step InRequest) reqBody
163− elements = getReqBody <$> bodyDefs <*> prodCons
164− getReqBody bodyDef mop = M.fromList $ do
165− bodyRef <- F.toList . tracedRequestBody $ mop
166− let
167− body = dereference bodyDef bodyRef
168− -- Single element map
169− pure ((), ProductLike
170− { productValue = body
171− , required = fromMaybe False . _requestBodyRequired . extract $ body
172− })
190+ let check reqBody = checkCompatibility @RequestBody env (beh >>> step InRequest) reqBody
191+ elements = getReqBody <$> bodyDefs <*> prodCons
192+ getReqBody bodyDef mop = M.fromList $ do
193+ bodyRef <- F.toList . tracedRequestBody $ mop
194+ let body = dereference bodyDef bodyRef
195+ -- Single element map
196+ pure
197+ ( ()
198+ , ProductLike
199+ { productValue = body
200+ , required = fromMaybe False . _requestBodyRequired . extract $ body
201+ }
202+ )
173203 checkProducts beh (const NoRequestBody) (const check) elements
174204 checkResponses = do
175− let
176− respEnv = HCons (swapProdCons respDefs)
177− $ HCons (swapProdCons headerDefs)
178− $ HCons (swapProdCons schemaDefs) HNil
179− resps = tracedResponses <$> prodCons
205+ let respEnv =
206+ HCons (swapProdCons respDefs) $
207+ HCons (swapProdCons headerDefs) $
208+ HCons (swapProdCons schemaDefs) $
209+ HCons (swapProdCons linkDefs) HNil
210+ resps = tracedResponses <$> prodCons
180211 checkCompatibility respEnv beh $ swapProdCons resps
181212 -- FIXME: https://github.com/typeable/openapi-diff/issues/27
182213 checkCallbacks = pure () -- (error "FIXME: not implemented")
183214 -- FIXME: https://github.com/typeable/openapi-diff/issues/28
184215 checkOperationSecurity = pure () -- (error "FIXME: not implemented")
185216 checkServers =
186− checkCompatibility env beh $
187− tracedServers <$> getH @(ProdCons [Server]) env <*> prodCons
217+ checkCompatibility env beh $ do
218+ x <- prodCons
219+ se <- getH @(ProdCons [Server]) env
220+ pure $ Traced (ask x >>> step OperationServersStep) (getServers se (extract x))
188221 bodyDefs = getH @(ProdCons (Traced (Definitions RequestBody))) env
189222 respDefs = getH @(ProdCons (Traced (Definitions Response))) env
190− headerDefs = getH @(ProdCons (Traced (Definitions Header))) env
223+ headerDefs = getH @(ProdCons (Traced (Definitions Header))) env
191224 schemaDefs = getH @(ProdCons (Traced (Definitions Schema))) env
192225 paramDefs = getH @(ProdCons (Traced (Definitions Param))) env
226+ linkDefs = getH @(ProdCons (Traced (Definitions Link))) env
193227
194−data OperationMethod =
195− GetMethod
228+data OperationMethod
229+ = GetMethod
196230 | PutMethod
197231 | PostMethod
198232 | DeleteMethod