@@ -1,1274 +0,0 @@
1−{-# OPTIONS_GHC -fno-warn-orphans #-}
2−
3−module OpenAPI.Checker.Validate.Schema
4− ( JsonType (..)
5− , ForeachType (..)
6− , foldType
7− , forType_
8− , TypedValue (..)
9− , untypeValue
10− , Bound (..)
11− , schemaToFormula
12− , foldLattice
13− , Behave (..)
14− , describeJSONType
15− )
16−where
17−
18−import Algebra.Lattice
19−import Control.Applicative
20−import Control.Arrow
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
28−import Data.Coerce
29−import qualified Data.Foldable as F
30−import Data.Functor
31−import Data.Functor.Identity
32−import Data.HList
33−import qualified Data.HashMap.Strict as HM
34−import qualified Data.HashMap.Strict.InsOrd as IOHM
35−import Data.Int
36−import Data.Kind
37−import qualified Data.List.NonEmpty as NE
38−import qualified Data.Map as M
39−import Data.Maybe
40−import Data.OpenApi hiding (get)
41−import Data.Ord
42−import Data.Ratio
43−import Data.Scientific
44−import qualified Data.Set as S
45−import Data.String
46−import Data.Text (Text)
47−import qualified Data.Text as T hiding (singleton)
48−import qualified Data.Text.Encoding as T
49−import Data.Typeable
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
59−
60−-- | Type of a JSON value
61−data JsonType
62− = Null
63− | Boolean
64− | Number
65− | String
66− | Array
67− | Object
68− deriving stock (Eq, Ord, Show)
69−
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
78−
79−deriving stock instance Eq (TypedValue t)
80−
81−deriving stock instance Ord (TypedValue t)
82−
83−deriving stock instance Show (TypedValue t)
84−
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
92−
93−data Bound a = Exclusive !a | Inclusive !a
94− deriving stock (Eq, Show, Functor)
95−
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
102−
103−data Property = Property
104− { propRequired :: Bool
105− , propFormula :: ForeachType JsonFormula
106− , propRefSchema :: Traced (Referenced Schema)
107− }
108− deriving stock (Eq, Ord, Show)
109−
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
114− Minimum
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
123− Items
124− :: !(ForeachType JsonFormula)
125− -> !(Traced (Referenced Schema))
126− -> Condition 'Array
127− MaxItems :: !Integer -> Condition 'Array
128− MinItems :: !Integer -> Condition 'Array
129− UniqueItems :: Condition 'Array
130− Properties
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
137−
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 _) ->
154− bulletList $
155− (M.toList props
156− <&> (\(k, p) ->
157− para (code k)
158− <> para (strong $ if propRequired p then "Required" else "Optional")
159− <> showForEachJsonFormula (propFormula p)))
160− <> [ para (emph "Additional properties")
161− <> showForEachJsonFormula additional
162− ]
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 <> "."
165− where
166− showForEachJsonFormula :: ForeachType JsonFormula -> Blocks
167− showForEachJsonFormula i =
168− bulletList $
169− foldType
170− (\t f -> case f i of
171− BottomFormula -> mempty
172− (DNF conds') ->
173− let conds = S.toList <$> S.toList conds'
174− in [ para (describeJSONType t)
175− <> bulletList
176− (conds <&> \case
177− [] -> para "Empty"
178− cond -> bulletList (showCondition <$> cond))
179− ])
180−
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
202−
203−checkNumberFormat :: Format -> Scientific -> Bool
204−checkNumberFormat "int32" (toRational -> n) =
205− denominator n == 1
206− && n >= toRational (minBound :: Int32)
207− && n <= toRational (maxBound :: Int32)
208−checkNumberFormat "int64" (toRational -> n) =
209− denominator n == 1
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
215−
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
224−
225−deriving stock instance Eq (Condition t)
226−
227−deriving stock instance Ord (Condition t)
228−
229−deriving stock instance Show (Condition t)
230−
231−data SomeCondition where
232− SomeCondition :: Typeable t => Condition t -> SomeCondition
233−
234−instance Eq SomeCondition where
235− SomeCondition x == SomeCondition y = case cast x of
236− Just x' -> x' == y
237− Nothing -> False
238−
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)
243−
244−deriving stock instance Show SomeCondition
245−
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)
252−
253−disjAdd
254− :: JsonFormula t
255− -> S.Set (Condition t)
256− -> JsonFormula t
257−disjAdd (DNF yss) xs
258− | any (`S.isSubsetOf` xs) yss = DNF yss
259− | otherwise = DNF $ S.insert xs $ S.filter (not . S.isSubsetOf xs) yss
260−
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)
266−
267−pattern BottomFormula :: JsonFormula t
268−pattern BottomFormula <-
269− DNF (S.null -> True)
270− where
271− BottomFormula = DNF S.empty
272−
273−isSingleton :: S.Set a -> Maybe a
274−isSingleton s
275− | S.size s == 1 = S.lookupMin s
276− | otherwise = Nothing
277−
278−pattern Conjunct :: [Condition t] -> S.Set (Condition t)
279−pattern Conjunct xs <-
280− (S.toList -> xs)
281− where
282− Conjunct = S.fromList
283−
284−{-# COMPLETE Conjunct #-}
285−
286−pattern SingleConjunct :: [Condition t] -> JsonFormula t
287−pattern SingleConjunct xs <-
288− DNF (isSingleton -> Just (Conjunct xs))
289− where
290− SingleConjunct xs = DNF $ S.singleton $ Conjunct xs
291−
292−pattern TopFormula :: JsonFormula t
293−pattern TopFormula <-
294− DNF (isSingleton -> Just (S.null -> True))
295− where
296− TopFormula = DNF $ S.singleton S.empty
297−
298−instance BoundedJoinSemiLattice (JsonFormula t) where
299− bottom = BottomFormula
300−
301−instance BoundedMeetSemiLattice (JsonFormula t) where
302− top = TopFormula
303−
304−foldLattice
305− :: BoundedLattice l
306− => (Condition t -> l)
307− -> JsonFormula t
308− -> l
309−foldLattice f (DNF xss) =
310− S.foldl'
311− (\z w ->
312− z \/ S.foldl' (\x y -> x /\ f y) top w)
313− bottom
314− xss
315−
316−satisfiesFormula :: TypedValue t -> JsonFormula t -> Bool
317−satisfiesFormula val = foldLattice (satisfiesTyped val)
318−
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
326− }
327−
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
336−
337−deriving stock instance (forall x. Typeable x => Eq (f x)) => Eq (ForeachType f)
338−
339−deriving stock instance (forall x. Typeable x => Ord (f x)) => Ord (ForeachType f)
340−
341−deriving stock instance (forall x. Typeable x => Show (f x)) => Show (ForeachType f)
342−
343−foldType
344− :: Monoid m
345− => (forall x. Typeable x => JsonType -> (ForeachType f -> f x) -> m)
346− -> m
347−foldType k =
348− k Null forNull
349− <> k Boolean forBoolean
350− <> k Number forNumber
351− <> k String forString
352− <> k Array forArray
353− <> k Object forObject
354−
355−forType_
356− :: Applicative m
357− => (forall x. Typeable x => JsonType -> (ForeachType f -> f x) -> m ())
358− -> m ()
359−forType_ k = do
360− k Null forNull
361− k Boolean forBoolean
362− k Number forNumber
363− k String forString
364− k Array forArray
365− k Object forObject
366− pure ()
367−
368−instance (forall x. Lattice (f x)) => Lattice (ForeachType f) where
369− f1 \/ f2 =
370− ForeachType
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
377− }
378− f1 /\ f2 =
379− ForeachType
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
386− }
387−
388−instance
389− (forall x. BoundedJoinSemiLattice (f x))
390− => BoundedJoinSemiLattice (ForeachType f)
391− where
392− bottom =
393− ForeachType
394− { forNull = bottom
395− , forBoolean = bottom
396− , forNumber = bottom
397− , forString = bottom
398− , forArray = bottom
399− , forObject = bottom
400− }
401−
402−instance
403− (forall x. BoundedMeetSemiLattice (f x))
404− => BoundedMeetSemiLattice (ForeachType f)
405− where
406− top =
407− ForeachType
408− { forNull = top
409− , forBoolean = top
410− , forNumber = top
411− , forString = top
412− , forArray = top
413− , forObject = top
414− }
415−
416−instance Steppable Schema (Referenced Schema) where
417− data Step Schema (Referenced Schema)
418− = AllOfStep Int
419− | OneOfStep Int
420− | AnyOfStep Int
421− | ItemsObjectStep
422− | ItemsArrayStep Int
423− | AdditionalPropertiesStep
424− | NotStep
425− deriving stock (Eq, Ord, Show)
426−
427−instance Steppable Schema (Definitions (Referenced Schema)) where
428− data Step Schema (Definitions (Referenced Schema)) = PropertiesStep
429− deriving stock (Eq, Ord, Show)
430−
431−instance Steppable Schema Discriminator where
432− data Step Schema Discriminator = DiscriminatorStep
433− deriving stock (Eq, Ord, Show)
434−
435−instance Steppable Discriminator (Definitions (Referenced Schema)) where
436− data Step Discriminator (Definitions (Referenced Schema)) = DiscriminatorMapping
437− deriving stock (Eq, Ord, Show)
438−
439−parseDiscriminatorValue :: Text -> Referenced Schema
440−parseDiscriminatorValue v = case A.fromJSON @(Referenced Schema) $ A.object ["$ref" A..= v] of
441− A.Success x -> x
442− A.Error _ -> Ref $ Reference v
443−
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
448−
449−instance MonadWriter (P.PathsPrefixTree q f r) (Silent q f r) where
450− tell _ = Silent ()
451− listen (Silent x) = Silent (x, P.empty)
452− pass (Silent (x, _)) = Silent x
453−
454−instance MonadState (MemoState ()) (Silent q f r) where
455− get = Silent $ runIdentity $ runMemo () get
456− put _ = pure ()
457−
458−type MonadProcess m =
459− ( MonadReader (Traced (Definitions Schema)) m
460− , MonadWriter (P.PathsPrefixTree Behave AnIssue 'SchemaLevel) m
461− , MonadState (MemoState ()) m
462− )
463−
464−type SilentM = ReaderT (Traced (Definitions Schema)) (Silent Behave AnIssue 'SchemaLevel)
465−
466−warn :: MonadProcess m => Issue 'SchemaLevel -> m ()
467−warn issue = tell $ P.singleton $ AnItem Root $ anIssue issue
468−
469−-- | Ignore warnings but allow a recursive loop that lazily computes a recursive 'Condition'.
470−silently :: MonadProcess m => SilentM a -> m a
471−silently m = do
472− defs <- R.ask
473− pure . runSilent $ runReaderT m defs
474−
475−warnKnot :: MonadProcess m => KnotTier (ForeachType JsonFormula) () m
476−warnKnot =
477− KnotTier
478− { onKnotFound = warn UnguardedRecursion
479− , onKnotUsed = \_ -> pure bottom
480− , tieKnot = \_ -> pure
481− }
482−
483−processRefSchema
484− :: MonadProcess m
485− => Traced (Referenced Schema)
486− -> m (ForeachType JsonFormula)
487−processRefSchema x = do
488− defs <- R.ask
489− memoWithKnot warnKnot (processSchema $ dereference defs x) (ask x)
490−
491−tracedAllOf :: Traced Schema -> Maybe [Traced (Referenced Schema)]
492−tracedAllOf sch =
493− _schemaAllOf (extract sch) <&> \xs ->
494− [traced (ask sch >>> step (AllOfStep i)) x | (i, x) <- zip [0 ..] xs]
495−
496−tracedAnyOf :: Traced Schema -> Maybe [Traced (Referenced Schema)]
497−tracedAnyOf sch =
498− _schemaAnyOf (extract sch) <&> \xs ->
499− [traced (ask sch >>> step (AnyOfStep i)) x | (i, x) <- zip [0 ..] xs]
500−
501−tracedOneOf :: Traced Schema -> Maybe [Traced (Referenced Schema)]
502−tracedOneOf sch =
503− _schemaOneOf (extract sch) <&> \xs ->
504− [traced (ask sch >>> step (OneOfStep i)) x | (i, x) <- zip [0 ..] xs]
505−
506−tracedItems :: Traced Schema -> Maybe (Either (Traced (Referenced Schema)) [Traced (Referenced Schema)])
507−tracedItems sch =
508− _schemaItems (extract sch) <&> \case
509− OpenApiItemsObject x -> Left $ traced (ask sch >>> step ItemsObjectStep) x
510− OpenApiItemsArray xs ->
511− Right
512− [traced (ask sch >>> step (ItemsArrayStep i)) x | (i, x) <- zip [0 ..] xs]
513−
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
519−
520−tracedDiscriminator :: Traced Schema -> Maybe (Traced Discriminator)
521−tracedDiscriminator = sequence . stepTraced DiscriminatorStep . fmap _schemaDiscriminator
522−
523−tracedProperties :: Traced Schema -> IOHM.InsOrdHashMap Text (Traced (Referenced Schema))
524−tracedProperties sch =
525− IOHM.mapWithKey
526− (\k -> traced (ask sch >>> step PropertiesStep >>> step (InsOrdHashMapKeyStep k)))
527− (_schemaProperties $ extract sch)
528−
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.
532−processSchema
533− :: MonadProcess m
534− => Traced Schema
535− -> m (ForeachType JsonFormula)
536−processSchema sch@(extract -> Schema {..}) = do
537− let singletonFormula :: Condition t -> JsonFormula t
538− singletonFormula f = SingleConjunct [f]
539−
540− allClauses <- case tracedAllOf sch of
541− Nothing -> pure []
542− Just [] -> [] <$ warn (InvalidSchema "no items in allOf")
543− Just xs -> mapM processRefSchema xs
544−
545− anyClause <- case tracedAnyOf sch of
546− Nothing -> pure top
547− Just [] -> bottom <$ warn (InvalidSchema "no items in anyOf")
548− Just xs -> joins <$> mapM processRefSchema xs
549−
550− oneClause <- case tracedOneOf sch of
551− Nothing -> pure top
552− Just [] -> bottom <$ warn (InvalidSchema "no items in oneOf")
553− Just xs -> do
554− checkOneOfDisjoint xs >>= \case
555− True -> pure ()
556− False -> warn (NotSupported "Could not determine that oneOf branches are disjoint")
557− joins <$> mapM processRefSchema xs
558−
559− case _schemaNot of
560− Nothing -> pure ()
561− Just _ -> warn (NotSupported "not clause is unsupported")
562−
563− let typeClause = case _schemaType of
564− Nothing -> top
565− Just OpenApiNull ->
566− bottom
567− { forNull = top
568− }
569− Just OpenApiBoolean ->
570− bottom
571− { forBoolean = top
572− }
573− Just OpenApiNumber ->
574− bottom
575− { forNumber = top
576− }
577− Just OpenApiInteger ->
578− bottom
579− { forNumber = singletonFormula $ MultipleOf 1
580− }
581− Just OpenApiString ->
582− bottom
583− { forString = top
584− }
585− Just OpenApiArray ->
586− bottom
587− { forArray = top
588− }
589− Just OpenApiObject ->
590− bottom
591− { forObject = top
592− }
593−
594− let valueEnum A.Null =
595− bottom
596− { forNull = singletonFormula $ Exactly TNull
597− }
598− valueEnum (A.Bool b) =
599− bottom
600− { forBoolean = singletonFormula $ Exactly $ TBool b
601− }
602− valueEnum (A.Number n) =
603− bottom
604− { forNumber = singletonFormula $ Exactly $ TNumber n
605− }
606− valueEnum (A.String s) =
607− bottom
608− { forString = singletonFormula $ Exactly $ TString s
609− }
610− valueEnum (A.Array a) =
611− bottom
612− { forArray = singletonFormula $ Exactly $ TArray a
613− }
614− valueEnum (A.Object o) =
615− bottom
616− { forObject = singletonFormula $ Exactly $ TObject o
617− }
618− enumClause <- case _schemaEnum of
619− Nothing -> pure top
620− Just [] -> bottom <$ warn (InvalidSchema "no items in enum")
621− Just xs -> pure $ joins (valueEnum <$> xs)
622−
623− let maximumClause = case _schemaMaximum of
624− Nothing -> top
625− Just n ->
626− top
627− { forNumber = singletonFormula $
628− Maximum $
629− case _schemaExclusiveMaximum of
630− Just True -> Exclusive n
631− _ -> Inclusive n
632− }
633−
634− minimumClause = case _schemaMinimum of
635− Nothing -> top
636− Just n ->
637− top
638− { forNumber = singletonFormula $
639− Minimum $
640− Down $
641− case _schemaExclusiveMinimum of
642− Just True -> Exclusive $ Down n
643− _ -> Inclusive $ Down n
644− }
645−
646− multipleOfClause = case _schemaMultipleOf of
647− Nothing -> top
648− Just n ->
649− top
650− { forNumber = singletonFormula $ MultipleOf n
651− }
652−
653− formatClause <- case _schemaFormat of
654− Nothing -> pure top
655− Just f
656− | f `elem` ["int32", "int64", "float", "double"] ->
657− pure
658− top
659− { forNumber = singletonFormula $ NumberFormat f
660− }
661− Just f
662− | f `elem` ["byte", "binary", "date", "date-time", "password", "uuid"] ->
663− pure
664− top
665− { forString = singletonFormula $ StringFormat f
666− }
667− Just f -> top <$ warn (NotSupported $ "Unknown format: " <> f)
668−
669− let maxLengthClause = case _schemaMaxLength of
670− Nothing -> top
671− Just n ->
672− top
673− { forString = singletonFormula $ MaxLength n
674− }
675−
676− minLengthClause = case _schemaMinLength of
677− Nothing -> top
678− Just n ->
679− top
680− { forString = singletonFormula $ MinLength n
681− }
682−
683− patternClause = case _schemaPattern of
684− Nothing -> top
685− Just p ->
686− top
687− { forString = singletonFormula $ Pattern p
688− }
689−
690− itemsClause <- case tracedItems sch of
691− Nothing -> pure top
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")
696−
697− let maxItemsClause = case _schemaMaxItems of
698− Nothing -> top
699− Just n ->
700− top
701− { forArray = singletonFormula $ MaxItems n
702− }
703−
704− minItemsClause = case _schemaMinItems of
705− Nothing -> top
706− Just n ->
707− top
708− { forArray = singletonFormula $ MinItems n
709− }
710−
711− uniqueItemsClause = case _schemaUniqueItems of
712− Just True ->
713− top
714− { forArray = singletonFormula UniqueItems
715− }
716− _ -> top
717−
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)
725− Nothing ->
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
735− _ -> All False
736− allTop f = getAll $
737− foldType $ \_ ty -> case ty f of
738− TopFormula -> All True
739− _ -> All False
740− -- remove optional fields whose schemata match that of additional props
741− propMap = M.filter (\p -> propRequired p || propFormula p /= addProps) $ M.fromList propList
742− propertiesClause
743− | any (\p -> propRequired p && allBottom (propFormula p)) propMap =
744− bottom -- if any required field has unsatisfiable schema
745− | M.null propMap
746− , allTop addProps =
747− top -- if all fields are optional and have trivial schemata
748− | otherwise =
749− top
750− { forObject = singletonFormula $ Properties propMap addProps addPropSchema
751− }
752−
753− maxPropertiesClause = case _schemaMaxProperties of
754− Nothing -> top
755− Just n ->
756− top
757− { forObject = singletonFormula $ MaxProperties n
758− }
759−
760− minPropertiesClause = case _schemaMinProperties of
761− Nothing -> top
762− Just n ->
763− top
764− { forObject = singletonFormula $ MinProperties n
765− }
766−
767− nullableClause
768− | Just True <- _schemaNullable =
769− bottom
770− { forNull = singletonFormula $ Exactly TNull
771− }
772− | otherwise = bottom
773−
774− pure $
775− nullableClause
776− \/ meets
777− (allClauses
778− <> [ anyClause
779− , oneClause
780− , typeClause
781− , enumClause
782− , maximumClause
783− , minimumClause
784− , multipleOfClause
785− , formatClause
786− , maxLengthClause
787− , minLengthClause
788− , patternClause
789− , itemsClause
790− , maxItemsClause
791− , minItemsClause
792− , uniqueItemsClause
793− , propertiesClause
794− , maxPropertiesClause
795− , minPropertiesClause
796− ])
797−
798−{- TODO: ReadOnly/WriteOnly #68 -}
799−
800−checkOneOfDisjoint :: MonadProcess m => [Traced (Referenced Schema)] -> m Bool
801−checkOneOfDisjoint = const $ pure True -- TODO #69
802−
803−schemaToFormula
804− :: Traced (Definitions Schema)
805− -> Traced Schema
806− -> (ForeachType JsonFormula, P.PathsPrefixTree Behave AnIssue 'SchemaLevel)
807−schemaToFormula defs rs = runWriter . (`runReaderT` defs) . runMemo () $ processSchema rs
808−
809−checkFormulas
810− :: (ReassembleHList xs (CheckEnv (Referenced Schema)))
811− => HList xs
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
818− [] -> do
819− -- We have the following isomorphisms:
820− -- (A ⊂ X ∪ Y) = (A ⊂ X) \/ (A ⊂ Y)
821− -- (A ⊂ X ∩ Y) = (A ⊂ X) /\ (A ⊂ Y)
822− -- (A ⊂ ⊤) = 1
823− -- (X ∪ Y ⊂ B) = (X ⊂ B) /\ (Y ⊂ B)
824− -- (∅ ⊂ B) = 1
825− -- The remaining cases are, notably, not isomorphisms:
826− -- 1) (A ⊂ ∅) <= 0
827− -- 2) (X ∩ Y ⊂ B) <= (X ⊂ B) \/ (Y ⊂ B)
828− -- 3) (⊤ ⊂ B) <= 0
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.
837− --
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)).
841− --
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
866− anyOfAt
867− beh'
868− (issueFromConjunct ps)
869− [F.for_ cs $ checkImplication env beh' ps | Conjunct cs <- S.toList css]
870− pure ()
871− where
872− anyBottomTypes f = getAny $
873− foldType $ \_ ty -> case ty f of
874− BottomFormula -> Any True
875− _ -> mempty
876− nonBottomTypes f = foldType $ \tyName ty -> case ty f of
877− BottomFormula -> mempty
878− _ -> [tyName]
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
885−
886−checkContradiction
887− :: Behavior 'TypedSchemaLevel
888− -> [Condition t]
889− -> SemanticCompatFormula ()
890−checkContradiction beh _ = issueAt beh NoContradiction -- TODO #70
891−
892−checkImplication
893− :: (ReassembleHList xs (CheckEnv (Referenced Schema)))
894− => HList xs
895− -> Behavior 'TypedSchemaLevel
896− -> [Condition t]
897− -> Condition t
898− -> SemanticCompatFormula ()
899−checkImplication env beh prods cons = case findExactly prods of
900− Just e
901− | all (satisfiesTyped e) prods ->
902− if satisfiesTyped e cons
903− then pure ()
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
910− Just m' ->
911− if m' <= m
912− then pure ()
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
916− Just m' ->
917− if m' >= m
918− then pure ()
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
922− Just m' ->
923− if lcmScientific m m' == m'
924− then pure ()
925− else issueAt beh (MatchingMultipleOfWeak $ ProdCons {producer = m', consumer = m})
926− Nothing -> issueAt beh (NoMatchingMultipleOf m)
927− NumberFormat f ->
928− if any (\case NumberFormat f' -> f == f'; _ -> False) prods
929− then pure ()
930− else issueAt beh (NoMatchingFormat f)
931− MaxLength m -> case findRelevant min (\case MaxLength m' -> Just m'; _ -> Nothing) prods of
932− Just m' ->
933− if m' <= m
934− then pure ()
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
938− Just m' ->
939− if m' >= m
940− then pure ()
941− else issueAt beh (MatchingMinLengthWeak $ ProdCons {producer = m', consumer = m})
942− Nothing -> issueAt beh (NoMatchingMinLength m)
943− Pattern p ->
944− if any (\case Pattern p' -> p == p'; _ -> False) prods
945− then pure ()
946− else issueAt beh (NoMatchingPattern p) -- TODO: regex comparison #32
947− StringFormat f ->
948− if any (\case StringFormat f' -> f == f'; _ -> False) prods
949− then pure ()
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'
953− Just rs -> do
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
958− Just m' ->
959− if m' <= m
960− then pure ()
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
964− Just m' ->
965− if m' >= m
966− then pure ()
967− else issueAt beh (MatchingMinItemsWeak ProdCons {producer = m', consumer = m})
968− Nothing -> issueAt beh (NoMatchingMinItems m)
969− UniqueItems ->
970− if any (== UniqueItems) $ prods
971− then pure ()
972− else issueAt beh NoMatchingUniqueItems
973− Properties props _ madd -> case findRelevant (<>) (\case Properties props' _ madd' -> Just $ (props', madd') NE.:| []; _ -> Nothing) prods of
974− Just pm ->
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
983− _ -> pure ()
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 ()
997− 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)
1002− pure ()
1003− Nothing -> issueAt beh NoMatchingProperties
1004− MaxProperties m -> case findRelevant min (\case MaxProperties m' -> Just m'; _ -> Nothing) prods of
1005− Just m' ->
1006− if m' <= m
1007− then pure ()
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
1011− Just m' ->
1012− if m' >= m
1013− then pure ()
1014− else issueAt beh (MatchingMinPropertiesWeak ProdCons {producer = m', consumer = m})
1015− Nothing -> issueAt beh (NoMatchingMinProperties m)
1016− where
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)
1021−
1022−findExactly :: [Condition t] -> Maybe (TypedValue t)
1023−findExactly (Exactly x : _) = Just x
1024−findExactly (_ : xs) = findExactly xs
1025−findExactly [] = Nothing
1026−
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
1058− NoMatchingItems
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
1085− NoContradiction
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."
1136−
1137−showJSONValue :: A.Value -> Blocks
1138−showJSONValue v = codeBlockWith ("", ["json"], mempty) (T.decodeUtf8 . BSL.toStrict . A.encode $ v)
1139−
1140−showBound :: Show a => Bound a -> Inlines
1141−showBound (Inclusive x) = show' x <> " inclusive"
1142−showBound (Exclusive x) = show' x <> " exclusive"
1143−
1144−show' :: Show x => x -> Inlines
1145−show' = str . T.pack . show
1146−
1147−instance Issuable 'SchemaLevel where
1148− data Issue 'SchemaLevel
1149− = -- | Some (openapi-supported) feature that we do not support was encountered in the schema
1150− NotSupported Text
1151− | -- | The schema is actually invalid
1152− InvalidSchema Text
1153− | -- | The schema contains a reference loop along "anyOf"/"allOf"/"oneOf".
1154− UnguardedRecursion
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
1164− UnexpectedProperty
1165− deriving stock (Eq, Ord, Show)
1166− issueIsUnsupported = \case
1167− NotSupported _ -> True
1168− InvalidSchema _ -> True
1169− UnguardedRecursion -> True
1170− _ -> False
1171−
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."
1192−
1193−instance Behavable 'SchemaLevel 'TypedSchemaLevel where
1194− data Behave 'SchemaLevel 'TypedSchemaLevel
1195− = OfType JsonType
1196− deriving stock (Eq, Ord, Show)
1197−
1198− describeBehaviour (OfType t) = describeJSONType t
1199−
1200−describeJSONType :: IsString s => JsonType -> s
1201−describeJSONType = \case
1202− Null -> "Null"
1203− Boolean -> "Boolean"
1204− Number -> "Number"
1205− String -> "String"
1206− Array -> "Array"
1207− Object -> "Object"
1208−
1209−instance Behavable 'TypedSchemaLevel 'SchemaLevel where
1210− data Behave 'TypedSchemaLevel 'SchemaLevel
1211− = InItems
1212− | InProperty Text
1213− | InAdditionalProperty
1214− deriving stock (Eq, Ord, Show)
1215−
1216− describeBehaviour InItems = "Items"
1217− describeBehaviour (InProperty p) = "Property " <> code p
1218− describeBehaviour InAdditionalProperty = "Additional properties"
1219−
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
1254− pure ()
1255− where
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'
1266− pure ()
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