@@ -1,4 +1,5 @@
11{-# OPTIONS_GHC -fno-warn-orphans #-}
2+
23module OpenAPI.Checker.Validate.Schema
34 ( JsonType (..)
45 , ForeachType (..)
@@ -10,7 +11,7 @@ module OpenAPI.Checker.Validate.Schema
1011 , schemaToFormula
1112 , foldLattice
1213 )
13− where
14+where
1415
1516import Algebra.Lattice
1617import Control.Applicative
@@ -23,9 +24,9 @@ import Control.Monad.Writer
2324import qualified Data.Aeson as A
2425import Data.Coerce
2526import qualified Data.Foldable as F
27+import Data.HList
2628import qualified Data.HashMap.Strict as HM
2729import qualified Data.HashMap.Strict.InsOrd as IOHM
28−import Data.HList
2930import Data.Int
3031import Data.Kind
3132import qualified Data.List.NonEmpty as NE
@@ -38,15 +39,13 @@ import Data.Scientific
3839import qualified Data.Set as S
3940import Data.Text (Text)
4041import qualified Data.Text as T hiding (singleton)
41−import qualified Data.Text.Encoding as T
4242import Data.Typeable
4343import OpenAPI.Checker.Behavior
4444import OpenAPI.Checker.Orphans ()
45−import OpenAPI.Checker.References
4645import OpenAPI.Checker.Paths
4746import qualified OpenAPI.Checker.PathsPrefixTree as P
47+import OpenAPI.Checker.References
4848import OpenAPI.Checker.Subtree
49−import Debug.Trace
5049
5150-- | Type of a JSON value
5251data JsonType
@@ -68,7 +67,9 @@ data TypedValue :: JsonType -> Type where
6867 TObject :: !A.Object -> TypedValue 'Object
6968
7069deriving stock instance Eq (TypedValue t)
70+
7171deriving stock instance Ord (TypedValue t)
72+
7273deriving stock instance Show (TypedValue t)
7374
7475untypeValue :: TypedValue t -> A.Value
@@ -100,8 +101,9 @@ data Property = Property
100101data Condition :: JsonType -> Type where
101102 Exactly :: TypedValue t -> Condition t
102103 Maximum :: !(Bound Scientific) -> Condition 'Number
103− Minimum :: !(Down (Bound (Down Scientific))) -> Condition 'Number
104− -- ^ this has the right Ord
104+ Minimum
105+ :: !(Down (Bound (Down Scientific)))
106+ -> Condition 'Number -- ^ this has the right Ord
105107 MultipleOf :: !Scientific -> Condition 'Number
106108 NumberFormat :: !Format -> Condition 'Number
107109 MaxLength :: !Integer -> Condition 'String
@@ -117,10 +119,8 @@ data Condition :: JsonType -> Type where
117119 UniqueItems :: Condition 'Array
118120 Properties
119121 :: !(M.Map Text Property)
120− -> !(ForeachType JsonFormula)
121− -- ^ formula for additional properties
122− -> !(Maybe (Traced (Referenced Schema)))
123− -- ^ schema for additional properties, Nothing means bottom
122+ -> !(ForeachType JsonFormula) -- ^ formula for additional properties
123+ -> !(Maybe (Traced (Referenced Schema))) -- ^ schema for additional properties, Nothing means bottom
124124 -> Condition 'Object
125125 MaxProperties :: !Integer -> Condition 'Object
126126 MinProperties :: !Integer -> Condition 'Object
@@ -136,28 +136,34 @@ satisfiesTyped (TNumber n) (NumberFormat f) = checkNumberFormat f n
136136satisfiesTyped (TString s) (MaxLength m) = fromIntegral (T.length s) <= m
137137satisfiesTyped (TString s) (MinLength m) = fromIntegral (T.length s) >= m
138138satisfiesTyped (TString s) (Pattern p) = undefined s p -- TODO: regex stuff
139−satisfiesTyped (TString s) (StringFormat f) = undefined s f-- TODO: string format
139+satisfiesTyped (TString s) (StringFormat f) = undefined s f -- TODO: string format
140140satisfiesTyped (TArray a) (Items f _) = all (`satisfies` f) a
141141satisfiesTyped (TArray a) (MaxItems m) = fromIntegral (F.length a) <= m
142142satisfiesTyped (TArray a) (MinItems m) = fromIntegral (F.length a) >= m
143143satisfiesTyped (TArray a) UniqueItems = S.size (S.fromList $ F.toList a) == F.length a -- TODO: could be better
144−satisfiesTyped (TObject o) (Properties props additional _)
145− = all (`HM.member` o) (M.keys (M.filter propRequired props))
146− && all (\(k, v) -> satisfies v $ maybe additional propFormula $ M.lookup k props) (HM.toList o)
144+satisfiesTyped (TObject o) (Properties props additional _) =
145+ all (`HM.member` o) (M.keys (M.filter propRequired props))
146+ && all (\(k, v) -> satisfies v $ maybe additional propFormula $ M.lookup k props) (HM.toList o)
147147satisfiesTyped (TObject o) (MaxProperties m) = fromIntegral (HM.size o) <= m
148148satisfiesTyped (TObject o) (MinProperties m) = fromIntegral (HM.size o) >= m
149149
150150checkNumberFormat :: Format -> Scientific -> Bool
151−checkNumberFormat "int32" (toRational -> n) = denominator n == 1
152− && n >= toRational (minBound :: Int32) && n <= toRational (maxBound :: Int32)
153−checkNumberFormat "int64" (toRational -> n) = denominator n == 1
154− && n >= toRational (minBound :: Int64) && n <= toRational (maxBound :: Int64)
151+checkNumberFormat "int32" (toRational -> n) =
152+ denominator n == 1
153+ && n >= toRational (minBound :: Int32)
154+ && n <= toRational (maxBound :: Int32)
155+checkNumberFormat "int64" (toRational -> n) =
156+ denominator n == 1
157+ && n >= toRational (minBound :: Int64)
158+ && n <= toRational (maxBound :: Int64)
155159checkNumberFormat "float" _n = True
156160checkNumberFormat "double" _n = True
157161checkNumberFormat f _n = error $ "Invalid number format: " <> T.unpack f
158162
159163deriving stock instance Eq (Condition t)
164+
160165deriving stock instance Ord (Condition t)
166+
161167deriving stock instance Show (Condition t)
162168
163169data SomeCondition where
@@ -192,12 +198,15 @@ disjAdd (DNF yss) xs
192198
193199instance Lattice (JsonFormula t) where
194200 xss \/ DNF yss = S.foldl' disjAdd xss yss
195− DNF xss /\ DNF yss = F.foldl' disjAdd bottom $
196− liftA2 S.union (S.toList xss) (S.toList yss)
201+ DNF xss /\ DNF yss =
202+ F.foldl' disjAdd bottom $
203+ liftA2 S.union (S.toList xss) (S.toList yss)
197204
198205pattern BottomFormula :: JsonFormula t
199−pattern BottomFormula <- DNF (S.null -> True)
200− where BottomFormula = DNF S.empty
206+pattern BottomFormula <-
207+ DNF (S.null -> True)
208+ where
209+ BottomFormula = DNF S.empty
201210
202211isSingleton :: S.Set a -> Maybe a
203212isSingleton s
@@ -205,17 +214,24 @@ isSingleton s
205214 | otherwise = Nothing
206215
207216pattern Conjunct :: [Condition t] -> S.Set (Condition t)
208−pattern Conjunct xs <- (S.toList -> xs)
209− where Conjunct = S.fromList
217+pattern Conjunct xs <-
218+ (S.toList -> xs)
219+ where
220+ Conjunct = S.fromList
221+
210222{-# COMPLETE Conjunct #-}
211223
212224pattern SingleConjunct :: [Condition t] -> JsonFormula t
213−pattern SingleConjunct xs <- DNF (isSingleton -> Just (Conjunct xs))
214− where SingleConjunct xs = DNF $ S.singleton $ Conjunct xs
225+pattern SingleConjunct xs <-
226+ DNF (isSingleton -> Just (Conjunct xs))
227+ where
228+ SingleConjunct xs = DNF $ S.singleton $ Conjunct xs
215229
216230pattern TopFormula :: JsonFormula t
217−pattern TopFormula <- DNF (isSingleton -> Just (S.null -> True))
218− where TopFormula = DNF $ S.singleton S.empty
231+pattern TopFormula <-
232+ DNF (isSingleton -> Just (S.null -> True))
233+ where
234+ TopFormula = DNF $ S.singleton S.empty
219235
220236instance BoundedJoinSemiLattice (JsonFormula t) where
221237 bottom = BottomFormula
@@ -228,8 +244,12 @@ foldLattice
228244 => (Condition t -> l)
229245 -> JsonFormula t
230246 -> l
231−foldLattice f (DNF xss) = S.foldl' (\z w ->
232− z \/ S.foldl' (\x y -> x /\ f y) top w) bottom xss
247+foldLattice f (DNF xss) =
248+ S.foldl'
249+ (\z w ->
250+ z \/ S.foldl' (\x y -> x /\ f y) top w)
251+ bottom
252+ xss
233253
234254satisfiesFormula :: TypedValue t -> JsonFormula t -> Bool
235255satisfiesFormula val = foldLattice (satisfiesTyped val)
@@ -253,7 +273,9 @@ satisfies val p = case val of
253273 A.Object o -> satisfiesFormula (TObject o) $ forObject p
254274
255275deriving stock instance (forall x. Typeable x => Eq (f x)) => Eq (ForeachType f)
276+
256277deriving stock instance (forall x. Typeable x => Ord (f x)) => Ord (ForeachType f)
278+
257279deriving stock instance (forall x. Typeable x => Show (f x)) => Show (ForeachType f)
258280
259281foldType
@@ -261,12 +283,12 @@ foldType
261283 => (forall x. Typeable x => JsonType -> (ForeachType f -> f x) -> m)
262284 -> m
263285foldType k =
264− k Null forNull <>
265− k Boolean forBoolean <>
266− k Number forNumber <>
267− k String forString <>
268− k Array forArray <>
269− k Object forObject
286+ k Null forNull
287+ <> k Boolean forBoolean
288+ <> k Number forNumber
289+ <> k String forString
290+ <> k Array forArray
291+ <> k Object forObject
270292
271293forType_
272294 :: Applicative m
@@ -282,44 +304,52 @@ forType_ k = do
282304 pure ()
283305
284306instance (forall x. Lattice (f x)) => Lattice (ForeachType f) where
285− f1 \/ f2 = ForeachType
286− { forNull = forNull f1 \/ forNull f2
287− , forBoolean = forBoolean f1 \/ forBoolean f2
288− , forNumber = forNumber f1 \/ forNumber f2
289− , forString = forString f1 \/ forString f2
290− , forArray = forArray f1 \/ forArray f2
291− , forObject = forObject f1 \/ forObject f2
292− }
293− f1 /\ f2 = ForeachType
294− { forNull = forNull f1 /\ forNull f2
295− , forBoolean = forBoolean f1 /\ forBoolean f2
296− , forNumber = forNumber f1 /\ forNumber f2
297− , forString = forString f1 /\ forString f2
298− , forArray = forArray f1 /\ forArray f2
299− , forObject = forObject f1 /\ forObject f2
300− }
301−
302−instance (forall x. BoundedJoinSemiLattice (f x))
303− => BoundedJoinSemiLattice (ForeachType f) where
304− bottom = ForeachType
305− { forNull = bottom
306− , forBoolean = bottom
307− , forNumber = bottom
308− , forString = bottom
309− , forArray = bottom
310− , forObject = bottom
311− }
312−
313−instance (forall x. BoundedMeetSemiLattice (f x))
314− => BoundedMeetSemiLattice (ForeachType f) where
315− top = ForeachType
316− { forNull = top
317− , forBoolean = top
318− , forNumber = top
319− , forString = top
320− , forArray = top
321− , forObject = top
322− }
307+ f1 \/ f2 =
308+ ForeachType
309+ { forNull = forNull f1 \/ forNull f2
310+ , forBoolean = forBoolean f1 \/ forBoolean f2
311+ , forNumber = forNumber f1 \/ forNumber f2
312+ , forString = forString f1 \/ forString f2
313+ , forArray = forArray f1 \/ forArray f2
314+ , forObject = forObject f1 \/ forObject f2
315+ }
316+ f1 /\ f2 =
317+ ForeachType
318+ { forNull = forNull f1 /\ forNull f2
319+ , forBoolean = forBoolean f1 /\ forBoolean f2
320+ , forNumber = forNumber f1 /\ forNumber f2
321+ , forString = forString f1 /\ forString f2
322+ , forArray = forArray f1 /\ forArray f2
323+ , forObject = forObject f1 /\ forObject f2
324+ }
325+
326+instance
327+ (forall x. BoundedJoinSemiLattice (f x))
328+ => BoundedJoinSemiLattice (ForeachType f)
329+ where
330+ bottom =
331+ ForeachType
332+ { forNull = bottom
333+ , forBoolean = bottom
334+ , forNumber = bottom
335+ , forString = bottom
336+ , forArray = bottom
337+ , forObject = bottom
338+ }
339+
340+instance
341+ (forall x. BoundedMeetSemiLattice (f x))
342+ => BoundedMeetSemiLattice (ForeachType f)
343+ where
344+ top =
345+ ForeachType
346+ { forNull = top
347+ , forBoolean = top
348+ , forNumber = top
349+ , forString = top
350+ , forArray = top
351+ , forObject = top
352+ }
323353
324354{- TODO: remove
325355instance Typeable t => Steppable Schema (Condition t) where
@@ -356,9 +386,26 @@ instance Steppable Schema (Referenced Schema) where
356386 | ItemsObjectStep
357387 | ItemsArrayStep Int
358388 | AdditionalPropertiesStep
359− | PropertiesStep Text
389+ | NotStep
390+ deriving (Eq, Ord, Show)
391+
392+instance Steppable Schema (Definitions (Referenced Schema)) where
393+ data Step Schema (Definitions (Referenced Schema)) = PropertiesStep
394+ deriving (Eq, Ord, Show)
395+
396+instance Steppable Schema Discriminator where
397+ data Step Schema Discriminator = DiscriminatorStep
398+ deriving (Eq, Ord, Show)
399+
400+instance Steppable Discriminator (Definitions (Referenced Schema)) where
401+ data Step Discriminator (Definitions (Referenced Schema)) = DiscriminatorMapping
360402 deriving (Eq, Ord, Show)
361403
404+parseDiscriminatorValue :: Text -> Referenced Schema
405+parseDiscriminatorValue v = case A.fromJSON @(Referenced Schema) $ A.object ["$ref" A..= v] of
406+ A.Success x -> x
407+ A.Error _ -> Ref $ Reference v
408+
362409type ProcessM = ReaderT (Traced (Definitions Schema)) (Writer (P.PathsPrefixTree Behave AnIssue 'SchemaLevel))
363410
364411warn :: Issue 'SchemaLevel -> ProcessM ()
@@ -372,31 +419,42 @@ processRefSchema x = do
372419 processSchema $ dereference defs x
373420
374421tracedAllOf :: Traced Schema -> Maybe [Traced (Referenced Schema)]
375−tracedAllOf sch = _schemaAllOf (extract sch) <&> \xs ->
376− [ traced (ask sch >>> step (AllOfStep i)) x | (i, x) <- zip [0..] xs ]
422+tracedAllOf sch =
423+ _schemaAllOf (extract sch) <&> \xs ->
424+ [traced (ask sch >>> step (AllOfStep i)) x | (i, x) <- zip [0 ..] xs]
377425
378426tracedAnyOf :: Traced Schema -> Maybe [Traced (Referenced Schema)]
379−tracedAnyOf sch = _schemaAnyOf (extract sch) <&> \xs ->
380− [ traced (ask sch >>> step (AnyOfStep i)) x | (i, x) <- zip [0..] xs ]
427+tracedAnyOf sch =
428+ _schemaAnyOf (extract sch) <&> \xs ->
429+ [traced (ask sch >>> step (AnyOfStep i)) x | (i, x) <- zip [0 ..] xs]
381430
382431tracedOneOf :: Traced Schema -> Maybe [Traced (Referenced Schema)]
383−tracedOneOf sch = _schemaOneOf (extract sch) <&> \xs ->
384− [ traced (ask sch >>> step (OneOfStep i)) x | (i, x) <- zip [0..] xs ]
432+tracedOneOf sch =
433+ _schemaOneOf (extract sch) <&> \xs ->
434+ [traced (ask sch >>> step (OneOfStep i)) x | (i, x) <- zip [0 ..] xs]
385435
386436tracedItems :: Traced Schema -> Maybe (Either (Traced (Referenced Schema)) [Traced (Referenced Schema)])
387−tracedItems sch = _schemaItems (extract sch) <&> \case
388− OpenApiItemsObject x -> Left $ traced (ask sch >>> step ItemsObjectStep) x
389− OpenApiItemsArray xs -> Right
390− [ traced (ask sch >>> step (ItemsArrayStep i)) x | (i, x) <- zip [0..] xs ]
437+tracedItems sch =
438+ _schemaItems (extract sch) <&> \case
439+ OpenApiItemsObject x -> Left $ traced (ask sch >>> step ItemsObjectStep) x
440+ OpenApiItemsArray xs ->
441+ Right
442+ [traced (ask sch >>> step (ItemsArrayStep i)) x | (i, x) <- zip [0 ..] xs]
391443
392444tracedAdditionalProperties :: Traced Schema -> Maybe (Either Bool (Traced (Referenced Schema)))
393−tracedAdditionalProperties sch = _schemaAdditionalProperties (extract sch) <&> \case
394− AdditionalPropertiesAllowed b -> Left b
395− AdditionalPropertiesSchema x -> Right $ traced (ask sch >>> step AdditionalPropertiesStep) x
445+tracedAdditionalProperties sch =
446+ _schemaAdditionalProperties (extract sch) <&> \case
447+ AdditionalPropertiesAllowed b -> Left b
448+ AdditionalPropertiesSchema x -> Right $ traced (ask sch >>> step AdditionalPropertiesStep) x
449+
450+tracedDiscriminator :: Traced Schema -> Maybe (Traced Discriminator)
451+tracedDiscriminator = sequence . stepTraced DiscriminatorStep . fmap _schemaDiscriminator
396452
397453tracedProperties :: Traced Schema -> IOHM.InsOrdHashMap Text (Traced (Referenced Schema))
398−tracedProperties sch = IOHM.mapWithKey (\k -> traced (ask sch >>> step (PropertiesStep k)))
399− $ _schemaProperties $ extract sch
454+tracedProperties sch =
455+ IOHM.mapWithKey
456+ (\k -> traced (ask sch >>> step PropertiesStep >>> step (InsOrdHashMapKeyStep k)))
457+ (_schemaProperties $ extract sch)
400458
401459-- | Turn a schema into a tuple of 'JsonFormula's that describes the condition
402460-- for every possible type of a JSON value. The conditions are independent, and
@@ -404,10 +462,9 @@ tracedProperties sch = IOHM.mapWithKey (\k -> traced (ask sch >>> step (Properti
404462processSchema
405463 :: Traced Schema
406464 -> ProcessM (ForeachType JsonFormula)
407−processSchema sch@(extract -> Schema{..}) = do
408− let
409− singletonFormula :: Condition t -> JsonFormula t
410− singletonFormula f = SingleConjunct [f]
465+processSchema sch@(extract -> Schema {..}) = do
466+ let singletonFormula :: Condition t -> JsonFormula t
467+ singletonFormula f = SingleConjunct [f]
411468
412469 allClauses <- case tracedAllOf sch of
413470 Nothing -> pure []
@@ -432,110 +489,160 @@ processSchema sch@(extract -> Schema{..}) = do
432489 Nothing -> pure ()
433490 Just _ -> warn (NotSupported "not clause is unsupported")
434491
435− let
436− typeClause = case _schemaType of
437− Nothing -> top
438− Just OpenApiNull -> bottom
439− { forNull = top }
440− Just OpenApiBoolean -> bottom
441− { forBoolean = top }
442− Just OpenApiNumber -> bottom
443− { forBoolean = top }
444− Just OpenApiInteger -> bottom
445− { forNumber = singletonFormula $ MultipleOf 1 }
446− Just OpenApiString -> bottom
447− { forString = top }
448− Just OpenApiArray -> bottom
449− { forArray = top }
450− Just OpenApiObject -> bottom
451− { forObject = top }
452−
453− let
454− valueEnum A.Null = bottom
455− { forNull = singletonFormula $ Exactly TNull }
456− valueEnum (A.Bool b) = bottom
457− { forBoolean = singletonFormula $ Exactly $ TBool b }
458− valueEnum (A.Number n) = bottom
459− { forNumber = singletonFormula $ Exactly $ TNumber n }
460− valueEnum (A.String s) = bottom
461− { forString = singletonFormula $ Exactly $ TString s }
462− valueEnum (A.Array a) = bottom
463− { forArray = singletonFormula $ Exactly $ TArray a }
464− valueEnum (A.Object o) = bottom
465− { forObject = singletonFormula $ Exactly $ TObject o }
492+ let typeClause = case _schemaType of
493+ Nothing -> top
494+ Just OpenApiNull ->
495+ bottom
496+ { forNull = top
497+ }
498+ Just OpenApiBoolean ->
499+ bottom
500+ { forBoolean = top
501+ }
502+ Just OpenApiNumber ->
503+ bottom
504+ { forBoolean = top
505+ }
506+ Just OpenApiInteger ->
507+ bottom
508+ { forNumber = singletonFormula $ MultipleOf 1
509+ }
510+ Just OpenApiString ->
511+ bottom
512+ { forString = top
513+ }
514+ Just OpenApiArray ->
515+ bottom
516+ { forArray = top
517+ }
518+ Just OpenApiObject ->
519+ bottom
520+ { forObject = top
521+ }
522+
523+ let valueEnum A.Null =
524+ bottom
525+ { forNull = singletonFormula $ Exactly TNull
526+ }
527+ valueEnum (A.Bool b) =
528+ bottom
529+ { forBoolean = singletonFormula $ Exactly $ TBool b
530+ }
531+ valueEnum (A.Number n) =
532+ bottom
533+ { forNumber = singletonFormula $ Exactly $ TNumber n
534+ }
535+ valueEnum (A.String s) =
536+ bottom
537+ { forString = singletonFormula $ Exactly $ TString s
538+ }
539+ valueEnum (A.Array a) =
540+ bottom
541+ { forArray = singletonFormula $ Exactly $ TArray a
542+ }
543+ valueEnum (A.Object o) =
544+ bottom
545+ { forObject = singletonFormula $ Exactly $ TObject o
546+ }
466547 enumClause <- case _schemaEnum of
467548 Nothing -> pure top
468549 Just [] -> bottom <$ warn (InvalidSchema "no items in enum")
469550 Just xs -> pure $ joins (valueEnum <$> xs)
470551
471− let
472− maximumClause = case _schemaMaximum of
473− Nothing -> top
474− Just n -> top
475− { forNumber = singletonFormula $ Maximum $
476− case _schemaExclusiveMaximum of
477− Just True -> Exclusive n
478− _ -> Inclusive n }
479−
480− minimumClause = case _schemaMinimum of
481− Nothing -> top
482− Just n -> top
483− { forNumber = singletonFormula $ Minimum $ Down $
484− case _schemaExclusiveMinimum of
485− Just True -> Exclusive $ Down n
486− _ -> Inclusive $ Down n }
487−
488− multipleOfClause = case _schemaMultipleOf of
489− Nothing -> top
490− Just n -> top
491− { forNumber = singletonFormula $ MultipleOf n }
552+ let maximumClause = case _schemaMaximum of
553+ Nothing -> top
554+ Just n ->
555+ top
556+ { forNumber = singletonFormula $
557+ Maximum $
558+ case _schemaExclusiveMaximum of
559+ Just True -> Exclusive n
560+ _ -> Inclusive n
561+ }
562+
563+ minimumClause = case _schemaMinimum of
564+ Nothing -> top
565+ Just n ->
566+ top
567+ { forNumber = singletonFormula $
568+ Minimum $
569+ Down $
570+ case _schemaExclusiveMinimum of
571+ Just True -> Exclusive $ Down n
572+ _ -> Inclusive $ Down n
573+ }
574+
575+ multipleOfClause = case _schemaMultipleOf of
576+ Nothing -> top
577+ Just n ->
578+ top
579+ { forNumber = singletonFormula $ MultipleOf n
580+ }
492581
493582 formatClause <- case _schemaFormat of
494583 Nothing -> pure top
495− Just f | f `elem` ["int32", "int64", "float", "double"] -> pure top
496− { forNumber = singletonFormula $ NumberFormat f }
497− Just f | f `elem` ["byte", "binary", "date", "date-time", "password"] -> pure top
498− { forString = singletonFormula $ StringFormat f }
584+ Just f
585+ | f `elem` ["int32", "int64", "float", "double"] ->
586+ pure
587+ top
588+ { forNumber = singletonFormula $ NumberFormat f
589+ }
590+ Just f
591+ | f `elem` ["byte", "binary", "date", "date-time", "password"] ->
592+ pure
593+ top
594+ { forString = singletonFormula $ StringFormat f
595+ }
499596 Just f -> top <$ warn (NotSupported $ "Unknown format: " <> f)
500597
501− let
502− maxLengthClause = case _schemaMaxLength of
503− Nothing -> top
504− Just n -> top
505− { forString = singletonFormula $ MaxLength n }
506−
507− minLengthClause = case _schemaMinLength of
508− Nothing -> top
509− Just n -> top
510− { forString = singletonFormula $ MinLength n }
511−
512− patternClause = case _schemaPattern of
513− Nothing -> top
514− Just p -> top
515− { forString = singletonFormula $ Pattern p }
598+ let maxLengthClause = case _schemaMaxLength of
599+ Nothing -> top
600+ Just n ->
601+ top
602+ { forString = singletonFormula $ MaxLength n
603+ }
604+
605+ minLengthClause = case _schemaMinLength of
606+ Nothing -> top
607+ Just n ->
608+ top
609+ { forString = singletonFormula $ MinLength n
610+ }
611+
612+ patternClause = case _schemaPattern of
613+ Nothing -> top
614+ Just p ->
615+ top
616+ { forString = singletonFormula $ Pattern p
617+ }
516618
517619 itemsClause <- case tracedItems sch of
518620 Nothing -> pure top
519621 Just (Left rs) -> do
520622 f <- processRefSchema rs
521− pure top { forArray = singletonFormula $ Items f rs }
623+ pure top {forArray = singletonFormula $ Items f rs}
522624 Just (Right _) -> top <$ warn (NotSupported "array in items is not supported")
523625
524− let
525− maxItemsClause = case _schemaMaxItems of
526− Nothing -> top
527− Just n -> top
528− { forArray = singletonFormula $ MaxItems n }
529−
530− minItemsClause = case _schemaMinItems of
531− Nothing -> top
532− Just n -> top
533− { forArray = singletonFormula $ MinItems n }
534−
535− uniqueItemsClause = case _schemaUniqueItems of
536− Just True -> top
537− { forArray = singletonFormula UniqueItems }
538− _ -> top
626+ let maxItemsClause = case _schemaMaxItems of
627+ Nothing -> top
628+ Just n ->
629+ top
630+ { forArray = singletonFormula $ MaxItems n
631+ }
632+
633+ minItemsClause = case _schemaMinItems of
634+ Nothing -> top
635+ Just n ->
636+ top
637+ { forArray = singletonFormula $ MinItems n
638+ }
639+
640+ uniqueItemsClause = case _schemaUniqueItems of
641+ Just True ->
642+ top
643+ { forArray = singletonFormula UniqueItems
644+ }
645+ _ -> top
539646
540647 (addProps, addPropSchema) <- case tracedAdditionalProperties sch of
541648 Just (Right rs) -> (,Just rs) <$> processRefSchema rs
@@ -544,50 +651,79 @@ processSchema sch@(extract -> Schema{..}) = do
544651 propList <- forM (S.toList . S.fromList $ IOHM.keys _schemaProperties <> _schemaRequired) $ \k -> do
545652 (f, psch) <- case IOHM.lookup k $ tracedProperties sch of
546653 Just rs -> (,rs) <$> processRefSchema rs
547− Nothing -> let fakeSchema = traced (ask sch `Snoc` AdditionalPropertiesStep) $ Inline mempty
548− -- The mempty here is incorrect, but if addPropSchema was Nothing, then
549− -- addProps is bottom, and k is in _schemaRequired. We handle this situation
550− -- below and short-circuit the entire Properties condition to bottom
551− in pure (addProps, fromMaybe fakeSchema addPropSchema)
654+ Nothing ->
655+ let fakeSchema = traced (ask sch `Snoc` AdditionalPropertiesStep) $ Inline mempty
656+ in -- The mempty here is incorrect, but if addPropSchema was Nothing, then
657+ -- addProps is bottom, and k is in _schemaRequired. We handle this situation
658+ -- below and short-circuit the entire Properties condition to bottom
659+ pure (addProps, fromMaybe fakeSchema addPropSchema)
552660 pure (k, Property (k `elem` _schemaRequired) f psch)
553− let
554− allBottom f = getAll $ foldType $ \_ ty -> case ty f of
555− BottomFormula -> All True
556− _ -> All False
557− allTop f = getAll $ foldType $ \_ ty -> case ty f of
558− TopFormula -> All True
559− _ -> All False
560− -- remove optional fields whose schemata match that of additional props
561− propMap = M.filter (\p -> propRequired p || propFormula p /= addProps) $ M.fromList propList
562− propertiesClause
563− | any (\p -> propRequired p && allBottom (propFormula p)) propMap
564− = bottom -- if any required field has unsatisfiable schema
565− | M.null propMap, allTop addProps
566− = top -- if all fields are optional and have trivial schemata
567− | otherwise
568− = top
569− { forObject = singletonFormula $ Properties propMap addProps addPropSchema }
570−
571− maxPropertiesClause = case _schemaMaxProperties of
572− Nothing -> top
573− Just n -> top
574− { forObject = singletonFormula $ MaxProperties n }
575−
576− minPropertiesClause = case _schemaMinProperties of
577− Nothing -> top
578− Just n -> top
579− { forObject = singletonFormula $ MinProperties n }
580−
661+ let allBottom f = getAll $
662+ foldType $ \_ ty -> case ty f of
663+ BottomFormula -> All True
664+ _ -> All False
665+ allTop f = getAll $
666+ foldType $ \_ ty -> case ty f of
667+ TopFormula -> All True
668+ _ -> All False
669+ -- remove optional fields whose schemata match that of additional props
670+ propMap = M.filter (\p -> propRequired p || propFormula p /= addProps) $ M.fromList propList
671+ propertiesClause
672+ | any (\p -> propRequired p && allBottom (propFormula p)) propMap =
673+ bottom -- if any required field has unsatisfiable schema
674+ | M.null propMap
675+ , allTop addProps =
676+ top -- if all fields are optional and have trivial schemata
677+ | otherwise =
678+ top
679+ { forObject = singletonFormula $ Properties propMap addProps addPropSchema
680+ }
681+
682+ maxPropertiesClause = case _schemaMaxProperties of
683+ Nothing -> top
684+ Just n ->
685+ top
686+ { forObject = singletonFormula $ MaxProperties n
687+ }
688+
689+ minPropertiesClause = case _schemaMinProperties of
690+ Nothing -> top
691+ Just n ->
692+ top
693+ { forObject = singletonFormula $ MinProperties n
694+ }
695+
696+ nullableClause
697+ | Just True <- _schemaNullable =
698+ bottom
699+ { forNull = singletonFormula $ Exactly TNull
700+ }
701+ | otherwise = bottom
702+
703+ pure $
581704 nullableClause
582− | Just True <- _schemaNullable = bottom
583− { forNull = singletonFormula $ Exactly TNull }
584− | otherwise = bottom
585−
586− pure $ nullableClause \/ meets (allClauses <>
587− [ anyClause, oneClause, typeClause, enumClause, maximumClause, minimumClause
588− , multipleOfClause, formatClause, maxLengthClause, minLengthClause
589− , patternClause, itemsClause, maxItemsClause, minItemsClause
590− , uniqueItemsClause, propertiesClause, maxPropertiesClause, minPropertiesClause])
705+ \/ meets
706+ (allClauses
707+ <> [ anyClause
708+ , oneClause
709+ , typeClause
710+ , enumClause
711+ , maximumClause
712+ , minimumClause
713+ , multipleOfClause
714+ , formatClause
715+ , maxLengthClause
716+ , minLengthClause
717+ , patternClause
718+ , itemsClause
719+ , maxItemsClause
720+ , minItemsClause
721+ , uniqueItemsClause
722+ , propertiesClause
723+ , maxPropertiesClause
724+ , minPropertiesClause
725+ ])
726+
591727{- TODO: ReadOnly/WriteOnly -}
592728
593729checkOneOfDisjoint :: [Traced (Referenced Schema)] -> ProcessM Bool
@@ -607,7 +743,7 @@ checkFormulas
607743 -> SemanticCompatFormula ()
608744checkFormulas env beh (ProdCons (fp, ep) (fc, ec)) =
609745 case P.toList ep ++ P.toList ec of
610− issues@(_:_) -> F.for_ issues $ \(AnItem t (AnIssue e)) -> issueAt (beh >>> t) e
746+ issues@(_ : _) -> F.for_ issues $ \(AnItem t (AnIssue e)) -> issueAt (beh >>> t) e
611747 [] -> do
612748 -- We have the following isomorphisms:
613749 -- (A ⊂ X ∪ Y) = (A ⊂ X) \/ (A ⊂ Y)
@@ -643,7 +779,9 @@ checkFormulas env beh (ProdCons (fp, ep) (fc, ec)) =
643779 (DNF pss, SingleConjunct cs) -> F.for_ pss $ \(Conjunct ps) -> do
644780 F.for_ cs $ checkImplication env beh' ps -- avoid disjuntion if there's only one conjunct
645781 (DNF pss, DNF css) -> F.for_ pss $ \(Conjunct ps) -> do
646− anyOfAt beh' (NoMatchingCondition $ SomeCondition <$> ps)
782+ anyOfAt
783+ beh'
784+ (NoMatchingCondition $ SomeCondition <$> ps)
647785 [F.for_ cs $ checkImplication env beh' ps | Conjunct cs <- S.toList css]
648786
649787checkContradiction
@@ -662,54 +800,77 @@ checkImplication
662800checkImplication env beh prods cons = case findExactly prods of
663801 Just e
664802 | all (satisfiesTyped e) prods ->
665− if satisfiesTyped e cons then pure ()
803+ if satisfiesTyped e cons
804+ then pure ()
666805 else issueAt beh (EnumDoesntSatisfy $ untypeValue e)
667806 | otherwise -> pure () -- vacuously true
668807 Nothing -> case cons of
669808 -- the above code didn't catch it, so there's no Exactly condition on the lhs
670809 Exactly e -> issueAt beh (NoMatchingEnum $ untypeValue e)
671810 Maximum m -> case findRelevant min (\case Maximum m' -> Just m'; _ -> Nothing) prods of
672− Just m' -> if m' <= m then pure ()
673− else issueAt beh (MatchingMaximumWeak m m')
811+ Just m' ->
812+ if m' <= m
813+ then pure ()
814+ else issueAt beh (MatchingMaximumWeak m m')
674815 Nothing -> issueAt beh (NoMatchingMaximum m)
675816 Minimum m -> case findRelevant max (\case Minimum m' -> Just m'; _ -> Nothing) prods of
676− Just m' -> if m' >= m then pure ()
677− else issueAt beh (MatchingMinimumWeak (coerce m) (coerce m'))
817+ Just m' ->
818+ if m' >= m
819+ then pure ()
820+ else issueAt beh (MatchingMinimumWeak (coerce m) (coerce m'))
678821 Nothing -> issueAt beh (NoMatchingMinimum (coerce m))
679822 MultipleOf m -> case findRelevant lcmScientific (\case MultipleOf m' -> Just m'; _ -> Nothing) prods of
680− Just m' -> if lcmScientific m m' == m' then pure ()
681− else issueAt beh (MatchingMultipleOfWeak m m')
823+ Just m' ->
824+ if lcmScientific m m' == m'
825+ then pure ()
826+ else issueAt beh (MatchingMultipleOfWeak m m')
682827 Nothing -> issueAt beh (NoMatchingMultipleOf m)
683− NumberFormat f -> if any (\case NumberFormat f' -> f == f'; _ -> False) prods
684− then pure () else issueAt beh (NoMatchingFormat f)
828+ NumberFormat f ->
829+ if any (\case NumberFormat f' -> f == f'; _ -> False) prods
830+ then pure ()
831+ else issueAt beh (NoMatchingFormat f)
685832 MaxLength m -> case findRelevant min (\case MaxLength m' -> Just m'; _ -> Nothing) prods of
686− Just m' -> if m' <= m then pure ()
687− else issueAt beh (MatchingMaxLengthWeak m m')
833+ Just m' ->
834+ if m' <= m
835+ then pure ()
836+ else issueAt beh (MatchingMaxLengthWeak m m')
688837 Nothing -> issueAt beh (NoMatchingMaxLength m)
689838 MinLength m -> case findRelevant max (\case MinLength m' -> Just m'; _ -> Nothing) prods of
690− Just m' -> if m' >= m then pure ()
691− else issueAt beh (MatchingMinLengthWeak m m')
839+ Just m' ->
840+ if m' >= m
841+ then pure ()
842+ else issueAt beh (MatchingMinLengthWeak m m')
692843 Nothing -> issueAt beh (NoMatchingMinLength m)
693− Pattern p -> if any (\case Pattern p' -> p == p'; _ -> False) prods
694− then pure () else issueAt beh (NoMatchingPattern p) -- TODO: regex comparison
695− StringFormat f -> if any (\case StringFormat f' -> f == f'; _ -> False) prods
696− then pure () else issueAt beh (NoMatchingFormat f)
844+ Pattern p ->
845+ if any (\case Pattern p' -> p == p'; _ -> False) prods
846+ then pure ()
847+ else issueAt beh (NoMatchingPattern p) -- TODO: regex comparison
848+ StringFormat f ->
849+ if any (\case StringFormat f' -> f == f'; _ -> False) prods
850+ then pure ()
851+ else issueAt beh (NoMatchingFormat f)
697852 Items _ cons' -> case findRelevant (<>) (\case Items _ rs -> Just (rs NE.:| []); _ -> Nothing) prods of
698853 Just (rs NE.:| []) -> checkCompatibility env (beh >>> step InItems) $ ProdCons rs cons'
699854 Just rs -> do
700− let sch = Inline mempty { _schemaAllOf = Just . NE.toList $ extract <$> rs }
855+ let sch = Inline mempty {_schemaAllOf = Just . NE.toList $ extract <$> rs}
701856 checkCompatibility env (beh >>> step InItems) $ ProdCons (traced (ask $ NE.head rs) sch) cons' -- TODO: bad trace
702857 Nothing -> issueAt beh NoMatchingItems
703858 MaxItems m -> case findRelevant min (\case MaxItems m' -> Just m'; _ -> Nothing) prods of
704− Just m' -> if m' <= m then pure ()
705− else issueAt beh (MatchingMaxItemsWeak m m')
859+ Just m' ->
860+ if m' <= m
861+ then pure ()
862+ else issueAt beh (MatchingMaxItemsWeak m m')
706863 Nothing -> issueAt beh (NoMatchingMaxItems m)
707864 MinItems m -> case findRelevant max (\case MinItems m' -> Just m'; _ -> Nothing) prods of
708− Just m' -> if m' >= m then pure ()
709− else issueAt beh (MatchingMinItemsWeak m m')
865+ Just m' ->
866+ if m' >= m
867+ then pure ()
868+ else issueAt beh (MatchingMinItemsWeak m m')
710869 Nothing -> issueAt beh (NoMatchingMinItems m)
711− UniqueItems -> if any (== UniqueItems) $ prods then pure ()
712− else issueAt beh NoMatchingUniqueItems
870+ UniqueItems ->
871+ if any (== UniqueItems) $ prods
872+ then pure ()
873+ else issueAt beh NoMatchingUniqueItems
713874 Properties props _ madd -> case findRelevant (<>) (\case Properties props' _ madd' -> Just $ (props', madd') NE.:| []; _ -> Nothing) prods of
714875 Just ((props', madd') NE.:| []) -> do
715876 F.for_ (S.fromList $ M.keys props <> M.keys props') $ \k -> do
@@ -732,21 +893,25 @@ checkImplication env beh prods cons = case findExactly prods of
732893 pure ()
733894 Nothing -> issueAt beh NoMatchingProperties
734895 MaxProperties m -> case findRelevant min (\case MaxProperties m' -> Just m'; _ -> Nothing) prods of
735− Just m' -> if m' <= m then pure ()
736− else issueAt beh (MatchingMaxPropertiesWeak m m')
896+ Just m' ->
897+ if m' <= m
898+ then pure ()
899+ else issueAt beh (MatchingMaxPropertiesWeak m m')
737900 Nothing -> issueAt beh (NoMatchingMaxProperties m)
738901 MinProperties m -> case findRelevant max (\case MinProperties m' -> Just m'; _ -> Nothing) prods of
739− Just m' -> if m' >= m then pure ()
740− else issueAt beh (MatchingMinPropertiesWeak m m')
902+ Just m' ->
903+ if m' >= m
904+ then pure ()
905+ else issueAt beh (MatchingMinPropertiesWeak m m')
741906 Nothing -> issueAt beh (NoMatchingMinProperties m)
742907 where
743− findExactly (Exactly x:_) = Just x
744− findExactly (_:xs) = findExactly xs
908+ findExactly (Exactly x : _) = Just x
909+ findExactly (_ : xs) = findExactly xs
745910 findExactly [] = Nothing
746− findRelevant combine extr
747− = fmap (foldr1 combine) . NE.nonEmpty . mapMaybe extr
748− lcmScientific (toRational -> a) (toRational -> b)
749− = fromRational $ lcm (numerator a) (numerator b) % gcd (denominator a) (denominator b)
911+ findRelevant combine extr =
912+ fmap (foldr1 combine) . NE.nonEmpty . mapMaybe extr
913+ lcmScientific (toRational -> a) (toRational -> b) =
914+ fromRational $ lcm (numerator a) (numerator b) % gcd (denominator a) (denominator b)
750915
751916instance Issuable 'TypedSchemaLevel where
752917 data Issue 'TypedSchemaLevel
@@ -806,59 +971,52 @@ instance Subtree Schema where
806971 type SubtreeLevel Schema = 'SchemaLevel
807972 type CheckEnv Schema = '[ProdCons (Traced (Definitions Schema))]
808973 checkStructuralCompatibility env pc = do
809− traceShowM pc
810− structuralEq $ _schemaRequired <$> pc
811− structuralMaybeWith structuralEq $ _schemaNullable <$> pc
812− structuralMaybeWith (structuralList env) $ _schemaAllOf <$> pc
813− structuralMaybeWith (structuralList env) $ _schemaOneOf <$> pc
814− structuralMaybe env $ _schemaNot <$> pc
815− structuralMaybeWith (structuralList env) $ _schemaAnyOf <$> pc
816− iohmStructural env $ _schemaProperties <$> pc
817− structuralMaybeWith structuralAdditionalProperties $ _schemaAdditionalProperties <$> pc
818− structuralMaybeWith structuralDiscriminator $ _schemaDiscriminator <$> pc
819− structuralEq $ _schemaReadOnly <$> pc
820− structuralEq $ _schemaWriteOnly <$> pc
821− structuralEq $ _schemaXml <$> pc
822− structuralEq $ _schemaMaxProperties <$> pc
823− structuralEq $ _schemaMinProperties <$> pc
824− structuralEq $ _schemaDefault <$> pc
825− structuralEq $ _schemaType <$> pc
826− structuralEq $ _schemaFormat <$> pc
827− structuralMaybeWith structuralItems $ _schemaItems <$> pc
828− structuralEq $ _schemaMaximum <$> pc
829− structuralEq $ _schemaExclusiveMaximum <$> pc
830− structuralEq $ _schemaMinimum <$> pc
831− structuralEq $ _schemaExclusiveMinimum <$> pc
832− structuralEq $ _schemaMaxLength <$> pc
833− structuralEq $ _schemaMinLength <$> pc
834− structuralEq $ _schemaPattern <$> pc
835− structuralEq $ _schemaMaxItems <$> pc
836− structuralEq $ _schemaMinItems <$> pc
837− structuralEq $ _schemaUniqueItems <$> pc
838− structuralEq $ _schemaEnum <$> pc
839− structuralEq $ _schemaMultipleOf <$> pc
974+ structuralEq $ fmap _schemaRequired <$> pc
975+ structuralEq $ fmap _schemaNullable <$> pc
976+ structuralMaybeWith (structuralList env) $ tracedAllOf <$> pc
977+ structuralMaybeWith (structuralList env) $ tracedOneOf <$> pc
978+ structuralMaybe env $ sequence . stepTraced NotStep . fmap _schemaNot <$> pc
979+ structuralMaybeWith (structuralList env) $ tracedAnyOf <$> pc
980+ iohmStructural env $ stepTraced PropertiesStep . fmap _schemaProperties <$> pc
981+ structuralMaybeWith structuralAdditionalProperties $ tracedAdditionalProperties <$> pc
982+ structuralMaybeWith structuralDiscriminator $ tracedDiscriminator <$> pc
983+ structuralEq $ fmap _schemaReadOnly <$> pc
984+ structuralEq $ fmap _schemaWriteOnly <$> pc
985+ structuralEq $ fmap _schemaXml <$> pc
986+ structuralEq $ fmap _schemaMaxProperties <$> pc
987+ structuralEq $ fmap _schemaMinProperties <$> pc
988+ structuralEq $ fmap _schemaDefault <$> pc
989+ structuralEq $ fmap _schemaType <$> pc
990+ structuralEq $ fmap _schemaFormat <$> pc
991+ structuralMaybeWith structuralItems $ tracedItems <$> pc
992+ structuralEq $ fmap _schemaMaximum <$> pc
993+ structuralEq $ fmap _schemaExclusiveMaximum <$> pc
994+ structuralEq $ fmap _schemaMinimum <$> pc
995+ structuralEq $ fmap _schemaExclusiveMinimum <$> pc
996+ structuralEq $ fmap _schemaMaxLength <$> pc
997+ structuralEq $ fmap _schemaMinLength <$> pc
998+ structuralEq $ fmap _schemaPattern <$> pc
999+ structuralEq $ fmap _schemaMaxItems <$> pc
1000+ structuralEq $ fmap _schemaMinItems <$> pc
1001+ structuralEq $ fmap _schemaUniqueItems <$> pc
1002+ structuralEq $ fmap _schemaEnum <$> pc
1003+ structuralEq $ fmap _schemaMultipleOf <$> pc
8401004 pure ()
8411005 where
8421006 structuralAdditionalProperties
843− (ProdCons (AdditionalPropertiesAllowed x) (AdditionalPropertiesAllowed y)) =
844− structuralEq $ ProdCons x y
1007+ (ProdCons (Left x) (Left y)) = unless (x == y) structuralIssue
8451008 structuralAdditionalProperties
846− (ProdCons (AdditionalPropertiesSchema x) (AdditionalPropertiesSchema y)) =
847− checkStructuralCompatibility env $ ProdCons x y
1009+ (ProdCons (Right x) (Right y)) =
1010+ checkSubstructure env $ ProdCons x y
8481011 structuralAdditionalProperties _ = structuralIssue
8491012 structuralDiscriminator pc' = do
850− structuralEq $ _discriminatorPropertyName <$> pc'
851− iohmStructuralWith
852− (\_ mappingPC -> case A.decodeStrict @(Referenced Schema) . T.encodeUtf8 <$> mappingPC of
853− ProdCons (Just a) (Just b) -> checkStructuralCompatibility env $ ProdCons a b
854− ProdCons Nothing Nothing -> structuralEq mappingPC
855− _ -> structuralIssue
856− )
857− (_discriminatorMapping <$> pc')
1013+ structuralEq $ fmap _discriminatorPropertyName <$> pc'
1014+ iohmStructural env $
1015+ stepTraced DiscriminatorMapping . fmap (fmap parseDiscriminatorValue . _discriminatorMapping) <$> pc'
8581016 pure ()
859− structuralItems (ProdCons (OpenApiItemsObject a) (OpenApiItemsObject b)) =
860− checkStructuralCompatibility env $ ProdCons a b
861− structuralItems (ProdCons (OpenApiItemsArray a) (OpenApiItemsArray b)) =
1017+ structuralItems (ProdCons (Left a) (Left b)) =
1018+ checkSubstructure env $ ProdCons a b
1019+ structuralItems (ProdCons (Right a) (Right b)) =
8621020 structuralList env $ ProdCons a b
8631021 structuralItems _ = structuralIssue
8641022 checkSemanticCompatibility env beh schs = do