@@ -7,15 +7,17 @@ where
77import Control.Monad.Writer
88import qualified Data.Aeson as A
99import Data.Coerce
10−import Data.Foldable (for_)
10+import Data.Foldable (for_, toList)
1111import Data.Functor
1212import Data.HList
1313import qualified Data.List.NonEmpty as NE
1414import qualified Data.Map as M
15+import Data.List (group, genericLength, genericIndex)
1516import Data.Maybe
1617import Data.OpenApi
1718import Data.Ord
1819import Data.Ratio
20+import Data.Semigroup
1921import qualified Data.Set as S
2022import Data.Text (Text)
2123import OpenAPI.Checker.Behavior
@@ -34,10 +36,11 @@ checkFormulas
3436 :: (ReassembleHList xs (CheckEnv (Referenced Schema)))
3537 => HList xs
3638 -> Behavior 'SchemaLevel
39+ -> ProdCons (Trace Schema)
3740 -> ProdCons (Traced (Definitions Schema))
3841 -> ProdCons (ForeachType JsonFormula, P.PathsPrefixTree Behave AnIssue 'SchemaLevel)
3942 -> SemanticCompatFormula ()
40−checkFormulas env beh defs (ProdCons (fp, ep) (fc, ec)) =
43+checkFormulas env beh trs defs (ProdCons (fp, ep) (fc, ec)) =
4144 case P.toList ep ++ P.toList ec of
4245 issues@(_ : _) -> for_ issues $ embedFormula beh . anItem
4346 [] -> do
@@ -105,25 +108,25 @@ checkFormulas env beh defs (ProdCons (fp, ep) (fc, ec)) =
105108 -- don't repeat the TypesRestricted issue
106109 for_ pss $ \(Disjunct ps) -> checkContradiction beh' Nothing ps
107110 (DNF pss, SingleDisjunct (Disjunct cs)) -> for_ pss $ \(Disjunct ps) -> do
108− for_ cs $ checkImplication env beh' ps -- avoid disjunction if there's only one conjunct
111+ for_ cs $ checkImplication env beh' trs ps -- avoid disjunction if there's only one conjunct
109112 (TopDNF, DNF css) ->
110113 -- producer is "open" (allows any value), but consumer has restrictions.
111114 -- In this case we want to show which restrictions were added. (instead
112115 -- of showing an empty list restrictions that couldn't be satisfied.)
113− for_ css $ \(Disjunct cs) -> for_ cs $ checkImplication env beh' S.empty
116+ for_ css $ \(Disjunct cs) -> for_ cs $ checkImplication env beh' trs S.empty
114117 (pss', css') -> for_ (tryPartition defs $ ProdCons (JsonFormula pss') (JsonFormula css')) $ \case
115118 (mPart, ProdCons pf cf) -> do
116119 let beh'' = foldr ((<<<) . step . InPartition) beh' mPart
117120 case (getJsonFormula pf, getJsonFormula cf) of
118121 (DNF pss, BottomDNF) -> for_ pss $ \(Disjunct ps) -> checkContradiction beh' mPart ps
119122 (DNF pss, SingleDisjunct (Disjunct cs)) -> for_ pss $ \(Disjunct ps) -> do
120− for_ cs $ checkImplication env beh'' ps
123+ for_ cs $ checkImplication env beh'' trs ps
121124 -- unlucky:
122125 (DNF pss, DNF css) -> for_ pss $ \(Disjunct ps) -> do
123126 anyOfAt
124127 beh'
125128 (issueFromDisjunct Nothing ps)
126− [for_ cs $ checkImplication env beh' ps | Disjunct cs <- S.toList css]
129+ [for_ cs $ checkImplication env beh' trs ps | Disjunct cs <- S.toList css]
127130 pure ()
128131 where
129132 anyBottomTypes f = getAny $
@@ -151,10 +154,11 @@ checkImplication
151154 :: (ReassembleHList xs (CheckEnv (Referenced Schema)))
152155 => HList xs
153156 -> Behavior 'TypedSchemaLevel
157+ -> ProdCons (Trace Schema) -- the traces of the root schemas used in this comparison
154158 -> S.Set (Condition t)
155159 -> Condition t
156160 -> SemanticCompatFormula ()
157−checkImplication env beh prods cons = case findExactly prods of
161+checkImplication env beh trs prods cons = case findExactly prods of
158162 Just e
159163 | all (satisfiesTyped e) prods ->
160164 if satisfiesTyped e cons
@@ -208,24 +212,69 @@ checkImplication env beh prods cons = case findExactly prods of
208212 False -> issueAt beh (NoMatchingFormat f)
209213
210214 Items _ cons' -> case foldSome (<>) prods $ \case
211− Items _ rs -> Just (rs NE.:| [])
215+ Items _ rs -> Just (Just (rs NE.:| []), mempty)
216+ TupleItems (map snd -> fs) -> Just (mempty, Just (fs NE.:| []))
212217 _ -> Nothing
213218 of
214− Just (tracedConjunct -> rs) -> checkCompatibility (beh >>> step InItems) env $ ProdCons rs cons'
215− Nothing -> issueAt beh NoMatchingItems
219+ Just (mItems, Just pfs)
220+ | not $ allSame (length <$> pfs) -> pure () -- vacuously
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'
227+ Just (Just prods', Nothing) -> do
228+ let prod' = tracedConjunct prods'
229+ checkCompatibility (beh >>> step InItems) env $ ProdCons prod' cons'
230+ _ -> clarifyIssue (AnItem beh (anIssue NoMatchingItems)) $ do
231+ checkCompatibility (beh >>> step InItems) env $ ProdCons prodTopSchema cons'
232+
233+ TupleItems (map snd -> fs) -> case foldSome (<>) prods $ \case
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
248+ checkCompatibility (beh >>> step (InItem i)) env $ ProdCons (tracedConjunct $ (`genericIndex` i) <$> pfs) (fs `genericIndex` i)
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})
255+ Just rs -> for_ [0 .. plen - 1] $ \i -> do
256+ checkCompatibility (beh >>> step (InItem i)) env $ ProdCons (tracedConjunct rs) (fs `genericIndex` i)
257+ -- ...and no "items" schema
258+ Nothing -> clarifyIssue (AnItem beh (anIssue NoMatchingTupleItems)) $ do
259+ for_ [0 .. plen - 1] $ \i -> do
260+ checkCompatibility (beh >>> step (InItem i)) env $ ProdCons prodTopSchema (fs `genericIndex` i)
261+ _ -> issueAt beh NoMatchingTupleItems
216262
217263 MaxItems m -> foldCheck min m NoMatchingMaxItems MatchingMaxItemsWeak $ \case
218264 MaxItems m' -> Just m'
265+ TupleItems fs -> Just $ toInteger $ length fs
219266 _ -> Nothing
220267
221268 MinItems m -> foldCheck max m NoMatchingMinItems MatchingMinItemsWeak $ \case
222269 MinItems m' -> Just m'
223− _ -> Nothing -- TODO: tuple items
270+ TupleItems fs -> Just $ toInteger $ length fs
271+ _ -> Nothing
224272
225273 UniqueItems -> case flip any prods $ \case
226274 UniqueItems -> True
227275 MaxItems 1 -> True
228− _ -> False -- TODO: tuple items
276+ TupleItems fs | length fs == 1 -> True
277+ _ -> False
229278 of
230279 True -> pure ()
231280 False -> issueAt beh NoMatchingUniqueItems
@@ -290,6 +339,14 @@ checkImplication env beh prods cons = case findExactly prods of
290339 | otherwise -> issueAt beh (weak ProdCons {producer = m', consumer = m})
291340 Nothing -> issueAt beh (missing m)
292341
342+ prodTopSchema = traced (producer trs >>> step ImplicitTopSchema) $ Inline mempty
343+
344+allSame :: (Foldable f, Eq a) => f a -> Bool
345+allSame xs = case group (toList xs) of
346+ [] -> True
347+ [_] -> True
348+ _ -> False
349+
293350foldSome :: (b -> b -> b) -> S.Set a -> (a -> Maybe b) -> Maybe b
294351foldSome combine xs extr =
295352 fmap (foldr1 combine) . NE.nonEmpty . mapMaybe extr . S.toList $ xs
@@ -353,7 +410,7 @@ instance Subtree Schema where
353410 structuralItems _ = structuralIssue
354411 checkSemanticCompatibility env beh schs = do
355412 let defs = getH env
356− checkFormulas env beh defs $ schemaToFormula <$> defs <*> schs
413+ checkFormulas env beh (ask <$> schs) defs $ schemaToFormula <$> defs <*> schs
357414
358415parseDiscriminatorValue :: Text -> Referenced Schema
359416parseDiscriminatorValue v = case A.fromJSON @(Referenced Schema) $ A.object ["$ref" A..= v] of