git.iko.soy/compaREST
on master help sign in
Structural compatibility (#49)
cbfeeediko
openapi-diff.cabal+5
compare with master
unifiedsplit
@@ -53,6 +53,7 @@ common common-options
53 , unordered-containers
53 , unordered-containers
54 , vector
54 , vector
55 , yaml
55 , yaml
56+ , hashable
56
57
57 default-extensions: ApplicativeDo
58 default-extensions: ApplicativeDo
58 , BangPatterns
59 , BangPatterns
@@ -93,6 +94,7 @@ common common-options
93 , UndecidableInstances
94 , UndecidableInstances
94 , ViewPatterns
95 , ViewPatterns
95 , QuantifiedConstraints
96 , QuantifiedConstraints
97+ , DefaultSignatures
96
98
97library
99library
98 import: common-options
100 import: common-options
@@ -121,6 +123,9 @@ library
121 , OpenAPI.Checker.Validate.SecurityRequirement
123 , OpenAPI.Checker.Validate.SecurityRequirement
122 , OpenAPI.Checker.Validate.Server
124 , OpenAPI.Checker.Validate.Server
123 , OpenAPI.Checker.Validate.Sums
125 , OpenAPI.Checker.Validate.Sums
126+ , OpenAPI.Checker.Validate.Header
127+ , OpenAPI.Checker.Validate.Link
128+ , OpenAPI.Checker.Common
124
129
125executable openapi-diff
130executable openapi-diff
126 import: common-options
131 import: common-options
src/Data/HList.hs+6
@@ -43,3 +43,9 @@ instance
43
43
44singletonH :: a -> HList '[a]
44singletonH :: a -> HList '[a]
45singletonH a = a `HCons` HNil
45singletonH a = a `HCons` HNil
46+
47+instance Eq (HList '[]) where
48+ HNil == HNil = True
49+
50+instance (Eq x, Eq (HList xs)) => Eq (HList (x ': xs)) where
51+ (HCons x xs) == (HCons y ys) = x == y && xs == ys
src/OpenAPI/Checker/Behavior.hs+1
@@ -26,6 +26,7 @@ data BehaviorLevel
26 PayloadLevel
26 PayloadLevel
27 | SchemaLevel
27 | SchemaLevel
28 | TypedSchemaLevel
28 | TypedSchemaLevel
29+ | LinkLevel
29
30
30class (Ord (Behave a b), Show (Behave a b))
31class (Ord (Behave a b), Show (Behave a b))
31 => Behavable (a :: BehaviorLevel) (b :: BehaviorLevel) where
32 => Behavable (a :: BehaviorLevel) (b :: BehaviorLevel) where
src/OpenAPI/Checker/Common.hsnew file+10
@@ -0,0 +1,10 @@
1+module OpenAPI.Checker.Common
2+ ( zipAll
3+ )
4+where
5+
6+zipAll :: [a] -> [b] -> Maybe [(a, b)]
7+zipAll [] [] = Just []
8+zipAll (x : xs) (y : ys) = ((x, y) :) <$> zipAll xs ys
9+zipAll (_ : _) [] = Nothing
10+zipAll [] (_ : _) = Nothing
src/OpenAPI/Checker/References.hs+25−4
@@ -1,13 +1,16 @@
1{-# OPTIONS_GHC -Wno-orphans #-}
1{-# OPTIONS_GHC -Wno-orphans #-}
2+
2module OpenAPI.Checker.References
3module OpenAPI.Checker.References
3 ( Step (..)
4 ( Step (..)
4 , dereference
5 , dereference
5 )
6 )
6where
7where
7
8
9+import Data.HList
8import qualified Data.HashMap.Strict.InsOrd as IOHM
10import qualified Data.HashMap.Strict.InsOrd as IOHM
9import Data.Maybe
11import Data.Maybe
10import Data.OpenApi
12import Data.OpenApi
13+import qualified Data.OpenApi.Schema.Generator as G
11import Data.Typeable
14import Data.Typeable
12import OpenAPI.Checker.Orphans ()
15import OpenAPI.Checker.Orphans ()
13import OpenAPI.Checker.Subtree
16import OpenAPI.Checker.Subtree
@@ -26,7 +29,25 @@ dereference
26 -> Traced (Referenced a)
29 -> Traced (Referenced a)
27 -> Traced a
30 -> Traced a
28dereference defs x = case extract x of
31dereference defs x = case extract x of
29− Inline a
32+ Inline a ->
30− -> traced (ask x >>> step InlineStep) a
33+ traced (ask x >>> step InlineStep) a
31− Ref r@(Reference ref)
34+ Ref r@(Reference ref) ->
32− -> traced (ask defs >>> step (ReferencedStep r)) (fromJust $ IOHM.lookup ref $ extract defs)
35+ traced (ask defs >>> step (ReferencedStep r)) (fromJust $ IOHM.lookup ref $ extract defs)
36+
37+instance Subtree a => Subtree (Referenced a) where
38+ type CheckEnv (Referenced a) = ProdCons (Traced (Definitions a)) ': CheckEnv a
39+ type SubtreeLevel (Referenced a) = SubtreeLevel a
40+
41+ checkStructuralCompatibility env pc' = do
42+ let pc = do
43+ x <- pc'
44+ defs <- extract <$> getH @(ProdCons (Traced (Definitions a))) env
45+ pure (G.dereference defs x)
46+ checkStructuralCompatibility env pc
47+
48+ checkSemanticCompatibility env bhv pc' = do
49+ let pc = do
50+ x <- pc'
51+ defs <- getH @(ProdCons (Traced (Definitions a))) env
52+ pure (dereference defs x)
53+ checkCompatibility env bhv pc
src/OpenAPI/Checker/Subtree.hs+103−5
@@ -1,3 +1,5 @@
1+{-# OPTIONS_GHC -Wno-orphans #-}
2+
1module OpenAPI.Checker.Subtree
3module OpenAPI.Checker.Subtree
2 ( Steppable (..)
4 ( Steppable (..)
3 , Trace
5 , Trace
@@ -6,17 +8,27 @@ module OpenAPI.Checker.Subtree
6 , pattern Traced
8 , pattern Traced
7 , traced
9 , traced
8 , Subtree (..)
10 , Subtree (..)
11+ , checkCompatibility
9 , CompatM (..)
12 , CompatM (..)
10 , CompatFormula'
13 , CompatFormula'
11− , CompatFormula
14+ , SemanticCompatFormula
12 , ProdCons (..)
15 , ProdCons (..)
13 , HasUnsupportedFeature (..)
16 , HasUnsupportedFeature (..)
14 , swapProdCons
17 , swapProdCons
15 , runCompatFormula
18 , runCompatFormula
16 , issueAt
19 , issueAt
17 , anyOfAt
20 , anyOfAt
21+ , structuralIssue
18 , memo
22 , memo
19
23
24+ -- * Structural helpers
25+ , structuralMaybe
26+ , structuralMaybeWith
27+ , structuralEq
28+ , iohmStructural
29+ , iohmStructuralWith
30+ , structuralList
31+
20 -- * Reexports
32 -- * Reexports
21 , (>>>)
33 , (>>>)
22 , (<<<)
34 , (<<<)
@@ -30,11 +42,15 @@ where
30import Control.Comonad.Env
42import Control.Comonad.Env
31import Control.Monad.Identity
43import Control.Monad.Identity
32import Control.Monad.State
44import Control.Monad.State
45+import Data.Foldable
33import Data.Functor.Compose
46import Data.Functor.Compose
34import Data.HList
47import Data.HList
48+import qualified Data.HashMap.Strict.InsOrd as IOHM
49+import Data.Hashable
35import Data.Kind
50import Data.Kind
36import Data.Monoid
51import Data.Monoid
37import Data.OpenApi
52import Data.OpenApi
53+import qualified Data.Set as S
38import Data.Typeable
54import Data.Typeable
39import OpenAPI.Checker.Behavior
55import OpenAPI.Checker.Behavior
40import OpenAPI.Checker.Formula
56import OpenAPI.Checker.Formula
@@ -89,18 +105,97 @@ newtype CompatM a = CompatM
89
105
90type CompatFormula' q f r = Compose CompatM (FormulaF q f r)
106type CompatFormula' q f r = Compose CompatM (FormulaF q f r)
91
107
92−type CompatFormula = CompatFormula' Behave AnIssue 'APILevel
108+type SemanticCompatFormula = CompatFormula' Behave AnIssue 'APILevel
109+
110+type StructuralCompatFormula = CompatFormula' UnitQuiver Proxy ()
111+
112+data UnitQuiver a b where
113+ UnitQuiver :: UnitQuiver () ()
114+
115+deriving stock instance Eq (UnitQuiver a b)
116+
117+deriving stock instance Ord (UnitQuiver a b)
118+
119+deriving stock instance Show (UnitQuiver a b)
93
120
94class (Typeable t, Issuable (SubtreeLevel t)) => Subtree (t :: Type) where
121class (Typeable t, Issuable (SubtreeLevel t)) => Subtree (t :: Type) where
95 type CheckEnv t :: [Type]
122 type CheckEnv t :: [Type]
96 type SubtreeLevel t :: BehaviorLevel
123 type SubtreeLevel t :: BehaviorLevel
97
124
98− checkCompatibility
125+ checkStructuralCompatibility
99− :: HasAll (CheckEnv t) xs
126+ :: (HasAll (CheckEnv t) xs)
127+ => HList xs
128+ -> ProdCons t
129+ -> StructuralCompatFormula ()
130+
131+ checkSemanticCompatibility
132+ :: (HasAll (CheckEnv t) xs)
100 => HList xs
133 => HList xs
101 -> Behavior (SubtreeLevel t)
134 -> Behavior (SubtreeLevel t)
102 -> ProdCons (Traced t)
135 -> ProdCons (Traced t)
103− -> CompatFormula ()
136+ -> SemanticCompatFormula ()
137+
138+checkCompatibility
139+ :: (HasAll (CheckEnv t) xs, Subtree t)
140+ => HList xs
141+ -> Behavior (SubtreeLevel t)
142+ -> ProdCons (Traced t)
143+ -> SemanticCompatFormula ()
144+checkCompatibility e bhv pc =
145+ case runCompatFormula $ checkStructuralCompatibility e $ fmap extract pc of
146+ Left _ -> checkSemanticCompatibility e bhv pc
147+ Right () -> pure ()
148+
149+structuralMaybe
150+ :: (Subtree a, HasAll (CheckEnv a) xs)
151+ => HList xs
152+ -> ProdCons (Maybe a)
153+ -> StructuralCompatFormula ()
154+structuralMaybe e = structuralMaybeWith (checkStructuralCompatibility e)
155+
156+structuralMaybeWith
157+ :: (ProdCons a -> StructuralCompatFormula ())
158+ -> ProdCons (Maybe a)
159+ -> StructuralCompatFormula ()
160+structuralMaybeWith f (ProdCons (Just a) (Just b)) = f $ ProdCons a b
161+structuralMaybeWith _ (ProdCons Nothing Nothing) = pure ()
162+structuralMaybeWith _ _ = structuralIssue
163+
164+structuralList
165+ :: (Subtree a, HasAll (CheckEnv a) xs)
166+ => HList xs -> ProdCons [a] -> StructuralCompatFormula ()
167+structuralList _ (ProdCons [] []) = pure ()
168+structuralList e (ProdCons (a:aa) (b:bb)) = do
169+ checkStructuralCompatibility e $ ProdCons a b
170+ structuralList e $ ProdCons aa bb
171+ pure ()
172+structuralList _ _ = structuralIssue
173+
174+structuralEq :: Eq a => ProdCons a -> StructuralCompatFormula ()
175+structuralEq (ProdCons a b) = if a == b then pure () else structuralIssue
176+
177+iohmStructural
178+ :: (HasAll (CheckEnv v) (k ': xs), Ord k, Subtree v, Hashable k)
179+ => HList xs
180+ -> ProdCons (IOHM.InsOrdHashMap k v)
181+ -> StructuralCompatFormula ()
182+iohmStructural e =
183+ iohmStructuralWith (\k -> checkStructuralCompatibility (k `HCons` e))
184+
185+iohmStructuralWith
186+ :: (Ord k, Hashable k)
187+ => (k -> ProdCons v -> StructuralCompatFormula ())
188+ -> ProdCons (IOHM.InsOrdHashMap k v)
189+ -> StructuralCompatFormula ()
190+iohmStructuralWith f pc = do
191+ let ProdCons pEKeys cEKeys = S.fromList . IOHM.keys <$> pc
192+ if pEKeys == cEKeys
193+ then
194+ for_
195+ pEKeys
196+ (\eKey ->
197+ f eKey $ IOHM.lookupDefault (error "impossible") eKey <$> pc)
198+ else structuralIssue
104
199
105class HasUnsupportedFeature x where
200class HasUnsupportedFeature x where
106 hasUnsupportedFeature :: x -> Bool
201 hasUnsupportedFeature :: x -> Bool
@@ -137,6 +232,9 @@ runCompatFormula (Compose f) =
137issueAt :: Issuable l => Paths q r l -> Issue l -> CompatFormula' q AnIssue r a
232issueAt :: Issuable l => Paths q r l -> Issue l -> CompatFormula' q AnIssue r a
138issueAt xs issue = Compose $ pure $ anError $ AnItem xs $ AnIssue issue
233issueAt xs issue = Compose $ pure $ anError $ AnItem xs $ AnIssue issue
139
234
235+structuralIssue :: StructuralCompatFormula a
236+structuralIssue = Compose $ pure $ anError $ AnItem (step UnitQuiver) Proxy
237+
140anyOfAt
238anyOfAt
141 :: Issuable l
239 :: Issuable l
142 => Paths q r l
240 => Paths q r l
src/OpenAPI/Checker/Validate/Header.hsnew file+57
@@ -0,0 +1,57 @@
1+{-# OPTIONS_GHC -Wno-orphans #-}
2+
3+module OpenAPI.Checker.Validate.Header
4+ (
5+ )
6+where
7+
8+import Data.Foldable
9+import Data.Functor
10+import Data.Maybe
11+import Data.OpenApi
12+import OpenAPI.Checker.Behavior
13+import OpenAPI.Checker.References ()
14+import OpenAPI.Checker.Subtree
15+import OpenAPI.Checker.Validate.Schema ()
16+
17+instance Subtree Header where
18+ type SubtreeLevel Header = 'HeaderLevel
19+ type CheckEnv Header = '[ProdCons (Traced (Definitions Schema))]
20+ checkStructuralCompatibility env pc = do
21+ structuralEq $ _headerRequired <$> pc
22+ structuralEq $ _headerAllowEmptyValue <$> pc
23+ structuralEq $ _headerExplode <$> pc
24+ structuralMaybe env $ _headerSchema <$> pc
25+ pure ()
26+ checkSemanticCompatibility env beh (ProdCons p c) = do
27+ if (fromMaybe False $ _headerRequired $ extract c) && not (fromMaybe False $ _headerRequired $ extract p)
28+ then issueAt beh RequiredHeaderMissing
29+ else pure ()
30+ if not (fromMaybe False $ _headerAllowEmptyValue $ extract c) && (fromMaybe False $ _headerAllowEmptyValue $ extract p)
31+ then issueAt beh NonEmptyHeaderRequired
32+ else pure ()
33+ for_ (tracedSchema c) $ \consRef ->
34+ case tracedSchema p of
35+ Nothing -> issueAt beh HeaderSchemaRequired
36+ Just prodRef -> checkCompatibility env (beh >>> step InSchema) (ProdCons prodRef consRef)
37+ pure ()
38+
39+instance Steppable Header (Referenced Schema) where
40+ data Step Header (Referenced Schema) = HeaderSchema
41+ deriving stock (Eq, Ord, Show)
42+
43+tracedSchema :: Traced Header -> Maybe (Traced (Referenced Schema))
44+tracedSchema hdr = _headerSchema (extract hdr) <&> traced (ask hdr >>> step HeaderSchema)
45+
46+instance Issuable 'HeaderLevel where
47+ data Issue 'HeaderLevel
48+ = RequiredHeaderMissing
49+ | NonEmptyHeaderRequired
50+ | HeaderSchemaRequired
51+ deriving stock (Eq, Ord, Show)
52+ issueIsUnsupported _ = False
53+
54+instance Behavable 'HeaderLevel 'SchemaLevel where
55+ data Behave 'HeaderLevel 'SchemaLevel
56+ = InSchema
57+ deriving stock (Eq, Ord, Show)
src/OpenAPI/Checker/Validate/Link.hsnew file+20
@@ -0,0 +1,20 @@
1+{-# OPTIONS_GHC -Wno-orphans #-}
2+
3+module OpenAPI.Checker.Validate.Link () where
4+
5+import Data.OpenApi
6+import OpenAPI.Checker.Behavior
7+import OpenAPI.Checker.Subtree
8+
9+instance Subtree Link where
10+ type SubtreeLevel Link = 'LinkLevel
11+ type CheckEnv Link = '[]
12+ checkStructuralCompatibility _ _ = structuralIssue
13+ checkSemanticCompatibility _ bhv _ = issueAt bhv LinksUnsupported
14+
15+instance Issuable 'LinkLevel where
16+ data Issue 'LinkLevel
17+ = LinksUnsupported
18+ deriving (Eq, Ord, Show)
19+ issueIsUnsupported = \case
20+ LinksUnsupported -> True
src/OpenAPI/Checker/Validate/MediaTypeObject.hs+27−6
@@ -17,6 +17,8 @@ import OpenAPI.Checker.Behavior
17import OpenAPI.Checker.Subtree
17import OpenAPI.Checker.Subtree
18import OpenAPI.Checker.Validate.Products
18import OpenAPI.Checker.Validate.Products
19import OpenAPI.Checker.Validate.Schema ()
19import OpenAPI.Checker.Validate.Schema ()
20+import OpenAPI.Checker.Validate.Header ()
21+
20
22
21tracedSchema :: Traced MediaTypeObject -> Maybe (Traced (Referenced Schema))
23tracedSchema :: Traced MediaTypeObject -> Maybe (Traced (Referenced Schema))
22tracedSchema mto = _mediaTypeObjectSchema (extract mto) <&> traced (ask mto >>> step MediaTypeSchema)
24tracedSchema mto = _mediaTypeObjectSchema (extract mto) <&> traced (ask mto >>> step MediaTypeSchema)
@@ -47,8 +49,14 @@ instance Subtree MediaTypeObject where
47 type CheckEnv MediaTypeObject =
49 type CheckEnv MediaTypeObject =
48 '[ MediaType
50 '[ MediaType
49 , ProdCons (Traced (Definitions Schema))
51 , ProdCons (Traced (Definitions Schema))
52+ , ProdCons (Traced (Definitions Header))
50 ]
53 ]
54+ checkStructuralCompatibility env pc = do
55+ structuralMaybe env $ _mediaTypeObjectSchema <$> pc
56+ structuralEq $ _mediaTypeObjectExample <$> pc
57+ iohmStructural env $ _mediaTypeObjectEncoding <$> pc
58+ pure ()
51− checkCompatibility env beh prodCons@(ProdCons p c) = do
59+ checkSemanticCompatibility env beh prodCons@(ProdCons p c) = do
52 if | "multipart" == mainType mediaType -> checkEncoding
60 if | "multipart" == mainType mediaType -> checkEncoding
53 | "application" == mainType mediaType &&
61 | "application" == mainType mediaType &&
54 "x-www-form-urlencoded" == subType mediaType -> checkEncoding
62 "x-www-form-urlencoded" == subType mediaType -> checkEncoding
@@ -74,14 +82,27 @@ instance Subtree MediaTypeObject where
74 , required = True } )
82 , required = True } )
75 encProdCons = getEncoding <$> prodCons
83 encProdCons = getEncoding <$> prodCons
76 in checkProducts beh MediaEncodingMissing
84 in checkProducts beh MediaEncodingMissing
77− (const $ checkCompatibility HNil beh) encProdCons
85+ (const $ checkCompatibility env beh) encProdCons
78
86
79instance Subtree Encoding where
87instance Subtree Encoding where
80 type SubtreeLevel Encoding = 'PayloadLevel
88 type SubtreeLevel Encoding = 'PayloadLevel
89+ type
81− type CheckEnv Encoding = '[]
90+ CheckEnv Encoding =
91+ '[ ProdCons (Traced (Definitions Header))
92+ , ProdCons (Traced (Definitions Schema))
93+ ]
94+ checkStructuralCompatibility env pc = do
95+ structuralEq $ _encodingContentType <$> pc
96+ iohmStructural env $ _encodingHeaders <$> pc
97+ structuralEq $ _encodingStyle <$> pc
98+ structuralEq $ _encodingExplode <$> pc
99+ structuralEq $ _encodingAllowReserved <$> pc
100+ pure ()
101+
82− -- FIXME: Support only JSON body for now. Then Encoding is checked only for
102+ -- FIXME: Support only JSON body for now. Then Encoding is checked only for
83− -- multipart/form-url-encoded
103+ -- multipart/form-url-encoded
84− checkCompatibility _env beh _pc =
104+ -- https://github.com/typeable/openapi-diff/issues/54
105+ checkSemanticCompatibility _env beh _pc =
85 issueAt beh EncodingNotSupported
106 issueAt beh EncodingNotSupported
86
107
87instance Steppable MediaTypeObject (Referenced Schema) where
108instance Steppable MediaTypeObject (Referenced Schema) where
src/OpenAPI/Checker/Validate/OpenApi.hs+12−1
@@ -43,10 +43,16 @@ tracedSchemas :: Traced OpenApi -> Traced (Definitions Schema)
43tracedSchemas oa = traced (ask oa >>> step ComponentsSchema)
43tracedSchemas oa = traced (ask oa >>> step ComponentsSchema)
44 (_componentsSchemas . _openApiComponents . extract $ oa)
44 (_componentsSchemas . _openApiComponents . extract $ oa)
45
45
46+tracedLinks :: Traced OpenApi -> Traced (Definitions Link)
47+tracedLinks oa = traced (ask oa >>> step ComponentsLink)
48+ (_componentsLinks . _openApiComponents . extract $ oa)
49+
46instance Subtree OpenApi where
50instance Subtree OpenApi where
47 type SubtreeLevel OpenApi = 'APILevel
51 type SubtreeLevel OpenApi = 'APILevel
48 type CheckEnv OpenApi = '[]
52 type CheckEnv OpenApi = '[]
49− checkCompatibility _ beh prodCons = do
53+ -- There is no real reason to do a proper implementation
54+ checkStructuralCompatibility _ _ = structuralIssue
55+ checkSemanticCompatibility _ beh prodCons = do
50 checkCompatibility @ProcessedPathItems
56 checkCompatibility @ProcessedPathItems
51 ((tracedRequestBodies <$> prodCons)
57 ((tracedRequestBodies <$> prodCons)
52 `HCons` (tracedParameters <$> prodCons)
58 `HCons` (tracedParameters <$> prodCons)
@@ -55,6 +61,7 @@ instance Subtree OpenApi where
55 `HCons` (tracedHeaders <$> prodCons)
61 `HCons` (tracedHeaders <$> prodCons)
56 `HCons` (tracedSchemas <$> prodCons)
62 `HCons` (tracedSchemas <$> prodCons)
57 `HCons` (_openApiServers . extract <$> prodCons)
63 `HCons` (_openApiServers . extract <$> prodCons)
64+ `HCons` (tracedLinks <$> prodCons)
58 `HCons` HNil)
65 `HCons` HNil)
59 beh (tracedPaths <$> prodCons)
66 beh (tracedPaths <$> prodCons)
60
67
@@ -85,3 +92,7 @@ instance Steppable OpenApi (Definitions Header) where
85instance Steppable OpenApi (Definitions Schema) where
92instance Steppable OpenApi (Definitions Schema) where
86 data Step OpenApi (Definitions Schema) = ComponentsSchema
93 data Step OpenApi (Definitions Schema) = ComponentsSchema
87 deriving (Eq, Ord, Show)
94 deriving (Eq, Ord, Show)
95+
96+instance Steppable OpenApi (Definitions Link) where
97+ data Step OpenApi (Definitions Link) = ComponentsLink
98+ deriving (Eq, Ord, Show)
src/OpenAPI/Checker/Validate/Operation.hs+135−101
@@ -1,12 +1,12 @@
1−{-# OPTIONS_GHC -Wno-orphans #-}
2{-# OPTIONS_GHC -Wno-name-shadowing #-}
1{-# OPTIONS_GHC -Wno-name-shadowing #-}
2+{-# OPTIONS_GHC -Wno-orphans #-}
3
3
4module OpenAPI.Checker.Validate.Operation
4module OpenAPI.Checker.Validate.Operation
5 ( MatchedOperation (..)
5 ( MatchedOperation (..)
6− , OperationMethod(..)
6+ , OperationMethod (..)
7 , pathItemMethod
7 , pathItemMethod
8− ) where
8+ )
9−
9+where
10
10
11import Data.Foldable as F
11import Data.Foldable as F
12import Data.Functor
12import Data.Functor
@@ -15,8 +15,10 @@ import qualified Data.List as L
15import Data.Map.Strict as M
15import Data.Map.Strict as M
16import Data.Maybe
16import Data.Maybe
17import Data.OpenApi
17import Data.OpenApi
18+import qualified Data.OpenApi.Schema.Generator as G
18import Data.Text (Text)
19import Data.Text (Text)
19import OpenAPI.Checker.Behavior
20import OpenAPI.Checker.Behavior
21+import OpenAPI.Checker.Common
20import OpenAPI.Checker.References
22import OpenAPI.Checker.References
21import OpenAPI.Checker.Subtree
23import OpenAPI.Checker.Subtree
22import OpenAPI.Checker.Validate.MediaTypeObject
24import OpenAPI.Checker.Validate.MediaTypeObject
@@ -28,11 +30,11 @@ import OpenAPI.Checker.Validate.Server ()
28
30
29data MatchedOperation = MatchedOperation
31data MatchedOperation = MatchedOperation
30 { operation :: !Operation
32 { operation :: !Operation
31− , pathParams :: ![Traced Param]
32− -- ^ Params from the PathItem
33+ , -- | Params from the PathItem
33− , getPathFragments :: !([Traced Param] -> [Traced PathFragmentParam])
34+ pathParams :: ![Traced Param]
34− -- ^ Path fragments traced from PathItem. Takes full list of
35+ , -- | Path fragments traced from PathItem. Takes full list of
35− -- operation-specific parameters
36+ -- operation-specific parameters
37+ getPathFragments :: !([Traced Param] -> [Traced PathFragmentParam])
36 }
38 }
37
39
38type ParamKey = (ParamLocation, Text)
40type ParamKey = (ParamLocation, Text)
@@ -43,32 +45,32 @@ paramKey param = (_paramIn param, _paramName param)
43tracedParameters :: Traced MatchedOperation -> [Traced (Referenced Param)]
45tracedParameters :: Traced MatchedOperation -> [Traced (Referenced Param)]
44tracedParameters oper =
46tracedParameters oper =
45 [ traced (ask oper >>> step (OperationParamsStep i)) x
47 [ 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
47 ]
49 ]
48
50
49tracedRequestBody :: Traced MatchedOperation -> Maybe (Traced (Referenced RequestBody))
51tracedRequestBody :: Traced MatchedOperation -> Maybe (Traced (Referenced RequestBody))
50tracedRequestBody oper = _operationRequestBody (operation $ extract oper) <&> traced (ask oper >>> step OperationRequestBodyStep)
52tracedRequestBody oper = _operationRequestBody (operation $ extract oper) <&> traced (ask oper >>> step OperationRequestBodyStep)
51
53
52tracedResponses :: Traced MatchedOperation -> Traced Responses
54tracedResponses :: Traced MatchedOperation -> Traced Responses
55+tracedResponses oper =
53−tracedResponses oper = traced (ask oper >>> step OperationResponsesStep)
56+ traced (ask oper >>> step OperationResponsesStep) $
54− $ _operationResponses . operation $ extract oper
57+ _operationResponses . operation $ extract oper
55
58
56tracedSecurity :: Traced MatchedOperation -> [Traced SecurityRequirement]
59tracedSecurity :: Traced MatchedOperation -> [Traced SecurityRequirement]
57tracedSecurity oper =
60tracedSecurity oper =
58 [ traced (ask oper >>> step (OperationSecurityRequirementStep i)) x
61 [ 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
60 ]
63 ]
61
64
62-- FIXME: https://github.com/typeable/openapi-diff/issues/28
65-- FIXME: https://github.com/typeable/openapi-diff/issues/28
63−tracedServers
66+getServers
64 :: [Server] -- ^ Servers from env
67 :: [Server] -- ^ Servers from env
65− -> Traced MatchedOperation
68+ -> MatchedOperation
66− -> Traced [Server]
69+ -> [Server]
67−tracedServers env oper =
70+getServers env oper =
68− traced (ask oper >>> step OperationServersStep) $
69− case _operationServers . operation $ extract oper of
71+ case _operationServers . operation $ oper of
70− [] -> env
72+ [] -> env
71− ss -> ss
73+ ss -> ss
72
74
73instance Behavable 'OperationLevel 'PathFragmentLevel where
75instance Behavable 'OperationLevel 'PathFragmentLevel where
74 data Behave 'OperationLevel 'PathFragmentLevel
76 data Behave 'OperationLevel 'PathFragmentLevel
@@ -83,16 +85,42 @@ instance Behavable 'OperationLevel 'RequestLevel where
83
85
84instance Subtree MatchedOperation where
86instance Subtree MatchedOperation where
85 type SubtreeLevel MatchedOperation = 'OperationLevel
87 type SubtreeLevel MatchedOperation = 'OperationLevel
88+ type
86− type CheckEnv MatchedOperation =
89+ CheckEnv MatchedOperation =
87− '[ ProdCons (Traced (Definitions Param))
90+ '[ ProdCons (Traced (Definitions Param))
88− , ProdCons (Traced (Definitions RequestBody))
91+ , ProdCons (Traced (Definitions RequestBody))
89− , ProdCons (Traced (Definitions SecurityScheme))
92+ , ProdCons (Traced (Definitions SecurityScheme))
90− , ProdCons (Traced (Definitions Response))
93+ , ProdCons (Traced (Definitions Response))
91− , ProdCons (Traced (Definitions Header))
94+ , ProdCons (Traced (Definitions Header))
92− , ProdCons (Traced (Definitions Schema))
95+ , ProdCons (Traced (Definitions Schema))
93− , ProdCons [Server]
96+ , ProdCons [Server]
97+ , ProdCons (Traced (Definitions Link))
94− ]
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 ()
95− checkCompatibility env beh prodCons = do
123+ checkSemanticCompatibility env beh prodCons = do
96 checkParameters
124 checkParameters
97 checkRequestBodies
125 checkRequestBodies
98 checkResponses
126 checkResponses
@@ -102,97 +130,103 @@ instance Subtree MatchedOperation where
102 pure ()
130 pure ()
103 where
131 where
104 checkParameters = do
132 checkParameters = do
105− let
106− -- Merged parameters got from Operation and PathItem in one
133+ let -- Merged parameters got from Operation and PathItem in one
107− -- place. First element is path params, second is non-path params
134+ -- place. First element is path params, second is non-path params
108− tracedParams :: ProdCons ([Traced Param], [Traced Param])
135+ tracedParams :: ProdCons ([Traced Param], [Traced Param])
109− tracedParams = getParams <$> paramDefs <*> prodCons
136+ tracedParams = getParams <$> paramDefs <*> prodCons
110− getParams defs mp =
137+ getParams defs mp =
111− let
112− operationParamsMap :: Map ParamKey (Traced Param)
138+ let operationParamsMap :: Map ParamKey (Traced Param)
113− operationParamsMap = M.fromList $ do
139+ operationParamsMap = M.fromList $ do
114− paramRef <- tracedParameters mp
140+ paramRef <- tracedParameters mp
115− let
116− param = dereference defs paramRef
141+ let param = dereference defs paramRef
117− key = paramKey . extract $ param
142+ key = paramKey . extract $ param
118− pure (key, param)
143+ pure (key, param)
119− pathParamsMap :: Map ParamKey (Traced Param)
144+ pathParamsMap :: Map ParamKey (Traced Param)
120− pathParamsMap = M.fromList $ do
145+ pathParamsMap = M.fromList $ do
121− param <- pathParams . extract $ mp
146+ param <- pathParams . extract $ mp
122− pure (paramKey . extract $ param, param)
147+ pure (paramKey . extract $ param, param)
123− params = M.elems $ M.union operationParamsMap pathParamsMap -- We prefer params from Operation
148+ params = M.elems $ M.union operationParamsMap pathParamsMap -- We prefer params from Operation
149+ splitted =
124− splitted = L.partition
150+ L.partition
125− (\p -> (_paramIn . extract $ p) == ParamPath) params
151+ (\p -> (_paramIn . extract $ p) == ParamPath)
152+ params
126− in splitted
153+ in splitted
127 checkNonPathParams $ snd <$> tracedParams
154 checkNonPathParams $ snd <$> tracedParams
128 checkPathParams $ fst <$> tracedParams
155 checkPathParams $ fst <$> tracedParams
129 pure ()
156 pure ()
130− checkNonPathParams :: ProdCons [Traced Param] -> CompatFormula ()
157+ checkNonPathParams :: ProdCons [Traced Param] -> SemanticCompatFormula ()
131 checkNonPathParams params = do
158 checkNonPathParams params = do
132− let
133− elements = getEls <$> params
159+ let elements = getEls <$> params
134− getEls params = M.fromList $ do
160+ getEls params = M.fromList $ do
135− p <- params
161+ p <- params
136− let
137− k = (_paramIn . extract $ p, _paramName . extract $ p)
162+ let k = (_paramIn . extract $ p, _paramName . extract $ p)
163+ v =
138− v = ProductLike
164+ ProductLike
139− { productValue = p
165+ { productValue = p
140− , required = fromMaybe False . _paramRequired . extract $ p
166+ , required = fromMaybe False . _paramRequired . extract $ p
141− }
167+ }
142− pure (k, v)
168+ pure (k, v)
143− check (_, name) param = do
169+ check (_, name) param = do
144− checkCompatibility @Param (singletonH schemaDefs) (beh >>> step (InParam name)) param
170+ checkCompatibility @Param (singletonH schemaDefs) (beh >>> step (InParam name)) param
145 checkProducts beh (ParamNotMatched . snd) check elements
171 checkProducts beh (ParamNotMatched . snd) check elements
146− checkPathParams :: ProdCons [Traced Param] -> CompatFormula ()
172+ checkPathParams :: ProdCons [Traced Param] -> SemanticCompatFormula ()
147 checkPathParams pathParams = do
173 checkPathParams pathParams = do
148− let
149− fragments :: ProdCons [Traced PathFragmentParam]
174+ let fragments :: ProdCons [Traced PathFragmentParam]
150− fragments = getFragments <$> pathParams <*> prodCons
175+ fragments = getFragments <$> pathParams <*> prodCons
151− getFragments params mop = getPathFragments (extract mop) params
176+ getFragments params mop = getPathFragments (extract mop) params
152− -- Feed path parameters to the fragments getter
177+ -- Feed path parameters to the fragments getter
153− check idx frags = checkCompatibility @PathFragmentParam env (beh >>> step (InFragment idx)) frags
178+ check idx frags = checkCompatibility @PathFragmentParam env (beh >>> step (InFragment idx)) frags
179+ elements =
154− elements = fragments <&> \frags -> M.fromList $ zip [0 :: Int ..] $ do
180+ fragments <&> \frags -> M.fromList $
181+ zip [0 :: Int ..] $ do
155− frag <- frags
182+ frag <- frags
183+ pure $
156− pure $ ProductLike
184+ ProductLike
157− { productValue = frag
185+ { productValue = frag
158− , required = True }
186+ , required = True
187+ }
159 checkProducts beh PathFragmentNotMatched check elements
188 checkProducts beh PathFragmentNotMatched check elements
160 checkRequestBodies = do
189 checkRequestBodies = do
161− let
162− check reqBody = checkCompatibility @RequestBody env (beh >>> step InRequest) reqBody
190+ let check reqBody = checkCompatibility @RequestBody env (beh >>> step InRequest) reqBody
163− elements = getReqBody <$> bodyDefs <*> prodCons
191+ elements = getReqBody <$> bodyDefs <*> prodCons
164− getReqBody bodyDef mop = M.fromList $ do
192+ getReqBody bodyDef mop = M.fromList $ do
165− bodyRef <- F.toList . tracedRequestBody $ mop
193+ bodyRef <- F.toList . tracedRequestBody $ mop
166− let
167− body = dereference bodyDef bodyRef
194+ let body = dereference bodyDef bodyRef
168− -- Single element map
195+ -- Single element map
196+ pure
197+ ( ()
169− pure ((), ProductLike
198+ , ProductLike
170− { productValue = body
199+ { productValue = body
171− , required = fromMaybe False . _requestBodyRequired . extract $ body
200+ , required = fromMaybe False . _requestBodyRequired . extract $ body
172− })
201+ }
202+ )
173 checkProducts beh (const NoRequestBody) (const check) elements
203 checkProducts beh (const NoRequestBody) (const check) elements
174 checkResponses = do
204 checkResponses = do
175− let
205+ let respEnv =
176− respEnv = HCons (swapProdCons respDefs)
206+ HCons (swapProdCons respDefs) $
177− $ HCons (swapProdCons headerDefs)
207+ HCons (swapProdCons headerDefs) $
178− $ HCons (swapProdCons schemaDefs) HNil
208+ HCons (swapProdCons schemaDefs) $
209+ HCons (swapProdCons linkDefs) HNil
179− resps = tracedResponses <$> prodCons
210+ resps = tracedResponses <$> prodCons
180 checkCompatibility respEnv beh $ swapProdCons resps
211 checkCompatibility respEnv beh $ swapProdCons resps
181 -- FIXME: https://github.com/typeable/openapi-diff/issues/27
212 -- FIXME: https://github.com/typeable/openapi-diff/issues/27
182 checkCallbacks = pure () -- (error "FIXME: not implemented")
213 checkCallbacks = pure () -- (error "FIXME: not implemented")
183 -- FIXME: https://github.com/typeable/openapi-diff/issues/28
214 -- FIXME: https://github.com/typeable/openapi-diff/issues/28
184 checkOperationSecurity = pure () -- (error "FIXME: not implemented")
215 checkOperationSecurity = pure () -- (error "FIXME: not implemented")
185 checkServers =
216 checkServers =
186− checkCompatibility env beh $
217+ checkCompatibility env beh $ do
218+ x <- prodCons
187− tracedServers <$> getH @(ProdCons [Server]) env <*> prodCons
219+ se <- getH @(ProdCons [Server]) env
220+ pure $ Traced (ask x >>> step OperationServersStep) (getServers se (extract x))
188 bodyDefs = getH @(ProdCons (Traced (Definitions RequestBody))) env
221 bodyDefs = getH @(ProdCons (Traced (Definitions RequestBody))) env
189 respDefs = getH @(ProdCons (Traced (Definitions Response))) env
222 respDefs = getH @(ProdCons (Traced (Definitions Response))) env
190− headerDefs = getH @(ProdCons (Traced (Definitions Header))) env
223+ headerDefs = getH @(ProdCons (Traced (Definitions Header))) env
191 schemaDefs = getH @(ProdCons (Traced (Definitions Schema))) env
224 schemaDefs = getH @(ProdCons (Traced (Definitions Schema))) env
192 paramDefs = getH @(ProdCons (Traced (Definitions Param))) env
225 paramDefs = getH @(ProdCons (Traced (Definitions Param))) env
226+ linkDefs = getH @(ProdCons (Traced (Definitions Link))) env
193
227
194−data OperationMethod =
228+data OperationMethod
195− GetMethod
229+ = GetMethod
196 | PutMethod
230 | PutMethod
197 | PostMethod
231 | PostMethod
198 | DeleteMethod
232 | DeleteMethod
src/OpenAPI/Checker/Validate/Param.hs+11−1
@@ -71,7 +71,17 @@ instance Behavable 'PathFragmentLevel 'SchemaLevel where
71instance Subtree Param where
71instance Subtree Param where
72 type SubtreeLevel Param = 'PathFragmentLevel
72 type SubtreeLevel Param = 'PathFragmentLevel
73 type CheckEnv Param = '[ProdCons (Traced (Definitions Schema))]
73 type CheckEnv Param = '[ProdCons (Traced (Definitions Schema))]
74+ checkStructuralCompatibility env pc = do
75+ structuralEq $ _paramName <$> pc
76+ structuralEq $ _paramRequired <$> pc
77+ structuralEq $ _paramIn <$> pc
78+ structuralEq $ _paramAllowEmptyValue <$> pc
79+ structuralEq $ _paramAllowReserved <$> pc
80+ structuralMaybe env $ _paramSchema <$> pc
81+ structuralEq $ _paramStyle <$> pc
82+ structuralEq $ _paramExplode <$> pc
83+ pure ()
74− checkCompatibility env beh pc@(ProdCons p c) = do
84+ checkSemanticCompatibility env beh pc@(ProdCons p c) = do
75 when (_paramName (extract p) /= _paramName (extract c))
85 when (_paramName (extract p) /= _paramName (extract c))
76 $ issueAt beh ParamNameMismatch
86 $ issueAt beh ParamNameMismatch
77 when ((fromMaybe False . _paramRequired . extract $ c) &&
87 when ((fromMaybe False . _paramRequired . extract $ c) &&
src/OpenAPI/Checker/Validate/PathFragment.hs+4−2
@@ -63,10 +63,12 @@ instance Subtree PathFragmentParam where
63 type SubtreeLevel PathFragmentParam = 'PathFragmentLevel
63 type SubtreeLevel PathFragmentParam = 'PathFragmentLevel
64 type CheckEnv PathFragmentParam =
64 type CheckEnv PathFragmentParam =
65 '[ ProdCons (Traced (Definitions Schema)) ]
65 '[ ProdCons (Traced (Definitions Schema)) ]
66+ -- Not much to compare at this level
67+ checkStructuralCompatibility _ _ = structuralIssue
66 -- This case isn't strictly needed. It is here for optimization.
68 -- This case isn't strictly needed. It is here for optimization.
67− checkCompatibility _ beh (ProdCons (extract -> StaticPath x) (extract -> StaticPath y))
69+ checkSemanticCompatibility _ beh (ProdCons (extract -> StaticPath x) (extract -> StaticPath y))
68 = if x == y
70 = if x == y
69 then pure ()
71 then pure ()
70 else issueAt beh (PathFragmentsDontMatch x y)
72 else issueAt beh (PathFragmentsDontMatch x y)
71− checkCompatibility env beh prodCons = do
73+ checkSemanticCompatibility env beh prodCons = do
72 checkCompatibility env beh (tracedPathFragmentParam <$> prodCons)
74 checkCompatibility env beh (tracedPathFragmentParam <$> prodCons)
src/OpenAPI/Checker/Validate/ProcessedPathItem.hs+11−6
@@ -33,13 +33,14 @@ import OpenAPI.Checker.Validate.Sums
33data ProcessedPathItem = ProcessedPathItem
33data ProcessedPathItem = ProcessedPathItem
34 { path :: FilePath
34 { path :: FilePath
35 , item :: PathItem
35 , item :: PathItem
36− }
36+ } deriving stock (Eq, Show)
37
37
38processPathItems :: [(FilePath, PathItem)] -> ProcessedPathItems
38processPathItems :: [(FilePath, PathItem)] -> ProcessedPathItems
39processPathItems = ProcessedPathItems . fmap (uncurry ProcessedPathItem)
39processPathItems = ProcessedPathItems . fmap (uncurry ProcessedPathItem)
40
40
41newtype ProcessedPathItems =
41newtype ProcessedPathItems =
42 ProcessedPathItems {unProcessedPathItems :: [ProcessedPathItem]}
42 ProcessedPathItems {unProcessedPathItems :: [ProcessedPathItem]}
43+ deriving newtype (Eq, Show)
43
44
44instance Issuable 'APILevel where
45instance Issuable 'APILevel where
45 data Issue 'APILevel
46 data Issue 'APILevel
@@ -65,8 +66,11 @@ instance Subtree ProcessedPathItems where
65 , ProdCons (Traced (Definitions Header))
66 , ProdCons (Traced (Definitions Header))
66 , ProdCons (Traced (Definitions Schema))
67 , ProdCons (Traced (Definitions Schema))
67 , ProdCons [Server]
68 , ProdCons [Server]
69+ , ProdCons (Traced (Definitions Link))
68 ]
70 ]
71+ -- No real way to check it at this level
72+ checkStructuralCompatibility _ _ = structuralIssue
69− checkCompatibility env beh pc@(ProdCons p c) = do
73+ checkSemanticCompatibility env beh pc@(ProdCons p c) = do
70 -- Each path generated by producer must be handled by consumer with exactly
74 -- Each path generated by producer must be handled by consumer with exactly
71 -- one way
75 -- one way
72 for_ (unProcessedPathItems . extract $ p) $ \ prodItem -> do
76 for_ (unProcessedPathItems . extract $ p) $ \ prodItem -> do
@@ -74,8 +78,7 @@ instance Subtree ProcessedPathItems where
74 prodPath = path prodItem
78 prodPath = path prodItem
75 matchedItems = do
79 matchedItems = do
76 consItem <- unProcessedPathItems . extract $ c
80 consItem <- unProcessedPathItems . extract $ c
77− matched <- F.toList $ matchingPathItems $ ProdCons prodItem consItem
81+ F.toList $ matchingPathItems $ ProdCons prodItem consItem
78− return matched
79 case matchedItems of
82 case matchedItems of
80 [] -> issueAt beh $ NoPathsMatched prodPath
83 [] -> issueAt beh $ NoPathsMatched prodPath
81 [match] -> checkCompatibility env (beh >>> step (AtPath $ matchedPath <$> match)) (retraced <$> pc <*> match)
84 [match] -> checkCompatibility env (beh >>> step (AtPath $ matchedPath <$> match)) (retraced <$> pc <*> match)
@@ -116,7 +119,7 @@ data MatchedPathItem = MatchedPathItem
116 , matchedPath :: !FilePath
119 , matchedPath :: !FilePath
117 , pathFragments :: ![PathFragment Text]
120 , pathFragments :: ![PathFragment Text]
118 -- ^ Pre-parsed path from PathItem
121 -- ^ Pre-parsed path from PathItem
119− }
122+ } deriving stock (Eq)
120
123
121tracedParameters :: Traced MatchedPathItem -> [Traced (Referenced Param)]
124tracedParameters :: Traced MatchedPathItem -> [Traced (Referenced Param)]
122tracedParameters mpi =
125tracedParameters mpi =
@@ -158,8 +161,10 @@ instance Subtree MatchedPathItem where
158 , ProdCons (Traced (Definitions Header))
161 , ProdCons (Traced (Definitions Header))
159 , ProdCons (Traced (Definitions Schema))
162 , ProdCons (Traced (Definitions Schema))
160 , ProdCons [Server]
163 , ProdCons [Server]
164+ , ProdCons (Traced (Definitions Link))
161 ]
165 ]
166+ checkStructuralCompatibility _ _ = structuralIssue
162− checkCompatibility env beh prodCons = do
167+ checkSemanticCompatibility env beh prodCons = do
163 let
168 let
164 paramDefs = getH @(ProdCons (Traced (Definitions Param))) env
169 paramDefs = getH @(ProdCons (Traced (Definitions Param))) env
165 pathTracedParams = getPathParams <$> paramDefs <*> prodCons
170 pathTracedParams = getPathParams <$> paramDefs <*> prodCons
src/OpenAPI/Checker/Validate/RequestBody.hs+21−14
@@ -17,8 +17,9 @@ import OpenAPI.Checker.Validate.MediaTypeObject
17import OpenAPI.Checker.Validate.Sums
17import OpenAPI.Checker.Validate.Sums
18
18
19tracedContent :: Traced RequestBody -> IOHM.InsOrdHashMap MediaType (Traced MediaTypeObject)
19tracedContent :: Traced RequestBody -> IOHM.InsOrdHashMap MediaType (Traced MediaTypeObject)
20+tracedContent resp =
20−tracedContent resp = IOHM.mapWithKey (\k -> traced (ask resp >>> step (RequestMediaTypeObject k)))
21+ IOHM.mapWithKey (\k -> traced (ask resp >>> step (RequestMediaTypeObject k))) $
21− $ _requestBodyContent $ extract resp
22+ _requestBodyContent $ extract resp
22
23
23instance Issuable 'RequestLevel where
24instance Issuable 'RequestLevel where
24 data Issue 'RequestLevel
25 data Issue 'RequestLevel
@@ -34,19 +35,25 @@ instance Behavable 'RequestLevel 'PayloadLevel where
34
35
35instance Subtree RequestBody where
36instance Subtree RequestBody where
36 type SubtreeLevel RequestBody = 'RequestLevel
37 type SubtreeLevel RequestBody = 'RequestLevel
38+ type
37− type CheckEnv RequestBody =
39+ CheckEnv RequestBody =
38− '[ ProdCons (Traced (Definitions Schema)) ]
40+ '[ ProdCons (Traced (Definitions Schema))
41+ , ProdCons (Traced (Definitions Header))
42+ ]
43+ checkStructuralCompatibility env pc = do
44+ structuralEq $ _requestBodyRequired <$> pc
45+ iohmStructural env $ _requestBodyContent <$> pc
46+ pure ()
39− checkCompatibility env beh prodCons@(ProdCons p c) =
47+ checkSemanticCompatibility env beh prodCons@(ProdCons p c) =
40 if not (fromMaybe False . _requestBodyRequired . extract $ p)
48 if not (fromMaybe False . _requestBodyRequired . extract $ p)
41− && (fromMaybe False . _requestBodyRequired . extract $ c)
49+ && (fromMaybe False . _requestBodyRequired . extract $ c)
42− then issueAt beh RequestBodyRequired
50+ then issueAt beh RequestBodyRequired
43− else
44− -- Media type object are sums-like entities.
51+ else -- Media type object are sums-like entities.
45− let
52+
46− check mediaType pc = checkCompatibility @MediaTypeObject (HCons mediaType env) (beh >>> step InPayload) pc
53+ let check mediaType pc = checkCompatibility @MediaTypeObject (HCons mediaType env) (beh >>> step InPayload) pc
47− sumElts = getSum <$> prodCons
54+ sumElts = getSum <$> prodCons
48− getSum rb = M.fromList . IOHM.toList $ tracedContent rb
55+ getSum rb = M.fromList . IOHM.toList $ tracedContent rb
49− in checkSums beh RequestMediaTypeNotFound check sumElts
56+ in checkSums beh RequestMediaTypeNotFound check sumElts
50
57
51instance Steppable RequestBody MediaTypeObject where
58instance Steppable RequestBody MediaTypeObject where
52 data Step RequestBody MediaTypeObject = RequestMediaTypeObject MediaType
59 data Step RequestBody MediaTypeObject = RequestMediaTypeObject MediaType
src/OpenAPI/Checker/Validate/Responses.hs+62−78
@@ -6,8 +6,6 @@ module OpenAPI.Checker.Validate.Responses
6 )
6 )
7where
7where
8
8
9−import Control.Lens
10−import Data.Foldable
11import Data.HList
9import Data.HList
12import Data.HashMap.Strict.InsOrd as IOHM
10import Data.HashMap.Strict.InsOrd as IOHM
13import Data.Map.Strict as M
11import Data.Map.Strict as M
@@ -17,42 +15,54 @@ import Network.HTTP.Media (MediaType)
17import OpenAPI.Checker.Behavior
15import OpenAPI.Checker.Behavior
18import OpenAPI.Checker.References
16import OpenAPI.Checker.References
19import OpenAPI.Checker.Subtree
17import OpenAPI.Checker.Subtree
18+import OpenAPI.Checker.Validate.Header ()
19+import OpenAPI.Checker.Validate.Link ()
20import OpenAPI.Checker.Validate.MediaTypeObject
20import OpenAPI.Checker.Validate.MediaTypeObject
21import OpenAPI.Checker.Validate.Products
21import OpenAPI.Checker.Validate.Products
22import OpenAPI.Checker.Validate.Schema ()
22import OpenAPI.Checker.Validate.Schema ()
23import OpenAPI.Checker.Validate.Sums
23import OpenAPI.Checker.Validate.Sums
24
24
25tracedResponses :: Traced Responses -> IOHM.InsOrdHashMap HttpStatusCode (Traced (Referenced Response))
25tracedResponses :: Traced Responses -> IOHM.InsOrdHashMap HttpStatusCode (Traced (Referenced Response))
26+tracedResponses resp =
26−tracedResponses resp = IOHM.mapWithKey (\k -> traced (ask resp >>> step (ResponseCodeStep k)))
27+ IOHM.mapWithKey (\k -> traced (ask resp >>> step (ResponseCodeStep k))) $
27− $ _responsesResponses $ extract resp
28+ _responsesResponses $ extract resp
28
29
29instance Subtree Responses where
30instance Subtree Responses where
30 type SubtreeLevel Responses = 'OperationLevel
31 type SubtreeLevel Responses = 'OperationLevel
32+ type
31− type CheckEnv Responses =
33+ CheckEnv Responses =
32− '[ ProdCons (Traced (Definitions Response))
34+ '[ ProdCons (Traced (Definitions Response))
33− , ProdCons (Traced (Definitions Header))
35+ , ProdCons (Traced (Definitions Header))
34− , ProdCons (Traced (Definitions Schema))
36+ , ProdCons (Traced (Definitions Schema))
37+ , ProdCons (Traced (Definitions Link))
35− ]
38+ ]
39+
40+ checkStructuralCompatibility env pc = do
41+ structuralMaybe env $ _responsesDefault <$> pc
42+ iohmStructural env $ _responsesResponses <$> pc
43+ pure ()
44+
36 -- Roles are already swapped. Producer is a server and consumer is a
45 -- Roles are already swapped. Producer is a server and consumer is a
37 -- client. Response codes are sum-like entity because we can answer with only
46 -- client. Response codes are sum-like entity because we can answer with only
38 -- one element
47 -- one element
39− checkCompatibility env beh prodCons = do
48+ checkSemanticCompatibility env beh prodCons = do
40− let
41− defs = getH @(ProdCons (Traced (Definitions Response))) env
49+ let defs = getH @(ProdCons (Traced (Definitions Response))) env
42− check code resps = checkCompatibility @Response env (beh >>> step (WithStatusCode code)) resps
50+ check code resps = checkCompatibility @Response env (beh >>> step (WithStatusCode code)) resps
43− elements = getEls <$> defs <*> prodCons
51+ elements = getEls <$> defs <*> prodCons
44− getEls respDef resps = M.fromList $ do
52+ getEls respDef resps = M.fromList $ do
45− (code, respRef) <- IOHM.toList $ tracedResponses resps
53+ (code, respRef) <- IOHM.toList $ tracedResponses resps
46− pure (code, dereference respDef respRef)
54+ pure (code, dereference respDef respRef)
47 checkSums beh ResponseCodeNotFound check elements
55 checkSums beh ResponseCodeNotFound check elements
48
56
49tracedContent :: Traced Response -> IOHM.InsOrdHashMap MediaType (Traced MediaTypeObject)
57tracedContent :: Traced Response -> IOHM.InsOrdHashMap MediaType (Traced MediaTypeObject)
58+tracedContent resp =
50−tracedContent resp = IOHM.mapWithKey (\k -> traced (ask resp >>> step (ResponseMediaObject k)))
59+ IOHM.mapWithKey (\k -> traced (ask resp >>> step (ResponseMediaObject k))) $
51− $ _responseContent $ extract resp
60+ _responseContent $ extract resp
52
61
53tracedHeaders :: Traced Response -> IOHM.InsOrdHashMap HeaderName (Traced (Referenced Header))
62tracedHeaders :: Traced Response -> IOHM.InsOrdHashMap HeaderName (Traced (Referenced Header))
63+tracedHeaders resp =
54−tracedHeaders resp = IOHM.mapWithKey (\k -> traced (ask resp >>> step (ResponseHeader k)))
64+ IOHM.mapWithKey (\k -> traced (ask resp >>> step (ResponseHeader k))) $
55− $ _responseHeaders $ extract resp
65+ _responseHeaders $ extract resp
56
66
57instance Issuable 'ResponseLevel where
67instance Issuable 'ResponseLevel where
58 data Issue 'ResponseLevel
68 data Issue 'ResponseLevel
@@ -73,11 +83,18 @@ instance Behavable 'ResponseLevel 'HeaderLevel where
73
83
74instance Subtree Response where
84instance Subtree Response where
75 type SubtreeLevel Response = 'ResponseLevel
85 type SubtreeLevel Response = 'ResponseLevel
86+ type
76− type CheckEnv Response =
87+ CheckEnv Response =
77− '[ ProdCons (Traced (Definitions Header))
88+ '[ ProdCons (Traced (Definitions Header))
78− , ProdCons (Traced (Definitions Schema))
89+ , ProdCons (Traced (Definitions Schema))
90+ , ProdCons (Traced (Definitions Link))
79− ]
91+ ]
92+ checkStructuralCompatibility env pc = do
93+ iohmStructural env $ _responseContent <$> pc
94+ iohmStructural env $ _responseHeaders <$> pc
95+ iohmStructural env $ _responseLinks <$> pc
96+ pure ()
80− checkCompatibility env beh prodCons = do
97+ checkSemanticCompatibility env beh prodCons = do
81 -- Roles are already swapped. Producer is a server and consumer is a client
98 -- Roles are already swapped. Producer is a server and consumer is a client
82 checkMediaTypes
99 checkMediaTypes
83 checkHeaders
100 checkHeaders
@@ -85,71 +102,38 @@ instance Subtree Response where
85 where
102 where
86 checkMediaTypes = do
103 checkMediaTypes = do
87 -- Media types are sum-like entity
104 -- Media types are sum-like entity
88− let
89− check mediaType mtObj =
105+ let check mediaType mtObj =
90− let mtEnv = HCons mediaType $ env
106+ let mtEnv = HCons mediaType $ env
91− in checkCompatibility @MediaTypeObject mtEnv (beh >>> step ResponsePayload) mtObj
107+ in checkCompatibility @MediaTypeObject mtEnv (beh >>> step ResponsePayload) mtObj
92− elements = getEls <$> prodCons
108+ elements = getEls <$> prodCons
93− getEls resp = M.fromList . IOHM.toList $ tracedContent resp
109+ getEls resp = M.fromList . IOHM.toList $ tracedContent resp
94 checkSums beh ResponseMediaTypeMissing check elements
110 checkSums beh ResponseMediaTypeMissing check elements
95
111
96 checkHeaders = do
112 checkHeaders = do
97 -- Headers are product-like entities
113 -- Headers are product-like entities
98− let
99− check name hdrs = checkCompatibility @Header env (beh >>> step (InHeader name)) hdrs
114+ let check name hdrs = checkCompatibility @Header env (beh >>> step (InHeader name)) hdrs
100− elements = getEls <$> headerDefs <*> prodCons
115+ elements = getEls <$> headerDefs <*> prodCons
101− getEls headerDef resp = M.fromList $ do
116+ getEls headerDef resp = M.fromList $ do
102− (hname, headerRef) <- IOHM.toList $ tracedHeaders resp
117+ (hname, headerRef) <- IOHM.toList $ tracedHeaders resp
103− let header = dereference headerDef headerRef
118+ let header = dereference headerDef headerRef
119+ pure
120+ ( hname
104− pure (hname, ProductLike
121+ , ProductLike
105− { productValue = header
122+ { productValue = header
106− , required = fromMaybe False . _headerRequired . extract $ header
123+ , required = fromMaybe False . _headerRequired . extract $ header
107− })
124+ }
125+ )
108 checkProducts beh ResponseHeaderMissing check elements
126 checkProducts beh ResponseHeaderMissing check elements
109 headerDefs = getH @(ProdCons (Traced (Definitions Header))) env
127 headerDefs = getH @(ProdCons (Traced (Definitions Header))) env
110
128
111−tracedSchema :: Traced Header -> Maybe (Traced (Referenced Schema))
112−tracedSchema hdr = _headerSchema (extract hdr) <&> traced (ask hdr >>> step HeaderSchema)
113−
114−instance Issuable 'HeaderLevel where
115− data Issue 'HeaderLevel
116− = RequiredHeaderMissing
117− | NonEmptyHeaderRequired
118− | HeaderSchemaRequired
119− deriving stock (Eq, Ord, Show)
120− issueIsUnsupported _ = False
121−
122−instance Behavable 'HeaderLevel 'SchemaLevel where
123− data Behave 'HeaderLevel 'SchemaLevel
124− = InSchema
125− deriving stock (Eq, Ord, Show)
126−
127−instance Subtree Header where
128− type SubtreeLevel Header = 'HeaderLevel
129− type CheckEnv Header = '[ProdCons (Traced (Definitions Schema))]
130− checkCompatibility env beh (ProdCons p c) = do
131− if (fromMaybe False $ _headerRequired $ extract c) && not (fromMaybe False $ _headerRequired $ extract p)
132− then issueAt beh RequiredHeaderMissing else pure ()
133− if not (fromMaybe False $ _headerAllowEmptyValue $ extract c) && (fromMaybe False $ _headerAllowEmptyValue $ extract p)
134− then issueAt beh NonEmptyHeaderRequired else pure ()
135− for_ (tracedSchema c) $ \consRef ->
136− case tracedSchema p of
137− Nothing -> issueAt beh HeaderSchemaRequired
138− Just prodRef -> checkCompatibility env (beh >>> step InSchema) (ProdCons prodRef consRef)
139− pure ()
140−
141instance Steppable Responses (Referenced Response) where
129instance Steppable Responses (Referenced Response) where
142 data Step Responses (Referenced Response) = ResponseCodeStep HttpStatusCode
130 data Step Responses (Referenced Response) = ResponseCodeStep HttpStatusCode
143 deriving stock (Eq, Ord, Show)
131 deriving stock (Eq, Ord, Show)
144
132
145−instance Steppable Header (Referenced Schema) where
133+instance Steppable Response MediaTypeObject where
146− data Step Header (Referenced Schema) = HeaderSchema
134+ data Step Response MediaTypeObject = ResponseMediaObject MediaType
147 deriving stock (Eq, Ord, Show)
135 deriving stock (Eq, Ord, Show)
148
136
149instance Steppable Response (Referenced Header) where
137instance Steppable Response (Referenced Header) where
150 data Step Response (Referenced Header) = ResponseHeader HeaderName
138 data Step Response (Referenced Header) = ResponseHeader HeaderName
151 deriving stock (Eq, Ord, Show)
139 deriving stock (Eq, Ord, Show)
152−
153−instance Steppable Response MediaTypeObject where
154− data Step Response MediaTypeObject = ResponseMediaObject MediaType
155− deriving stock (Eq, Ord, Show)
src/OpenAPI/Checker/Validate/Schema.hs+63−14
@@ -38,6 +38,7 @@ import Data.Scientific
38import qualified Data.Set as S
38import qualified Data.Set as S
39import Data.Text (Text)
39import Data.Text (Text)
40import qualified Data.Text as T hiding (singleton)
40import qualified Data.Text as T hiding (singleton)
41+import qualified Data.Text.Encoding as T
41import Data.Typeable
42import Data.Typeable
42import OpenAPI.Checker.Behavior
43import OpenAPI.Checker.Behavior
43import OpenAPI.Checker.Orphans ()
44import OpenAPI.Checker.Orphans ()
@@ -45,6 +46,7 @@ import OpenAPI.Checker.References
45import OpenAPI.Checker.Paths
46import OpenAPI.Checker.Paths
46import qualified OpenAPI.Checker.PathsPrefixTree as P
47import qualified OpenAPI.Checker.PathsPrefixTree as P
47import OpenAPI.Checker.Subtree
48import OpenAPI.Checker.Subtree
49+import Debug.Trace
48
50
49-- | Type of a JSON value
51-- | Type of a JSON value
50data JsonType
52data JsonType
@@ -598,11 +600,11 @@ schemaToFormula
598schemaToFormula defs rs = runWriter . (`runReaderT` defs) $ processSchema rs
600schemaToFormula defs rs = runWriter . (`runReaderT` defs) $ processSchema rs
599
601
600checkFormulas
602checkFormulas
601− :: HasAll (CheckEnv Schema) xs
603+ :: (HasAll (CheckEnv Schema) xs)
602 => HList xs
604 => HList xs
603 -> Behavior 'SchemaLevel
605 -> Behavior 'SchemaLevel
604 -> ProdCons (ForeachType JsonFormula, P.PathsPrefixTree Behave AnIssue 'SchemaLevel)
606 -> ProdCons (ForeachType JsonFormula, P.PathsPrefixTree Behave AnIssue 'SchemaLevel)
605− -> CompatFormula ()
607+ -> SemanticCompatFormula ()
606checkFormulas env beh (ProdCons (fp, ep) (fc, ec)) =
608checkFormulas env beh (ProdCons (fp, ep) (fc, ec)) =
607 case P.toList ep ++ P.toList ec of
609 case P.toList ep ++ P.toList ec of
608 issues@(_:_) -> F.for_ issues $ \(AnItem t (AnIssue e)) -> issueAt (beh >>> t) e
610 issues@(_:_) -> F.for_ issues $ \(AnItem t (AnIssue e)) -> issueAt (beh >>> t) e
@@ -647,7 +649,7 @@ checkFormulas env beh (ProdCons (fp, ep) (fc, ec)) =
647checkContradiction
649checkContradiction
648 :: Behavior 'TypedSchemaLevel
650 :: Behavior 'TypedSchemaLevel
649 -> [Condition t]
651 -> [Condition t]
650− -> CompatFormula ()
652+ -> SemanticCompatFormula ()
651checkContradiction beh _ = issueAt beh NoContradiction -- TODO
653checkContradiction beh _ = issueAt beh NoContradiction -- TODO
652
654
653checkImplication
655checkImplication
@@ -656,7 +658,7 @@ checkImplication
656 -> Behavior 'TypedSchemaLevel
658 -> Behavior 'TypedSchemaLevel
657 -> [Condition t]
659 -> [Condition t]
658 -> Condition t
660 -> Condition t
659− -> CompatFormula ()
661+ -> SemanticCompatFormula ()
660checkImplication env beh prods cons = case findExactly prods of
662checkImplication env beh prods cons = case findExactly prods of
661 Just e
663 Just e
662 | all (satisfiesTyped e) prods ->
664 | all (satisfiesTyped e) prods ->
@@ -803,15 +805,62 @@ instance Behavable 'TypedSchemaLevel 'SchemaLevel where
803instance Subtree Schema where
805instance Subtree Schema where
804 type SubtreeLevel Schema = 'SchemaLevel
806 type SubtreeLevel Schema = 'SchemaLevel
805 type CheckEnv Schema = '[ProdCons (Traced (Definitions Schema))]
807 type CheckEnv Schema = '[ProdCons (Traced (Definitions Schema))]
806− checkCompatibility env beh schs = do
808+ checkStructuralCompatibility env pc = do
809+ traceShowM pc
810+ structuralEq $ _schemaRequired <$> pc
811+ structuralMaybeWith structuralEq $ _schemaNullable <$> pc
812+ structuralMaybeWith (structuralList env) $ _schemaAllOf <$> pc
813+ structuralMaybeWith (structuralList env) $ _schemaOneOf <$> pc
814+ structuralMaybe env $ _schemaNot <$> pc
815+ structuralMaybeWith (structuralList env) $ _schemaAnyOf <$> pc
816+ iohmStructural env $ _schemaProperties <$> pc
817+ structuralMaybeWith structuralAdditionalProperties $ _schemaAdditionalProperties <$> pc
818+ structuralMaybeWith structuralDiscriminator $ _schemaDiscriminator <$> pc
819+ structuralEq $ _schemaReadOnly <$> pc
820+ structuralEq $ _schemaWriteOnly <$> pc
821+ structuralEq $ _schemaXml <$> pc
822+ structuralEq $ _schemaMaxProperties <$> pc
823+ structuralEq $ _schemaMinProperties <$> pc
824+ structuralEq $ _schemaDefault <$> pc
825+ structuralEq $ _schemaType <$> pc
826+ structuralEq $ _schemaFormat <$> pc
827+ structuralMaybeWith structuralItems $ _schemaItems <$> pc
828+ structuralEq $ _schemaMaximum <$> pc
829+ structuralEq $ _schemaExclusiveMaximum <$> pc
830+ structuralEq $ _schemaMinimum <$> pc
831+ structuralEq $ _schemaExclusiveMinimum <$> pc
832+ structuralEq $ _schemaMaxLength <$> pc
833+ structuralEq $ _schemaMinLength <$> pc
834+ structuralEq $ _schemaPattern <$> pc
835+ structuralEq $ _schemaMaxItems <$> pc
836+ structuralEq $ _schemaMinItems <$> pc
837+ structuralEq $ _schemaUniqueItems <$> pc
838+ structuralEq $ _schemaEnum <$> pc
839+ structuralEq $ _schemaMultipleOf <$> pc
840+ pure ()
841+ where
842+ structuralAdditionalProperties
843+ (ProdCons (AdditionalPropertiesAllowed x) (AdditionalPropertiesAllowed y)) =
844+ structuralEq $ ProdCons x y
845+ structuralAdditionalProperties
846+ (ProdCons (AdditionalPropertiesSchema x) (AdditionalPropertiesSchema y)) =
847+ checkStructuralCompatibility env $ ProdCons x y
848+ structuralAdditionalProperties _ = structuralIssue
849+ structuralDiscriminator pc' = do
850+ structuralEq $ _discriminatorPropertyName <$> pc'
851+ iohmStructuralWith
852+ (\_ mappingPC -> case A.decodeStrict @(Referenced Schema) . T.encodeUtf8 <$> mappingPC of
853+ ProdCons (Just a) (Just b) -> checkStructuralCompatibility env $ ProdCons a b
854+ ProdCons Nothing Nothing -> structuralEq mappingPC
855+ _ -> structuralIssue
856+ )
857+ (_discriminatorMapping <$> pc')
858+ pure ()
859+ structuralItems (ProdCons (OpenApiItemsObject a) (OpenApiItemsObject b)) =
860+ checkStructuralCompatibility env $ ProdCons a b
861+ structuralItems (ProdCons (OpenApiItemsArray a) (OpenApiItemsArray b)) =
862+ structuralList env $ ProdCons a b
863+ structuralItems _ = structuralIssue
864+ checkSemanticCompatibility env beh schs = do
807 let defs = getH env
865 let defs = getH env
808 checkFormulas env beh $ schemaToFormula <$> defs <*> schs
866 checkFormulas env beh $ schemaToFormula <$> defs <*> schs
809−
810−instance Subtree (Referenced Schema) where
811− type SubtreeLevel (Referenced Schema) = 'SchemaLevel
812− type CheckEnv (Referenced Schema) = CheckEnv Schema
813− checkCompatibility env beh refs = do
814− let
815− defs = getH env
816− schs = dereference <$> defs <*> refs
817− checkFormulas env beh $ schemaToFormula <$> defs <*> schs
src/OpenAPI/Checker/Validate/SecurityRequirement.hs+4−2
@@ -2,7 +2,8 @@
2
2
3module OpenAPI.Checker.Validate.SecurityRequirement
3module OpenAPI.Checker.Validate.SecurityRequirement
4 ( Issue (..)
4 ( Issue (..)
5+ )
5− ) where
6+where
6
7
7import Data.OpenApi
8import Data.OpenApi
8import OpenAPI.Checker.Behavior
9import OpenAPI.Checker.Behavior
@@ -20,4 +21,5 @@ instance Subtree SecurityRequirement where
20 CheckEnv SecurityRequirement =
21 CheckEnv SecurityRequirement =
21 '[ ProdCons (Traced (Definitions SecurityScheme))
22 '[ ProdCons (Traced (Definitions SecurityScheme))
22 ]
23 ]
23− checkCompatibility = undefined
24+ checkStructuralCompatibility = undefined
25+ checkSemanticCompatibility = undefined
src/OpenAPI/Checker/Validate/Server.hs+19−9
@@ -6,6 +6,7 @@ module OpenAPI.Checker.Validate.Server
6where
6where
7
7
8import Control.Applicative
8import Control.Applicative
9+import Control.Arrow ((&&&))
9import Control.Comonad
10import Control.Comonad
10import Control.Monad
11import Control.Monad
11import Data.Attoparsec.Text
12import Data.Attoparsec.Text
@@ -14,13 +15,16 @@ import Data.Foldable
14import Data.Function
15import Data.Function
15import Data.Functor
16import Data.Functor
16import Data.HashMap.Strict.InsOrd as IOHM
17import Data.HashMap.Strict.InsOrd as IOHM
18+import qualified Data.HashSet.InsOrd as IOHM
17import qualified Data.HashSet.InsOrd as IOHS
19import qualified Data.HashSet.InsOrd as IOHS
18import Data.Maybe
20import Data.Maybe
19import Data.OpenApi
21import Data.OpenApi
22+import qualified Data.Set as S
20import Data.Text (Text)
23import Data.Text (Text)
21import qualified Data.Text as T
24import qualified Data.Text as T
22import Data.Traversable
25import Data.Traversable
23import OpenAPI.Checker.Behavior
26import OpenAPI.Checker.Behavior
27+import OpenAPI.Checker.Common
24import OpenAPI.Checker.Paths
28import OpenAPI.Checker.Paths
25import OpenAPI.Checker.Subtree
29import OpenAPI.Checker.Subtree
26import OpenAPI.Checker.Validate.MediaTypeObject
30import OpenAPI.Checker.Validate.MediaTypeObject
@@ -44,7 +48,14 @@ instance Behavable 'OperationLevel 'ServerLevel where
44instance Subtree [Server] where
48instance Subtree [Server] where
45 type SubtreeLevel [Server] = 'OperationLevel
49 type SubtreeLevel [Server] = 'OperationLevel
46 type CheckEnv [Server] = '[]
50 type CheckEnv [Server] = '[]
51+ checkStructuralCompatibility _ pc =
52+ structuralEq $ S.fromList . fmap reduceServer <$> pc
53+ where
54+ reducerServerVariable =
55+ fmap IOHM.toHashSet . _serverVariableEnum &&& _serverVariableDefault
56+ reduceServer =
57+ _serverUrl &&& fmap reducerServerVariable . IOHM.toHashMap . _serverVariables
47− checkCompatibility env beh pcServer = do
58+ checkSemanticCompatibility env beh pcServer = do
48 let (ProdCons (pErrs, pUrls) (cErrs, cUrls)) =
59 let (ProdCons (pErrs, pUrls) (cErrs, cUrls)) =
49 pcServer
60 pcServer
50 <&> partitionEithers
61 <&> partitionEithers
@@ -74,12 +85,6 @@ unifyPart :: ServerUrlPart ServerVariable -> Maybe (IOHS.InsOrdHashSet Text)
74unifyPart (ServerUrlVariable v) = _serverVariableEnum v
85unifyPart (ServerUrlVariable v) = _serverVariableEnum v
75unifyPart (ServerUrlConstant c) = Just $ IOHS.singleton c
86unifyPart (ServerUrlConstant c) = Just $ IOHS.singleton c
76
87
77−zipAll :: [a] -> [b] -> Maybe [(a, b)]
78−zipAll [] [] = Just []
79−zipAll (x : xs) (y : ys) = ((x, y) :) <$> zipAll xs ys
80−zipAll (_ : _) [] = Nothing
81−zipAll [] (_ : _) = Nothing
82−
83staticCompatiblePart :: ServerUrlPart x -> ServerUrlPart x -> Bool
88staticCompatiblePart :: ServerUrlPart x -> ServerUrlPart x -> Bool
84staticCompatiblePart (ServerUrlConstant x) (ServerUrlConstant y) = x == y
89staticCompatiblePart (ServerUrlConstant x) (ServerUrlConstant y) = x == y
85staticCompatiblePart _ _ = True
90staticCompatiblePart _ _ = True
@@ -90,7 +95,7 @@ staticCompatible a b = maybe False (all $ uncurry staticCompatiblePart) $ zipAll
90data ServerUrlPart var
95data ServerUrlPart var
91 = ServerUrlVariable var
96 = ServerUrlVariable var
92 | ServerUrlConstant Text
97 | ServerUrlConstant Text
93− deriving stock (Show, Functor, Foldable, Traversable)
98+ deriving stock (Eq, Show, Functor, Foldable, Traversable)
94
99
95-- | This is super rough. Things like @{a|b}c@ will not match @ac@.
100-- | This is super rough. Things like @{a|b}c@ will not match @ac@.
96-- FIXME: https://github.com/typeable/openapi-diff/issues/46
101-- FIXME: https://github.com/typeable/openapi-diff/issues/46
@@ -130,7 +135,12 @@ instance Issuable 'ServerLevel where
130instance Subtree ProcessedServer where
135instance Subtree ProcessedServer where
131 type SubtreeLevel ProcessedServer = 'ServerLevel
136 type SubtreeLevel ProcessedServer = 'ServerLevel
132 type CheckEnv ProcessedServer = '[]
137 type CheckEnv ProcessedServer = '[]
133− checkCompatibility _ beh pc =
138+ checkStructuralCompatibility _ pc =
139+ structuralEq $ (fmap . fmap . fmap) reducerServerVariable pc
140+ where
141+ reducerServerVariable =
142+ fmap IOHM.toHashSet . _serverVariableEnum &&& _serverVariableDefault
143+ checkSemanticCompatibility _ beh pc =
134 -- traversing here is fine because we have already filtered for length
144 -- traversing here is fine because we have already filtered for length
135 for_ (zip [0 ..] $ zipProdCons . fmap (fmap unifyPart . extract) $ pc) $ \(i, pcPart) -> case pcPart of
145 for_ (zip [0 ..] $ zipProdCons . fmap (fmap unifyPart . extract) $ pc) $ \(i, pcPart) -> case pcPart of
136 (Just x, Just y) -> for_ x $ \v -> unless (v `IOHS.member` y) (issueAt beh $ EnumValueNotConsumed i v)
146 (Just x, Just y) -> for_ x $ \v -> unless (v `IOHS.member` y) (issueAt beh $ EnumValueNotConsumed i v)
stack.yaml+1−1
@@ -1 +1 @@
1−resolver: lts-17.4
1+resolver: lts-17.11
stack.yaml.lock+4−4
@@ -6,7 +6,7 @@
6packages: []
6packages: []
7snapshots:
7snapshots:
8- completed:
8- completed:
9− size: 563103
9+ size: 567672
10− url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/17/4.yaml
10+ url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/17/11.yaml
11− sha256: f11e2153044f5f71ea7b1c9398f4721f517c9bd37642ed769647b896564021f3
11+ sha256: 03181cdbeb671eb605bbcf6f285bea4d094b6ac7433a0e14a9f1dd54ad995938
12− original: lts-17.4
12+ original: lts-17.11