@@ -0,0 +1,1274 @@
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