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