@@ -1,1627 +0,0 @@
1โ{-# OPTIONS_GHC -fno-warn-orphans #-}
3โmodule OpenAPI.Checker.Validate.Schema
18โimport Algebra.Lattice
19โimport Algebra.Lattice.Lifted
20โimport Control.Applicative
21โimport Control.Arrow
22โimport Control.Comonad.Env hiding (env)
23โimport Control.Monad.Reader hiding (ask)
24โimport qualified Control.Monad.Reader as R
25โimport Control.Monad.State
26โimport qualified Control.Monad.Trans.Reader as R (liftCatch)
27โimport qualified Control.Monad.Trans.Writer as W (liftCatch)
28โimport Control.Monad.Writer
29โimport qualified Data.Aeson as A
30โimport qualified Data.ByteString.Lazy as BSL
32โimport Data.Foldable
33โimport qualified Data.Foldable as F
35โimport Data.Functor.Identity
37โimport qualified Data.HashMap.Strict as HM
38โimport qualified Data.HashMap.Strict.InsOrd as IOHM
41โimport Data.List (sortBy)
42โimport qualified Data.List as L
43โimport qualified Data.List.NonEmpty as NE
44โimport qualified Data.Map as M
46โimport Data.OpenApi hiding (get)
49โimport Data.Scientific
50โimport qualified Data.Set as S
52โimport Data.Text (Text)
53โimport qualified Data.Text as T hiding (singleton)
54โimport qualified Data.Text.Encoding as T
55โimport Data.Typeable
56โimport OpenAPI.Checker.Behavior
57โimport OpenAPI.Checker.Memo
58โimport OpenAPI.Checker.Orphans ()
59โimport OpenAPI.Checker.Paths
60โimport qualified OpenAPI.Checker.PathsPrefixTree as P
61โimport OpenAPI.Checker.References
62โimport OpenAPI.Checker.Subtree
63โimport Text.Pandoc.Builder hiding (Format, Null)
64โimport Text.Regex.Pcre2
66โ-- | Type of a JSON value
74โ deriving stock (Eq, Ord, Show)
76โ-- | A 'A.Value' whose type we know
77โdata TypedValue :: JsonType -> Type where
78โ TNull :: TypedValue 'Null
79โ TBool :: !Bool -> TypedValue 'Boolean
80โ TNumber :: !Scientific -> TypedValue 'Number
81โ TString :: !Text -> TypedValue 'String
82โ TArray :: !A.Array -> TypedValue 'Array
83โ TObject :: !A.Object -> TypedValue 'Object
85โderiving stock instance Eq (TypedValue t)
87โderiving stock instance Ord (TypedValue t)
89โderiving stock instance Show (TypedValue t)
91โuntypeValue :: TypedValue t -> A.Value
92โuntypeValue TNull = A.Null
93โuntypeValue (TBool b) = A.Bool b
94โuntypeValue (TNumber n) = A.Number n
95โuntypeValue (TString s) = A.String s
96โuntypeValue (TArray a) = A.Array a
97โuntypeValue (TObject o) = A.Object o
99โdata Bound a = Exclusive !a | Inclusive !a
100โ deriving stock (Eq, Show, Functor)
102โ-- | The order is lexicographical on @a * Bool@.
103โinstance Ord a => Ord (Bound a) where
104โ Exclusive a `compare` Exclusive b = compare a b
105โ Exclusive a `compare` Inclusive b = if a <= b then LT else GT
106โ Inclusive a `compare` Exclusive b = if a < b then LT else GT
107โ Inclusive a `compare` Inclusive b = compare a b
109โdata Property = Property
110โ { propRequired :: Bool
111โ , propFormula :: ForeachType JsonFormula
112โ , propRefSchema :: Traced (Referenced Schema)
114โ deriving stock (Eq, Ord, Show)
116โ-- | A primitive structural condition for the "top level" of a JSON value (of a specific type)
117โdata Condition :: JsonType -> Type where
118โ Exactly :: TypedValue t -> Condition t
119โ Maximum :: !(Bound Scientific) -> Condition 'Number
121โ :: !(Down (Bound (Down Scientific)))
122โ -> Condition 'Number -- ^ this has the right Ord
123โ MultipleOf :: !Scientific -> Condition 'Number
124โ NumberFormat :: !Format -> Condition 'Number
125โ MaxLength :: !Integer -> Condition 'String
126โ MinLength :: !Integer -> Condition 'String
127โ Pattern :: !Pattern -> Condition 'String
128โ StringFormat :: !Format -> Condition 'String
130โ :: !(ForeachType JsonFormula)
131โ -> !(Traced (Referenced Schema))
132โ -> Condition 'Array
133โ MaxItems :: !Integer -> Condition 'Array
134โ MinItems :: !Integer -> Condition 'Array
135โ UniqueItems :: Condition 'Array
137โ :: !(M.Map Text Property)
138โ -> !(ForeachType JsonFormula) -- ^ formula for additional properties
139โ -> !(Maybe (Traced (Referenced Schema))) -- ^ schema for additional properties, Nothing means bottom
140โ -> Condition 'Object
141โ MaxProperties :: !Integer -> Condition 'Object
142โ MinProperties :: !Integer -> Condition 'Object
144โshowCondition :: Condition a -> Blocks
145โshowCondition = \case
146โ (Exactly v) -> para "The value should be:" <> showJSONValue (untypeValue v)
147โ (Maximum b) -> para $ "The value should be less than " <> showBound b <> "."
148โ (Minimum (Down b)) -> para $ "The value should be more than " <> showBound (getDown <$> b) <> "."
149โ (MultipleOf n) -> para $ "The value should be a multiple of " <> show' n <> "."
150โ (NumberFormat p) -> para $ "The number should have the following format:" <> code p <> "."
151โ (Pattern p) -> para "The value should satisfy the following pattern (regular expression):" <> codeBlock p
152โ (StringFormat p) -> para $ "The string should have the following format:" <> code p <> "."
153โ (MaxLength p) -> para $ "The length of the string should be less than or equal to " <> show' p <> "."
154โ (MinLength p) -> para $ "The length of the string should be more than or equal to " <> show' p <> "."
155โ (Items i _) -> para "The items of the array should satisfy:" <> showForEachJsonFormula i
156โ (MaxItems n) -> para $ "The length of the array should be less than or equal to " <> show' n <> "."
157โ (MinItems n) -> para $ "The length of the array should be more than or equal to " <> show' n <> "."
158โ UniqueItems -> para "The elements in the array should be unique."
159โ (Properties props additional _) ->
164โ <> para (strong $ if propRequired p then "Required" else "Optional")
165โ <> showForEachJsonFormula (propFormula p)))
166โ <> [ para (emph "Additional properties")
167โ <> showForEachJsonFormula additional
169โ (MaxProperties n) -> para $ "The maximum number of fields should be " <> show' n <> "."
170โ (MinProperties n) -> para $ "The minimum number of fields should be " <> show' n <> "."
172โ showForEachJsonFormula :: ForeachType JsonFormula -> Blocks
173โ showForEachJsonFormula i =
176โ (\t f -> case getJsonFormula $ f i of
177โ BottomFormula -> mempty
179โ let conds = S.toList <$> S.toList conds'
180โ in [ para (describeJSONType t)
183โ [] -> para "Empty"
184โ cond -> bulletList (showCondition <$> cond))
187โsatisfiesTyped :: TypedValue t -> Condition t -> Bool
188โsatisfiesTyped e (Exactly e') = e == e'
189โsatisfiesTyped (TNumber n) (Maximum (Exclusive m)) = n < m
190โsatisfiesTyped (TNumber n) (Maximum (Inclusive m)) = n <= m
191โsatisfiesTyped (TNumber n) (Minimum (Down (Exclusive (Down m)))) = n > m
192โsatisfiesTyped (TNumber n) (Minimum (Down (Inclusive (Down m)))) = n >= m
193โsatisfiesTyped (TNumber n) (MultipleOf m) = denominator (toRational n / toRational m) == 1 -- TODO: could be better #36
194โsatisfiesTyped (TNumber n) (NumberFormat f) = checkNumberFormat f n
195โsatisfiesTyped (TString s) (MaxLength m) = fromIntegral (T.length s) <= m
196โsatisfiesTyped (TString s) (MinLength m) = fromIntegral (T.length s) >= m
197โsatisfiesTyped (TString s) (Pattern p) = isJust $ match p s -- TODO: regex stuff #32
198โsatisfiesTyped (TString s) (StringFormat f) = checkStringFormat f s
199โsatisfiesTyped (TArray a) (Items f _) = all (`satisfies` f) a
200โsatisfiesTyped (TArray a) (MaxItems m) = fromIntegral (F.length a) <= m
201โsatisfiesTyped (TArray a) (MinItems m) = fromIntegral (F.length a) >= m
202โsatisfiesTyped (TArray a) UniqueItems = S.size (S.fromList $ F.toList a) == F.length a -- TODO: could be better #36
203โsatisfiesTyped (TObject o) (Properties props additional _) =
204โ all (`HM.member` o) (M.keys (M.filter propRequired props))
205โ && all (\(k, v) -> satisfies v $ maybe additional propFormula $ M.lookup k props) (HM.toList o)
206โsatisfiesTyped (TObject o) (MaxProperties m) = fromIntegral (HM.size o) <= m
207โsatisfiesTyped (TObject o) (MinProperties m) = fromIntegral (HM.size o) >= m
209โcheckNumberFormat :: Format -> Scientific -> Bool
210โcheckNumberFormat "int32" (toRational -> n) =
211โ denominator n == 1
212โ && n >= toRational (minBound :: Int32)
213โ && n <= toRational (maxBound :: Int32)
214โcheckNumberFormat "int64" (toRational -> n) =
215โ denominator n == 1
216โ && n >= toRational (minBound :: Int64)
217โ && n <= toRational (maxBound :: Int64)
218โcheckNumberFormat "float" _n = True
219โcheckNumberFormat "double" _n = True
220โcheckNumberFormat f _n = error $ "Invalid number format: " <> T.unpack f
222โcheckStringFormat :: Format -> Text -> Bool
223โcheckStringFormat "byte" _s = True -- TODO: regex stuff #32
224โcheckStringFormat "binary" _s = True
225โcheckStringFormat "date" _s = True
226โcheckStringFormat "date-time" _s = True
227โcheckStringFormat "password" _s = True
228โcheckStringFormat "uuid" _s = True
229โcheckStringFormat f _s = error $ "Invalid string format: " <> T.unpack f
231โderiving stock instance Eq (Condition t)
233โderiving stock instance Ord (Condition t)
235โderiving stock instance Show (Condition t)
237โdata SomeCondition where
238โ SomeCondition :: Typeable t => Condition t -> SomeCondition
240โinstance Eq SomeCondition where
241โ SomeCondition x == SomeCondition y = case cast x of
242โ Just x' -> x' == y
245โinstance Ord SomeCondition where
246โ compare (SomeCondition x) (SomeCondition y) = case cast x of
247โ Just x' -> compare x' y
248โ Nothing -> compare (typeRep x) (typeRep y)
250โderiving stock instance Show SomeCondition
252โ-- | A boolean formula (without "not") represented as a Disjunctive Normal Form:
253โ-- the formula is a disjunction of a set of conjuncts, each of which is a
254โ-- conjunction of a set of some elementary formulas.
256โ = DNF (S.Set (S.Set a))
257โ deriving stock (Eq, Ord, Show)
259โdisjAdd :: Ord a => DNF a -> S.Set a -> DNF a
260โdisjAdd (DNF yss) xs
261โ | any (`S.isSubsetOf` xs) yss = DNF yss
262โ | otherwise = DNF $ S.insert xs $ S.filter (not . S.isSubsetOf xs) yss
264โinstance Ord a => Lattice (DNF a) where
265โ xss \/ DNF yss = S.foldl' disjAdd xss yss
266โ DNF xss /\ DNF yss =
267โ F.foldl' disjAdd bottom $
268โ liftA2 S.union (S.toList xss) (S.toList yss)
270โpattern BottomFormula :: DNF a
271โpattern BottomFormula <-
272โ DNF (S.null -> True)
274โ BottomFormula = DNF S.empty
276โisSingleton :: S.Set a -> Maybe a
278โ | S.size s == 1 = S.lookupMin s
279โ | otherwise = Nothing
281โpattern Conjunct :: Ord a => [a] -> S.Set a
282โpattern Conjunct xs <-
285โ Conjunct = S.fromList
287โ{-# COMPLETE Conjunct #-}
289โpattern SingleConjunct :: Ord a => [a] -> DNF a
290โpattern SingleConjunct xs <-
291โ DNF (isSingleton -> Just (Conjunct xs))
293โ SingleConjunct xs = DNF $ S.singleton $ Conjunct xs
295โpattern TopFormula :: DNF a
296โpattern TopFormula <-
297โ DNF (isSingleton -> Just (S.null -> True))
299โ TopFormula = DNF $ S.singleton S.empty
301โinstance Ord a => BoundedJoinSemiLattice (DNF a) where
302โ bottom = BottomFormula
304โinstance Ord a => BoundedMeetSemiLattice (DNF a) where
308โ :: BoundedLattice l
312โfoldLattice f (DNF xss) =
315โ z \/ S.foldl' (\x y -> x /\ f y) top w)
319โnewtype JsonFormula t = JsonFormula {getJsonFormula :: DNF (Condition t)}
320โ deriving stock (Eq, Ord, Show)
321โ deriving newtype (Lattice, BoundedJoinSemiLattice, BoundedMeetSemiLattice)
323โsatisfiesFormula :: TypedValue t -> JsonFormula t -> Bool
324โsatisfiesFormula val = foldLattice (satisfiesTyped val) . getJsonFormula
326โdata ForeachType (f :: JsonType -> Type) = ForeachType
327โ { forNull :: f 'Null
328โ , forBoolean :: f 'Boolean
329โ , forNumber :: f 'Number
330โ , forString :: f 'String
331โ , forArray :: f 'Array
332โ , forObject :: f 'Object
335โsatisfies :: A.Value -> ForeachType JsonFormula -> Bool
336โsatisfies val p = case val of
337โ A.Null -> satisfiesFormula TNull $ forNull p
338โ A.Bool b -> satisfiesFormula (TBool b) $ forBoolean p
339โ A.Number n -> satisfiesFormula (TNumber n) $ forNumber p
340โ A.String s -> satisfiesFormula (TString s) $ forString p
341โ A.Array a -> satisfiesFormula (TArray a) $ forArray p
342โ A.Object o -> satisfiesFormula (TObject o) $ forObject p
344โderiving stock instance (forall x. Typeable x => Eq (f x)) => Eq (ForeachType f)
346โderiving stock instance (forall x. Typeable x => Ord (f x)) => Ord (ForeachType f)
348โderiving stock instance (forall x. Typeable x => Show (f x)) => Show (ForeachType f)
352โ => (forall x. Typeable x => JsonType -> (ForeachType f -> f x) -> m)
356โ <> k Boolean forBoolean
357โ <> k Number forNumber
358โ <> k String forString
359โ <> k Array forArray
360โ <> k Object forObject
364โ => (forall x. Typeable x => JsonType -> (ForeachType f -> f x) -> m ())
368โ k Boolean forBoolean
369โ k Number forNumber
370โ k String forString
372โ k Object forObject
375โinstance (forall x. Lattice (f x)) => Lattice (ForeachType f) where
378โ { forNull = forNull f1 \/ forNull f2
379โ , forBoolean = forBoolean f1 \/ forBoolean f2
380โ , forNumber = forNumber f1 \/ forNumber f2
381โ , forString = forString f1 \/ forString f2
382โ , forArray = forArray f1 \/ forArray f2
383โ , forObject = forObject f1 \/ forObject f2
387โ { forNull = forNull f1 /\ forNull f2
388โ , forBoolean = forBoolean f1 /\ forBoolean f2
389โ , forNumber = forNumber f1 /\ forNumber f2
390โ , forString = forString f1 /\ forString f2
391โ , forArray = forArray f1 /\ forArray f2
392โ , forObject = forObject f1 /\ forObject f2
396โ (forall x. BoundedJoinSemiLattice (f x))
397โ => BoundedJoinSemiLattice (ForeachType f)
401โ { forNull = bottom
402โ , forBoolean = bottom
403โ , forNumber = bottom
404โ , forString = bottom
405โ , forArray = bottom
406โ , forObject = bottom
410โ (forall x. BoundedMeetSemiLattice (f x))
411โ => BoundedMeetSemiLattice (ForeachType f)
416โ , forBoolean = top
423โinstance Steppable Schema (Referenced Schema) where
424โ data Step Schema (Referenced Schema)
429โ | ItemsArrayStep Int
430โ | AdditionalPropertiesStep
432โ deriving stock (Eq, Ord, Show)
434โinstance Steppable (Referenced Schema) (Referenced Schema) where
435โ data Step (Referenced Schema) (Referenced Schema)
436โ = -- | Invariant (for better memoization only): the "tail" of the trace is
437โ -- the "least" of the traces of the conjuncted schemata
438โ ConjunctedWith (NE.NonEmpty (Trace (Referenced Schema)))
439โ | Partitioned PartitionLocation PartitionChoice
440โ deriving stock (Eq, Ord, Show)
442โinstance Steppable Schema (Definitions (Referenced Schema)) where
443โ data Step Schema (Definitions (Referenced Schema)) = PropertiesStep
444โ deriving stock (Eq, Ord, Show)
446โinstance Steppable Schema Discriminator where
447โ data Step Schema Discriminator = DiscriminatorStep
448โ deriving stock (Eq, Ord, Show)
450โinstance Steppable Discriminator (Definitions (Referenced Schema)) where
451โ data Step Discriminator (Definitions (Referenced Schema)) = DiscriminatorMapping
452โ deriving stock (Eq, Ord, Show)
454โparseDiscriminatorValue :: Text -> Referenced Schema
455โparseDiscriminatorValue v = case A.fromJSON @(Referenced Schema) $ A.object ["$ref" A..= v] of
457โ A.Error _ -> Ref $ Reference v
459โ-- | A fake writer monad that doesn't actually record anything and allows lazy recursion.
460โnewtype Silent q f r a = Silent {runSilent :: a}
461โ deriving stock (Functor)
462โ deriving (Applicative, Monad) via Identity
464โinstance MonadWriter (P.PathsPrefixTree q f r) (Silent q f r) where
465โ tell _ = Silent ()
466โ listen (Silent x) = Silent (x, P.empty)
467โ pass (Silent (x, _)) = Silent x
469โinstance MonadState (MemoState ()) (Silent q f r) where
470โ get = Silent $ runIdentity $ runMemo () get
473โtype MonadProcess m =
474โ ( MonadReader (Traced (Definitions Schema)) m
475โ , MonadWriter (P.PathsPrefixTree Behave AnIssue 'SchemaLevel) m
476โ , MonadState (MemoState ()) m
479โtype SilentM = ReaderT (Traced (Definitions Schema)) (Silent Behave AnIssue 'SchemaLevel)
481โwarn :: MonadProcess m => Issue 'SchemaLevel -> m ()
482โwarn issue = tell $ P.singleton $ AnItem Root $ anIssue issue
484โ-- | Ignore warnings but allow a recursive loop that lazily computes a recursive 'Condition'.
485โsilently :: MonadProcess m => SilentM a -> m a
488โ pure . runSilent $ runReaderT m defs
490โwarnKnot :: MonadProcess m => KnotTier (ForeachType JsonFormula) () m
493โ { onKnotFound = warn UnguardedRecursion
494โ , onKnotUsed = \_ -> pure bottom
495โ , tieKnot = \_ -> pure
500โ => Traced (Referenced Schema)
501โ -> m (ForeachType JsonFormula)
502โprocessRefSchema x = do
504โ memoWithKnot warnKnot (processSchema $ dereference defs x) (ask x)
506โtracedAllOf :: Traced Schema -> Maybe [Traced (Referenced Schema)]
508โ _schemaAllOf (extract sch) <&> \xs ->
509โ [traced (ask sch >>> step (AllOfStep i)) x | (i, x) <- zip [0 ..] xs]
511โtracedAnyOf :: Traced Schema -> Maybe [Traced (Referenced Schema)]
513โ _schemaAnyOf (extract sch) <&> \xs ->
514โ [traced (ask sch >>> step (AnyOfStep i)) x | (i, x) <- zip [0 ..] xs]
516โtracedOneOf :: Traced Schema -> Maybe [Traced (Referenced Schema)]
518โ _schemaOneOf (extract sch) <&> \xs ->
519โ [traced (ask sch >>> step (OneOfStep i)) x | (i, x) <- zip [0 ..] xs]
521โtracedItems :: Traced Schema -> Maybe (Either (Traced (Referenced Schema)) [Traced (Referenced Schema)])
523โ _schemaItems (extract sch) <&> \case
524โ OpenApiItemsObject x -> Left $ traced (ask sch >>> step ItemsObjectStep) x
525โ OpenApiItemsArray xs ->
527โ [traced (ask sch >>> step (ItemsArrayStep i)) x | (i, x) <- zip [0 ..] xs]
529โtracedAdditionalProperties :: Traced Schema -> Maybe (Either Bool (Traced (Referenced Schema)))
530โtracedAdditionalProperties sch =
531โ _schemaAdditionalProperties (extract sch) <&> \case
532โ AdditionalPropertiesAllowed b -> Left b
533โ AdditionalPropertiesSchema x -> Right $ traced (ask sch >>> step AdditionalPropertiesStep) x
535โtracedDiscriminator :: Traced Schema -> Maybe (Traced Discriminator)
536โtracedDiscriminator = sequence . stepTraced DiscriminatorStep . fmap _schemaDiscriminator
538โtracedProperties :: Traced Schema -> IOHM.InsOrdHashMap Text (Traced (Referenced Schema))
539โtracedProperties sch =
541โ (\k -> traced (ask sch >>> step PropertiesStep >>> step (InsOrdHashMapKeyStep k)))
542โ (_schemaProperties $ extract sch)
544โ-- | Turn a schema into a tuple of 'JsonFormula's that describes the condition
545โ-- for every possible type of a JSON value. The conditions are independent, and
546โ-- are thus checked independently.
550โ -> m (ForeachType JsonFormula)
551โprocessSchema sch@(extract -> Schema {..}) = do
552โ let singletonFormula :: Condition t -> JsonFormula t
553โ singletonFormula f = JsonFormula $ SingleConjunct [f]
555โ allClauses <- case tracedAllOf sch of
556โ Nothing -> pure []
557โ Just [] -> [] <$ warn (InvalidSchema "no items in allOf")
558โ Just xs -> mapM processRefSchema xs
560โ anyClause <- case tracedAnyOf sch of
561โ Nothing -> pure top
562โ Just [] -> bottom <$ warn (InvalidSchema "no items in anyOf")
563โ Just xs -> joins <$> mapM processRefSchema xs
565โ oneClause <- case tracedOneOf sch of
566โ Nothing -> pure top
567โ Just [] -> bottom <$ warn (InvalidSchema "no items in oneOf")
569โ checkOneOfDisjoint xs >>= \case
571โ False -> warn (NotSupported "Could not determine that oneOf branches are disjoint")
572โ joins <$> mapM processRefSchema xs
574โ case _schemaNot of
575โ Nothing -> pure ()
576โ Just _ -> warn (NotSupported "not clause is unsupported")
578โ let typeClause = case _schemaType of
580โ Just OpenApiNull ->
584โ Just OpenApiBoolean ->
586โ { forBoolean = top
588โ Just OpenApiNumber ->
592โ Just OpenApiInteger ->
594โ { forNumber = singletonFormula $ MultipleOf 1
596โ Just OpenApiString ->
600โ Just OpenApiArray ->
604โ Just OpenApiObject ->
609โ let valueEnum A.Null =
611โ { forNull = singletonFormula $ Exactly TNull
613โ valueEnum (A.Bool b) =
615โ { forBoolean = singletonFormula $ Exactly $ TBool b
617โ valueEnum (A.Number n) =
619โ { forNumber = singletonFormula $ Exactly $ TNumber n
621โ valueEnum (A.String s) =
623โ { forString = singletonFormula $ Exactly $ TString s
625โ valueEnum (A.Array a) =
627โ { forArray = singletonFormula $ Exactly $ TArray a
629โ valueEnum (A.Object o) =
631โ { forObject = singletonFormula $ Exactly $ TObject o
633โ enumClause <- case _schemaEnum of
634โ Nothing -> pure top
635โ Just [] -> bottom <$ warn (InvalidSchema "no items in enum")
636โ Just xs -> pure $ joins (valueEnum <$> xs)
638โ let maximumClause = case _schemaMaximum of
642โ { forNumber = singletonFormula $
644โ case _schemaExclusiveMaximum of
645โ Just True -> Exclusive n
649โ minimumClause = case _schemaMinimum of
653โ { forNumber = singletonFormula $
656โ case _schemaExclusiveMinimum of
657โ Just True -> Exclusive $ Down n
658โ _ -> Inclusive $ Down n
661โ multipleOfClause = case _schemaMultipleOf of
665โ { forNumber = singletonFormula $ MultipleOf n
668โ formatClause <- case _schemaFormat of
669โ Nothing -> pure top
671โ | f `elem` ["int32", "int64", "float", "double"] ->
674โ { forNumber = singletonFormula $ NumberFormat f
677โ | f `elem` ["byte", "binary", "date", "date-time", "password", "uuid"] ->
680โ { forString = singletonFormula $ StringFormat f
682โ Just f -> top <$ warn (NotSupported $ "Unknown format: " <> f)
684โ let maxLengthClause = case _schemaMaxLength of
688โ { forString = singletonFormula $ MaxLength n
691โ minLengthClause = case _schemaMinLength of
695โ { forString = singletonFormula $ MinLength n
698โ patternClause = case _schemaPattern of
702โ { forString = singletonFormula $ Pattern p
705โ itemsClause <- case tracedItems sch of
706โ Nothing -> pure top
707โ Just (Left rs) -> do
708โ f <- silently $ processRefSchema rs
709โ pure top {forArray = singletonFormula $ Items f rs}
710โ Just (Right _) -> top <$ warn (NotSupported "array in items is not supported")
712โ let maxItemsClause = case _schemaMaxItems of
716โ { forArray = singletonFormula $ MaxItems n
719โ minItemsClause = case _schemaMinItems of
723โ { forArray = singletonFormula $ MinItems n
726โ uniqueItemsClause = case _schemaUniqueItems of
729โ { forArray = singletonFormula UniqueItems
733โ (addProps, addPropSchema) <- case tracedAdditionalProperties sch of
734โ Just (Right rs) -> (,Just rs) <$> silently (processRefSchema rs)
735โ Just (Left False) -> pure (bottom, Nothing)
736โ _ -> pure (top, Just $ traced (ask sch `Snoc` AdditionalPropertiesStep) $ Inline mempty)
737โ propList <- forM (S.toList . S.fromList $ IOHM.keys _schemaProperties <> _schemaRequired) $ \k -> do
738โ (f, psch) <- case IOHM.lookup k $ tracedProperties sch of
739โ Just rs -> (,rs) <$> silently (processRefSchema rs)
741โ let fakeSchema = traced (ask sch `Snoc` AdditionalPropertiesStep) $ Inline mempty
742โ in -- The mempty here is incorrect, but if addPropSchema was Nothing, then
743โ -- addProps is bottom, and k is in _schemaRequired. We handle this situation
744โ -- below and short-circuit the entire Properties condition to bottom
745โ pure (addProps, fromMaybe fakeSchema addPropSchema)
746โ pure (k, Property (k `elem` _schemaRequired) f psch)
747โ let allBottom f = getAll $
748โ foldType $ \_ ty -> case getJsonFormula $ ty f of
749โ BottomFormula -> All True
751โ allTop f = getAll $
752โ foldType $ \_ ty -> case getJsonFormula $ ty f of
753โ TopFormula -> All True
755โ -- remove optional fields whose schemata match that of additional props
756โ propMap = M.filter (\p -> propRequired p || propFormula p /= addProps) $ M.fromList propList
758โ | any (\p -> propRequired p && allBottom (propFormula p)) propMap =
759โ bottom -- if any required field has unsatisfiable schema
761โ , allTop addProps =
762โ top -- if all fields are optional and have trivial schemata
765โ { forObject = singletonFormula $ Properties propMap addProps addPropSchema
768โ maxPropertiesClause = case _schemaMaxProperties of
772โ { forObject = singletonFormula $ MaxProperties n
775โ minPropertiesClause = case _schemaMinProperties of
779โ { forObject = singletonFormula $ MinProperties n
783โ | Just True <- _schemaNullable =
785โ { forNull = singletonFormula $ Exactly TNull
787โ | otherwise = bottom
799โ , multipleOfClause
807โ , uniqueItemsClause
808โ , propertiesClause
809โ , maxPropertiesClause
810โ , minPropertiesClause
813โ{- TODO: ReadOnly/WriteOnly #68 -}
815โcheckOneOfDisjoint :: MonadProcess m => [Traced (Referenced Schema)] -> m Bool
816โcheckOneOfDisjoint = const $ pure True -- TODO #69
819โ :: Traced (Definitions Schema)
821โ -> (ForeachType JsonFormula, P.PathsPrefixTree Behave AnIssue 'SchemaLevel)
822โschemaToFormula defs rs = runWriter . (`runReaderT` defs) . runMemo () $ processSchema rs
825โ :: (ReassembleHList xs (CheckEnv (Referenced Schema)))
827โ -> Behavior 'SchemaLevel
828โ -> ProdCons (Traced (Definitions Schema))
829โ -> ProdCons (ForeachType JsonFormula, P.PathsPrefixTree Behave AnIssue 'SchemaLevel)
830โ -> SemanticCompatFormula ()
831โcheckFormulas env beh defs (ProdCons (fp, ep) (fc, ec)) =
832โ case P.toList ep ++ P.toList ec of
833โ issues@(_ : _) -> F.for_ issues $ embedFormula beh . anItem
835โ -- We have the following isomorphisms:
836โ -- (A โ X โช Y) = (A โ X) \/ (A โ Y)
837โ -- (A โ X โฉ Y) = (A โ X) /\ (A โ Y)
838โ -- (A โ โค) = 1
839โ -- (X โช Y โ B) = (X โ B) /\ (Y โ B)
841โ -- The remaining cases are, notably, not isomorphisms:
842โ -- 1) (A โ โ
) <= 0
843โ -- 2) (X โฉ Y โ B) <= (X โ B) \/ (Y โ B)
844โ -- 3) (โค โ B) <= 0
845โ -- Therefore we have the isomorphisms with (โ and โ being the N-ary
846โ -- versions of \/ and /\ respectively):
847โ -- (โ_i โ_j A[i,j]) โ (โ_k โ_l B[k,l])
848โ -- = โk โl โi, (โ_j A[i,j]) โ B[k,l]
849โ -- = โi โk โl, (โ_j A[i,j]) โ B[k,l]
850โ -- with the caveat that the the set over which k ranges is nonempty.
851โ -- This is because 1) is not an isomorphism.
852โ -- Our disjunction loses information, so it makes sense to nest it as
853โ -- deeply as possible, hence we choose the latter representation.
855โ -- We delegate the verification of (โ_j A[j]) โ B to a separate heuristic
856โ -- function, with the understanding that โj, A[j] โ B is a sufficient,
857โ -- but not necessary condition (because of 2) and 3)).
859โ -- If k ranges over an empty set, we have the isomorphism:
860โ -- (โ_i โ_j A[i,j]) โ โ
= โi, (โ_j A[i,j]) โ โ
861โ -- where we again delegate (โ_j A[j]) โ โ
to a heuristic, though here the
862โ -- shortcut of โj, A[j] โ โ
hardly helps.
864โ -- Disjunctions tend to erase informative error messages, so we may want
865โ -- to avoid them. This can be formally done as follows: if we can
866โ -- partition the universal set into a disjoint union of some parts:
867โ -- โค = โ_ฮฑ P[ฮฑ]
868โ -- such that the conjuncts in our disjunctive normal form are subordinate
869โ -- to the partition:
870โ -- โi โฮฑ, (โ_j A[i,j]) โ P[ฮฑ]
871โ -- โk โฮฑ, (โ_l B[k,l]) โ P[ฮฑ]
872โ -- then we can partition the sets over which i and k range into partitions
873โ -- I[ฮฑ] and K[ฮฑ], and then in each "bucket" verify the inclusion in the
874โ -- aforementioned way:
875โ -- โฮฑ, (โ_iโI[ฮฑ] โ_j A[i,j]) โ (โ_kโK[ฮฑ] โ_l B[k,l])
876โ -- = โฮฑ โiโI[ฮฑ] โkโK[ฮฑ] โl, (โ_j A[i,j]) โ B[k,l]
877โ -- We already somewhat do this by partitioning JSON into types, but we can
878โ -- additionally partition e.g. "enum" fields or existence of particular
879โ -- properties. This works especially well if we manage to ensure K[ฮฑ] are
880โ -- 1-element sets.
883โ -- (โ_iโI[ฮฑ] โ_j A[i,j]) = (โ_i โ_j A[i,j]) โฉ P[ฮฑ]
884โ -- does not actually appear in the source schema, we need to construct it
885โ -- ourselves and come up with a name for it.
886โ let typesRestricted = not (anyBottomTypes fp) && anyBottomTypes fc
887โ -- Specifically handle the case when a schema's type has been
888โ -- restricted from "all" to specific types: if all types were allowed
889โ -- in the producer and not all types are allowed in the consumer, it's
890โ -- usually easier to say what's left than what's removed
891โ when typesRestricted $ issueAt beh $ TypesRestricted $ nonBottomTypes fc
892โ forType_ $ \tyName ty -> do
893โ let beh' = beh >>> step (OfType tyName)
894โ case (getJsonFormula $ ty fp, getJsonFormula $ ty fc) of
895โ (DNF pss, BottomFormula) -> unless typesRestricted $ do
896โ -- don't repeat the TypesRestricted issue
897โ F.for_ pss $ \(Conjunct ps) -> checkContradiction beh' ps
898โ (DNF pss, SingleConjunct cs) -> F.for_ pss $ \(Conjunct ps) -> do
899โ F.for_ cs $ checkImplication env beh' ps -- avoid disjunction if there's only one conjunct
900โ (TopFormula, DNF css) ->
901โ -- producer is "open" (allows any value), but consumer has restrictions.
902โ -- In this case we want to show which restrictions were added. (instead
903โ -- of showing an empty list restrictions that couldn't be satisfied.)
904โ F.for_ css $ \(Conjunct cs) -> F.for_ cs $ checkImplication env beh' []
905โ (pss', css') -> F.for_ (tryPartition defs $ ProdCons (JsonFormula pss') (JsonFormula css')) $ \case
906โ (mPart, ProdCons pf cf) -> do
907โ let beh'' = foldr ((<<<) . step . InPartition) beh' mPart
908โ case (getJsonFormula pf, getJsonFormula cf) of
909โ (DNF pss, BottomFormula) -> F.for_ pss $ \(Conjunct ps) -> checkContradiction beh'' ps
910โ (DNF pss, SingleConjunct cs) -> F.for_ pss $ \(Conjunct ps) -> do
911โ F.for_ cs $ checkImplication env beh'' ps
913โ (DNF pss, DNF css) -> F.for_ pss $ \(Conjunct ps) -> do
916โ (issueFromConjunct Nothing ps)
917โ [F.for_ cs $ checkImplication env beh' ps | Conjunct cs <- S.toList css]
920โ anyBottomTypes f = getAny $
921โ foldType $ \_ ty -> case getJsonFormula $ ty f of
922โ BottomFormula -> Any True
924โ nonBottomTypes f = foldType $ \tyName ty -> case getJsonFormula $ ty f of
925โ BottomFormula -> mempty
927โ issueFromConjunct :: Typeable t => Partition -> [Condition t] -> Issue 'TypedSchemaLevel
928โ issueFromConjunct _ ps
929โ | Just e <- findExactly ps
930โ , all (satisfiesTyped e) ps =
931โ EnumDoesntSatisfy $ untypeValue e -- what does this look like when partitioned?
932โ issueFromConjunct mPart ps = NoMatchingCondition mPart $ SomeCondition <$> ps
935โ = DByEnumValue (DNF (S.Set A.Value))
936โ | DByProperties (DNF (S.Set Text, S.Set Text)) -- optional, required
937โ deriving stock (Eq, Ord, Show)
939โdata PartitionChoice
940โ = CByEnumValue (S.Set A.Value)
941โ | CByProperties (S.Set Text) (S.Set Text) -- included, excluded
942โ deriving stock (Eq, Ord, Show)
944โconjPart :: PartitionData -> PartitionData -> Maybe PartitionData
945โconjPart (DByEnumValue xss) (DByEnumValue yss) = Just . DByEnumValue $ xss /\ yss
946โconjPart (DByProperties xss) (DByProperties yss) = Just . DByProperties $ xss /\ yss
947โconjPart _ _ = Nothing
949โdisjPart :: PartitionData -> PartitionData -> Maybe PartitionData
950โdisjPart (DByEnumValue xss) (DByEnumValue yss) = Just . DByEnumValue $ xss \/ yss
951โdisjPart (DByProperties xss) (DByProperties yss) = Just . DByProperties $ xss \/ yss
952โdisjPart _ _ = Nothing
954โdata PartitionLocation
956โ | PInProperty Text PartitionLocation
957โ deriving stock (Eq, Ord, Show)
959โnewtype Partitions = Partitions (M.Map PartitionLocation (S.Set PartitionData))
960โ deriving stock (Eq, Ord, Show)
962โinstance Lattice Partitions where
963โ Partitions xss /\ Partitions yss = Partitions $ M.unionWith conj xss yss
965โ conj xs ys = S.fromList . catMaybes $ liftA2 conjPart (S.toList xs) (S.toList ys)
966โ Partitions xss \/ Partitions yss = Partitions $ M.intersectionWith disj xss yss
968โ disj xs ys = S.fromList . catMaybes $ liftA2 disjPart (S.toList xs) (S.toList ys)
970โinstance BoundedMeetSemiLattice Partitions where
971โ top = Partitions M.empty
973โ-- The lattice has no bottom, but we use 'Lifted' to adjoin a free bottom element
975โtype PartitionM = ReaderT (Traced (Definitions Schema)) (State (MemoState ()))
977โignoreKnot :: KnotTier (Lifted Partitions) () PartitionM
980โ { onKnotFound = pure ()
981โ , onKnotUsed = \_ -> pure bottom
982โ , tieKnot = \_ -> pure
985โsingletonPart :: PartitionData -> Lifted Partitions
986โsingletonPart = Lift . Partitions . M.singleton PHere . S.singleton
988โpartitionSchema :: Traced Schema -> PartitionM (Lifted Partitions)
989โpartitionSchema sch = do
990โ allClauses <- case tracedAllOf sch of
991โ Nothing -> pure []
992โ Just xs -> mapM partitionRefSchema xs
994โ anyClause <- case tracedAnyOf sch of
995โ Nothing -> pure top
996โ Just xs -> joins <$> mapM partitionRefSchema xs
998โ oneClause <- case tracedOneOf sch of
999โ Nothing -> pure top
1000โ Just xs -> joins <$> mapM partitionRefSchema xs
1002โ byEnumClause <- case _schemaEnum $ extract sch of
1003โ Nothing -> pure top
1005โ pure . singletonPart $
1006โ DByEnumValue $ SingleConjunct [S.fromList xs]
1008โ -- We can only partition by presence of a property if additional properties
1009โ -- are disallowed, and the property is not optional
1010โ let reqd = S.fromList $ _schemaRequired $ extract sch
1011โ byPropertiesClause <- case _schemaAdditionalProperties $ extract sch of
1012โ Just (AdditionalPropertiesAllowed False) -> do
1013โ let props = S.fromList . IOHM.keys . _schemaProperties $ extract sch
1014โ pure . singletonPart $
1015โ DByProperties $ SingleConjunct [(props S.\\ reqd, props `S.intersection` reqd)]
1018โ -- We can partition on something nested in a property only if the property is
1020โ let reqdProps = IOHM.filterWithKey (\k _ -> k `S.member` reqd) $ tracedProperties sch
1021โ inPropertiesClauses <- forM (IOHM.toList reqdProps) $ \(k, rs) -> do
1022โ f <- partitionRefSchema rs
1023โ pure $ fmap (\(Partitions m) -> Partitions $ M.mapKeysMonotonic (PInProperty k) m) f
1025โ pure $ meets $ allClauses <> [anyClause, oneClause, byEnumClause, byPropertiesClause] <> inPropertiesClauses
1027โpartitionRefSchema :: Traced (Referenced Schema) -> PartitionM (Lifted Partitions)
1028โpartitionRefSchema x = do
1030โ memoWithKnot ignoreKnot (partitionSchema $ dereference defs x) (ask x)
1032โnewtype LiftA f a = LiftA {getLiftA :: f a}
1033โ deriving newtype (Functor, Applicative)
1035โinstance (Lattice a, Applicative f) => Lattice (LiftA f a) where
1036โ (/\) = liftA2 (/\)
1037โ (\/) = liftA2 (\/)
1039โinstance (BoundedJoinSemiLattice a, Applicative f) => BoundedJoinSemiLattice (LiftA f a) where
1040โ bottom = pure bottom
1042โinstance (BoundedMeetSemiLattice a, Applicative f) => BoundedMeetSemiLattice (LiftA f a) where
1045โpartitionCondition :: Condition t -> PartitionM (Lifted Partitions)
1046โpartitionCondition = \case
1048โ pure . singletonPart $
1049โ DByEnumValue $ SingleConjunct [S.singleton $ untypeValue x]
1050โ Properties props _ madd -> do
1051โ let byProps = case madd of
1057โ [ ( M.keysSet $ M.filter (not . propRequired) props
1058โ , M.keysSet $ M.filter propRequired props
1061โ inProps <- forM (M.toList $ M.filter propRequired props) $ \(k, prop) -> do
1062โ f <- partitionRefSchema $ propRefSchema prop
1063โ pure $ fmap (\(Partitions m) -> Partitions $ M.mapKeysMonotonic (PInProperty k) m) f
1064โ pure $ byProps /\ meets inProps
1067โpartitionJsonFormulas
1068โ :: ProdCons (Traced (Definitions Schema))
1069โ -> ProdCons (JsonFormula t)
1070โ -> Lifted Partitions
1071โpartitionJsonFormulas defs pc = producer pcPart \/ consumer pcPart
1073โ pcPart = partitionFormula <$> defs <*> pc
1074โ partitionFormula def (JsonFormula xss) = runIdentity . runMemo () . (`runReaderT` def) $ do
1075โ getLiftA . foldLattice (LiftA . partitionCondition) $ xss
1077โselectPartition :: Lifted Partitions -> Maybe (PartitionLocation, S.Set PartitionChoice)
1078โselectPartition Bottom = Nothing
1079โselectPartition (Lift (Partitions m)) =
1080โ go [(loc, part) | (loc, parts) <- sortBy (comparing $ locLength . fst) $ M.toList m, part <- S.toList parts]
1082โ locLength :: PartitionLocation -> Int
1083โ locLength = walk 0
1085โ walk !n PHere = n
1086โ walk !n (PInProperty _ l) = walk (n + 1) l
1088โ -- Skip partitioning by property for now
1089โ go ((_, DByProperties _) : ps) = go ps
1090โ -- Don't partition by enum value at the root (this reports removed enum values as contradictions in their respective partitions)
1091โ go ((PHere, DByEnumValue _) : ps) = go ps
1092โ go ((loc, DByEnumValue (DNF xss)) : ps)
1093โ -- Check that no disjunction branches are unresticted
1094โ | Just enums <- traverse (fmap (foldr1 S.intersection) . NE.nonEmpty . S.toList) . S.toList $ xss =
1096โ Just (loc, S.map (CByEnumValue . S.singleton) $ S.unions enums)
1097โ | otherwise = go ps
1099โ-- This essentially has 3 cases:
1100โ-- Nothing -- we have produced a bottom schema
1101โ-- Just (False, _) -- there's been no change to the schema
1102โ-- Just (True, x) -- x is a new schema
1103โtype IntersectionM = ReaderT (Traced (Definitions Schema)) (WriterT Any Maybe)
1105โmBottom :: IntersectionM a
1106โmBottom = lift . lift $ Nothing
1108โcatchBottom :: IntersectionM a -> IntersectionM a -> IntersectionM a
1109โcatchBottom act handler = R.liftCatch (W.liftCatch (\a h -> a <|> h ())) act (\_ -> handler)
1111โmChange :: IntersectionM ()
1112โmChange = tell $ Any True
1115โ :: PartitionLocation
1116โ -> PartitionChoice
1118โ -> IntersectionM Schema
1119โintersectSchema loc part sch = do
1120โ allOf' <- forM (tracedAllOf sch) $ \rss ->
1121โ -- Assuming i ranges over a nonempty set (checked in processSchema)
1122โ -- (โ_i A[i]) โฉ X = โ_i (A[i] โฉ X)
1123โ -- If any intersections are empty, the result is empty. If any intersections are a change, the result is a change.
1124โ traverse (intersectRefSchema loc part) rss
1125โ anyOf' <- forM (tracedAnyOf sch) $ \rss -> do
1126โ -- (โ_i A[i]) โฉ X = โ_i (A[i] โฉ X)
1127โ -- Collect only the nonempty A[i] โฉ X, unless there are none, in which case the result is empty.
1128โ -- If any schema is empty, we remove it from the list which constitutes a change.
1129โ mSchemas <- forM rss $ \rs -> catchBottom (Just <$> intersectRefSchema loc part rs) (mChange >> pure Nothing)
1130โ case catMaybes mSchemas of
1132โ schs -> pure schs
1133โ oneOf' <- forM (tracedOneOf sch) $ \rss -> do
1134โ -- Same as anyOf'. By intersecting we're only making them more disjoint if anything.
1135โ mSchemas <- forM rss $ \rs -> catchBottom (Just <$> intersectRefSchema loc part rs) (mChange >> pure Nothing)
1136โ case catMaybes mSchemas of
1138โ schs -> pure schs
1139โ let sch' = (extract sch) {_schemaAllOf = allOf', _schemaAnyOf = anyOf', _schemaOneOf = oneOf'}
1140โ -- Now the local changes:
1142โ PInProperty k loc' -> case IOHM.lookup k $ tracedProperties sch of
1143โ Nothing -> error $ "Partitioning via absent property: " <> T.unpack k
1145โ prop' <- intersectRefSchema loc' part prop
1146โ pure $ sch' {_schemaProperties = IOHM.adjust (const prop') k $ _schemaProperties sch'}
1147โ PHere -> case part of
1148โ CByEnumValue vals -> do
1149โ enum' <- case _schemaEnum sch' of
1152โ pure $ S.toList vals
1154โ when (any (`S.notMember` vals) xs) mChange
1155โ case filter (`S.member` vals) xs of
1158โ pure $ sch' {_schemaEnum = Just enum'}
1159โ CByProperties {} -> error "CByProperties not implemented"
1161โintersectRefSchema
1162โ :: PartitionLocation
1163โ -> PartitionChoice
1164โ -> Traced (Referenced Schema)
1165โ -> IntersectionM (Referenced Schema)
1166โintersectRefSchema loc part rs = do
1168โ Inline <$> intersectSchema loc part (dereference defs rs)
1170โintersectCondition :: Traced (Definitions Schema) -> PartitionLocation -> PartitionChoice -> Condition t -> DNF (Condition t)
1171โintersectCondition _defs PHere (CByEnumValue values) cond@(Exactly x) =
1172โ if untypeValue x `S.member` values then SingleConjunct [cond] else bottom
1173โintersectCondition defs (PInProperty k loc) part cond@(Properties props add madd) = case M.lookup k props of
1174โ Nothing -> SingleConjunct [cond] -- shouldn't happen
1175โ Just prop -> case runWriterT . (`runReaderT` defs) $ intersectRefSchema loc part $ propRefSchema prop of
1176โ Just (rs', Any True) ->
1177โ let trs' = traced (ask (propRefSchema prop) >>> step (Partitioned loc part)) rs'
1178โ in SingleConjunct [Properties (M.insert k prop {propRefSchema = trs'} props) add madd]
1179โ Just (_, Any False) -> SingleConjunct [cond]
1180โ Nothing -> bottom
1181โintersectCondition _defs _loc _part cond = SingleConjunct [cond]
1183โintersectFormula :: Traced (Definitions Schema) -> PartitionLocation -> PartitionChoice -> JsonFormula t -> JsonFormula t
1184โintersectFormula defs loc part = JsonFormula . foldLattice (intersectCondition defs loc part) . getJsonFormula
1186โtype Partition = Maybe (PartitionLocation, PartitionChoice)
1188โtryPartition :: ProdCons (Traced (Definitions Schema)) -> ProdCons (JsonFormula t) -> [(Partition, ProdCons (JsonFormula t))]
1189โtryPartition defs pc = case selectPartition $ partitionJsonFormulas defs pc of
1190โ Nothing -> [(Nothing, pc)]
1191โ Just (loc, parts) -> [(Just (loc, part), intersectFormula <$> defs <*> pure loc <*> pure part <*> pc) | part <- S.toList parts]
1193โcheckContradiction
1194โ :: Behavior 'TypedSchemaLevel
1196โ -> SemanticCompatFormula ()
1197โcheckContradiction beh _ = issueAt beh NoContradiction -- TODO #70
1199โtracedConjunct :: NE.NonEmpty (Traced (Referenced Schema)) -> Traced (Referenced Schema)
1200โtracedConjunct refSchemas = case NE.sortWith ask refSchemas of
1201โ (rs NE.:| []) -> rs
1202โ (rs1 NE.:| rs2 : rss) ->
1203โ traced (ask rs1 >>> step (ConjunctedWith $ ask <$> rs2 NE.:| rss)) $
1204โ Inline mempty {_schemaAllOf = Just $ extract <$> rs1 : rs2 : rss}
1207โ :: (ReassembleHList xs (CheckEnv (Referenced Schema)))
1209โ -> Behavior 'TypedSchemaLevel
1212โ -> SemanticCompatFormula ()
1213โcheckImplication env beh prods cons = case findExactly prods of
1215โ | all (satisfiesTyped e) prods ->
1216โ if satisfiesTyped e cons
1218โ else issueAt beh (EnumDoesntSatisfy $ untypeValue e)
1219โ | otherwise -> pure () -- vacuously true
1220โ Nothing -> case cons of
1221โ -- the above code didn't catch it, so there's no Exactly condition on the lhs
1222โ Exactly e -> issueAt beh (NoMatchingEnum $ untypeValue e)
1223โ Maximum m -> case findRelevant min (\case Maximum m' -> Just m'; _ -> Nothing) prods of
1227โ else issueAt beh (MatchingMaximumWeak $ ProdCons {producer = m', consumer = m})
1228โ Nothing -> issueAt beh (NoMatchingMaximum m)
1229โ Minimum m -> case findRelevant max (\case Minimum m' -> Just m'; _ -> Nothing) prods of
1233โ else issueAt beh (MatchingMinimumWeak ProdCons {producer = coerce m', consumer = coerce m})
1234โ Nothing -> issueAt beh (NoMatchingMinimum (coerce m))
1235โ MultipleOf m -> case findRelevant lcmScientific (\case MultipleOf m' -> Just m'; _ -> Nothing) prods of
1237โ if lcmScientific m m' == m'
1239โ else issueAt beh (MatchingMultipleOfWeak $ ProdCons {producer = m', consumer = m})
1240โ Nothing -> issueAt beh (NoMatchingMultipleOf m)
1241โ NumberFormat f ->
1242โ if any (\case NumberFormat f' -> f == f'; _ -> False) prods
1244โ else issueAt beh (NoMatchingFormat f)
1245โ MaxLength m -> case findRelevant min (\case MaxLength m' -> Just m'; _ -> Nothing) prods of
1249โ else issueAt beh (MatchingMaxLengthWeak $ ProdCons {producer = m', consumer = m})
1250โ Nothing -> issueAt beh (NoMatchingMaxLength m)
1251โ MinLength m -> case findRelevant max (\case MinLength m' -> Just m'; _ -> Nothing) prods of
1255โ else issueAt beh (MatchingMinLengthWeak $ ProdCons {producer = m', consumer = m})
1256โ Nothing -> issueAt beh (NoMatchingMinLength m)
1258โ if any (\case Pattern p' -> p == p'; _ -> False) prods
1260โ else issueAt beh (NoMatchingPattern p) -- TODO: regex comparison #32
1261โ StringFormat f ->
1262โ if any (\case StringFormat f' -> f == f'; _ -> False) prods
1264โ else issueAt beh (NoMatchingFormat f)
1265โ Items _ cons' -> case findRelevant (<>) (\case Items _ rs -> Just (rs NE.:| []); _ -> Nothing) prods of
1266โ Just (tracedConjunct -> rs) -> checkCompatibility (beh >>> step InItems) env $ ProdCons rs cons'
1267โ Nothing -> issueAt beh NoMatchingItems
1268โ MaxItems m -> case findRelevant min (\case MaxItems m' -> Just m'; _ -> Nothing) prods of
1272โ else issueAt beh (MatchingMaxItemsWeak ProdCons {producer = m', consumer = m})
1273โ Nothing -> issueAt beh (NoMatchingMaxItems m)
1274โ MinItems m -> case findRelevant max (\case MinItems m' -> Just m'; _ -> Nothing) prods of
1278โ else issueAt beh (MatchingMinItemsWeak ProdCons {producer = m', consumer = m})
1279โ Nothing -> issueAt beh (NoMatchingMinItems m)
1281โ if any (== UniqueItems) $ prods
1283โ else issueAt beh NoMatchingUniqueItems
1284โ Properties props _ madd -> case findRelevant (<>) (\case Properties props' _ madd' -> Just $ (props', madd') NE.:| []; _ -> Nothing) prods of
1286โ anyOfAt beh NoMatchingProperties $
1287โ NE.toList pm <&> \(props', madd') -> do
1288โ F.for_ (S.fromList $ M.keys props <> M.keys props') $ \k -> do
1289โ let beh' = beh >>> step (InProperty k)
1290โ go sch sch' = checkCompatibility beh' env (ProdCons sch sch')
1291โ case (maybe False propRequired $ M.lookup k props', maybe False propRequired $ M.lookup k props) of
1292โ -- producer does not require field, but consumer does (can fail)
1293โ (False, True) -> issueAt beh' PropertyNowRequired
1295โ case (M.lookup k props', madd', M.lookup k props, madd) of
1296โ -- (producer, additional producer, consumer, additional consumer)
1297โ (Nothing, Nothing, _, _) -> pure () -- vacuously: the producer asserts that this field cannot exist,
1298โ -- and the consumer either doesn't require it, or it does and we've already raised an error about it.
1299โ (_, _, Nothing, Nothing) -> issueAt beh' UnexpectedProperty
1300โ (Just p', _, Just p, _) -> go (propRefSchema p') (propRefSchema p)
1301โ (Nothing, Just add', Just p, _) ->
1302โ clarifyIssue (AnItem beh' (anIssue AdditionalToProperty)) $
1303โ go add' (propRefSchema p)
1304โ (Just p', _, Nothing, Just add) ->
1305โ clarifyIssue (AnItem beh' (anIssue PropertyToAdditional)) $
1306โ go (propRefSchema p') add
1307โ (Nothing, Just _, Nothing, Just _) -> pure ()
1309โ case (madd', madd) of
1310โ (Nothing, _) -> pure () -- vacuously
1311โ (_, Nothing) -> issueAt beh NoAdditionalProperties
1312โ (Just add', Just add) -> checkCompatibility (beh >>> step InAdditionalProperty) env (ProdCons add' add)
1314โ Nothing -> issueAt beh NoMatchingProperties
1315โ MaxProperties m -> case findRelevant min (\case MaxProperties m' -> Just m'; _ -> Nothing) prods of
1319โ else issueAt beh (MatchingMaxPropertiesWeak ProdCons {producer = m', consumer = m})
1320โ Nothing -> issueAt beh (NoMatchingMaxProperties m)
1321โ MinProperties m -> case findRelevant max (\case MinProperties m' -> Just m'; _ -> Nothing) prods of
1325โ else issueAt beh (MatchingMinPropertiesWeak ProdCons {producer = m', consumer = m})
1326โ Nothing -> issueAt beh (NoMatchingMinProperties m)
1328โ findRelevant combine extr =
1329โ fmap (foldr1 combine) . NE.nonEmpty . mapMaybe extr
1330โ lcmScientific (toRational -> a) (toRational -> b) =
1331โ fromRational $ lcm (numerator a) (numerator b) % gcd (denominator a) (denominator b)
1333โfindExactly :: [Condition t] -> Maybe (TypedValue t)
1334โfindExactly (Exactly x : _) = Just x
1335โfindExactly (_ : xs) = findExactly xs
1336โfindExactly [] = Nothing
1338โinstance Issuable 'TypedSchemaLevel where
1339โ data Issue 'TypedSchemaLevel
1340โ = -- | producer produces a specific value ($1), consumer has a condition that is not satisfied by said value
1341โ EnumDoesntSatisfy A.Value
1342โ | -- | consumer only expects a specific value which the producer does not produce.
1343โ NoMatchingEnum A.Value
1344โ | -- | consumer declares a maximum numeric value ($1), producer doesn't
1345โ NoMatchingMaximum (Bound Scientific)
1346โ | -- | consumer declares a maximum numeric value ($1), producer declares a weaker (higher) limit ($2)
1347โ MatchingMaximumWeak (ProdCons (Bound Scientific))
1348โ | -- | consumer declares a minimum numeric value, producer doesn't
1349โ NoMatchingMinimum (Bound Scientific)
1350โ | -- | consumer declares a minimum numeric value ($1), producer declares a weaker (lower) limit ($2)
1351โ MatchingMinimumWeak (ProdCons (Bound Scientific))
1352โ | -- | consumer declares that the numeric value must be a multiple of $1, producer doesn't
1353โ NoMatchingMultipleOf Scientific
1354โ | -- | consumer declares that the numeric value must be a multiple of $1, producer declares a weaker condition (multiple of $2)
1355โ MatchingMultipleOfWeak (ProdCons Scientific)
1356โ | -- | consumer declares a string/number format, producer declares none or a different format (TODO: improve via regex #32)
1357โ NoMatchingFormat Format
1358โ | -- | consumer declares a maximum length of the string ($1), producer doesn't.
1359โ NoMatchingMaxLength Integer
1360โ | -- | consumer declares a maximum length of the string ($1), producer declares a weaker (higher) limit ($2)
1361โ MatchingMaxLengthWeak (ProdCons Integer)
1362โ | -- | consumer declares a minimum length of the string ($1), producer doesn't.
1363โ NoMatchingMinLength Integer
1364โ | -- | consumer declares a minimum length of the string ($1), producer declares a weaker (lower) limit ($2)
1365โ MatchingMinLengthWeak (ProdCons Integer)
1366โ | -- | consumer declares the string value must match a regex ($1), producer doesn't declare or declares different regex (TODO: #32)
1367โ NoMatchingPattern Pattern
1368โ | -- | consumer declares the items of an array must satisfy some condition, producer doesn't
1370โ | -- | consumer declares a maximum length of the array ($1), producer doesn't.
1371โ NoMatchingMaxItems Integer
1372โ | -- | consumer declares a maximum length of the array ($1), producer declares a weaker (higher) limit ($2)
1373โ MatchingMaxItemsWeak (ProdCons Integer)
1374โ | -- | consumer declares a minimum length of the array ($1), producer doesn't.
1375โ NoMatchingMinItems Integer
1376โ | -- | consumer declares a minimum length of the array ($1), producer declares a weaker (lower) limit ($2)
1377โ MatchingMinItemsWeak (ProdCons Integer)
1378โ | -- | consumer declares that items must be unique, producer doesn't
1379โ NoMatchingUniqueItems
1380โ | -- | consumer declares the properties of an object must satisfy some condition, producer doesn't
1381โ NoMatchingProperties
1382โ | -- | producer allows additional properties, consumer doesn't
1383โ NoAdditionalProperties
1384โ | -- | consumer declares a maximum number of properties in the object ($1), producer doesn't.
1385โ NoMatchingMaxProperties Integer
1386โ | -- | consumer declares a maximum number of properties in the object ($1), producer declares a weaker (higher) limit ($2)
1387โ MatchingMaxPropertiesWeak (ProdCons Integer)
1388โ | -- | consumer declares a minimum number of properties in the object ($1), producer doesn't.
1389โ NoMatchingMinProperties Integer
1390โ | -- | consumer declares a minimum number of properties in the object ($1), producer declares a weaker (lower) limit ($2)
1391โ MatchingMinPropertiesWeak (ProdCons Integer)
1392โ | -- | producer declares that the value must satisfy a disjunction of some conditions, but consumer's requirements couldn't be matched against any single one of them (TODO: split heuristic #71)
1393โ NoMatchingCondition Partition [SomeCondition]
1394โ | -- | producer indicates that values of this type are now allowed, but the consumer does not do so (currently we only check immediate contradictions, c.f. #70)
1395โ -- AKA consumer does not have the type
1397โ deriving stock (Eq, Ord, Show)
1398โ issueIsUnsupported _ = False
1399โ describeIssue Forward (EnumDoesntSatisfy v) = para "The following enum value was removed:" <> showJSONValue v
1400โ describeIssue Backward (EnumDoesntSatisfy v) = para "The following enum value was added:" <> showJSONValue v
1401โ describeIssue Forward (NoMatchingEnum v) = para "The following enum value has been added:" <> showJSONValue v
1402โ describeIssue Backward (NoMatchingEnum v) = para "The following enum value has been removed:" <> showJSONValue v
1403โ describeIssue Forward (NoMatchingMaximum b) = para $ "Upper bound has been added:" <> showBound b <> "."
1404โ describeIssue Backward (NoMatchingMaximum b) = para $ "Upper bound has been removed:" <> showBound b <> "."
1405โ describeIssue _ (MatchingMaximumWeak (ProdCons p c)) = para $ "Upper bound changed from " <> showBound p <> " to " <> showBound c <> "."
1406โ describeIssue Forward (NoMatchingMinimum b) = para $ "Lower bound has been added: " <> showBound b <> "."
1407โ describeIssue Backward (NoMatchingMinimum b) = para $ "Lower bound has been removed: " <> showBound b <> "."
1408โ describeIssue _ (MatchingMinimumWeak (ProdCons p c)) = para $ "Lower bound changed from " <> showBound p <> " to " <> showBound c <> "."
1409โ describeIssue Forward (NoMatchingMultipleOf n) = para $ "Value is now a multiple of " <> show' n <> "."
1410โ describeIssue Backward (NoMatchingMultipleOf n) = para $ "Value is no longer a multiple of " <> show' n <> "."
1411โ describeIssue _ (MatchingMultipleOfWeak (ProdCons p c)) = para $ "Value changed from being a multiple of " <> show' p <> " to being a multiple of " <> show' c <> "."
1412โ describeIssue Forward (NoMatchingFormat f) = para $ "Format added: " <> code f <> "."
1413โ describeIssue Backward (NoMatchingFormat f) = para $ "Format removed: " <> code f <> "."
1414โ describeIssue Forward (NoMatchingMaxLength n) = para $ "Maximum length added: " <> show' n <> "."
1415โ describeIssue Backward (NoMatchingMaxLength n) = para $ "Maximum length removed: " <> show' n <> "."
1416โ describeIssue _ (MatchingMaxLengthWeak (ProdCons p c)) = para $ "Maximum length of the string changed from " <> show' p <> " to " <> show' c <> "."
1417โ describeIssue Forward (NoMatchingMinLength n) = para $ "Minimum length of the string added: " <> show' n <> "."
1418โ describeIssue Backward (NoMatchingMinLength n) = para $ "Minimum length of the string removed: " <> show' n <> "."
1419โ describeIssue _ (MatchingMinLengthWeak (ProdCons p c)) = para $ "Minimum length of the string changed from " <> show' p <> " to " <> show' c <> "."
1420โ describeIssue Forward (NoMatchingPattern p) = para "Pattern (regular expression) added: " <> codeBlock p
1421โ describeIssue Backward (NoMatchingPattern p) = para "Pattern (regular expression) removed: " <> codeBlock p
1422โ describeIssue Forward NoMatchingItems = para "Array item schema has been added."
1423โ describeIssue Backward NoMatchingItems = para "Array item schema has been removed."
1424โ describeIssue Forward (NoMatchingMaxItems n) = para $ "Maximum length of the array has been added " <> show' n <> "."
1425โ describeIssue Backward (NoMatchingMaxItems n) = para $ "Maximum length of the array has been removed " <> show' n <> "."
1426โ describeIssue _ (MatchingMaxItemsWeak (ProdCons p c)) = para $ "Maximum length of the array changed from " <> show' p <> " to " <> show' c <> "."
1427โ describeIssue Forward (NoMatchingMinItems n) = para $ "Minimum length of the array added: " <> show' n <> "."
1428โ describeIssue Backward (NoMatchingMinItems n) = para $ "Minimum length of the array removed: " <> show' n <> "."
1429โ describeIssue _ (MatchingMinItemsWeak (ProdCons p c)) = para $ "Minimum length of the array changed from " <> show' p <> " to " <> show' c <> "."
1430โ describeIssue Forward NoMatchingUniqueItems = para "Items are now required to be unique."
1431โ describeIssue Backward NoMatchingUniqueItems = para "Items are no longer required to be unique."
1432โ describeIssue Forward NoMatchingProperties = para "Property added."
1433โ describeIssue Backward NoMatchingProperties = para "Property removed."
1434โ describeIssue Forward NoAdditionalProperties = para "Additional properties have been removed."
1435โ describeIssue Backward NoAdditionalProperties = para "Additional properties have been added."
1436โ describeIssue Forward (NoMatchingMaxProperties n) = para $ "Maximum number of properties has been added: " <> show' n <> "."
1437โ describeIssue Backward (NoMatchingMaxProperties n) = para $ "Maximum number of properties has been removed: " <> show' n <> "."
1438โ describeIssue _ (MatchingMaxPropertiesWeak (ProdCons p c)) = para $ "Maximum number of properties has changed from " <> show' p <> " to " <> show' c <> "."
1439โ describeIssue Forward (NoMatchingMinProperties n) = para $ "Minimum number of properties added: " <> show' n <> "."
1440โ describeIssue Backward (NoMatchingMinProperties n) = para $ "Minimum number of properties removed: " <> show' n <> "."
1441โ describeIssue _ (MatchingMinPropertiesWeak (ProdCons p c)) = para $ "Minimum number of properties has changed from " <> show' p <> " to " <> show' c <> "."
1442โ describeIssue _ (NoMatchingCondition mPart conds) =
1445โ Nothing -> "Could not verify that the following conditions hold (please file a bug if you see this)"
1447โ showPartition locPart
1448โ <> " โ could not verify that the following conditions hold (please file a bug if you see this):")
1449โ <> bulletList ((\(SomeCondition c) -> showCondition c) <$> conds)
1450โ describeIssue Forward NoContradiction = para "The value has been removed."
1451โ describeIssue Backward NoContradiction = para "The value has been added."
1453โshowJSONValue :: A.Value -> Blocks
1454โshowJSONValue v = codeBlockWith ("", ["json"], mempty) (T.decodeUtf8 . BSL.toStrict . A.encode $ v)
1456โshowJSONValueInline :: A.Value -> Inlines
1457โshowJSONValueInline v = code (T.decodeUtf8 . BSL.toStrict . A.encode $ v)
1459โshowBound :: Show a => Bound a -> Inlines
1460โshowBound (Inclusive x) = show' x <> " inclusive"
1461โshowBound (Exclusive x) = show' x <> " exclusive"
1463โshow' :: Show x => x -> Inlines
1464โshow' = str . T.pack . show
1466โinstance Issuable 'SchemaLevel where
1467โ data Issue 'SchemaLevel
1468โ = -- | Some (openapi-supported) feature that we do not support was encountered in the schema
1469โ NotSupported Text
1470โ | -- | The schema is actually invalid
1471โ InvalidSchema Text
1472โ | -- | The schema contains a reference loop along "anyOf"/"allOf"/"oneOf".
1473โ UnguardedRecursion
1474โ | -- | Producer doesn't place any restrictions on the types, but the consumer does. List what types remain available in the consumer.
1475โ TypesRestricted [JsonType]
1476โ | -- | in the producer this field used to be handled as part of "additionalProperties", and the consumer this is a specific "properties" entry. Only thrown when this change actually causes other issues
1477โ AdditionalToProperty
1478โ | -- | in the consumer this field used to be handled as part of "additionalProperties", and the producer this is a specific "properties" entry. Only thrown when this change actually causes other issues
1479โ PropertyToAdditional
1480โ | -- | consumer requires a property that is not required/allowed in the producer
1481โ PropertyNowRequired
1482โ | -- | producer allows a property that is not allowed in the consumer
1483โ UnexpectedProperty
1484โ deriving stock (Eq, Ord, Show)
1485โ issueIsUnsupported = \case
1486โ NotSupported _ -> True
1487โ InvalidSchema _ -> True
1488โ UnguardedRecursion -> True
1491โ describeIssue _ (NotSupported i) =
1492โ para (emph "Encountered a feature that OpenApi Diff does not support: " <> text i <> ".")
1493โ describeIssue _ (InvalidSchema i) =
1494โ para (emph "The schema is invalid: " <> text i <> ".")
1495โ describeIssue _ UnguardedRecursion =
1496โ para "Encountered recursion that is too complex for OpenApi Diff to untangle."
1497โ describeIssue Forward (TypesRestricted tys) = case tys of
1498โ [] -> para "No longer has any valid values." -- weird
1499โ _ -> para "Values are now limited to the following types: " <> bulletList (para . describeJSONType <$> tys)
1500โ describeIssue Backward (TypesRestricted tys) = case tys of
1501โ [] -> para "Any value of any type is now allowed." -- weird
1502โ _ -> para "Values are no longer limited to the following types: " <> bulletList (para . describeJSONType <$> tys)
1503โ describeIssue Forward AdditionalToProperty = para "The property was previously implicitly described by the catch-all \"additional properties\" case. It is now explicitly defined."
1504โ describeIssue Backward AdditionalToProperty = para "The property was previously explicitly defined. It is now implicitly described by the catch-all \"additional properties\" case."
1505โ describeIssue Forward PropertyToAdditional = para "The property was previously explicitly defined. It is now implicitly described by the catch-all \"additional properties\" case."
1506โ describeIssue Backward PropertyToAdditional = para "The property was previously implicitly described by the catch-all \"additional properties\" case. It is now explicitly defined."
1507โ describeIssue Forward PropertyNowRequired = para "The property has become required."
1508โ describeIssue Backward PropertyNowRequired = para "The property may not be present."
1509โ describeIssue Forward UnexpectedProperty = para "The property has been removed."
1510โ describeIssue Backward UnexpectedProperty = para "The property has been added."
1512โinstance Behavable 'SchemaLevel 'TypedSchemaLevel where
1513โ data Behave 'SchemaLevel 'TypedSchemaLevel
1514โ = OfType JsonType
1515โ deriving stock (Eq, Ord, Show)
1517โ describeBehaviour (OfType t) = describeJSONType t
1519โdescribeJSONType :: IsString s => JsonType -> s
1520โdescribeJSONType = \case
1522โ Boolean -> "Boolean"
1523โ Number -> "Number"
1524โ String -> "String"
1526โ Object -> "Object"
1528โinstance Behavable 'TypedSchemaLevel 'TypedSchemaLevel where
1529โ data Behave 'TypedSchemaLevel 'TypedSchemaLevel
1530โ = InPartition (PartitionLocation, PartitionChoice)
1531โ deriving stock (Eq, Ord, Show)
1533โ describeBehaviour (InPartition partition) = showPartition partition
1535โshowPartition :: (PartitionLocation, PartitionChoice) -> Inlines
1536โshowPartition = \case
1537โ (partition, CByEnumValue (S.toList -> [v])) ->
1538โ "In cases where " <> renderPartitionLocation partition <> " is " <> showJSONValueInline v
1539โ (partition, CByEnumValue (S.toList -> vs)) ->
1540โ "In cases where " <> renderPartitionLocation partition <> " has values: "
1541โ <> (fold . L.intersperse ", " . fmap showJSONValueInline $ vs)
1542โ (partition, CByProperties (S.toList -> incl) (S.toList -> [])) ->
1543โ "In cases where " <> renderPartitionLocation partition <> " contains the properties: " <> listCodes incl
1544โ (partition, CByProperties (S.toList -> []) (S.toList -> excl)) ->
1545โ "In cases where " <> renderPartitionLocation partition <> " does not contain the properties: " <> listCodes excl
1546โ (partition, CByProperties (S.toList -> incl) (S.toList -> excl)) ->
1547โ "In cases where " <> renderPartitionLocation partition
1548โ <> " contains the properties "
1549โ <> listCodes incl
1550โ <> " and does not contain the properties "
1551โ <> listCodes excl
1553โ listCodes :: [Text] -> Inlines
1554โ listCodes = fold . L.intersperse ", " . fmap code
1555โ renderPartitionLocation :: PartitionLocation -> Inlines
1556โ renderPartitionLocation p = code $ "$" <> renderPartitionLocation' p
1558โ renderPartitionLocation' :: PartitionLocation -> Text
1559โ renderPartitionLocation' PHere = mempty
1560โ renderPartitionLocation' (PInProperty prop rest) = "." <> prop <> renderPartitionLocation' rest
1562โinstance Behavable 'TypedSchemaLevel 'SchemaLevel where
1563โ data Behave 'TypedSchemaLevel 'SchemaLevel
1565โ | InProperty Text
1566โ | InAdditionalProperty
1567โ deriving stock (Eq, Ord, Show)
1569โ describeBehaviour InItems = "Items"
1570โ describeBehaviour (InProperty p) = "Property " <> code p
1571โ describeBehaviour InAdditionalProperty = "Additional properties"
1573โinstance Subtree Schema where
1574โ type SubtreeLevel Schema = 'SchemaLevel
1575โ type CheckEnv Schema = '[ProdCons (Traced (Definitions Schema))]
1576โ checkStructuralCompatibility env pc = do
1577โ structuralEq $ fmap _schemaRequired <$> pc
1578โ structuralEq $ fmap _schemaNullable <$> pc
1579โ structuralMaybeWith (structuralList env) $ tracedAllOf <$> pc
1580โ structuralMaybeWith (structuralList env) $ tracedOneOf <$> pc
1581โ structuralMaybe env $ sequence . stepTraced NotStep . fmap _schemaNot <$> pc
1582โ structuralMaybeWith (structuralList env) $ tracedAnyOf <$> pc
1583โ iohmStructural env $ stepTraced PropertiesStep . fmap _schemaProperties <$> pc
1584โ structuralMaybeWith structuralAdditionalProperties $ tracedAdditionalProperties <$> pc
1585โ structuralMaybeWith structuralDiscriminator $ tracedDiscriminator <$> pc
1586โ structuralEq $ fmap _schemaReadOnly <$> pc
1587โ structuralEq $ fmap _schemaWriteOnly <$> pc
1588โ structuralEq $ fmap _schemaXml <$> pc
1589โ structuralEq $ fmap _schemaMaxProperties <$> pc
1590โ structuralEq $ fmap _schemaMinProperties <$> pc
1591โ structuralEq $ fmap _schemaDefault <$> pc
1592โ structuralEq $ fmap _schemaType <$> pc
1593โ structuralEq $ fmap _schemaFormat <$> pc
1594โ structuralMaybeWith structuralItems $ tracedItems <$> pc
1595โ structuralEq $ fmap _schemaMaximum <$> pc
1596โ structuralEq $ fmap _schemaExclusiveMaximum <$> pc
1597โ structuralEq $ fmap _schemaMinimum <$> pc
1598โ structuralEq $ fmap _schemaExclusiveMinimum <$> pc
1599โ structuralEq $ fmap _schemaMaxLength <$> pc
1600โ structuralEq $ fmap _schemaMinLength <$> pc
1601โ structuralEq $ fmap _schemaPattern <$> pc
1602โ structuralEq $ fmap _schemaMaxItems <$> pc
1603โ structuralEq $ fmap _schemaMinItems <$> pc
1604โ structuralEq $ fmap _schemaUniqueItems <$> pc
1605โ structuralEq $ fmap _schemaEnum <$> pc
1606โ structuralEq $ fmap _schemaMultipleOf <$> pc
1609โ structuralAdditionalProperties
1610โ (ProdCons (Left x) (Left y)) = unless (x == y) structuralIssue
1611โ structuralAdditionalProperties
1612โ (ProdCons (Right x) (Right y)) =
1613โ checkSubstructure env $ ProdCons x y
1614โ structuralAdditionalProperties _ = structuralIssue
1615โ structuralDiscriminator pc' = do
1616โ structuralEq $ fmap _discriminatorPropertyName <$> pc'
1617โ iohmStructural env $
1618โ stepTraced DiscriminatorMapping . fmap (fmap parseDiscriminatorValue . _discriminatorMapping) <$> pc'
1620โ structuralItems (ProdCons (Left a) (Left b)) =
1621โ checkSubstructure env $ ProdCons a b
1622โ structuralItems (ProdCons (Right a) (Right b)) =
1623โ structuralList env $ ProdCons a b
1624โ structuralItems _ = structuralIssue
1625โ checkSemanticCompatibility env beh schs = do
1626โ let defs = getH env
1627โ checkFormulas env beh defs $ schemaToFormula <$> defs <*> schs