@@ -1,1274 +0,0 @@
1−{-# OPTIONS_GHC -fno-warn-orphans #-}
3−module OpenAPI.Checker.Validate.Schema
18−import Algebra.Lattice
19−import Control.Applicative
21−import Control.Comonad.Env hiding (env)
22−import Control.Monad.Reader hiding (ask)
23−import qualified Control.Monad.Reader as R
24−import Control.Monad.State
25−import Control.Monad.Writer
26−import qualified Data.Aeson as A
27−import qualified Data.ByteString.Lazy as BSL
29−import qualified Data.Foldable as F
31−import Data.Functor.Identity
33−import qualified Data.HashMap.Strict as HM
34−import qualified Data.HashMap.Strict.InsOrd as IOHM
37−import qualified Data.List.NonEmpty as NE
38−import qualified Data.Map as M
40−import Data.OpenApi hiding (get)
43−import Data.Scientific
44−import qualified Data.Set as S
46−import Data.Text (Text)
47−import qualified Data.Text as T hiding (singleton)
48−import qualified Data.Text.Encoding as T
50−import OpenAPI.Checker.Behavior
51−import OpenAPI.Checker.Memo
52−import OpenAPI.Checker.Orphans ()
53−import OpenAPI.Checker.Paths
54−import qualified OpenAPI.Checker.PathsPrefixTree as P
55−import OpenAPI.Checker.References
56−import OpenAPI.Checker.Subtree
57−import Text.Pandoc.Builder hiding (Format, Null)
58−import Text.Regex.Pcre2
60−-- | Type of a JSON value
68− deriving stock (Eq, Ord, Show)
70−-- | A 'A.Value' whose type we know
71−data TypedValue :: JsonType -> Type where
72− TNull :: TypedValue 'Null
73− TBool :: !Bool -> TypedValue 'Boolean
74− TNumber :: !Scientific -> TypedValue 'Number
75− TString :: !Text -> TypedValue 'String
76− TArray :: !A.Array -> TypedValue 'Array
77− TObject :: !A.Object -> TypedValue 'Object
79−deriving stock instance Eq (TypedValue t)
81−deriving stock instance Ord (TypedValue t)
83−deriving stock instance Show (TypedValue t)
85−untypeValue :: TypedValue t -> A.Value
86−untypeValue TNull = A.Null
87−untypeValue (TBool b) = A.Bool b
88−untypeValue (TNumber n) = A.Number n
89−untypeValue (TString s) = A.String s
90−untypeValue (TArray a) = A.Array a
91−untypeValue (TObject o) = A.Object o
93−data Bound a = Exclusive !a | Inclusive !a
94− deriving stock (Eq, Show, Functor)
96−-- | The order is lexicographical on @a * Bool@.
97−instance Ord a => Ord (Bound a) where
98− Exclusive a `compare` Exclusive b = compare a b
99− Exclusive a `compare` Inclusive b = if a <= b then LT else GT
100− Inclusive a `compare` Exclusive b = if a < b then LT else GT
101− Inclusive a `compare` Inclusive b = compare a b
103−data Property = Property
104− { propRequired :: Bool
105− , propFormula :: ForeachType JsonFormula
106− , propRefSchema :: Traced (Referenced Schema)
108− deriving stock (Eq, Ord, Show)
110−-- | A primitive structural condition for the "top level" of a JSON value (of a specific type)
111−data Condition :: JsonType -> Type where
112− Exactly :: TypedValue t -> Condition t
113− Maximum :: !(Bound Scientific) -> Condition 'Number
115− :: !(Down (Bound (Down Scientific)))
116− -> Condition 'Number -- ^ this has the right Ord
117− MultipleOf :: !Scientific -> Condition 'Number
118− NumberFormat :: !Format -> Condition 'Number
119− MaxLength :: !Integer -> Condition 'String
120− MinLength :: !Integer -> Condition 'String
121− Pattern :: !Pattern -> Condition 'String
122− StringFormat :: !Format -> Condition 'String
124− :: !(ForeachType JsonFormula)
125− -> !(Traced (Referenced Schema))
127− MaxItems :: !Integer -> Condition 'Array
128− MinItems :: !Integer -> Condition 'Array
129− UniqueItems :: Condition 'Array
131− :: !(M.Map Text Property)
132− -> !(ForeachType JsonFormula) -- ^ formula for additional properties
133− -> !(Maybe (Traced (Referenced Schema))) -- ^ schema for additional properties, Nothing means bottom
134− -> Condition 'Object
135− MaxProperties :: !Integer -> Condition 'Object
136− MinProperties :: !Integer -> Condition 'Object
138−showCondition :: Condition a -> Blocks
139−showCondition = \case
140− (Exactly v) -> para "The value should be:" <> showJSONValue (untypeValue v)
141− (Maximum b) -> para $ "The value should be less than " <> showBound b <> "."
142− (Minimum (Down b)) -> para $ "The value should be more than " <> showBound (getDown <$> b) <> "."
143− (MultipleOf n) -> para $ "The value should be a multiple of " <> show' n <> "."
144− (NumberFormat p) -> para $ "The number should have the following format:" <> code p <> "."
145− (Pattern p) -> para "The value should satisfy the following pattern (regular expression):" <> codeBlock p
146− (StringFormat p) -> para $ "The string should have the following format:" <> code p <> "."
147− (MaxLength p) -> para $ "The length of the string should be less than or equal to " <> show' p <> "."
148− (MinLength p) -> para $ "The length of the string should be more than or equal to " <> show' p <> "."
149− (Items i _) -> para "The items of the array should satisfy:" <> showForEachJsonFormula i
150− (MaxItems n) -> para $ "The length of the array should be less than or equal to " <> show' n <> "."
151− (MinItems n) -> para $ "The length of the array should be more than or equal to " <> show' n <> "."
152− UniqueItems -> para "The elements in the array should be unique."
153− (Properties props additional _) ->
158− <> para (strong $ if propRequired p then "Required" else "Optional")
159− <> showForEachJsonFormula (propFormula p)))
160− <> [ para (emph "Additional properties")
161− <> showForEachJsonFormula additional
163− (MaxProperties n) -> para $ "The maximum number of fields should be " <> show' n <> "."
164− (MinProperties n) -> para $ "The minimum number of fields should be " <> show' n <> "."
166− showForEachJsonFormula :: ForeachType JsonFormula -> Blocks
167− showForEachJsonFormula i =
170− (\t f -> case f i of
171− BottomFormula -> mempty
173− let conds = S.toList <$> S.toList conds'
174− in [ para (describeJSONType t)
178− cond -> bulletList (showCondition <$> cond))
181−satisfiesTyped :: TypedValue t -> Condition t -> Bool
182−satisfiesTyped e (Exactly e') = e == e'
183−satisfiesTyped (TNumber n) (Maximum (Exclusive m)) = n < m
184−satisfiesTyped (TNumber n) (Maximum (Inclusive m)) = n <= m
185−satisfiesTyped (TNumber n) (Minimum (Down (Exclusive (Down m)))) = n > m
186−satisfiesTyped (TNumber n) (Minimum (Down (Inclusive (Down m)))) = n >= m
187−satisfiesTyped (TNumber n) (MultipleOf m) = denominator (toRational n / toRational m) == 1 -- TODO: could be better #36
188−satisfiesTyped (TNumber n) (NumberFormat f) = checkNumberFormat f n
189−satisfiesTyped (TString s) (MaxLength m) = fromIntegral (T.length s) <= m
190−satisfiesTyped (TString s) (MinLength m) = fromIntegral (T.length s) >= m
191−satisfiesTyped (TString s) (Pattern p) = isJust $ match p s -- TODO: regex stuff #32
192−satisfiesTyped (TString s) (StringFormat f) = checkStringFormat f s
193−satisfiesTyped (TArray a) (Items f _) = all (`satisfies` f) a
194−satisfiesTyped (TArray a) (MaxItems m) = fromIntegral (F.length a) <= m
195−satisfiesTyped (TArray a) (MinItems m) = fromIntegral (F.length a) >= m
196−satisfiesTyped (TArray a) UniqueItems = S.size (S.fromList $ F.toList a) == F.length a -- TODO: could be better #36
197−satisfiesTyped (TObject o) (Properties props additional _) =
198− all (`HM.member` o) (M.keys (M.filter propRequired props))
199− && all (\(k, v) -> satisfies v $ maybe additional propFormula $ M.lookup k props) (HM.toList o)
200−satisfiesTyped (TObject o) (MaxProperties m) = fromIntegral (HM.size o) <= m
201−satisfiesTyped (TObject o) (MinProperties m) = fromIntegral (HM.size o) >= m
203−checkNumberFormat :: Format -> Scientific -> Bool
204−checkNumberFormat "int32" (toRational -> n) =
206− && n >= toRational (minBound :: Int32)
207− && n <= toRational (maxBound :: Int32)
208−checkNumberFormat "int64" (toRational -> n) =
210− && n >= toRational (minBound :: Int64)
211− && n <= toRational (maxBound :: Int64)
212−checkNumberFormat "float" _n = True
213−checkNumberFormat "double" _n = True
214−checkNumberFormat f _n = error $ "Invalid number format: " <> T.unpack f
216−checkStringFormat :: Format -> Text -> Bool
217−checkStringFormat "byte" _s = True -- TODO: regex stuff #32
218−checkStringFormat "binary" _s = True
219−checkStringFormat "date" _s = True
220−checkStringFormat "date-time" _s = True
221−checkStringFormat "password" _s = True
222−checkStringFormat "uuid" _s = True
223−checkStringFormat f _s = error $ "Invalid string format: " <> T.unpack f
225−deriving stock instance Eq (Condition t)
227−deriving stock instance Ord (Condition t)
229−deriving stock instance Show (Condition t)
231−data SomeCondition where
232− SomeCondition :: Typeable t => Condition t -> SomeCondition
234−instance Eq SomeCondition where
235− SomeCondition x == SomeCondition y = case cast x of
239−instance Ord SomeCondition where
240− compare (SomeCondition x) (SomeCondition y) = case cast x of
241− Just x' -> compare x' y
242− Nothing -> compare (typeRep x) (typeRep y)
244−deriving stock instance Show SomeCondition
246−-- | A boolean formula (without "not") of 'Condition's. Represented as a
247−-- Disjunctive Normal Form: the formula is a disjunction of a set of conjuncts,
248−-- each of which is a conjunction of a set of 'Condition's.
249−newtype JsonFormula t
250− = DNF (S.Set (S.Set (Condition t)))
251− deriving stock (Eq, Ord, Show)
255− -> S.Set (Condition t)
258− | any (`S.isSubsetOf` xs) yss = DNF yss
259− | otherwise = DNF $ S.insert xs $ S.filter (not . S.isSubsetOf xs) yss
261−instance Lattice (JsonFormula t) where
262− xss \/ DNF yss = S.foldl' disjAdd xss yss
263− DNF xss /\ DNF yss =
264− F.foldl' disjAdd bottom $
265− liftA2 S.union (S.toList xss) (S.toList yss)
267−pattern BottomFormula :: JsonFormula t
268−pattern BottomFormula <-
269− DNF (S.null -> True)
271− BottomFormula = DNF S.empty
273−isSingleton :: S.Set a -> Maybe a
275− | S.size s == 1 = S.lookupMin s
276− | otherwise = Nothing
278−pattern Conjunct :: [Condition t] -> S.Set (Condition t)
279−pattern Conjunct xs <-
282− Conjunct = S.fromList
284−{-# COMPLETE Conjunct #-}
286−pattern SingleConjunct :: [Condition t] -> JsonFormula t
287−pattern SingleConjunct xs <-
288− DNF (isSingleton -> Just (Conjunct xs))
290− SingleConjunct xs = DNF $ S.singleton $ Conjunct xs
292−pattern TopFormula :: JsonFormula t
293−pattern TopFormula <-
294− DNF (isSingleton -> Just (S.null -> True))
296− TopFormula = DNF $ S.singleton S.empty
298−instance BoundedJoinSemiLattice (JsonFormula t) where
299− bottom = BottomFormula
301−instance BoundedMeetSemiLattice (JsonFormula t) where
306− => (Condition t -> l)
309−foldLattice f (DNF xss) =
312− z \/ S.foldl' (\x y -> x /\ f y) top w)
316−satisfiesFormula :: TypedValue t -> JsonFormula t -> Bool
317−satisfiesFormula val = foldLattice (satisfiesTyped val)
319−data ForeachType (f :: JsonType -> Type) = ForeachType
320− { forNull :: f 'Null
321− , forBoolean :: f 'Boolean
322− , forNumber :: f 'Number
323− , forString :: f 'String
324− , forArray :: f 'Array
325− , forObject :: f 'Object
328−satisfies :: A.Value -> ForeachType JsonFormula -> Bool
329−satisfies val p = case val of
330− A.Null -> satisfiesFormula TNull $ forNull p
331− A.Bool b -> satisfiesFormula (TBool b) $ forBoolean p
332− A.Number n -> satisfiesFormula (TNumber n) $ forNumber p
333− A.String s -> satisfiesFormula (TString s) $ forString p
334− A.Array a -> satisfiesFormula (TArray a) $ forArray p
335− A.Object o -> satisfiesFormula (TObject o) $ forObject p
337−deriving stock instance (forall x. Typeable x => Eq (f x)) => Eq (ForeachType f)
339−deriving stock instance (forall x. Typeable x => Ord (f x)) => Ord (ForeachType f)
341−deriving stock instance (forall x. Typeable x => Show (f x)) => Show (ForeachType f)
345− => (forall x. Typeable x => JsonType -> (ForeachType f -> f x) -> m)
349− <> k Boolean forBoolean
350− <> k Number forNumber
351− <> k String forString
353− <> k Object forObject
357− => (forall x. Typeable x => JsonType -> (ForeachType f -> f x) -> m ())
361− k Boolean forBoolean
368−instance (forall x. Lattice (f x)) => Lattice (ForeachType f) where
371− { forNull = forNull f1 \/ forNull f2
372− , forBoolean = forBoolean f1 \/ forBoolean f2
373− , forNumber = forNumber f1 \/ forNumber f2
374− , forString = forString f1 \/ forString f2
375− , forArray = forArray f1 \/ forArray f2
376− , forObject = forObject f1 \/ forObject f2
380− { forNull = forNull f1 /\ forNull f2
381− , forBoolean = forBoolean f1 /\ forBoolean f2
382− , forNumber = forNumber f1 /\ forNumber f2
383− , forString = forString f1 /\ forString f2
384− , forArray = forArray f1 /\ forArray f2
385− , forObject = forObject f1 /\ forObject f2
389− (forall x. BoundedJoinSemiLattice (f x))
390− => BoundedJoinSemiLattice (ForeachType f)
395− , forBoolean = bottom
396− , forNumber = bottom
397− , forString = bottom
399− , forObject = bottom
403− (forall x. BoundedMeetSemiLattice (f x))
404− => BoundedMeetSemiLattice (ForeachType f)
416−instance Steppable Schema (Referenced Schema) where
417− data Step Schema (Referenced Schema)
422− | ItemsArrayStep Int
423− | AdditionalPropertiesStep
425− deriving stock (Eq, Ord, Show)
427−instance Steppable Schema (Definitions (Referenced Schema)) where
428− data Step Schema (Definitions (Referenced Schema)) = PropertiesStep
429− deriving stock (Eq, Ord, Show)
431−instance Steppable Schema Discriminator where
432− data Step Schema Discriminator = DiscriminatorStep
433− deriving stock (Eq, Ord, Show)
435−instance Steppable Discriminator (Definitions (Referenced Schema)) where
436− data Step Discriminator (Definitions (Referenced Schema)) = DiscriminatorMapping
437− deriving stock (Eq, Ord, Show)
439−parseDiscriminatorValue :: Text -> Referenced Schema
440−parseDiscriminatorValue v = case A.fromJSON @(Referenced Schema) $ A.object ["$ref" A..= v] of
442− A.Error _ -> Ref $ Reference v
444−-- | A fake writer monad that doesn't actually record anything and allows lazy recursion.
445−newtype Silent q f r a = Silent {runSilent :: a}
446− deriving stock (Functor)
447− deriving (Applicative, Monad) via Identity
449−instance MonadWriter (P.PathsPrefixTree q f r) (Silent q f r) where
451− listen (Silent x) = Silent (x, P.empty)
452− pass (Silent (x, _)) = Silent x
454−instance MonadState (MemoState ()) (Silent q f r) where
455− get = Silent $ runIdentity $ runMemo () get
458−type MonadProcess m =
459− ( MonadReader (Traced (Definitions Schema)) m
460− , MonadWriter (P.PathsPrefixTree Behave AnIssue 'SchemaLevel) m
461− , MonadState (MemoState ()) m
464−type SilentM = ReaderT (Traced (Definitions Schema)) (Silent Behave AnIssue 'SchemaLevel)
466−warn :: MonadProcess m => Issue 'SchemaLevel -> m ()
467−warn issue = tell $ P.singleton $ AnItem Root $ anIssue issue
469−-- | Ignore warnings but allow a recursive loop that lazily computes a recursive 'Condition'.
470−silently :: MonadProcess m => SilentM a -> m a
473− pure . runSilent $ runReaderT m defs
475−warnKnot :: MonadProcess m => KnotTier (ForeachType JsonFormula) () m
478− { onKnotFound = warn UnguardedRecursion
479− , onKnotUsed = \_ -> pure bottom
480− , tieKnot = \_ -> pure
485− => Traced (Referenced Schema)
486− -> m (ForeachType JsonFormula)
487−processRefSchema x = do
489− memoWithKnot warnKnot (processSchema $ dereference defs x) (ask x)
491−tracedAllOf :: Traced Schema -> Maybe [Traced (Referenced Schema)]
493− _schemaAllOf (extract sch) <&> \xs ->
494− [traced (ask sch >>> step (AllOfStep i)) x | (i, x) <- zip [0 ..] xs]
496−tracedAnyOf :: Traced Schema -> Maybe [Traced (Referenced Schema)]
498− _schemaAnyOf (extract sch) <&> \xs ->
499− [traced (ask sch >>> step (AnyOfStep i)) x | (i, x) <- zip [0 ..] xs]
501−tracedOneOf :: Traced Schema -> Maybe [Traced (Referenced Schema)]
503− _schemaOneOf (extract sch) <&> \xs ->
504− [traced (ask sch >>> step (OneOfStep i)) x | (i, x) <- zip [0 ..] xs]
506−tracedItems :: Traced Schema -> Maybe (Either (Traced (Referenced Schema)) [Traced (Referenced Schema)])
508− _schemaItems (extract sch) <&> \case
509− OpenApiItemsObject x -> Left $ traced (ask sch >>> step ItemsObjectStep) x
510− OpenApiItemsArray xs ->
512− [traced (ask sch >>> step (ItemsArrayStep i)) x | (i, x) <- zip [0 ..] xs]
514−tracedAdditionalProperties :: Traced Schema -> Maybe (Either Bool (Traced (Referenced Schema)))
515−tracedAdditionalProperties sch =
516− _schemaAdditionalProperties (extract sch) <&> \case
517− AdditionalPropertiesAllowed b -> Left b
518− AdditionalPropertiesSchema x -> Right $ traced (ask sch >>> step AdditionalPropertiesStep) x
520−tracedDiscriminator :: Traced Schema -> Maybe (Traced Discriminator)
521−tracedDiscriminator = sequence . stepTraced DiscriminatorStep . fmap _schemaDiscriminator
523−tracedProperties :: Traced Schema -> IOHM.InsOrdHashMap Text (Traced (Referenced Schema))
524−tracedProperties sch =
526− (\k -> traced (ask sch >>> step PropertiesStep >>> step (InsOrdHashMapKeyStep k)))
527− (_schemaProperties $ extract sch)
529−-- | Turn a schema into a tuple of 'JsonFormula's that describes the condition
530−-- for every possible type of a JSON value. The conditions are independent, and
531−-- are thus checked independently.
535− -> m (ForeachType JsonFormula)
536−processSchema sch@(extract -> Schema {..}) = do
537− let singletonFormula :: Condition t -> JsonFormula t
538− singletonFormula f = SingleConjunct [f]
540− allClauses <- case tracedAllOf sch of
542− Just [] -> [] <$ warn (InvalidSchema "no items in allOf")
543− Just xs -> mapM processRefSchema xs
545− anyClause <- case tracedAnyOf sch of
547− Just [] -> bottom <$ warn (InvalidSchema "no items in anyOf")
548− Just xs -> joins <$> mapM processRefSchema xs
550− oneClause <- case tracedOneOf sch of
552− Just [] -> bottom <$ warn (InvalidSchema "no items in oneOf")
554− checkOneOfDisjoint xs >>= \case
556− False -> warn (NotSupported "Could not determine that oneOf branches are disjoint")
557− joins <$> mapM processRefSchema xs
561− Just _ -> warn (NotSupported "not clause is unsupported")
563− let typeClause = case _schemaType of
569− Just OpenApiBoolean ->
573− Just OpenApiNumber ->
577− Just OpenApiInteger ->
579− { forNumber = singletonFormula $ MultipleOf 1
581− Just OpenApiString ->
585− Just OpenApiArray ->
589− Just OpenApiObject ->
594− let valueEnum A.Null =
596− { forNull = singletonFormula $ Exactly TNull
598− valueEnum (A.Bool b) =
600− { forBoolean = singletonFormula $ Exactly $ TBool b
602− valueEnum (A.Number n) =
604− { forNumber = singletonFormula $ Exactly $ TNumber n
606− valueEnum (A.String s) =
608− { forString = singletonFormula $ Exactly $ TString s
610− valueEnum (A.Array a) =
612− { forArray = singletonFormula $ Exactly $ TArray a
614− valueEnum (A.Object o) =
616− { forObject = singletonFormula $ Exactly $ TObject o
618− enumClause <- case _schemaEnum of
620− Just [] -> bottom <$ warn (InvalidSchema "no items in enum")
621− Just xs -> pure $ joins (valueEnum <$> xs)
623− let maximumClause = case _schemaMaximum of
627− { forNumber = singletonFormula $
629− case _schemaExclusiveMaximum of
630− Just True -> Exclusive n
634− minimumClause = case _schemaMinimum of
638− { forNumber = singletonFormula $
641− case _schemaExclusiveMinimum of
642− Just True -> Exclusive $ Down n
643− _ -> Inclusive $ Down n
646− multipleOfClause = case _schemaMultipleOf of
650− { forNumber = singletonFormula $ MultipleOf n
653− formatClause <- case _schemaFormat of
656− | f `elem` ["int32", "int64", "float", "double"] ->
659− { forNumber = singletonFormula $ NumberFormat f
662− | f `elem` ["byte", "binary", "date", "date-time", "password", "uuid"] ->
665− { forString = singletonFormula $ StringFormat f
667− Just f -> top <$ warn (NotSupported $ "Unknown format: " <> f)
669− let maxLengthClause = case _schemaMaxLength of
673− { forString = singletonFormula $ MaxLength n
676− minLengthClause = case _schemaMinLength of
680− { forString = singletonFormula $ MinLength n
683− patternClause = case _schemaPattern of
687− { forString = singletonFormula $ Pattern p
690− itemsClause <- case tracedItems sch of
692− Just (Left rs) -> do
693− f <- silently $ processRefSchema rs
694− pure top {forArray = singletonFormula $ Items f rs}
695− Just (Right _) -> top <$ warn (NotSupported "array in items is not supported")
697− let maxItemsClause = case _schemaMaxItems of
701− { forArray = singletonFormula $ MaxItems n
704− minItemsClause = case _schemaMinItems of
708− { forArray = singletonFormula $ MinItems n
711− uniqueItemsClause = case _schemaUniqueItems of
714− { forArray = singletonFormula UniqueItems
718− (addProps, addPropSchema) <- case tracedAdditionalProperties sch of
719− Just (Right rs) -> (,Just rs) <$> silently (processRefSchema rs)
720− Just (Left False) -> pure (bottom, Nothing)
721− _ -> pure (top, Just $ traced (ask sch `Snoc` AdditionalPropertiesStep) $ Inline mempty)
722− propList <- forM (S.toList . S.fromList $ IOHM.keys _schemaProperties <> _schemaRequired) $ \k -> do
723− (f, psch) <- case IOHM.lookup k $ tracedProperties sch of
724− Just rs -> (,rs) <$> silently (processRefSchema rs)
726− let fakeSchema = traced (ask sch `Snoc` AdditionalPropertiesStep) $ Inline mempty
727− in -- The mempty here is incorrect, but if addPropSchema was Nothing, then
728− -- addProps is bottom, and k is in _schemaRequired. We handle this situation
729− -- below and short-circuit the entire Properties condition to bottom
730− pure (addProps, fromMaybe fakeSchema addPropSchema)
731− pure (k, Property (k `elem` _schemaRequired) f psch)
732− let allBottom f = getAll $
733− foldType $ \_ ty -> case ty f of
734− BottomFormula -> All True
737− foldType $ \_ ty -> case ty f of
738− TopFormula -> All True
740− -- remove optional fields whose schemata match that of additional props
741− propMap = M.filter (\p -> propRequired p || propFormula p /= addProps) $ M.fromList propList
743− | any (\p -> propRequired p && allBottom (propFormula p)) propMap =
744− bottom -- if any required field has unsatisfiable schema
747− top -- if all fields are optional and have trivial schemata
750− { forObject = singletonFormula $ Properties propMap addProps addPropSchema
753− maxPropertiesClause = case _schemaMaxProperties of
757− { forObject = singletonFormula $ MaxProperties n
760− minPropertiesClause = case _schemaMinProperties of
764− { forObject = singletonFormula $ MinProperties n
768− | Just True <- _schemaNullable =
770− { forNull = singletonFormula $ Exactly TNull
772− | otherwise = bottom
794− , maxPropertiesClause
795− , minPropertiesClause
798−{- TODO: ReadOnly/WriteOnly #68 -}
800−checkOneOfDisjoint :: MonadProcess m => [Traced (Referenced Schema)] -> m Bool
801−checkOneOfDisjoint = const $ pure True -- TODO #69
804− :: Traced (Definitions Schema)
806− -> (ForeachType JsonFormula, P.PathsPrefixTree Behave AnIssue 'SchemaLevel)
807−schemaToFormula defs rs = runWriter . (`runReaderT` defs) . runMemo () $ processSchema rs
810− :: (ReassembleHList xs (CheckEnv (Referenced Schema)))
812− -> Behavior 'SchemaLevel
813− -> ProdCons (ForeachType JsonFormula, P.PathsPrefixTree Behave AnIssue 'SchemaLevel)
814− -> SemanticCompatFormula ()
815−checkFormulas env beh (ProdCons (fp, ep) (fc, ec)) =
816− case P.toList ep ++ P.toList ec of
817− issues@(_ : _) -> F.for_ issues $ embedFormula beh . anItem
819− -- We have the following isomorphisms:
820− -- (A ⊂ X ∪ Y) = (A ⊂ X) \/ (A ⊂ Y)
821− -- (A ⊂ X ∩ Y) = (A ⊂ X) /\ (A ⊂ Y)
823− -- (X ∪ Y ⊂ B) = (X ⊂ B) /\ (Y ⊂ B)
825− -- The remaining cases are, notably, not isomorphisms:
827− -- 2) (X ∩ Y ⊂ B) <= (X ⊂ B) \/ (Y ⊂ B)
829− -- Therefore we have the isomorphisms:
830− -- (⋃_i ⋂_j A[i,j]) ⊂ (⋃_k ⋂_l B[k,l])
831− -- = \/_k /\_l /\_i (⋂_j A[i,j]) ⊂ B[k,l]
832− -- = /\_i \/_k /\_l (⋂_j A[i,j]) ⊂ B[k,l]
833− -- with the caveat that the the set over which k ranges is nonempty.
834− -- This is because 1) is not an isomorphism.
835− -- Our disjunction loses information, so it makes sense to nest it as
836− -- deeply as possible, hence we choose the latter representation.
838− -- We delegate the verification of (⋂_j A[j]) ⊂ B to a separate heuristic
839− -- function, with the understanding that \/_j A[j] ⊂ B is a sufficient,
840− -- but not necessary condition (because of 2) and 3)).
842− -- If k ranges over an empty set, we have the isomorphism:
843− -- (⋃_i ⋂_j A[i,j]) ⊂ ∅ = /\_i (⋂_j A[i,j]) ⊂ ∅
844− -- where we again delegate (⋂_j A[j]) ⊂ ∅ to a heuristic, though here the
845− -- shortcut of \/_j A[j] ⊂ ∅ hardly helps.
846− let typesRestricted = not (anyBottomTypes fp) && anyBottomTypes fc
847− -- Specifically handle the case when a schema's type has been
848− -- restricted from "all" to specific types: if all types were allowed
849− -- in the producer and not all types are allowed in the consumer, it's
850− -- usually easier to say what's left than what's removed
851− when typesRestricted $ issueAt beh $ TypesRestricted $ nonBottomTypes fc
852− forType_ $ \tyName ty -> do
853− let beh' = beh >>> step (OfType tyName)
854− case (ty fp, ty fc) of
855− (DNF pss, BottomFormula) -> unless typesRestricted $ do
856− -- don't repeat the TypesRestricted issue
857− F.for_ pss $ \(Conjunct ps) -> checkContradiction beh' ps
858− (DNF pss, SingleConjunct cs) -> F.for_ pss $ \(Conjunct ps) -> do
859− F.for_ cs $ checkImplication env beh' ps -- avoid disjunction if there's only one conjunct
860− (TopFormula, DNF css) ->
861− -- producer is "open" (allows any value), but consumer has restrictions.
862− -- In this case we want to show which restrictions were added. (instead
863− -- of showing an empty list restrictions that couldn't be satisfied.)
864− F.for_ css $ \(Conjunct cs) -> F.for_ cs $ checkImplication env beh' []
865− (DNF pss, DNF css) -> F.for_ pss $ \(Conjunct ps) -> do
868− (issueFromConjunct ps)
869− [F.for_ cs $ checkImplication env beh' ps | Conjunct cs <- S.toList css]
872− anyBottomTypes f = getAny $
873− foldType $ \_ ty -> case ty f of
874− BottomFormula -> Any True
876− nonBottomTypes f = foldType $ \tyName ty -> case ty f of
877− BottomFormula -> mempty
879− issueFromConjunct :: Typeable t => [Condition t] -> Issue 'TypedSchemaLevel
880− issueFromConjunct ps
881− | Just e <- findExactly ps
882− , all (satisfiesTyped e) ps =
883− EnumDoesntSatisfy $ untypeValue e
884− issueFromConjunct ps = NoMatchingCondition $ SomeCondition <$> ps
887− :: Behavior 'TypedSchemaLevel
889− -> SemanticCompatFormula ()
890−checkContradiction beh _ = issueAt beh NoContradiction -- TODO #70
893− :: (ReassembleHList xs (CheckEnv (Referenced Schema)))
895− -> Behavior 'TypedSchemaLevel
898− -> SemanticCompatFormula ()
899−checkImplication env beh prods cons = case findExactly prods of
901− | all (satisfiesTyped e) prods ->
902− if satisfiesTyped e cons
904− else issueAt beh (EnumDoesntSatisfy $ untypeValue e)
905− | otherwise -> pure () -- vacuously true
906− Nothing -> case cons of
907− -- the above code didn't catch it, so there's no Exactly condition on the lhs
908− Exactly e -> issueAt beh (NoMatchingEnum $ untypeValue e)
909− Maximum m -> case findRelevant min (\case Maximum m' -> Just m'; _ -> Nothing) prods of
913− else issueAt beh (MatchingMaximumWeak $ ProdCons {producer = m', consumer = m})
914− Nothing -> issueAt beh (NoMatchingMaximum m)
915− Minimum m -> case findRelevant max (\case Minimum m' -> Just m'; _ -> Nothing) prods of
919− else issueAt beh (MatchingMinimumWeak ProdCons {producer = coerce m', consumer = coerce m})
920− Nothing -> issueAt beh (NoMatchingMinimum (coerce m))
921− MultipleOf m -> case findRelevant lcmScientific (\case MultipleOf m' -> Just m'; _ -> Nothing) prods of
923− if lcmScientific m m' == m'
925− else issueAt beh (MatchingMultipleOfWeak $ ProdCons {producer = m', consumer = m})
926− Nothing -> issueAt beh (NoMatchingMultipleOf m)
928− if any (\case NumberFormat f' -> f == f'; _ -> False) prods
930− else issueAt beh (NoMatchingFormat f)
931− MaxLength m -> case findRelevant min (\case MaxLength m' -> Just m'; _ -> Nothing) prods of
935− else issueAt beh (MatchingMaxLengthWeak $ ProdCons {producer = m', consumer = m})
936− Nothing -> issueAt beh (NoMatchingMaxLength m)
937− MinLength m -> case findRelevant max (\case MinLength m' -> Just m'; _ -> Nothing) prods of
941− else issueAt beh (MatchingMinLengthWeak $ ProdCons {producer = m', consumer = m})
942− Nothing -> issueAt beh (NoMatchingMinLength m)
944− if any (\case Pattern p' -> p == p'; _ -> False) prods
946− else issueAt beh (NoMatchingPattern p) -- TODO: regex comparison #32
948− if any (\case StringFormat f' -> f == f'; _ -> False) prods
950− else issueAt beh (NoMatchingFormat f)
951− Items _ cons' -> case findRelevant (<>) (\case Items _ rs -> Just (rs NE.:| []); _ -> Nothing) prods of
952− Just (rs NE.:| []) -> checkCompatibility (beh >>> step InItems) env $ ProdCons rs cons'
954− let sch = Inline mempty {_schemaAllOf = Just . NE.toList $ extract <$> rs}
955− checkCompatibility (beh >>> step InItems) env $ ProdCons (traced (ask $ NE.head rs) sch) cons' -- TODO: bad trace
956− Nothing -> issueAt beh NoMatchingItems
957− MaxItems m -> case findRelevant min (\case MaxItems m' -> Just m'; _ -> Nothing) prods of
961− else issueAt beh (MatchingMaxItemsWeak ProdCons {producer = m', consumer = m})
962− Nothing -> issueAt beh (NoMatchingMaxItems m)
963− MinItems m -> case findRelevant max (\case MinItems m' -> Just m'; _ -> Nothing) prods of
967− else issueAt beh (MatchingMinItemsWeak ProdCons {producer = m', consumer = m})
968− Nothing -> issueAt beh (NoMatchingMinItems m)
970− if any (== UniqueItems) $ prods
972− else issueAt beh NoMatchingUniqueItems
973− Properties props _ madd -> case findRelevant (<>) (\case Properties props' _ madd' -> Just $ (props', madd') NE.:| []; _ -> Nothing) prods of
975− anyOfAt beh NoMatchingProperties $
976− NE.toList pm <&> \(props', madd') -> do
977− F.for_ (S.fromList $ M.keys props <> M.keys props') $ \k -> do
978− let beh' = beh >>> step (InProperty k)
979− go sch sch' = checkCompatibility beh' env (ProdCons sch sch')
980− case (maybe False propRequired $ M.lookup k props', maybe False propRequired $ M.lookup k props) of
981− -- producer does not require field, but consumer does (can fail)
982− (False, True) -> issueAt beh' PropertyNowRequired
984− case (M.lookup k props', madd', M.lookup k props, madd) of
985− -- (producer, additional producer, consumer, additional consumer)
986− (Nothing, Nothing, _, _) -> pure () -- vacuously: the producer asserts that this field cannot exist,
987− -- and the consumer either doesn't require it, or it does and we've already raised an error about it.
988− (_, _, Nothing, Nothing) -> issueAt beh' UnexpectedProperty
989− (Just p', _, Just p, _) -> go (propRefSchema p') (propRefSchema p)
990− (Nothing, Just add', Just p, _) ->
991− clarifyIssue (AnItem beh' (anIssue AdditionalToProperty)) $
992− go add' (propRefSchema p)
993− (Just p', _, Nothing, Just add) ->
994− clarifyIssue (AnItem beh' (anIssue PropertyToAdditional)) $
995− go (propRefSchema p') add
996− (Nothing, Just _, Nothing, Just _) -> pure ()
998− case (madd', madd) of
999− (Nothing, _) -> pure () -- vacuously
1000− (_, Nothing) -> issueAt beh NoAdditionalProperties
1001− (Just add', Just add) -> checkCompatibility (beh >>> step InAdditionalProperty) env (ProdCons add' add)
1003− Nothing -> issueAt beh NoMatchingProperties
1004− MaxProperties m -> case findRelevant min (\case MaxProperties m' -> Just m'; _ -> Nothing) prods of
1008− else issueAt beh (MatchingMaxPropertiesWeak ProdCons {producer = m', consumer = m})
1009− Nothing -> issueAt beh (NoMatchingMaxProperties m)
1010− MinProperties m -> case findRelevant max (\case MinProperties m' -> Just m'; _ -> Nothing) prods of
1014− else issueAt beh (MatchingMinPropertiesWeak ProdCons {producer = m', consumer = m})
1015− Nothing -> issueAt beh (NoMatchingMinProperties m)
1017− findRelevant combine extr =
1018− fmap (foldr1 combine) . NE.nonEmpty . mapMaybe extr
1019− lcmScientific (toRational -> a) (toRational -> b) =
1020− fromRational $ lcm (numerator a) (numerator b) % gcd (denominator a) (denominator b)
1022−findExactly :: [Condition t] -> Maybe (TypedValue t)
1023−findExactly (Exactly x : _) = Just x
1024−findExactly (_ : xs) = findExactly xs
1025−findExactly [] = Nothing
1027−instance Issuable 'TypedSchemaLevel where
1028− data Issue 'TypedSchemaLevel
1029− = -- | producer produces a specific value ($1), consumer has a condition that is not satisfied by said value
1030− EnumDoesntSatisfy A.Value
1031− | -- | consumer only expects a specific value which the producer does not produce.
1032− NoMatchingEnum A.Value
1033− | -- | consumer declares a maximum numeric value ($1), producer doesn't
1034− NoMatchingMaximum (Bound Scientific)
1035− | -- | consumer declares a maximum numeric value ($1), producer declares a weaker (higher) limit ($2)
1036− MatchingMaximumWeak (ProdCons (Bound Scientific))
1037− | -- | consumer declares a minimum numeric value, producer doesn't
1038− NoMatchingMinimum (Bound Scientific)
1039− | -- | consumer declares a minimum numeric value ($1), producer declares a weaker (lower) limit ($2)
1040− MatchingMinimumWeak (ProdCons (Bound Scientific))
1041− | -- | consumer declares that the numeric value must be a multiple of $1, producer doesn't
1042− NoMatchingMultipleOf Scientific
1043− | -- | consumer declares that the numeric value must be a multiple of $1, producer declares a weaker condition (multiple of $2)
1044− MatchingMultipleOfWeak (ProdCons Scientific)
1045− | -- | consumer declares a string/number format, producer declares none or a different format (TODO: improve via regex #32)
1046− NoMatchingFormat Format
1047− | -- | consumer declares a maximum length of the string ($1), producer doesn't.
1048− NoMatchingMaxLength Integer
1049− | -- | consumer declares a maximum length of the string ($1), producer declares a weaker (higher) limit ($2)
1050− MatchingMaxLengthWeak (ProdCons Integer)
1051− | -- | consumer declares a minimum length of the string ($1), producer doesn't.
1052− NoMatchingMinLength Integer
1053− | -- | consumer declares a minimum length of the string ($1), producer declares a weaker (lower) limit ($2)
1054− MatchingMinLengthWeak (ProdCons Integer)
1055− | -- | consumer declares the string value must match a regex ($1), producer doesn't declare or declares different regex (TODO: #32)
1056− NoMatchingPattern Pattern
1057− | -- | consumer declares the items of an array must satisfy some condition, producer doesn't
1059− | -- | consumer declares a maximum length of the array ($1), producer doesn't.
1060− NoMatchingMaxItems Integer
1061− | -- | consumer declares a maximum length of the array ($1), producer declares a weaker (higher) limit ($2)
1062− MatchingMaxItemsWeak (ProdCons Integer)
1063− | -- | consumer declares a minimum length of the array ($1), producer doesn't.
1064− NoMatchingMinItems Integer
1065− | -- | consumer declares a minimum length of the array ($1), producer declares a weaker (lower) limit ($2)
1066− MatchingMinItemsWeak (ProdCons Integer)
1067− | -- | consumer declares that items must be unique, producer doesn't
1068− NoMatchingUniqueItems
1069− | -- | consumer declares the properties of an object must satisfy some condition, producer doesn't
1070− NoMatchingProperties
1071− | -- | producer allows additional properties, consumer doesn't
1072− NoAdditionalProperties
1073− | -- | consumer declares a maximum number of properties in the object ($1), producer doesn't.
1074− NoMatchingMaxProperties Integer
1075− | -- | consumer declares a maximum number of properties in the object ($1), producer declares a weaker (higher) limit ($2)
1076− MatchingMaxPropertiesWeak (ProdCons Integer)
1077− | -- | consumer declares a minimum number of properties in the object ($1), producer doesn't.
1078− NoMatchingMinProperties Integer
1079− | -- | consumer declares a minimum number of properties in the object ($1), producer declares a weaker (lower) limit ($2)
1080− MatchingMinPropertiesWeak (ProdCons Integer)
1081− | -- | 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)
1082− NoMatchingCondition [SomeCondition]
1083− | -- | 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)
1084− -- AKA consumer does not have the type
1086− deriving stock (Eq, Ord, Show)
1087− issueIsUnsupported _ = False
1088− describeIssue Forward (EnumDoesntSatisfy v) = para "The following enum value was removed:" <> showJSONValue v
1089− describeIssue Backward (EnumDoesntSatisfy v) = para "The following enum value was added:" <> showJSONValue v
1090− describeIssue Forward (NoMatchingEnum v) = para "The following enum value has been added:" <> showJSONValue v
1091− describeIssue Backward (NoMatchingEnum v) = para "The following enum value has been removed:" <> showJSONValue v
1092− describeIssue Forward (NoMatchingMaximum b) = para $ "Upper bound has been added:" <> showBound b <> "."
1093− describeIssue Backward (NoMatchingMaximum b) = para $ "Upper bound has been removed:" <> showBound b <> "."
1094− describeIssue _ (MatchingMaximumWeak (ProdCons p c)) = para $ "Upper bound changed from " <> showBound p <> " to " <> showBound c <> "."
1095− describeIssue Forward (NoMatchingMinimum b) = para $ "Lower bound has been added: " <> showBound b <> "."
1096− describeIssue Backward (NoMatchingMinimum b) = para $ "Lower bound has been removed: " <> showBound b <> "."
1097− describeIssue _ (MatchingMinimumWeak (ProdCons p c)) = para $ "Lower bound changed from " <> showBound p <> " to " <> showBound c <> "."
1098− describeIssue Forward (NoMatchingMultipleOf n) = para $ "Value is now a multiple of " <> show' n <> "."
1099− describeIssue Backward (NoMatchingMultipleOf n) = para $ "Value is no longer a multiple of " <> show' n <> "."
1100− describeIssue _ (MatchingMultipleOfWeak (ProdCons p c)) = para $ "Value changed from being a multiple of " <> show' p <> " to being a multiple of " <> show' c <> "."
1101− describeIssue Forward (NoMatchingFormat f) = para $ "Format added: " <> code f <> "."
1102− describeIssue Backward (NoMatchingFormat f) = para $ "Format removed: " <> code f <> "."
1103− describeIssue Forward (NoMatchingMaxLength n) = para $ "Maximum length added: " <> show' n <> "."
1104− describeIssue Backward (NoMatchingMaxLength n) = para $ "Maximum length removed: " <> show' n <> "."
1105− describeIssue _ (MatchingMaxLengthWeak (ProdCons p c)) = para $ "Maximum length of the string changed from " <> show' p <> " to " <> show' c <> "."
1106− describeIssue Forward (NoMatchingMinLength n) = para $ "Minimum length of the string added: " <> show' n <> "."
1107− describeIssue Backward (NoMatchingMinLength n) = para $ "Minimum length of the string removed: " <> show' n <> "."
1108− describeIssue _ (MatchingMinLengthWeak (ProdCons p c)) = para $ "Minimum length of the string changed from " <> show' p <> " to " <> show' c <> "."
1109− describeIssue Forward (NoMatchingPattern p) = para "Pattern (regular expression) added: " <> codeBlock p
1110− describeIssue Backward (NoMatchingPattern p) = para "Pattern (regular expression) removed: " <> codeBlock p
1111− describeIssue Forward NoMatchingItems = para "Array item schema has been added."
1112− describeIssue Backward NoMatchingItems = para "Array item schema has been removed."
1113− describeIssue Forward (NoMatchingMaxItems n) = para $ "Maximum length of the array has been added " <> show' n <> "."
1114− describeIssue Backward (NoMatchingMaxItems n) = para $ "Maximum length of the array has been removed " <> show' n <> "."
1115− describeIssue _ (MatchingMaxItemsWeak (ProdCons p c)) = para $ "Maximum length of the array changed from " <> show' p <> " to " <> show' c <> "."
1116− describeIssue Forward (NoMatchingMinItems n) = para $ "Minimum length of the array added: " <> show' n <> "."
1117− describeIssue Backward (NoMatchingMinItems n) = para $ "Minimum length of the array removed: " <> show' n <> "."
1118− describeIssue _ (MatchingMinItemsWeak (ProdCons p c)) = para $ "Minimum length of the array changed from " <> show' p <> " to " <> show' c <> "."
1119− describeIssue Forward NoMatchingUniqueItems = para "Items are now required to be unique."
1120− describeIssue Backward NoMatchingUniqueItems = para "Items are no longer required to be unique."
1121− describeIssue Forward NoMatchingProperties = para "Property added."
1122− describeIssue Backward NoMatchingProperties = para "Property removed."
1123− describeIssue Forward NoAdditionalProperties = para "Additional properties have been removed."
1124− describeIssue Backward NoAdditionalProperties = para "Additional properties have been added."
1125− describeIssue Forward (NoMatchingMaxProperties n) = para $ "Maximum number of properties has been added: " <> show' n <> "."
1126− describeIssue Backward (NoMatchingMaxProperties n) = para $ "Maximum number of properties has been removed: " <> show' n <> "."
1127− describeIssue _ (MatchingMaxPropertiesWeak (ProdCons p c)) = para $ "Maximum number of properties has changed from " <> show' p <> " to " <> show' c <> "."
1128− describeIssue Forward (NoMatchingMinProperties n) = para $ "Minimum number of properties added: " <> show' n <> "."
1129− describeIssue Backward (NoMatchingMinProperties n) = para $ "Minimum number of properties removed: " <> show' n <> "."
1130− describeIssue _ (MatchingMinPropertiesWeak (ProdCons p c)) = para $ "Minimum number of properties has changed from " <> show' p <> " to " <> show' c <> "."
1131− describeIssue _ (NoMatchingCondition conds) =
1132− para "Expected the following conditions to hold, but they didn't (please file a bug if you see this):"
1133− <> bulletList ((\(SomeCondition c) -> showCondition c) <$> conds)
1134− describeIssue Forward NoContradiction = para "The type has been removed."
1135− describeIssue Backward NoContradiction = para "The type has been added."
1137−showJSONValue :: A.Value -> Blocks
1138−showJSONValue v = codeBlockWith ("", ["json"], mempty) (T.decodeUtf8 . BSL.toStrict . A.encode $ v)
1140−showBound :: Show a => Bound a -> Inlines
1141−showBound (Inclusive x) = show' x <> " inclusive"
1142−showBound (Exclusive x) = show' x <> " exclusive"
1144−show' :: Show x => x -> Inlines
1145−show' = str . T.pack . show
1147−instance Issuable 'SchemaLevel where
1148− data Issue 'SchemaLevel
1149− = -- | Some (openapi-supported) feature that we do not support was encountered in the schema
1151− | -- | The schema is actually invalid
1153− | -- | The schema contains a reference loop along "anyOf"/"allOf"/"oneOf".
1155− | -- | Producer doesn't place any restrictions on the types, but the consumer does. List what types remain available in the consumer.
1156− TypesRestricted [JsonType]
1157− | -- | 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
1158− AdditionalToProperty
1159− | -- | 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
1160− PropertyToAdditional
1161− | -- | consumer requires a property that is not required/allowed in the producer
1162− PropertyNowRequired
1163− | -- | producer allows a property that is not allowed in the consumer
1165− deriving stock (Eq, Ord, Show)
1166− issueIsUnsupported = \case
1167− NotSupported _ -> True
1168− InvalidSchema _ -> True
1169− UnguardedRecursion -> True
1172− describeIssue _ (NotSupported i) =
1173− para (emph "Encountered a feature that OpenApi Diff does not support: " <> text i <> ".")
1174− describeIssue _ (InvalidSchema i) =
1175− para (emph "The schema is invalid: " <> text i <> ".")
1176− describeIssue _ UnguardedRecursion =
1177− para "Encountered recursion that is too complex for OpenApi Diff to untangle."
1178− describeIssue Forward (TypesRestricted tys) = case tys of
1179− [] -> para "No longer has any valid values." -- weird
1180− _ -> para "Values are now limited to the following types: " <> bulletList (para . describeJSONType <$> tys)
1181− describeIssue Backward (TypesRestricted tys) = case tys of
1182− [] -> para "Any value of any type is now allowed." -- weird
1183− _ -> para "Values are no longer limited to the following types: " <> bulletList (para . describeJSONType <$> tys)
1184− describeIssue Forward AdditionalToProperty = para "The property was previously implicitly described by the catch-all \"additional properties\" case. It is now explicitly defined."
1185− describeIssue Backward AdditionalToProperty = para "The property was previously explicitly defined. It is now implicitly described by the catch-all \"additional properties\" case."
1186− describeIssue Forward PropertyToAdditional = para "The property was previously explicitly defined. It is now implicitly described by the catch-all \"additional properties\" case."
1187− describeIssue Backward PropertyToAdditional = para "The property was previously implicitly described by the catch-all \"additional properties\" case. It is now explicitly defined."
1188− describeIssue Forward PropertyNowRequired = para "The property has become required."
1189− describeIssue Backward PropertyNowRequired = para "The property may not be present."
1190− describeIssue Forward UnexpectedProperty = para "The property has been removed."
1191− describeIssue Backward UnexpectedProperty = para "The property has been added."
1193−instance Behavable 'SchemaLevel 'TypedSchemaLevel where
1194− data Behave 'SchemaLevel 'TypedSchemaLevel
1196− deriving stock (Eq, Ord, Show)
1198− describeBehaviour (OfType t) = describeJSONType t
1200−describeJSONType :: IsString s => JsonType -> s
1201−describeJSONType = \case
1203− Boolean -> "Boolean"
1209−instance Behavable 'TypedSchemaLevel 'SchemaLevel where
1210− data Behave 'TypedSchemaLevel 'SchemaLevel
1213− | InAdditionalProperty
1214− deriving stock (Eq, Ord, Show)
1216− describeBehaviour InItems = "Items"
1217− describeBehaviour (InProperty p) = "Property " <> code p
1218− describeBehaviour InAdditionalProperty = "Additional properties"
1220−instance Subtree Schema where
1221− type SubtreeLevel Schema = 'SchemaLevel
1222− type CheckEnv Schema = '[ProdCons (Traced (Definitions Schema))]
1223− checkStructuralCompatibility env pc = do
1224− structuralEq $ fmap _schemaRequired <$> pc
1225− structuralEq $ fmap _schemaNullable <$> pc
1226− structuralMaybeWith (structuralList env) $ tracedAllOf <$> pc
1227− structuralMaybeWith (structuralList env) $ tracedOneOf <$> pc
1228− structuralMaybe env $ sequence . stepTraced NotStep . fmap _schemaNot <$> pc
1229− structuralMaybeWith (structuralList env) $ tracedAnyOf <$> pc
1230− iohmStructural env $ stepTraced PropertiesStep . fmap _schemaProperties <$> pc
1231− structuralMaybeWith structuralAdditionalProperties $ tracedAdditionalProperties <$> pc
1232− structuralMaybeWith structuralDiscriminator $ tracedDiscriminator <$> pc
1233− structuralEq $ fmap _schemaReadOnly <$> pc
1234− structuralEq $ fmap _schemaWriteOnly <$> pc
1235− structuralEq $ fmap _schemaXml <$> pc
1236− structuralEq $ fmap _schemaMaxProperties <$> pc
1237− structuralEq $ fmap _schemaMinProperties <$> pc
1238− structuralEq $ fmap _schemaDefault <$> pc
1239− structuralEq $ fmap _schemaType <$> pc
1240− structuralEq $ fmap _schemaFormat <$> pc
1241− structuralMaybeWith structuralItems $ tracedItems <$> pc
1242− structuralEq $ fmap _schemaMaximum <$> pc
1243− structuralEq $ fmap _schemaExclusiveMaximum <$> pc
1244− structuralEq $ fmap _schemaMinimum <$> pc
1245− structuralEq $ fmap _schemaExclusiveMinimum <$> pc
1246− structuralEq $ fmap _schemaMaxLength <$> pc
1247− structuralEq $ fmap _schemaMinLength <$> pc
1248− structuralEq $ fmap _schemaPattern <$> pc
1249− structuralEq $ fmap _schemaMaxItems <$> pc
1250− structuralEq $ fmap _schemaMinItems <$> pc
1251− structuralEq $ fmap _schemaUniqueItems <$> pc
1252− structuralEq $ fmap _schemaEnum <$> pc
1253− structuralEq $ fmap _schemaMultipleOf <$> pc
1256− structuralAdditionalProperties
1257− (ProdCons (Left x) (Left y)) = unless (x == y) structuralIssue
1258− structuralAdditionalProperties
1259− (ProdCons (Right x) (Right y)) =
1260− checkSubstructure env $ ProdCons x y
1261− structuralAdditionalProperties _ = structuralIssue
1262− structuralDiscriminator pc' = do
1263− structuralEq $ fmap _discriminatorPropertyName <$> pc'
1264− iohmStructural env $
1265− stepTraced DiscriminatorMapping . fmap (fmap parseDiscriminatorValue . _discriminatorMapping) <$> pc'
1267− structuralItems (ProdCons (Left a) (Left b)) =
1268− checkSubstructure env $ ProdCons a b
1269− structuralItems (ProdCons (Right a) (Right b)) =
1270− structuralList env $ ProdCons a b
1271− structuralItems _ = structuralIssue
1272− checkSemanticCompatibility env beh schs = do
1273− let defs = getH env
1274− checkFormulas env beh $ schemaToFormula <$> defs <*> schs