@@ -1,6 +1,5 @@
11{-# OPTIONS_GHC -Wno-orphans #-}
2−
3−module Data.OpenApi.Compare.Validate.Schema
2+module OpenAPI.Checker.Validate.Schema
43 (
54 )
65where
@@ -11,64 +10,63 @@ import Data.Coerce
1110import Data.Foldable (for_, toList)
1211import Data.Functor
1312import Data.HList
14−import Data.List (genericIndex, genericLength, group)
1513import qualified Data.List.NonEmpty as NE
1614import qualified Data.Map as M
15+import Data.List (group, genericLength, genericIndex)
1716import Data.Maybe
1817import Data.OpenApi
19−import Data.OpenApi.Compare.Behavior
20−import Data.OpenApi.Compare.Paths
21−import qualified Data.OpenApi.Compare.PathsPrefixTree as P
22−import Data.OpenApi.Compare.Subtree
23−import Data.OpenApi.Compare.Validate.Schema.DNF
24−import Data.OpenApi.Compare.Validate.Schema.Issues
25−import Data.OpenApi.Compare.Validate.Schema.JsonFormula
26−import Data.OpenApi.Compare.Validate.Schema.Partition
27−import Data.OpenApi.Compare.Validate.Schema.Process
28−import Data.OpenApi.Compare.Validate.Schema.Traced
29−import Data.OpenApi.Compare.Validate.Schema.TypedJson
3018import Data.Ord
3119import Data.Ratio
3220import Data.Semigroup
3321import qualified Data.Set as S
3422import Data.Text (Text)
23+import OpenAPI.Checker.Behavior
24+import OpenAPI.Checker.Paths
25+import qualified OpenAPI.Checker.PathsPrefixTree as P
26+import OpenAPI.Checker.Subtree
27+import OpenAPI.Checker.Validate.Schema.DNF
28+import OpenAPI.Checker.Validate.Schema.Issues
29+import OpenAPI.Checker.Validate.Schema.JsonFormula
30+import OpenAPI.Checker.Validate.Schema.Traced
31+import OpenAPI.Checker.Validate.Schema.TypedJson
32+import OpenAPI.Checker.Validate.Schema.Partition
33+import OpenAPI.Checker.Validate.Schema.Process
3534
36−checkFormulas ::
37− (ReassembleHList xs (CheckEnv (Referenced Schema))) =>
38− HList xs ->
39− Behavior 'SchemaLevel ->
40− ProdCons (Trace Schema) ->
41− ProdCons (Traced (Definitions Schema)) ->
42− ProdCons (ForeachType JsonFormula, P.PathsPrefixTree Behave AnIssue 'SchemaLevel) ->
43− SemanticCompatFormula ()
35+checkFormulas
36+ :: (ReassembleHList xs (CheckEnv (Referenced Schema)))
37+ => HList xs
38+ -> Behavior 'SchemaLevel
39+ -> ProdCons (Trace Schema)
40+ -> ProdCons (Traced (Definitions Schema))
41+ -> ProdCons (ForeachType JsonFormula, P.PathsPrefixTree Behave AnIssue 'SchemaLevel)
42+ -> SemanticCompatFormula ()
4443checkFormulas env beh trs defs (ProdCons (fp, ep) (fc, ec)) =
4544 case P.toList ep ++ P.toList ec of
4645 issues@(_ : _) -> for_ issues $ embedFormula beh . anItem
4746 [] -> do
4847 -- We have the following isomorphisms:
48+ -- (A ⊂ X ∪ Y) = (A ⊂ X) \/ (A ⊂ Y)
4949 -- (A ⊂ X ∩ Y) = (A ⊂ X) /\ (A ⊂ Y)
5050 -- (A ⊂ ⊤) = 1
5151 -- (X ∪ Y ⊂ B) = (X ⊂ B) /\ (Y ⊂ B)
5252 -- (∅ ⊂ B) = 1
5353 -- The remaining cases are, notably, not isomorphisms:
54− -- 1) (A ⊂ X ∪ Y) <= (A ⊂ X) \/ (A ⊂ Y)
55− -- 2) (A ⊂ ∅) <= 0
56− -- 3) (X ∩ Y ⊂ B) <= (X ⊂ B) \/ (Y ⊂ B)
57− -- 4) (⊤ ⊂ B) <= 0
58− -- Therefore we have the implications with (∃ and ∀ being the N-ary
54+ -- 1) (A ⊂ ∅) <= 0
55+ -- 2) (X ∩ Y ⊂ B) <= (X ⊂ B) \/ (Y ⊂ B)
56+ -- 3) (⊤ ⊂ B) <= 0
57+ -- Therefore we have the isomorphisms with (∃ and ∀ being the N-ary
5958 -- versions of \/ and /\ respectively):
6059 -- (⋃_i ⋂_j A[i,j]) ⊂ (⋃_k ⋂_l B[k,l])
61− -- <= ∃k ∀l ∀i, (⋂_j A[i,j]) ⊂ B[k,l]
60+ -- = ∃k ∀l ∀i, (⋂_j A[i,j]) ⊂ B[k,l]
6261 -- = ∀i ∃k ∀l, (⋂_j A[i,j]) ⊂ B[k,l]
6362 -- with the caveat that the the set over which k ranges is nonempty.
64− -- (because 2) is not an isomorphism), and that this is a sufficient
65− -- but not necessary condition (because 1) is not an isomorphism).
63+ -- This is because 1) is not an isomorphism.
6664 -- Our disjunction loses information, so it makes sense to nest it as
6765 -- deeply as possible, hence we choose the latter representation.
6866 --
6967 -- We delegate the verification of (⋂_j A[j]) ⊂ B to a separate heuristic
7068 -- function, with the understanding that ∃j, A[j] ⊂ B is a sufficient,
71− -- but not necessary condition (because of 3) and 4)).
69+ -- but not necessary condition (because of 2) and 3)).
7270 --
7371 -- If k ranges over an empty set, we have the isomorphism:
7472 -- (⋃_i ⋂_j A[i,j]) ⊂ ∅ = ∀i, (⋂_j A[i,j]) ⊂ ∅
@@ -145,21 +143,21 @@ checkFormulas env beh trs defs (ProdCons (fp, ep) (fc, ec)) =
145143 EnumDoesntSatisfy $ untypeValue e -- what does this look like when partitioned?
146144 issueFromDisjunct mPart ps = NoMatchingCondition mPart $ SomeCondition <$> S.toList ps
147145
148−checkContradiction ::
149− Behavior 'TypedSchemaLevel ->
150− Maybe Partition ->
151− S.Set (Condition t) ->
152− SemanticCompatFormula ()
146+checkContradiction
147+ :: Behavior 'TypedSchemaLevel
148+ -> Maybe Partition
149+ -> S.Set (Condition t)
150+ -> SemanticCompatFormula ()
153151checkContradiction beh mPart _ = issueAt beh $ maybe TypeBecomesEmpty PartitionBecomesEmpty mPart -- TODO #70
154152
155−checkImplication ::
156− (ReassembleHList xs (CheckEnv (Referenced Schema))) =>
157− HList xs ->
158− Behavior 'TypedSchemaLevel ->
159− ProdCons (Trace Schema) -> -- the traces of the root schemas used in this comparison
160− S.Set (Condition t) ->
161− Condition t ->
162− SemanticCompatFormula ()
153+checkImplication
154+ :: (ReassembleHList xs (CheckEnv (Referenced Schema)))
155+ => HList xs
156+ -> Behavior 'TypedSchemaLevel
157+ -> ProdCons (Trace Schema) -- the traces of the root schemas used in this comparison
158+ -> S.Set (Condition t)
159+ -> Condition t
160+ -> SemanticCompatFormula ()
163161checkImplication env beh trs prods cons = case findExactly prods of
164162 Just e
165163 | all (satisfiesTyped e) prods ->
@@ -167,104 +165,124 @@ checkImplication env beh trs prods cons = case findExactly prods of
167165 then pure ()
168166 else issueAt beh (EnumDoesntSatisfy $ untypeValue e)
169167 | otherwise -> pure () -- vacuously true
168+
170169 Nothing -> case cons of
171170 -- the above code didn't catch it, so there's no Exactly condition on the lhs
172171 Exactly e -> issueAt beh (NoMatchingEnum $ untypeValue e)
172+
173173 Maximum m -> foldCheck min m NoMatchingMaximum MatchingMaximumWeak $ \case
174174 Maximum m' -> Just m'
175175 _ -> Nothing
176+
176177 Minimum m -> foldCheck max m (NoMatchingMinimum . coerce) (MatchingMinimumWeak . coerce) $ \case
177178 Minimum m' -> Just m'
178179 _ -> Nothing
180+
179181 MultipleOf m -> foldCheck lcmScientific m NoMatchingMultipleOf MatchingMultipleOfWeak $ \case
180182 MultipleOf m' -> Just m'
181183 _ -> Nothing
184+
182185 NumberFormat f -> case flip any prods $ \case
183− NumberFormat f' -> f == f'
184− _ -> False of
186+ NumberFormat f' -> f == f'
187+ _ -> False
188+ of
185189 True -> pure ()
186190 False -> issueAt beh (NoMatchingFormat f)
191+
187192 MaxLength m -> foldCheck min m NoMatchingMaxLength MatchingMaxLengthWeak $ \case
188193 MaxLength m' -> Just m'
189194 _ -> Nothing
195+
190196 MinLength m -> foldCheck max m NoMatchingMinLength MatchingMinLengthWeak $ \case
191197 MinLength m' -> Just m'
192198 _ -> Nothing
199+
193200 Pattern p -> case flip any prods $ \case
194− Pattern p' -> p == p'
195− _ -> False of
201+ Pattern p' -> p == p'
202+ _ -> False
203+ of
196204 True -> pure ()
197205 False -> issueAt beh (NoMatchingPattern p) -- TODO: regex comparison #32
206+
198207 StringFormat f -> case flip any prods $ \case
199− StringFormat f' -> f == f'
200− _ -> False of
208+ StringFormat f' -> f == f'
209+ _ -> False
210+ of
201211 True -> pure ()
202212 False -> issueAt beh (NoMatchingFormat f)
213+
203214 Items _ cons' -> case foldSome (<>) prods $ \case
204− Items _ rs -> Just (Just (rs NE.:| []), mempty)
205− TupleItems (map snd -> fs) -> Just (mempty, Just (fs NE.:| []))
206− _ -> Nothing of
215+ Items _ rs -> Just (Just (rs NE.:| []), mempty)
216+ TupleItems (map snd -> fs) -> Just (mempty, Just (fs NE.:| []))
217+ _ -> Nothing
218+ of
207219 Just (mItems, Just pfs)
208220 | not $ allSame (length <$> pfs) -> pure () -- vacuously
209− | let plen = genericLength (NE.head pfs) ->
210− clarifyIssue (AnItem beh (anIssue TupleToArray)) $
211− for_ [0 .. plen - 1] $ \i -> do
212− let prod' = tracedConjunct $ case mItems of
213− Just prods' -> ((`genericIndex` i) <$> pfs) <> prods'
214− Nothing -> (`genericIndex` i) <$> pfs
215− checkCompatibility (beh >>> step (InItem i)) env $ ProdCons prod' cons'
221+ | let plen = genericLength (NE.head pfs)
222+ -> clarifyIssue (AnItem beh (anIssue TupleToArray)) $ for_ [0 .. plen - 1] $ \i -> do
223+ let prod' = tracedConjunct $ case mItems of
224+ Just prods' -> ((`genericIndex` i) <$> pfs) <> prods'
225+ Nothing -> (`genericIndex` i) <$> pfs
226+ checkCompatibility (beh >>> step (InItem i)) env $ ProdCons prod' cons'
216227 Just (Just prods', Nothing) -> do
217228 let prod' = tracedConjunct prods'
218229 checkCompatibility (beh >>> step InItems) env $ ProdCons prod' cons'
219230 _ -> clarifyIssue (AnItem beh (anIssue NoMatchingItems)) $ do
220231 checkCompatibility (beh >>> step InItems) env $ ProdCons prodTopSchema cons'
232+
221233 TupleItems (map snd -> fs) -> case foldSome (<>) prods $ \case
222− TupleItems (map snd -> fs') -> Just (Just $ fs' NE.:| [], Just . Max $ genericLength fs', Just . Min $ genericLength fs', mempty)
223− MinItems m' -> Just (mempty, Just . Max $ m', mempty, mempty)
224− MaxItems m' -> Just (mempty, mempty, Just . Min $ m', mempty)
225− Items _ rs -> Just (mempty, mempty, mempty, Just (rs NE.:| []))
226− _ -> Nothing of
227− -- if the length constraints in the producer are contradictory:
228− Just (_, Just (Max lowest), Just (Min highest), _) | lowest > highest -> pure ()
229− -- We have an explicit tuple items clause...
230− Just (Just pfs, Just (Max plen), _, _)
231− | plen /= genericLength fs -> -- ...of wrong length
232− issueAt beh (TupleItemsLengthChanged ProdCons {producer = plen, consumer = genericLength fs})
233− | otherwise ->
234− for_ [0 .. plen - 1] $ \i -> do
234+ TupleItems (map snd -> fs') -> Just (Just $ fs' NE.:| [], Just . Max $ genericLength fs', Just . Min $ genericLength fs', mempty)
235+ MinItems m' -> Just (mempty, Just . Max $ m', mempty, mempty)
236+ MaxItems m' -> Just (mempty, mempty, Just . Min $ m', mempty)
237+ Items _ rs -> Just (mempty, mempty, mempty, Just (rs NE.:| []))
238+ _ -> Nothing
239+ of
240+ -- if the length constraints in the producer are contradictory:
241+ Just (_, Just (Max lowest), Just (Min highest), _) | lowest > highest -> pure ()
242+ -- We have an explicit tuple items clause...
243+ Just (Just pfs, Just (Max plen), _, _)
244+ | plen /= genericLength fs -- ...of wrong length
245+ -> issueAt beh (TupleItemsLengthChanged ProdCons {producer = plen, consumer = genericLength fs})
246+ | otherwise
247+ -> for_ [0 .. plen - 1] $ \i -> do
235248 checkCompatibility (beh >>> step (InItem i)) env $ ProdCons (tracedConjunct $ (`genericIndex` i) <$> pfs) (fs `genericIndex` i)
236− -- We have a fixed length array in the producer...
237− Just (Nothing, Just (Max plen), Just (Min plen'), mProd)
238− | plen == plen' ->
239− clarifyIssue (AnItem beh (anIssue ArrayToTuple)) $ case mProd of
240− _
241− | plen /= genericLength fs -> -- ...of wrong length
242− issueAt beh (TupleItemsLengthChanged ProdCons {producer = plen, consumer = genericLength fs})
249+ -- We have a fixed length array in the producer...
250+ Just (Nothing, Just (Max plen), Just (Min plen'), mProd)
251+ | plen == plen'
252+ -> clarifyIssue (AnItem beh (anIssue ArrayToTuple)) $ case mProd of
253+ _ | plen /= genericLength fs -> -- ...of wrong length
254+ issueAt beh (TupleItemsLengthChanged ProdCons {producer = plen, consumer = genericLength fs})
243255 Just rs -> for_ [0 .. plen - 1] $ \i -> do
244256 checkCompatibility (beh >>> step (InItem i)) env $ ProdCons (tracedConjunct rs) (fs `genericIndex` i)
245257 -- ...and no "items" schema
246258 Nothing -> clarifyIssue (AnItem beh (anIssue NoMatchingTupleItems)) $ do
247259 for_ [0 .. plen - 1] $ \i -> do
248260 checkCompatibility (beh >>> step (InItem i)) env $ ProdCons prodTopSchema (fs `genericIndex` i)
249− _ -> issueAt beh NoMatchingTupleItems
261+ _ -> issueAt beh NoMatchingTupleItems
262+
250263 MaxItems m -> foldCheck min m NoMatchingMaxItems MatchingMaxItemsWeak $ \case
251264 MaxItems m' -> Just m'
252265 TupleItems fs -> Just $ toInteger $ length fs
253266 _ -> Nothing
267+
254268 MinItems m -> foldCheck max m NoMatchingMinItems MatchingMinItemsWeak $ \case
255269 MinItems m' -> Just m'
256270 TupleItems fs -> Just $ toInteger $ length fs
257271 _ -> Nothing
272+
258273 UniqueItems -> case flip any prods $ \case
259− UniqueItems -> True
260− MaxItems 1 -> True
261− TupleItems fs | length fs == 1 -> True
262− _ -> False of
274+ UniqueItems -> True
275+ MaxItems 1 -> True
276+ TupleItems fs | length fs == 1 -> True
277+ _ -> False
278+ of
263279 True -> pure ()
264280 False -> issueAt beh NoMatchingUniqueItems
281+
265282 Properties props _ madd -> case foldSome (<>) prods $ \case
266− Properties props' _ madd' -> Just $ (props', madd') NE.:| []
267− _ -> Nothing of
283+ Properties props' _ madd' -> Just $ (props', madd') NE.:| []
284+ _ -> Nothing
285+ of
268286 Just pm ->
269287 anyOfAt beh NoMatchingProperties $ -- TODO: could first "concat" the lists
270288 NE.toList pm <&> \(props', madd') -> do
@@ -295,9 +313,11 @@ checkImplication env beh trs prods cons = case findExactly prods of
295313 (Just add', Just add) -> checkCompatibility (beh >>> step InAdditionalProperty) env (ProdCons add' add)
296314 pure ()
297315 Nothing -> issueAt beh NoMatchingProperties
316+
298317 MaxProperties m -> foldCheck min m NoMatchingMaxProperties MatchingMaxPropertiesWeak $ \case
299318 MaxProperties m' -> Just m'
300319 _ -> Nothing
320+
301321 MinProperties m -> foldCheck max m NoMatchingMinProperties MatchingMinPropertiesWeak $ \case
302322 MinProperties m' -> Just m'
303323 _ -> Nothing
@@ -305,14 +325,14 @@ checkImplication env beh trs prods cons = case findExactly prods of
305325 lcmScientific (toRational -> a) (toRational -> b) =
306326 fromRational $ lcm (numerator a) (numerator b) % gcd (denominator a) (denominator b)
307327
308− foldCheck ::
309− Eq a =>
310− (a -> a -> a) ->
311− a ->
312− (a -> Issue 'TypedSchemaLevel) ->
313− (ProdCons a -> Issue 'TypedSchemaLevel) ->
314− (forall t. Condition t -> Maybe a) ->
315− SemanticCompatFormula ()
328+ foldCheck
329+ :: Eq a
330+ => (a -> a -> a)
331+ -> a
332+ -> (a -> Issue 'TypedSchemaLevel)
333+ -> (ProdCons a -> Issue 'TypedSchemaLevel)
334+ -> (forall t. Condition t -> Maybe a)
335+ -> SemanticCompatFormula ()
316336 foldCheck f m missing weak extr = case foldSome f prods extr of
317337 Just m'
318338 | f m' m == m' -> pure ()