c2968fe · typeable/compaREST

git.iko.soy/typeable/compaREST

on master help sign in

Turn Traced into a comonad (#41)

c2968femniip5 years ago

openapi-diff.cabal+1

compare with master

unifiedsplit

@@ -34,6 +34,7 @@ common common-options

34 , attoparsec

35 , bytestring

36 , containers

37+ , comonad

37 , deriving-aeson

38 , deriving-aeson

38 , generic-data

39 , generic-data

39 , generic-monoid

40 , generic-monoid

src/OpenAPI/Checker/Orphans.hs+5

@@ -2,6 +2,7 @@

3module OpenAPI.Checker.Orphans (Step (..)) where

5+import Control.Comonad.Env

5import Data.OpenApi

6import Data.OpenApi

6import Data.Typeable

7import Data.Typeable

7import qualified Data.HashMap.Strict.InsOrd as IOHM

8import qualified Data.HashMap.Strict.InsOrd as IOHM

@@ -28,3 +29,7 @@ deriving stock instance Ord ParamLocation

29instance (Ord k, Ord v) => Ord (IOHM.InsOrdHashMap k v) where

30instance (Ord k, Ord v) => Ord (IOHM.InsOrdHashMap k v) where

30 compare xs ys = compare (IOHM.toList xs) (IOHM.toList ys)

31 compare xs ys = compare (IOHM.toList xs) (IOHM.toList ys)

32+

33+deriving stock instance (Eq e, Eq (w a)) => Eq (EnvT e w a)

34+deriving stock instance (Ord e, Ord (w a)) => Ord (EnvT e w a)

35+deriving stock instance (Show e, Show (w a)) => Show (EnvT e w a)

src/OpenAPI/Checker/References.hs+5−11

@@ -1,7 +1,6 @@

1module OpenAPI.Checker.References

2 ( TracedReferences

3 , dereference

4− , dereferenceTraced

5 )

4 )

6where

5where

@@ -16,17 +15,12 @@ import OpenAPI.Checker.Trace

16type TracedReferences root a = Map Reference (Traced root a)

15type TracedReferences root a = Map Reference (Traced root a)

18dereference

17dereference

19− :: Typeable a

20− => Definitions a

21− -> Referenced a

22− -> Traced (Referenced a) a

23−dereference _ (Inline a) = Traced (step InlineStep) a

24−dereference defs (Ref r@(Reference ref)) =

25− Traced (step $ ReferencedStep r) (fromJust $ IOHM.lookup ref defs)

26−

27−dereferenceTraced

28 :: Typeable a

18 :: Typeable a

29 => Definitions a

19 => Definitions a

30 -> Traced r (Referenced a)

20 -> Traced r (Referenced a)

31 -> Traced r a

21 -> Traced r a

32−dereferenceTraced defs (Traced t x) = retrace t $ dereference defs x

22+dereference defs x = case extract x of

23+ Inline a

24+ -> traced (ask x >>> step InlineStep) a

25+ Ref r@(Reference ref)

26+ -> traced (ask x >>> step (ReferencedStep r)) (fromJust $ IOHM.lookup ref defs)

src/OpenAPI/Checker/Run.hs+4−4

@@ -1,12 +1,12 @@

1module OpenAPI.Checker.Run (runChecker) where

3−import Control.Category

4import Data.Aeson

3import Data.Aeson

5import qualified Data.ByteString.Char8 as BSC

4import qualified Data.ByteString.Char8 as BSC

6import Data.HList

5import Data.HList

7import qualified Data.Yaml as Yaml

6import qualified Data.Yaml as Yaml

8import OpenAPI.Checker.Options

7import OpenAPI.Checker.Options

9import OpenAPI.Checker.Subtree

8import OpenAPI.Checker.Subtree

9+import OpenAPI.Checker.Trace

10import OpenAPI.Checker.Validate.OpenApi ()

11import Prelude hiding (id, (.))

@@ -24,7 +24,7 @@ runChecker = do

24 fail "Exiting"

25 Right s -> pure s

26 Right s -> pure s

27− a <- parseSchema (clientFile opts)

27+ a <- traced Root <$> parseSchema (clientFile opts)

28− b <- parseSchema (serverFile opts)

28+ b <- traced Root <$> parseSchema (serverFile opts)

29− let report = runCompatFormula (pure id) $ checkCompatibility HNil (ProdCons a b)

29+ let report = runCompatFormula $ checkCompatibility HNil (ProdCons a b)

30 BSC.putStrLn $ Yaml.encode report

src/OpenAPI/Checker/Subtree.hs+38−87

@@ -2,19 +2,13 @@ module OpenAPI.Checker.Subtree

2 ( APIStep (..)

3 , Subtree (..)

4 , CompatM (..)

5+ , CompatFormula'

5 , CompatFormula

6 , CompatFormula

6 , ProdCons (..)

7 , ProdCons (..)

7 , HasUnsupportedFeature (..)

8 , HasUnsupportedFeature (..)

8− , swapRoles

9 , swapProdCons

10− , checkProdCons

11 , SubtreeCheckIssue (..)

10 , SubtreeCheckIssue (..)

12 , runCompatFormula

11 , runCompatFormula

13− , withTrace

14− , localM

15− , localTrace

16− , localStep

17− , localTrace'

18 , anyOfM

12 , anyOfM

19 , anyOfAt

13 , anyOfAt

20 , issueAtTrace

14 , issueAtTrace

@@ -23,8 +17,8 @@ module OpenAPI.Checker.Subtree

23 )

17 )

24where

18where

20+import Control.Comonad.Env

26import Control.Monad.Identity

21import Control.Monad.Identity

27−import Control.Monad.Reader

28import Control.Monad.State

22import Control.Monad.State

29import Data.Aeson

23import Data.Aeson

30import Data.Functor.Compose

24import Data.Functor.Compose

@@ -58,29 +52,19 @@ instance Applicative ProdCons where

58 pure x = ProdCons x x

52 pure x = ProdCons x x

59 ProdCons fp fc <*> ProdCons xp xc = ProdCons (fp xp) (fc xc)

53 ProdCons fp fc <*> ProdCons xp xc = ProdCons (fp xp) (fc xc)

61−newtype CompatM t a = CompatM

55+newtype CompatM a = CompatM

62 { unCompatM

56 { unCompatM

63− :: ReaderT

64− (ProdCons (Trace OpenApi t))

65− (StateT (MemoState VarRef) Identity)

57+ :: (StateT (MemoState VarRef) Identity) a

66− a

67 }

58 }

68 deriving newtype

59 deriving newtype

69 ( Functor

60 ( Functor

70 , Applicative

61 , Applicative

71 , Monad

62 , Monad

72− , MonadReader (ProdCons (Trace OpenApi t))

73 , MonadState (MemoState VarRef)

63 , MonadState (MemoState VarRef)

74 )

64 )

76−type CompatFormula t = Compose (CompatM t) (FormulaF SubtreeCheckIssue OpenApi)

66+type CompatFormula' f r = Compose CompatM (FormulaF f r)

77−

67+type CompatFormula = CompatFormula' SubtreeCheckIssue OpenApi

78−-- | Swaps roles of producer and consumer. Used when we check the @Response@ at

79−-- least. In response producer and consumer swap their places because response

80−-- is generated by consumer and parsed by producer.

81−swapRoles :: CompatFormula t a -> CompatFormula t a

82−swapRoles (Compose r) = Compose $ do

83− local swapProdCons r

85class (Typeable t, Ord (CheckIssue t), Show (CheckIssue t)) => Subtree (t :: Type) where

69class (Typeable t, Ord (CheckIssue t), Show (CheckIssue t)) => Subtree (t :: Type) where

86 type CheckEnv t :: [Type]

70 type CheckEnv t :: [Type]

@@ -93,14 +77,14 @@ class (Typeable t, Ord (CheckIssue t), Show (CheckIssue t)) => Subtree (t :: Typ

93 normalizeTrace :: Trace OpenApi t -> Trace OpenApi t

77 normalizeTrace :: Trace OpenApi t -> Trace OpenApi t

94 normalizeTrace = id

78 normalizeTrace = id

96− checkCompatibility :: HasAll (CheckEnv t) xs => HList xs -> ProdCons t -> CompatFormula t ()

80+ checkCompatibility

81+ :: HasAll (CheckEnv t) xs

82+ => HList xs

83+ -> ProdCons (Traced OpenApi t)

84+ -> CompatFormula ()

98{-# WARNING normalizeTrace "It must be refactored. Does nothing for now" #-}

86{-# WARNING normalizeTrace "It must be refactored. Does nothing for now" #-}

100−checkProdCons :: (Subtree t, HasAll (CheckEnv t) env) => HList env -> ProdCons (Traced r t) -> CompatFormula r ()

101−checkProdCons env (ProdCons (Traced p x) (Traced c y)) =

102− localTrace (ProdCons p c) $ checkCompatibility env $ ProdCons x y

103−

104class HasUnsupportedFeature x where

88class HasUnsupportedFeature x where

105 hasUnsupportedFeature :: x -> Bool

89 hasUnsupportedFeature :: x -> Bool

106

@@ -141,76 +125,41 @@ instance ToJSON (SubtreeCheckIssue t) where

141 toJSON (SubtreeCheckIssue i) = toJSON i

125 toJSON (SubtreeCheckIssue i) = toJSON i

142

126

143runCompatFormula

127runCompatFormula

144− :: ProdCons (Trace OpenApi t)

128+ :: CompatFormula' f r a

145− -> Compose (CompatM t) (FormulaF f r) a

146 -> Either (T.TracePrefixTree f r) a

129 -> Either (T.TracePrefixTree f r) a

147−runCompatFormula env (Compose f) =

130+runCompatFormula (Compose f) =

148− calculate . runIdentity . runMemo 0 . (`runReaderT` env) . unCompatM $ f

131+ calculate . runIdentity . runMemo 0 . unCompatM $ f

149−

150−withTrace

151− :: (ProdCons (Trace OpenApi a) -> Compose (CompatM a) (FormulaF f r) x)

152− -> Compose (CompatM a) (FormulaF f r) x

153−withTrace k = Compose $ do

154− xs <- ask

155− getCompose $ k xs

156−

157−localM

158− :: ProdCons (Trace a b)

159− -> CompatM b x

160− -> CompatM a x

161−localM xs (CompatM k) =

162− CompatM $ ReaderT $ \env -> runReaderT k ((>>>) <$> env <*> xs)

163−

164−localTrace

165− :: ProdCons (Trace a b)

166− -> Compose (CompatM b) (FormulaF f r) x

167− -> Compose (CompatM a) (FormulaF f r) x

168−localTrace xs (Compose h) = Compose (localM xs h)

169−

170−localStep

171− :: Steppable a b

172− => Step a b

173− -> Compose (CompatM b) (FormulaF f r) x

174− -> Compose (CompatM a) (FormulaF f r) x

175−localStep xs (Compose h) = Compose (localM (pure $ step xs) h)

176−

177−localTrace'

178− :: ProdCons (Trace OpenApi b)

179− -> Compose (CompatM b) (FormulaF f r) x

180− -> Compose (CompatM a) (FormulaF f r) x

181−localTrace' xs (Compose (CompatM k)) = Compose $ CompatM$ ReaderT $ \_ -> runReaderT k xs

182

132

183issueAtTrace

133issueAtTrace

184− :: Subtree t => Trace OpenApi t -> CheckIssue t -> CompatFormula s a

134+ :: Subtree t

135+ => Trace r t

136+ -> CheckIssue t

137+ -> CompatFormula' SubtreeCheckIssue r a

185issueAtTrace xs issue = Compose $ pure $ anError $ AnItem xs $ SubtreeCheckIssue issue

138issueAtTrace xs issue = Compose $ pure $ anError $ AnItem xs $ SubtreeCheckIssue issue

186

139

187issueAt

140issueAt

188− :: Subtree t

141+ :: (Subtree t, ComonadEnv (Trace r t) w)

189− => (forall x. ProdCons x -> x)

142+ => w x

190 -> CheckIssue t

143 -> CheckIssue t

191− -> CompatFormula t a

144+ -> CompatFormula' SubtreeCheckIssue r a

192−issueAt f issue = Compose $ do

145+issueAt x = issueAtTrace (ask x)

193− xs <- asks f

194− pure $ anError $ AnItem xs $ SubtreeCheckIssue issue

195

146

196anyOfM

147anyOfM

197− :: Ord (f t)

148+ :: Subtree t

198 => Trace r t

149 => Trace r t

199− -> f t

150+ -> CheckIssue t

200− -> [Compose (CompatM t) (FormulaF f r) a]

151+ -> [CompatFormula' SubtreeCheckIssue r a]

201− -> Compose (CompatM t) (FormulaF f r) a

152+ -> CompatFormula' SubtreeCheckIssue r a

202anyOfM xs issue fs =

153anyOfM xs issue fs =

203− Compose $ (`eitherOf` AnItem xs issue) <$> sequenceA (getCompose <$> fs)

154+ Compose $ (`eitherOf` AnItem xs (SubtreeCheckIssue issue)) <$> sequenceA (getCompose <$> fs)

204

155

205anyOfAt

156anyOfAt

206− :: Subtree t

157+ :: (Subtree t, ComonadEnv (Trace r t) w)

207− => (forall x. ProdCons x -> x)

158+ => w x

208 -> CheckIssue t

159 -> CheckIssue t

209− -> [CompatFormula t a]

160+ -> [CompatFormula' SubtreeCheckIssue r a]

210− -> CompatFormula t a

161+ -> CompatFormula' SubtreeCheckIssue r a

211−anyOfAt f issue fs = Compose $ do

162+anyOfAt x = anyOfM (ask x)

212− xs <- asks f

213− (`eitherOf` AnItem xs (SubtreeCheckIssue issue)) <$> sequenceA (getCompose <$> fs)

214

163

215fixpointKnot

164fixpointKnot

216 :: MonadState (MemoState VarRef) m

165 :: MonadState (MemoState VarRef) m

@@ -222,7 +171,9 @@ fixpointKnot =

222 , tieKnot = \i x -> pure $ maxFixpoint i x

171 , tieKnot = \i x -> pure $ maxFixpoint i x

223 }

172 }

224

173

225−memo :: Subtree t => CompatFormula t () -> CompatFormula t ()

174+memo

175+ :: (Typeable r, Subtree t)

176+ => (ProdCons (Traced r t) -> CompatFormula ())

177+ -> (ProdCons (Traced r t) -> CompatFormula ())

226−memo (Compose f) = Compose $ do

178+memo f pc = Compose $ do

227− pxs <- asks (fmap normalizeTrace)

228− memoWithKnot fixpointKnot f pxs

179+ memoWithKnot fixpointKnot (getCompose $ f pc) (ask <$> pc)

src/OpenAPI/Checker/Trace.hs+10−20

@@ -9,18 +9,21 @@ module OpenAPI.Checker.Trace

9 , _DiffTrace

10 , AnItem (..)

11 , step

12− , Traced (..)

12+ , Traced

13− , mapTraced

13+ , traced

14− , retrace

15− , deTraced

17 -- * Reexports

15 -- * Reexports

18 , (>>>)

16 , (>>>)

19 , (<<<)

17 , (<<<)

18+ , extract

19+ , ask

20+ , asks

21+ , local

20 )

22 )

21where

23where

23import Control.Category

25import Control.Category

26+import Control.Comonad.Env

24import Control.Lens

27import Control.Lens

25import Data.Kind

28import Data.Kind

26import Data.Type.Equality

29import Data.Type.Equality

@@ -117,20 +120,7 @@ instance Typeable r => Ord (AnItem f r) where

117 Root -> compare (someTypeRep xs) (someTypeRep ys)

120 Root -> compare (someTypeRep xs) (someTypeRep ys)

118 Snoc _ _ -> compare (someTypeRep xs) (someTypeRep ys)

121 Snoc _ _ -> compare (someTypeRep xs) (someTypeRep ys)

119

122

120−data Traced r a = Traced {getTrace :: Trace r a, getTraced :: a}

123+type Traced r a = Env (Trace r a) a

121− deriving (Eq, Show)

122

124

123−-- | Reverse lexicographical order, so that getTraced is a monotonous function

124−instance Ord a => Ord (Traced r a) where

125− compare (Traced t1 a1) (Traced t2 a2) = compare a1 a2 <> compare t1 t2

126−

127−mapTraced :: (Trace r a -> Trace r b) -> (a -> b) -> Traced r a -> Traced r b

125+traced :: Trace r a -> a -> Traced r a

128−mapTraced f g (Traced t a) = Traced (f t) (g a)

126+traced = env

129−

130−retrace :: Trace s r -> Traced r a -> Traced s a

131−retrace xs (Traced t a) = Traced (xs >>> t) a

132−

133−deTraced :: Traced r a -> (Trace r a, a)

134−deTraced (Traced a b) = (a, b)

135−

136−-- type APath = AnItem Proxy

src/OpenAPI/Checker/Validate/MediaTypeObject.hs+25−14

@@ -1,9 +1,11 @@

1{-# OPTIONS_GHC -Wno-orphans #-}

3−module OpenAPI.Checker.Validate.MediaTypeObject () where

3+module OpenAPI.Checker.Validate.MediaTypeObject

4+ ( CheckIssue(..)

5+ ) where

7+import Control.Lens

5import Data.Foldable as F

8import Data.Foldable as F

6−import Data.Functor

7import Data.HList

9import Data.HList

8import Data.HashMap.Strict.InsOrd as IOHM

10import Data.HashMap.Strict.InsOrd as IOHM

9import Data.Map.Strict as M

11import Data.Map.Strict as M

@@ -15,13 +17,21 @@ import OpenAPI.Checker.Trace

15import OpenAPI.Checker.Validate.Products

17import OpenAPI.Checker.Validate.Products

16import OpenAPI.Checker.Validate.Schema ()

18import OpenAPI.Checker.Validate.Schema ()

20+tracedSchema :: Traced r MediaTypeObject -> Maybe (Traced r (Referenced Schema))

21+tracedSchema mto = _mediaTypeObjectSchema (extract mto) <&> traced (ask mto >>> step MediaTypeSchema)

22+

23+tracedEncoding :: Traced r MediaTypeObject -> InsOrdHashMap Text (Traced r Encoding)

24+tracedEncoding mto = IOHM.mapWithKey (\k -> traced (ask mto >>> step (MediaTypeParamEncoding k)))

25+ $ _mediaTypeObjectEncoding $ extract mto

26+

18instance Subtree MediaTypeObject where

27instance Subtree MediaTypeObject where

19 type CheckEnv MediaTypeObject =

28 type CheckEnv MediaTypeObject =

20 '[ MediaType

29 '[ MediaType

21 , ProdCons (Definitions Schema)

30 , ProdCons (Definitions Schema)

22 ]

31 ]

23 data CheckIssue MediaTypeObject

32 data CheckIssue MediaTypeObject

24− = MediaEncodingMissing Text

33+ = RequestMediaTypeNotFound

34+ | ResponseMediaTypeMissing

25 | MediaEncodingIncompat

35 | MediaEncodingIncompat

26 | MediaTypeSchemaRequired

36 | MediaTypeSchemaRequired

27 deriving (Eq, Ord, Show)

37 deriving (Eq, Ord, Show)

@@ -32,11 +42,10 @@ instance Subtree MediaTypeObject where

32 | otherwise -> pure ()

42 | otherwise -> pure ()

33 -- If consumer requires schema then producer must produce compatible

43 -- If consumer requires schema then producer must produce compatible

34 -- request

44 -- request

35− for_ (_mediaTypeObjectSchema c) $ \consRef ->

45+ for_ (tracedSchema c) $ \consRef ->

36− case _mediaTypeObjectSchema p of

46+ case tracedSchema p of

37− Nothing -> issueAt producer MediaTypeSchemaRequired

47+ Nothing -> issueAt p MediaTypeSchemaRequired

38− Just prodRef -> localStep MediaTypeSchema

39− $ checkCompatibility env $ ProdCons prodRef consRef

48+ Just prodRef -> checkCompatibility env $ ProdCons prodRef consRef

40 pure ()

49 pure ()

41 where

50 where

42 mediaType = getH @MediaType env

51 mediaType = getH @MediaType env

@@ -44,23 +53,25 @@ instance Subtree MediaTypeObject where

44 let

53 let

45 -- Parameters of the media type are product-like entities

54 -- Parameters of the media type are product-like entities

46 getEncoding mt = M.fromList

55 getEncoding mt = M.fromList

47− $ (IOHM.toList $ _mediaTypeObjectEncoding mt) <&> \(k, enc) ->

56+ $ (IOHM.toList $ tracedEncoding mt) <&> \(k, enc) ->

48 ( k

57 ( k

49 , ProductLike

58 , ProductLike

50− { traced = Traced (step $ MediaTypeParamEncoding k) enc

59+ { tracedValue = enc

51 , required = True } )

60 , required = True } )

52 encProdCons = getEncoding <$> prodCons

61 encProdCons = getEncoding <$> prodCons

53− in checkProducts MediaEncodingMissing

62+ in checkProducts (const MediaEncodingMissing)

54 (const $ checkCompatibility HNil) encProdCons

63 (const $ checkCompatibility HNil) encProdCons

56instance Subtree Encoding where

65instance Subtree Encoding where

57 type CheckEnv Encoding = '[]

66 type CheckEnv Encoding = '[]

58− data CheckIssue Encoding = EncodingNotSupported

67+ data CheckIssue Encoding

68+ = MediaEncodingMissing

69+ | EncodingNotSupported

59 -- FIXME: Support only JSON body for now. Then Encoding is checked only for

70 -- FIXME: Support only JSON body for now. Then Encoding is checked only for

60 -- multipart/form-url-encoded

71 -- multipart/form-url-encoded

61 deriving (Eq, Ord, Show)

72 deriving (Eq, Ord, Show)

62− checkCompatibility _env _prodCons =

73+ checkCompatibility _env pc =

63− issueAt producer EncodingNotSupported

74+ issueAt (producer pc) EncodingNotSupported

65instance Steppable MediaTypeObject (Referenced Schema) where

76instance Steppable MediaTypeObject (Referenced Schema) where

66 data Step MediaTypeObject (Referenced Schema) = MediaTypeSchema

77 data Step MediaTypeObject (Referenced Schema) = MediaTypeSchema

src/OpenAPI/Checker/Validate/OpenApi.hs+14−11

@@ -13,22 +13,25 @@ import OpenAPI.Checker.Subtree

13import OpenAPI.Checker.Trace

14import OpenAPI.Checker.Validate.ProcessedPathItem

16+tracedPaths :: Traced r OpenApi -> Traced r ProcessedPathItems

17+tracedPaths oa = traced (ask oa >>> step OpenApiPathsStep)

18+ (processPathItems . IOHM.toList . _openApiPaths . extract $ oa)

19+

16instance Subtree OpenApi where

20instance Subtree OpenApi where

17 type CheckEnv OpenApi = '[]

21 type CheckEnv OpenApi = '[]

18 data CheckIssue OpenApi

22 data CheckIssue OpenApi

19 deriving (Eq, Ord, Show)

23 deriving (Eq, Ord, Show)

20 checkCompatibility _ prodCons = do

24 checkCompatibility _ prodCons = do

21− let cs = _openApiComponents <$> prodCons

25+ let cs = _openApiComponents . extract <$> prodCons

22− localStep OpenApiPathsStep $

23− checkCompatibility

26+ checkCompatibility @ProcessedPathItems

24− ((_componentsRequestBodies <$> cs)

27+ ((_componentsRequestBodies <$> cs)

25− `HCons` (_componentsParameters <$> cs)

28+ `HCons` (_componentsParameters <$> cs)

26− `HCons` (_componentsSecuritySchemes <$> cs)

29+ `HCons` (_componentsSecuritySchemes <$> cs)

27− `HCons` (_componentsResponses <$> cs)

30+ `HCons` (_componentsResponses <$> cs)

28− `HCons` (_componentsHeaders <$> cs)

31+ `HCons` (_componentsHeaders <$> cs)

29− `HCons` (_componentsSchemas <$> cs)

32+ `HCons` (_componentsSchemas <$> cs)

30− `HCons` HNil)

33+ `HCons` HNil)

31− (processPathItems . IOHM.toList . _openApiPaths <$> prodCons)

34+ (tracedPaths <$> prodCons)

33instance Steppable OpenApi ProcessedPathItems where

36instance Steppable OpenApi ProcessedPathItems where

34 data Step OpenApi ProcessedPathItems = OpenApiPathsStep

37 data Step OpenApi ProcessedPathItems = OpenApiPathsStep

src/OpenAPI/Checker/Validate/Operation.hs+93−57

@@ -2,7 +2,10 @@

2{-# OPTIONS_GHC -Wno-name-shadowing #-}

4module OpenAPI.Checker.Validate.Operation

5− ( MatchedOperation(..)

5+ ( MatchedOperation (..)

6+ , CheckIssue (..)

7+ , OperationMethod(..)

8+ , pathItemMethod

6 ) where

9 ) where

@@ -17,15 +20,11 @@ import Data.Text (Text)

17import OpenAPI.Checker.References

20import OpenAPI.Checker.References

18import OpenAPI.Checker.Subtree

21import OpenAPI.Checker.Subtree

19import OpenAPI.Checker.Trace

22import OpenAPI.Checker.Trace

20−import OpenAPI.Checker.Validate.Param ()

23+import OpenAPI.Checker.Validate.Param

21import OpenAPI.Checker.Validate.PathFragment

24import OpenAPI.Checker.Validate.PathFragment

22import OpenAPI.Checker.Validate.Products

25import OpenAPI.Checker.Validate.Products

23−import OpenAPI.Checker.Validate.RequestBody ()

26+import OpenAPI.Checker.Validate.RequestBody

24import OpenAPI.Checker.Validate.Responses ()

27import OpenAPI.Checker.Validate.Responses ()

25−import OpenAPI.Checker.Validate.SecurityRequirement ()

26−import OpenAPI.Checker.Validate.Server ()

27−

28−-- data ParamKey

30data MatchedOperation = MatchedOperation

29data MatchedOperation = MatchedOperation

31 { operation :: !Operation

30 { operation :: !Operation

@@ -41,6 +40,31 @@ type ParamKey = (ParamLocation, Text)

41paramKey :: Param -> ParamKey

40paramKey :: Param -> ParamKey

42paramKey param = (_paramIn param, _paramName param)

41paramKey param = (_paramIn param, _paramName param)

43+tracedParameters :: Traced r MatchedOperation -> [Traced r (Referenced Param)]

44+tracedParameters oper =

45+ [ traced (ask oper >>> step (OperationParamsStep i)) x

46+ | (i, x) <- zip [0..] $ _operationParameters . operation $ extract oper

47+ ]

48+

49+tracedRequestBody :: Traced r MatchedOperation -> Maybe (Traced r (Referenced RequestBody))

50+tracedRequestBody oper = _operationRequestBody (operation $ extract oper) <&> traced (ask oper >>> step OperationRequestBodyStep)

51+

52+tracedResponses :: Traced r MatchedOperation -> Traced r Responses

53+tracedResponses oper = traced (ask oper >>> step OperationResponsesStep)

54+ $ _operationResponses . operation $ extract oper

55+

56+tracedSecurity :: Traced r MatchedOperation -> [Traced r SecurityRequirement]

57+tracedSecurity oper =

58+ [ traced (ask oper >>> step (OperationSecurityRequirementStep i)) x

59+ | (i, x) <- zip [0..] $ _operationSecurity . operation $ extract oper

60+ ]

61+

62+tracedServers :: Traced r MatchedOperation -> [Traced r Server]

63+tracedServers oper =

64+ [ traced (ask oper >>> step (OperationServerStep i)) x

65+ | (i, x) <- zip [0..] $ _operationServers . operation $ extract oper

66+ ]

67+

44instance Subtree MatchedOperation where

68instance Subtree MatchedOperation where

45 type CheckEnv MatchedOperation =

69 type CheckEnv MatchedOperation =

46 '[ ProdCons (Definitions Param)

70 '[ ProdCons (Definitions Param)

@@ -51,17 +75,11 @@ instance Subtree MatchedOperation where

51 , ProdCons (Definitions Schema)

75 , ProdCons (Definitions Schema)

52 ]

76 ]

53 data CheckIssue MatchedOperation

77 data CheckIssue MatchedOperation

54− = ParamNotMatched ParamLocation Text

78+ = OperationMissing OperationMethod

55− -- ^ Non-path param has no pair

56− | PathFragmentNotMatched Int

57− -- ^ Path fragment with given position has no match

58− | NoRequestBody

59 | CallbacksNotSupported

79 | CallbacksNotSupported

60− | SecurityRequirementNotMet Int -- security indexs

61− | ServerNotConsumed Int -- server index

62 deriving (Eq, Ord, Show)

80 deriving (Eq, Ord, Show)

63− checkCompatibility env prodCons = withTrace $ \myTrace -> do

81+ checkCompatibility env prodCons = do

64− checkParameters myTrace

82+ checkParameters

65 checkRequestBodies

83 checkRequestBodies

66 checkResponses

84 checkResponses

67 checkCallbacks

85 checkCallbacks

@@ -69,88 +87,84 @@ instance Subtree MatchedOperation where

69 checkServers

87 checkServers

70 pure ()

88 pure ()

71 where

89 where

72− checkParameters myTrace = do

90+ checkParameters = do

73 let

91 let

74 -- Merged parameters got from Operation and PathItem in one

92 -- Merged parameters got from Operation and PathItem in one

75 -- place. First element is path params, second is non-path params

93 -- place. First element is path params, second is non-path params

76 tracedParams :: ProdCons ([Traced OpenApi Param], [Traced OpenApi Param])

94 tracedParams :: ProdCons ([Traced OpenApi Param], [Traced OpenApi Param])

77− tracedParams = getParams <$> myTrace <*> paramDefs <*> prodCons

95+ tracedParams = getParams <$> paramDefs <*> prodCons

78− getParams root defs mp =

96+ getParams defs mp =

79 let

97 let

80 operationParamsMap :: Map ParamKey (Traced OpenApi Param)

98 operationParamsMap :: Map ParamKey (Traced OpenApi Param)

81 operationParamsMap = M.fromList $ do

99 operationParamsMap = M.fromList $ do

82− paramRef <- _operationParameters $ operation mp

100+ paramRef <- tracedParameters mp

83 let

101 let

84− tracedParam = retrace root

102+ param = dereference defs paramRef

85− $ dereferenceTraced defs

86− $ Traced (step $ OperationParamsStep) paramRef

87− key = paramKey $ getTraced tracedParam

103+ key = paramKey . extract $ param

88− pure (key, tracedParam)

104+ pure (key, param)

89 pathParamsMap :: Map ParamKey (Traced OpenApi Param)

105 pathParamsMap :: Map ParamKey (Traced OpenApi Param)

90 pathParamsMap = M.fromList $ do

106 pathParamsMap = M.fromList $ do

91− param <- pathParams mp

107+ param <- pathParams . extract $ mp

92− pure (paramKey $ getTraced param, param)

108+ pure (paramKey . extract $ param, param)

93 params = M.elems $ M.union operationParamsMap pathParamsMap

109 params = M.elems $ M.union operationParamsMap pathParamsMap

94 -- We prefer params from Operation

110 -- We prefer params from Operation

95 splitted = L.partition

111 splitted = L.partition

96− (\p -> (_paramIn $ getTraced p) == ParamPath) params

112+ (\p -> (_paramIn . extract $ p) == ParamPath) params

97 in splitted

113 in splitted

98 checkNonPathParams $ snd <$> tracedParams

114 checkNonPathParams $ snd <$> tracedParams

99 checkPathParams $ fst <$> tracedParams

115 checkPathParams $ fst <$> tracedParams

100 pure ()

116 pure ()

101− checkNonPathParams :: ProdCons [Traced OpenApi Param] -> CompatFormula MatchedOperation ()

117+ checkNonPathParams :: ProdCons [Traced OpenApi Param] -> CompatFormula ()

102 checkNonPathParams params = do

118 checkNonPathParams params = do

103 let

119 let

104 elements = getEls <$> params

120 elements = getEls <$> params

105− getEls traced = M.fromList $ do

121+ getEls params = M.fromList $ do

106− p <- traced

122+ p <- params

107 let

123 let

108− param = getTraced p

109− k = (_paramIn param, _paramName param)

124+ k = (_paramIn . extract $ p, _paramName . extract $ p)

110 v = ProductLike

125 v = ProductLike

111− { traced = p

126+ { tracedValue = p

112− , required = fromMaybe False $ _paramRequired param

127+ , required = fromMaybe False . _paramRequired . extract $ p

113 }

128 }

114 pure (k, v)

129 pure (k, v)

115− check _ param = do

130+ check param = do

116 checkCompatibility @Param (singletonH schemaDefs) param

131 checkCompatibility @Param (singletonH schemaDefs) param

117− checkProducts' (uncurry ParamNotMatched) check elements

132+ checkProducts (ParamNotMatched . snd) (const check) elements

133+ checkPathParams :: ProdCons [Traced OpenApi Param] -> CompatFormula ()

118 checkPathParams pathParams = do

134 checkPathParams pathParams = do

119 let

135 let

120 fragments :: ProdCons [Traced OpenApi PathFragmentParam]

136 fragments :: ProdCons [Traced OpenApi PathFragmentParam]

121 fragments = getFragments <$> pathParams <*> prodCons

137 fragments = getFragments <$> pathParams <*> prodCons

122− getFragments params mop = (getPathFragments mop) params

138+ getFragments params mop = getPathFragments (extract mop) params

123 -- Feed path parameters to the fragments getter

139 -- Feed path parameters to the fragments getter

124− check _ frags = checkCompatibility @PathFragmentParam env frags

140+ check frags = checkCompatibility @PathFragmentParam env frags

125− elements = fragments <&> \frags -> M.fromList $ zip [0..] $ do

141+ elements = fragments <&> \frags -> M.fromList $ zip [0 :: Int ..] $ do

126 frag <- frags

142 frag <- frags

127 pure $ ProductLike

143 pure $ ProductLike

128− { traced = frag

144+ { tracedValue = frag

129 , required = True }

145 , required = True }

130− checkProducts' PathFragmentNotMatched check elements

146+ checkProducts (const PathFragmentNotMatched) (const check) elements

131 checkRequestBodies = do

147 checkRequestBodies = do

132 let

148 let

133− check _ reqBody = checkCompatibility @RequestBody env reqBody

149+ check reqBody = checkCompatibility @RequestBody env reqBody

134 elements = getReqBody <$> bodyDefs <*> prodCons

150 elements = getReqBody <$> bodyDefs <*> prodCons

135 getReqBody bodyDef mop = M.fromList $ do

151 getReqBody bodyDef mop = M.fromList $ do

136− bodyRef <- F.toList $ _operationRequestBody $ operation mop

152+ bodyRef <- F.toList . tracedRequestBody $ mop

137 let

153 let

138− traced = dereferenceTraced bodyDef

154+ body = dereference bodyDef bodyRef

139− $ Traced (step $ OperationRequestBodyStep) bodyRef

140− required = fromMaybe False

141− $ _requestBodyRequired $ getTraced traced

142− elt = ProductLike { traced, required }

143 -- Single element map

155 -- Single element map

144− pure ((), elt)

156+ pure ((), ProductLike

157+ { tracedValue = body

158+ , required = fromMaybe False . _requestBodyRequired . extract $ body

159+ })

145− checkProducts (const NoRequestBody) check elements

160+ checkProducts (const NoRequestBody) (const check) elements

146 checkResponses = do

161 checkResponses = do

147 let

162 let

148− resps = (_operationResponses . operation) <$> prodCons

149 respEnv = HCons (swapProdCons respDefs)

163 respEnv = HCons (swapProdCons respDefs)

150 $ HCons (swapProdCons headerDefs)

164 $ HCons (swapProdCons headerDefs)

151 $ HCons (swapProdCons schemaDefs) HNil

165 $ HCons (swapProdCons schemaDefs) HNil

152− localStep OperationResponsesStep

166+ resps = tracedResponses <$> prodCons

153− $ swapRoles $ checkCompatibility respEnv $ swapProdCons resps

167+ checkCompatibility respEnv $ swapProdCons resps

154 checkCallbacks = pure () -- (error "FIXME: not implemented")

168 checkCallbacks = pure () -- (error "FIXME: not implemented")

155 checkOperationSecurity = pure () -- (error "FIXME: not implemented")

169 checkOperationSecurity = pure () -- (error "FIXME: not implemented")

156 checkServers = pure () -- (error "FIXME: not implemented")

170 checkServers = pure () -- (error "FIXME: not implemented")

@@ -160,8 +174,30 @@ instance Subtree MatchedOperation where

160 schemaDefs = getH @(ProdCons (Definitions Schema)) env

174 schemaDefs = getH @(ProdCons (Definitions Schema)) env

161 paramDefs = getH @(ProdCons (Definitions Param)) env

175 paramDefs = getH @(ProdCons (Definitions Param)) env

162

176

177+data OperationMethod =

178+ GetMethod

179+ | PutMethod

180+ | PostMethod

181+ | DeleteMethod

182+ | OptionsMethod

183+ | HeadMethod

184+ | PatchMethod

185+ | TraceMethod

186+ deriving (Eq, Ord, Show)

187+

188+pathItemMethod :: OperationMethod -> PathItem -> Maybe Operation

189+pathItemMethod = \case

190+ GetMethod -> _pathItemGet

191+ PutMethod -> _pathItemPut

192+ PostMethod -> _pathItemPost

193+ DeleteMethod -> _pathItemDelete

194+ OptionsMethod -> _pathItemOptions

195+ HeadMethod -> _pathItemHead

196+ PatchMethod -> _pathItemPatch

197+ TraceMethod -> _pathItemTrace

198+

163instance Steppable MatchedOperation (Referenced Param) where

199instance Steppable MatchedOperation (Referenced Param) where

164− data Step MatchedOperation (Referenced Param) = OperationParamsStep

200+ data Step MatchedOperation (Referenced Param) = OperationParamsStep Int

165 deriving (Eq, Ord, Show)

201 deriving (Eq, Ord, Show)

166

202

167instance Steppable MatchedOperation (Referenced RequestBody) where

203instance Steppable MatchedOperation (Referenced RequestBody) where

@@ -173,9 +209,9 @@ instance Steppable MatchedOperation Responses where

173 deriving (Eq, Ord, Show)

209 deriving (Eq, Ord, Show)

174

210

175instance Steppable MatchedOperation SecurityRequirement where

211instance Steppable MatchedOperation SecurityRequirement where

176− data Step MatchedOperation SecurityRequirement = OperationSecurityRequirementStep

212+ data Step MatchedOperation SecurityRequirement = OperationSecurityRequirementStep Int

177 deriving (Eq, Ord, Show)

213 deriving (Eq, Ord, Show)

178

214

179instance Steppable MatchedOperation Server where

215instance Steppable MatchedOperation Server where

180− data Step MatchedOperation Server = OperationServerStep

216+ data Step MatchedOperation Server = OperationServerStep Int

181 deriving (Eq, Ord, Show)

217 deriving (Eq, Ord, Show)

src/OpenAPI/Checker/Validate/Param.hs+29−21

@@ -1,11 +1,15 @@

1{-# OPTIONS_GHC -Wno-orphans #-}

2{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

4−module OpenAPI.Checker.Validate.Param () where

4+module OpenAPI.Checker.Validate.Param

5+ ( CheckIssue (..)

6+ ) where

8+import Control.Lens

6import Control.Monad

9import Control.Monad

7import Data.Maybe

10import Data.Maybe

8import Data.OpenApi

11import Data.OpenApi

12+import Data.Text

9import OpenAPI.Checker.Orphans

13import OpenAPI.Checker.Orphans

10import OpenAPI.Checker.Subtree

14import OpenAPI.Checker.Subtree

11import OpenAPI.Checker.Trace

15import OpenAPI.Checker.Trace

@@ -38,10 +42,14 @@ paramEncoding p = EncodingStyle

38 ParamQuery -> Just $ fromMaybe False $ _paramAllowReserved p

42 ParamQuery -> Just $ fromMaybe False $ _paramAllowReserved p

39 _ -> Nothing

43 _ -> Nothing

45+tracedSchema :: Traced r Param -> Maybe (Traced r (Referenced Schema))

46+tracedSchema par = _paramSchema (extract par) <&> traced (ask par >>> step ParamSchema)

47+

41instance Subtree Param where

48instance Subtree Param where

42 type CheckEnv Param = '[ProdCons (Definitions Schema)]

49 type CheckEnv Param = '[ProdCons (Definitions Schema)]

43 data CheckIssue Param

50 data CheckIssue Param

51+ = ParamNotMatched Text

44− = ParamNameMismatch

52+ | ParamNameMismatch

45 -- ^ Params have different names

53 -- ^ Params have different names

46 | ParamEmptinessIncompatible

54 | ParamEmptinessIncompatible

47 -- ^ Consumer requires non-empty param, but producer gives emptyable

55 -- ^ Consumer requires non-empty param, but producer gives emptyable

@@ -53,28 +61,28 @@ instance Subtree Param where

53 | ParamSchemaMismatch

61 | ParamSchemaMismatch

54 -- ^ One of schemas not presented

62 -- ^ One of schemas not presented

55 deriving (Eq, Ord, Show)

63 deriving (Eq, Ord, Show)

56− checkCompatibility env (ProdCons p c) = do

64+ checkCompatibility env pc@(ProdCons p c) = do

57− when (_paramName p /= _paramName c)

65+ when (_paramName (extract p) /= _paramName (extract c))

58− $ issueAt producer ParamNameMismatch

66+ $ issueAt p ParamNameMismatch

59− when ((fromMaybe False $ _paramRequired c) &&

67+ when ((fromMaybe False . _paramRequired . extract $ c) &&

60− not (fromMaybe False $ _paramRequired p))

68+ not (fromMaybe False . _paramRequired . extract $ p))

61− $ issueAt producer ParamRequired

69+ $ issueAt p ParamRequired

62− case (_paramIn p, _paramIn c) of

70+ case (_paramIn . extract $ p, _paramIn . extract $ c) of

63 (ParamQuery, ParamQuery) -> do

71 (ParamQuery, ParamQuery) -> do

64 -- Emptiness is only for query params

72 -- Emptiness is only for query params

65− when ((fromMaybe False $ _paramAllowEmptyValue p)

73+ when ((fromMaybe False . _paramAllowEmptyValue . extract $ p)

66− && not (fromMaybe False $ _paramAllowEmptyValue c))

74+ && not (fromMaybe False . _paramAllowEmptyValue . extract $ c))

67− $ issueAt producer ParamEmptinessIncompatible

75+ $ issueAt p ParamEmptinessIncompatible

68 (a, b) | a == b -> pure ()

76 (a, b) | a == b -> pure ()

69− _ -> issueAt producer ParamPlaceIncompatible

77+ _ -> issueAt p ParamPlaceIncompatible

70− unless (paramEncoding p == paramEncoding c)

78+ unless (paramEncoding (extract p) == paramEncoding (extract c))

71− $ issueAt producer ParamStyleMismatch

79+ $ issueAt p ParamStyleMismatch

72− case (_paramSchema p, _paramSchema c) of

80+ case tracedSchema <$> pc of

73− (Just prodSchema, Just consSchema) -> localStep ParamSchema

81+ ProdCons (Just prodSchema) (Just consSchema) -> do

74− $ checkCompatibility env (ProdCons prodSchema consSchema)

82+ checkCompatibility env $ ProdCons prodSchema consSchema

75− (Nothing, Nothing) -> pure ()

83+ ProdCons Nothing Nothing -> pure ()

76− (Nothing, Just _consSchema) -> issueAt producer ParamSchemaMismatch

84+ ProdCons Nothing (Just _consSchema) -> issueAt p ParamSchemaMismatch

77− (Just _prodSchema, Nothing) -> pure ()

85+ ProdCons (Just _prodSchema) Nothing -> pure ()

78 -- If consumer doesn't care then why we should?

86 -- If consumer doesn't care then why we should?

79 pure ()

87 pure ()

src/OpenAPI/Checker/Validate/PathFragment.hs+26−26

@@ -2,6 +2,7 @@ module OpenAPI.Checker.Validate.PathFragment

2 ( parsePath

3 , PathFragment (..)

4 , PathFragmentParam

5+ , CheckIssue (..)

5 )

6 )

6where

7where

@@ -40,32 +41,16 @@ instance (Typeable param) => Steppable (PathFragment param) Param where

40 data Step (PathFragment param) Param = StaticPathParam Text

41 data Step (PathFragment param) Param = StaticPathParam Text

41 deriving (Eq, Ord, Show)

42 deriving (Eq, Ord, Show)

43−instance Subtree PathFragmentParam where

44+tracedPathFragmentParam :: Traced OpenApi PathFragmentParam -> Traced OpenApi Param

44− type CheckEnv PathFragmentParam =

45+tracedPathFragmentParam pfp = case extract pfp of

45− '[ ProdCons (Definitions Schema) ]

46− data CheckIssue PathFragmentParam =

47− PathFragmentsDontMatch Text Text

48− deriving (Eq, Ord, Show)

49− -- This case isn't strictly needed. It is here for optimization.

50− checkCompatibility _ ProdCons {producer = (StaticPath x), consumer = (StaticPath y)} =

51− if x == y

52− then pure ()

53− else issueAt consumer (PathFragmentsDontMatch x y)

54− checkCompatibility env prodCons = withTrace $ \myTrace -> do

55− let

56− tracedParams = dePathFragment <$> myTrace <*> prodCons

57− dePathFragment root = \case

58− StaticPath s -> retrace root $ Traced (step $ StaticPathParam s)

46+ StaticPath s -> traced (ask pfp >>> step (StaticPathParam s))

59− $ mempty

47+ $ mempty

60− { _paramRequired = Just True

48+ { _paramRequired = Just True

61− , _paramIn = ParamPath

49+ , _paramIn = ParamPath

62− , _paramAllowEmptyValue = Just False

50+ , _paramAllowEmptyValue = Just False

63− , _paramAllowReserved = Just False

51+ , _paramAllowReserved = Just False

64− , _paramSchema = Just $ Inline $ staticStringSchema s }

52+ , _paramSchema = Just $ Inline $ staticStringSchema s }

65− DynamicPath p -> p

53+ DynamicPath p -> p

66− params = getTraced <$> tracedParams

67− paramTrace = getTrace <$> tracedParams

68− localTrace' paramTrace $ checkCompatibility env params

70staticStringSchema :: Text -> Schema

55staticStringSchema :: Text -> Schema

71staticStringSchema t =

56staticStringSchema t =

@@ -74,3 +59,18 @@ staticStringSchema t =

74 , _schemaType = Just OpenApiString

59 , _schemaType = Just OpenApiString

75 , _schemaEnum = Just [A.String t]

60 , _schemaEnum = Just [A.String t]

76 }

61 }

62+

63+instance Subtree PathFragmentParam where

64+ type CheckEnv PathFragmentParam =

65+ '[ ProdCons (Definitions Schema) ]

66+ data CheckIssue PathFragmentParam

67+ = PathFragmentNotMatched

68+ | PathFragmentsDontMatch Text Text

69+ deriving (Eq, Ord, Show)

70+ -- This case isn't strictly needed. It is here for optimization.

71+ checkCompatibility _ (ProdCons (extract -> StaticPath x) c@(extract -> StaticPath y))

72+ = if x == y

73+ then pure ()

74+ else issueAt c (PathFragmentsDontMatch x y)

75+ checkCompatibility env prodCons = do

76+ checkCompatibility env (tracedPathFragmentParam <$> prodCons)

src/OpenAPI/Checker/Validate/ProcessedPathItem.hs+50−60

@@ -9,6 +9,7 @@ module OpenAPI.Checker.Validate.ProcessedPathItem

9 )

10where

12+import Control.Comonad.Env

12import Control.Monad

13import Control.Monad

13import Data.Foldable as F

14import Data.Foldable as F

14import Data.Functor

15import Data.Functor

@@ -52,29 +53,24 @@ instance Subtree ProcessedPathItems where

52 | AllPathsFailed FilePath

53 | AllPathsFailed FilePath

53 -- When several paths match given but all checks failed

54 -- When several paths match given but all checks failed

54 deriving (Eq, Ord, Show)

55 deriving (Eq, Ord, Show)

55− checkCompatibility env (ProdCons p c) = do

56+ checkCompatibility env pc@(ProdCons p c) = do

56 -- Each path generated by producer must be handled by consumer with exactly

57 -- Each path generated by producer must be handled by consumer with exactly

57 -- one way

58 -- one way

58− for_ (unProcessedPathItems p) $ \ prodItem -> do

59+ for_ (unProcessedPathItems . extract $ p) $ \ prodItem -> do

59 let

60 let

60 prodPath = path prodItem

61 prodPath = path prodItem

61 matchedItems = do

62 matchedItems = do

62− consItem <- unProcessedPathItems c

63+ consItem <- unProcessedPathItems . extract $ c

63 matched <- F.toList $ matchingPathItems $ ProdCons prodItem consItem

64 matched <- F.toList $ matchingPathItems $ ProdCons prodItem consItem

64 return matched

65 return matched

65 case matchedItems of

66 case matchedItems of

66− [] -> issueAt producer $ NoPathsMatched prodPath

67+ [] -> issueAt p $ NoPathsMatched prodPath

67− [matched] -> do

68− -- Checking exact match with no wrapper

69− let trace = matchedTrace <$> matched

70− localTrace trace $ checkCompatibility env matched

68+ [match] -> checkCompatibility env (retraced <$> pc <*> match)

71− matches -> anyOfAt consumer (AllPathsFailed prodPath) $ do

69+ matches -> anyOfAt c (AllPathsFailed prodPath) $ do

72 match <- matches

70 match <- matches

73− let trace = matchedTrace <$> match

74− pure $ localTrace trace $ checkCompatibility env match

71+ pure $ checkCompatibility env (retraced <$> pc <*> match)

75 where

72 where

76− matchedTrace :: MatchedPathItem -> Trace ProcessedPathItems MatchedPathItem

77− matchedTrace mpi = step $ MatchedPathStep $ matchedPath mpi

73+ retraced pc mpi = traced (ask pc >>> step (MatchedPathStep $ matchedPath mpi)) mpi

79-- | Preliminary checks two paths for compatibility. Returns Nothing if two

75-- | Preliminary checks two paths for compatibility. Returns Nothing if two

80-- paths obviously do not match: static parts differ or count of path elements

76-- paths obviously do not match: static parts differ or count of path elements

@@ -109,6 +105,25 @@ data MatchedPathItem = MatchedPathItem

109 -- ^ Pre-parsed path from PathItem

105 -- ^ Pre-parsed path from PathItem

110 }

106 }

111

107

108+tracedParameters :: Traced r MatchedPathItem -> [Traced r (Referenced Param)]

109+tracedParameters mpi =

110+ [ traced (ask mpi >>> step (PathItemParam i)) x

111+ | (i, x) <- L.zip [0..] $ _pathItemParameters . pathItem $ extract mpi

112+ ]

113+

114+-- TODO: simplify?

115+tracedFragments :: Traced r MatchedPathItem -> [Env (Trace r PathFragmentParam) (PathFragment Text)]

116+tracedFragments mpi =

117+ [ env (ask mpi >>> step (PathFragmentStep i)) x

118+ | (i, x) <- L.zip [0..] $ pathFragments $ extract mpi

119+ ]

120+

121+tracedMethod

122+ :: OperationMethod

123+ -> Traced r MatchedPathItem

124+ -> Maybe (Env (Trace r MatchedOperation) Operation)

125+tracedMethod s mpi = env (ask mpi >>> step (OperationMethodStep s)) <$> (pathItemMethod s . pathItem . extract $ mpi)

126+

112instance Subtree MatchedPathItem where

127instance Subtree MatchedPathItem where

113 type CheckEnv MatchedPathItem =

128 type CheckEnv MatchedPathItem =

114 '[ ProdCons (Definitions Param)

129 '[ ProdCons (Definitions Param)

@@ -119,63 +134,46 @@ instance Subtree MatchedPathItem where

119 , ProdCons (Definitions Schema)

134 , ProdCons (Definitions Schema)

120 ]

135 ]

121 data CheckIssue MatchedPathItem

136 data CheckIssue MatchedPathItem

122− = OperationMissing (Step MatchedPathItem MatchedOperation)

123 deriving (Eq, Ord, Show)

137 deriving (Eq, Ord, Show)

124− checkCompatibility env prodCons = withTrace $ \rootTrace -> do

138+ checkCompatibility env prodCons = do

125 let

139 let

126 paramDefs = getH @(ProdCons (Definitions Param)) env

140 paramDefs = getH @(ProdCons (Definitions Param)) env

127− pathTracedParams = getPathParams <$> rootTrace <*> paramDefs <*> prodCons

141+ pathTracedParams = getPathParams <$> paramDefs <*> prodCons

128 getPathParams

142 getPathParams

129− :: Trace OpenApi MatchedPathItem

130− -> Definitions Param

143+ :: Definitions Param

131− -> MatchedPathItem

144+ -> Traced r MatchedPathItem

132− -> [Traced OpenApi Param]

145+ -> [Traced r Param]

133− getPathParams root defs mpi = do

146+ getPathParams defs mpi = do

134− paramRef <- _pathItemParameters $ pathItem mpi

147+ paramRef <- tracedParameters mpi

135− let

148+ pure $ dereference defs paramRef

136− traced = dereferenceTraced defs

137− $ Traced (step PathItemParam) paramRef

138− res = retrace root traced

139− pure res

140− pathTracedFragments = mkPathFragments <$> rootTrace <*> prodCons

149+ pathTracedFragments = mkPathFragments <$> prodCons

141− mkPathFragments myRoot mpi operationParams =

150+ mkPathFragments mpi operationParams =

142 -- operationParams will be known on Operation check stage, so we give a

151 -- operationParams will be known on Operation check stage, so we give a

143 -- function, returning fragments

152 -- function, returning fragments

144 let

153 let

145 paramsMap :: Map Text (Traced OpenApi Param)

154 paramsMap :: Map Text (Traced OpenApi Param)

146 paramsMap = M.fromList $ do

155 paramsMap = M.fromList $ do

147 tracedParam <- operationParams

156 tracedParam <- operationParams

148− let pname = _paramName $ getTraced tracedParam

157+ let pname = _paramName . extract $ tracedParam

149 pure (pname, tracedParam)

158 pure (pname, tracedParam)

150− fragments :: [PathFragmentParam]

159+ convertFragment = \case

151− fragments = (pathFragments mpi) <&> \case

152 StaticPath t -> StaticPath t

160 StaticPath t -> StaticPath t

153 DynamicPath pname -> DynamicPath

161 DynamicPath pname -> DynamicPath

154 $ fromMaybe (error $ "Param not found " <> T.unpack pname)

162 $ fromMaybe (error $ "Param not found " <> T.unpack pname)

155 $ M.lookup pname paramsMap

163 $ M.lookup pname paramsMap

156− tracedFragments :: [Traced OpenApi PathFragmentParam]

157− tracedFragments = L.zip [0..] fragments <&> \(pos, frag) ->

158− retrace myRoot $ Traced (step $ PathFragmentStep pos) frag

159− in tracedFragments

164+ in tracedFragments mpi <&> fmap convertFragment

160 operations = getOperations <$> pathTracedParams <*> pathTracedFragments <*> prodCons

165 operations = getOperations <$> pathTracedParams <*> pathTracedFragments <*> prodCons

161 getOperations pathParams getPathFragments mpi = M.fromList $ do

166 getOperations pathParams getPathFragments mpi = M.fromList $ do

162− (getOp, s) <-

167+ (i, getOp) <- (\m -> (m, tracedMethod m)) <$>

163− [ (_pathItemGet, GetStep)

168+ [GetMethod, PutMethod, PostMethod, DeleteMethod, OptionsMethod, HeadMethod, PatchMethod, DeleteMethod]

164− , (_pathItemPut, PutStep)

165− , (_pathItemPost, PostStep)

166− , (_pathItemDelete, DeleteStep)

167− , (_pathItemOptions, OptionsStep)

168− , (_pathItemHead, HeadStep)

169− , (_pathItemPatch, PatchStep)

170− , (_pathItemTrace, TraceStep) ]

171− operation <- F.toList $ getOp $ pathItem mpi

169+ operation <- F.toList $ getOp mpi

172 -- Got only Justs here

170 -- Got only Justs here

173− let mop = MatchedOperation { operation , pathParams, getPathFragments }

171+ let retraced = \op -> MatchedOperation { operation = op, pathParams, getPathFragments }

174− pure (s, Traced (step s) mop)

172+ pure (i, retraced <$> operation)

175− check _ pc = checkCompatibility @MatchedOperation env pc

173+ check pc = checkCompatibility @MatchedOperation env pc

176 -- Operations are sum-like entities. Use step to operation as key because

174 -- Operations are sum-like entities. Use step to operation as key because

177 -- why not

175 -- why not

178− checkSums OperationMissing check operations

176+ checkSums OperationMissing (const check) operations

179

177

180

178

181instance Steppable ProcessedPathItems MatchedPathItem where

179instance Steppable ProcessedPathItems MatchedPathItem where

@@ -183,19 +181,11 @@ instance Steppable ProcessedPathItems MatchedPathItem where

183 deriving (Eq, Ord, Show)

181 deriving (Eq, Ord, Show)

184

182

185instance Steppable MatchedPathItem MatchedOperation where

183instance Steppable MatchedPathItem MatchedOperation where

186− data Step MatchedPathItem MatchedOperation

184+ data Step MatchedPathItem MatchedOperation = OperationMethodStep OperationMethod

187− = GetStep

188− | PutStep

189− | PostStep

190− | DeleteStep

191− | OptionsStep

192− | HeadStep

193− | PatchStep

194− | TraceStep

195 deriving (Eq, Ord, Show)

185 deriving (Eq, Ord, Show)

196

186

197instance Steppable MatchedPathItem (Referenced Param) where

187instance Steppable MatchedPathItem (Referenced Param) where

198− data Step MatchedPathItem (Referenced Param) = PathItemParam

188+ data Step MatchedPathItem (Referenced Param) = PathItemParam Int

199 deriving (Eq, Ord, Show)

189 deriving (Eq, Ord, Show)

200

190

201instance Steppable MatchedPathItem PathFragmentParam where

191instance Steppable MatchedPathItem PathFragmentParam where

src/OpenAPI/Checker/Validate/Products.hs+12−34

@@ -14,58 +14,36 @@ This module abstracts this logic for arbitrary elements -}

15module OpenAPI.Checker.Validate.Products

16 ( checkProducts

17− , checkProducts'

18 , ProductLike(..)

17 , ProductLike(..)

19 ) where

18 ) where

21import Data.Foldable

20import Data.Foldable

22−import Data.Functor

23import Data.Map.Strict (Map)

21import Data.Map.Strict (Map)

24import qualified Data.Map.Strict as M

22import qualified Data.Map.Strict as M

25−import Data.OpenApi.Internal

26import OpenAPI.Checker.Subtree

23import OpenAPI.Checker.Subtree

27import OpenAPI.Checker.Trace

24import OpenAPI.Checker.Trace

29-- | Some entity which is product-like

26-- | Some entity which is product-like

30data ProductLike root a = ProductLike

27data ProductLike root a = ProductLike

31− { traced :: Traced root a

28+ { tracedValue :: Traced root a

32 , required :: Bool

29 , required :: Bool

33 }

30 }

35−checkProducts'

32+checkProducts

36− :: forall k root t

33+ :: forall k r t

37− . (Subtree root, Ord k)

34+ . (Subtree t, Ord k)

38− => (k -> CheckIssue root)

35+ => (k -> CheckIssue t)

39 -- ^ No required element found

36 -- ^ No required element found

40− -> (k -> ProdCons t -> CompatFormula t ())

37+ -> (k -> ProdCons (Traced r t) -> CompatFormula' SubtreeCheckIssue r ())

41− -> ProdCons (Map k (ProductLike OpenApi t))

38+ -> ProdCons (Map k (ProductLike r t))

42− -> CompatFormula root ()

39+ -> CompatFormula' SubtreeCheckIssue r ()

43−checkProducts' noElt check (ProdCons p c) = for_ (M.toList c) $ \(key, consElt) ->

40+checkProducts noElt check (ProdCons p c) = for_ (M.toList c) $ \(key, consElt) ->

44 case M.lookup key p of

41 case M.lookup key p of

45 Nothing -> case required consElt of

42 Nothing -> case required consElt of

46− True -> issueAt producer $ noElt key

43+ True -> issueAt (tracedValue consElt) $ noElt key

47 False -> pure ()

44 False -> pure ()

48 Just prodElt -> do

45 Just prodElt -> do

49 let

46 let

50− elts :: ProdCons (ProductLike OpenApi t)

47+ elts :: ProdCons (ProductLike r t)

51 elts = ProdCons prodElt consElt

48 elts = ProdCons prodElt consElt

52− trace = getTrace . traced <$> elts

49+ check key (tracedValue <$> elts)

53− elements = getTraced . traced <$> elts

54− localTrace' trace $ check key elements

55−

56−checkProducts

57− :: forall k root t

58− . (Subtree root, Ord k)

59− => (k -> CheckIssue root)

60− -- ^ No required element found

61− -> (k -> ProdCons t -> CompatFormula t ())

62− -> ProdCons (Map k (ProductLike root t))

63− -> CompatFormula root ()

64−checkProducts noElt check prodCons = withTrace $ \myTrace ->

65− let

66− retracedPC = retracePC <$> myTrace <*> prodCons

67− retracePC rootTrace els = els <&> \productLike ->

68− ProductLike

69− { traced = retrace rootTrace $ traced productLike

70− , required = required productLike }

71− in checkProducts' noElt check retracedPC

src/OpenAPI/Checker/Validate/RequestBody.hs+13−15

@@ -1,11 +1,10 @@

1{-# OPTIONS_GHC -Wno-orphans #-}

3module OpenAPI.Checker.Validate.RequestBody

4− (

4+ ( CheckIssue (..)

5 )

6where

8−import Data.Functor

9import Data.HList

8import Data.HList

10import Data.HashMap.Strict.InsOrd as IOHM

9import Data.HashMap.Strict.InsOrd as IOHM

11import Data.Map.Strict as M

10import Data.Map.Strict as M

@@ -14,32 +13,31 @@ import Data.OpenApi

14import Network.HTTP.Media (MediaType)

13import Network.HTTP.Media (MediaType)

15import OpenAPI.Checker.Subtree

14import OpenAPI.Checker.Subtree

16import OpenAPI.Checker.Trace

15import OpenAPI.Checker.Trace

17−import OpenAPI.Checker.Validate.MediaTypeObject ()

16+import OpenAPI.Checker.Validate.MediaTypeObject

18import OpenAPI.Checker.Validate.Sums

17import OpenAPI.Checker.Validate.Sums

19+tracedContent :: Traced r RequestBody -> IOHM.InsOrdHashMap MediaType (Traced r MediaTypeObject)

20+tracedContent resp = IOHM.mapWithKey (\k -> traced (ask resp >>> step (RequestMediaTypeObject k)))

21+ $ _requestBodyContent $ extract resp

22+

20instance Subtree RequestBody where

23instance Subtree RequestBody where

21 type CheckEnv RequestBody =

24 type CheckEnv RequestBody =

22 '[ ProdCons (Definitions Schema) ]

25 '[ ProdCons (Definitions Schema) ]

23 data CheckIssue RequestBody

26 data CheckIssue RequestBody

24− = RequestBodyRequired

27+ = NoRequestBody

25− | RequestMediaTypeNotFound MediaType

28+ | RequestBodyRequired

26 deriving (Eq, Ord, Show)

29 deriving (Eq, Ord, Show)

27 checkCompatibility env prodCons@(ProdCons p c) =

30 checkCompatibility env prodCons@(ProdCons p c) =

28− if not (fromMaybe False $ _requestBodyRequired p)

31+ if not (fromMaybe False . _requestBodyRequired . extract $ p)

29− && (fromMaybe False $ _requestBodyRequired c)

32+ && (fromMaybe False . _requestBodyRequired . extract $ c)

30− then issueAt producer RequestBodyRequired

33+ then issueAt p RequestBodyRequired

31 else

34 else

32 -- Media type object are sums-like entities.

35 -- Media type object are sums-like entities.

33 let

36 let

34 check mediaType pc = checkCompatibility @MediaTypeObject (HCons mediaType env) pc

37 check mediaType pc = checkCompatibility @MediaTypeObject (HCons mediaType env) pc

35 sumElts = getSum <$> prodCons

38 sumElts = getSum <$> prodCons

36− getSum rb = M.fromList

39+ getSum rb = M.fromList . IOHM.toList $ tracedContent rb

37− $ (IOHM.toList $ _requestBodyContent rb) <&> \(mt, mto) ->

38− ( mt

39− , Traced

40− { getTraced = mto

41− , getTrace = step $ RequestMediaTypeObject mt })

42− in checkSums RequestMediaTypeNotFound check sumElts

40+ in checkSums (const RequestMediaTypeNotFound) check sumElts

44instance Steppable RequestBody MediaTypeObject where

42instance Steppable RequestBody MediaTypeObject where

45 data Step RequestBody MediaTypeObject = RequestMediaTypeObject MediaType

43 data Step RequestBody MediaTypeObject = RequestMediaTypeObject MediaType

src/OpenAPI/Checker/Validate/Responses.hs+43−36

@@ -6,6 +6,7 @@ module OpenAPI.Checker.Validate.Responses

6 )

7where

9+import Control.Lens

9import Data.Foldable

10import Data.Foldable

10import Data.HList

11import Data.HList

11import Data.HashMap.Strict.InsOrd as IOHM

12import Data.HashMap.Strict.InsOrd as IOHM

@@ -16,18 +17,22 @@ import Network.HTTP.Media (MediaType)

16import OpenAPI.Checker.References

17import OpenAPI.Checker.References

17import OpenAPI.Checker.Subtree

18import OpenAPI.Checker.Subtree

18import OpenAPI.Checker.Trace

19import OpenAPI.Checker.Trace

19−import OpenAPI.Checker.Validate.MediaTypeObject ()

20+import OpenAPI.Checker.Validate.MediaTypeObject

20import OpenAPI.Checker.Validate.Products

21import OpenAPI.Checker.Validate.Products

21import OpenAPI.Checker.Validate.Schema ()

22import OpenAPI.Checker.Validate.Schema ()

22import OpenAPI.Checker.Validate.Sums

23import OpenAPI.Checker.Validate.Sums

25+tracedResponses :: Traced r Responses -> IOHM.InsOrdHashMap HttpStatusCode (Traced r (Referenced Response))

26+tracedResponses resp = IOHM.mapWithKey (\k -> traced (ask resp >>> step (ResponseCodeStep k)))

27+ $ _responsesResponses $ extract resp

28+

24instance Subtree Responses where

29instance Subtree Responses where

25 type CheckEnv Responses =

30 type CheckEnv Responses =

26 '[ ProdCons (Definitions Response)

31 '[ ProdCons (Definitions Response)

27 , ProdCons (Definitions Header)

32 , ProdCons (Definitions Header)

28 , ProdCons (Definitions Schema)

33 , ProdCons (Definitions Schema)

29 ]

34 ]

30− data CheckIssue Responses = ResponseCodeNotFound HttpStatusCode

35+ data CheckIssue Responses

31 deriving (Eq, Ord, Show)

36 deriving (Eq, Ord, Show)

32 -- Roles are already swapped. Producer is a server and consumer is a

37 -- Roles are already swapped. Producer is a server and consumer is a

33 -- client. Response codes are sum-like entity because we can answer with only

38 -- client. Response codes are sum-like entity because we can answer with only

@@ -35,15 +40,20 @@ instance Subtree Responses where

35 checkCompatibility env prodCons = do

40 checkCompatibility env prodCons = do

36 let

41 let

37 defs = getH @(ProdCons (Definitions Response)) env

42 defs = getH @(ProdCons (Definitions Response)) env

38− check _ resps = checkCompatibility @Response env resps

43+ check resps = checkCompatibility @Response env resps

39 elements = getEls <$> defs <*> prodCons

44 elements = getEls <$> defs <*> prodCons

40 getEls respDef resps = M.fromList $ do

45 getEls respDef resps = M.fromList $ do

41− (code, respRef) <- IOHM.toList $ _responsesResponses resps

46+ (code, respRef) <- IOHM.toList $ tracedResponses resps

42− let

47+ pure (code, dereference respDef respRef)

43− traced = dereferenceTraced respDef

44− $ Traced (step $ ResponseCodeStep code) respRef

45− pure (code, traced)

46− checkSums ResponseCodeNotFound check elements

48+ checkSums (const ResponseCodeNotFound) (const check) elements

49+

50+tracedContent :: Traced r Response -> IOHM.InsOrdHashMap MediaType (Traced r MediaTypeObject)

51+tracedContent resp = IOHM.mapWithKey (\k -> traced (ask resp >>> step (ResponseMediaObject k)))

52+ $ _responseContent $ extract resp

53+

54+tracedHeaders :: Traced r Response -> IOHM.InsOrdHashMap HeaderName (Traced r (Referenced Header))

55+tracedHeaders resp = IOHM.mapWithKey (\k -> traced (ask resp >>> step (ResponseHeader k)))

56+ $ _responseHeaders $ extract resp

48instance Subtree Response where

58instance Subtree Response where

49 type CheckEnv Response =

59 type CheckEnv Response =

@@ -51,8 +61,7 @@ instance Subtree Response where

51 , ProdCons (Definitions Schema)

61 , ProdCons (Definitions Schema)

52 ]

62 ]

53 data CheckIssue Response

63 data CheckIssue Response

54− = ResponseMediaTypeMissing MediaType

64+ = ResponseCodeNotFound

55− | ResponseHeaderMissing HeaderName

56 deriving (Eq, Ord, Show)

65 deriving (Eq, Ord, Show)

57 checkCompatibility env prodCons = do

66 checkCompatibility env prodCons = do

58 -- Roles are already swapped. Producer is a server and consumer is a client

67 -- Roles are already swapped. Producer is a server and consumer is a client

@@ -67,46 +76,44 @@ instance Subtree Response where

67 let mtEnv = HCons mediaType $ env

76 let mtEnv = HCons mediaType $ env

68 in checkCompatibility @MediaTypeObject mtEnv mtObj

77 in checkCompatibility @MediaTypeObject mtEnv mtObj

69 elements = getEls <$> prodCons

78 elements = getEls <$> prodCons

70− getEls resp = M.fromList $ do

79+ getEls resp = M.fromList . IOHM.toList $ tracedContent resp

71− (mediaType, mtObj) <- IOHM.toList $ _responseContent resp

72− let traced = Traced (step $ ResponseMediaObject mediaType) mtObj

73− pure (mediaType, traced)

74− checkSums ResponseMediaTypeMissing check elements

80+ checkSums (const ResponseMediaTypeMissing) check elements

76 checkHeaders = do

82 checkHeaders = do

77 -- Headers are product-like entities

83 -- Headers are product-like entities

78 let

84 let

79− check _hname hdrs = checkCompatibility @Header env hdrs

85+ check hdrs = checkCompatibility @Header env hdrs

80 elements = getEls <$> headerDefs <*> prodCons

86 elements = getEls <$> headerDefs <*> prodCons

81 getEls headerDef resp = M.fromList $ do

87 getEls headerDef resp = M.fromList $ do

82− (hname, headerRef) <- IOHM.toList $ _responseHeaders resp

88+ (hname, headerRef) <- IOHM.toList $ tracedHeaders resp

83− let

89+ let header = dereference headerDef headerRef

84− traced = dereferenceTraced headerDef

90+ pure (hname, ProductLike

85− $ Traced (step $ ResponseHeader hname) headerRef

91+ { tracedValue = header

86− required = fromMaybe False $ _headerRequired $ getTraced traced

92+ , required = fromMaybe False . _headerRequired . extract $ header

87− elt = ProductLike { traced, required }

93+ })

88− pure (hname, elt)

89− checkProducts ResponseHeaderMissing check elements

94+ checkProducts (const ResponseHeaderMissing) (const check) elements

90 headerDefs = getH @(ProdCons (Definitions Header)) env

95 headerDefs = getH @(ProdCons (Definitions Header)) env

97+tracedSchema :: Traced r Header -> Maybe (Traced r (Referenced Schema))

98+tracedSchema hdr = _headerSchema (extract hdr) <&> traced (ask hdr >>> step HeaderSchema)

99+

92instance Subtree Header where

100instance Subtree Header where

93 type CheckEnv Header = '[ProdCons (Definitions Schema)]

101 type CheckEnv Header = '[ProdCons (Definitions Schema)]

94 data CheckIssue Header

102 data CheckIssue Header

103+ = ResponseHeaderMissing

95− = RequiredHeaderMissing

104+ | RequiredHeaderMissing

96 | NonEmptyHeaderRequired

105 | NonEmptyHeaderRequired

97 | HeaderSchemaRequired

106 | HeaderSchemaRequired

98 deriving (Eq, Ord, Show)

107 deriving (Eq, Ord, Show)

99 checkCompatibility env (ProdCons p c) = do

108 checkCompatibility env (ProdCons p c) = do

100− if (fromMaybe False $ _headerRequired c) && not (fromMaybe False $ _headerRequired p)

109+ if (fromMaybe False $ _headerRequired $ extract c) && not (fromMaybe False $ _headerRequired $ extract p)

101− then issueAt producer RequiredHeaderMissing else pure ()

110+ then issueAt p RequiredHeaderMissing else pure ()

102− if not (fromMaybe False $ _headerAllowEmptyValue c) && (fromMaybe False $ _headerAllowEmptyValue p)

111+ if not (fromMaybe False $ _headerAllowEmptyValue $ extract c) && (fromMaybe False $ _headerAllowEmptyValue $ extract p)

103− then issueAt producer NonEmptyHeaderRequired else pure ()

112+ then issueAt p NonEmptyHeaderRequired else pure ()

104− for_ (_headerSchema c) $ \consRef ->

113+ for_ (tracedSchema c) $ \consRef ->

105− case (_headerSchema p) of

114+ case tracedSchema p of

106− Nothing -> issueAt producer HeaderSchemaRequired

115+ Nothing -> issueAt p HeaderSchemaRequired

107− Just prodRef -> do

108− localStep HeaderSchema

109− $ checkCompatibility env $ ProdCons prodRef consRef

116+ Just prodRef -> checkCompatibility env (ProdCons prodRef consRef)

110 pure ()

117 pure ()

111

118

112instance Steppable Responses (Referenced Response) where

119instance Steppable Responses (Referenced Response) where

src/OpenAPI/Checker/Validate/Schema.hs+154−137

@@ -14,7 +14,11 @@ module OpenAPI.Checker.Validate.Schema

15import Algebra.Lattice

16import Control.Applicative

17−import Control.Monad.Reader

17+import Control.Arrow

18+import Control.Comonad.Env hiding (env)

19+import Control.Lens hiding (cons)

20+import Control.Monad.Reader hiding (ask)

21+import qualified Control.Monad.Reader as R

18import Control.Monad.Writer

22import Control.Monad.Writer

19import qualified Data.Aeson as A

23import qualified Data.Aeson as A

20import Data.Coerce

24import Data.Coerce

@@ -154,7 +158,7 @@ deriving stock instance Ord (Condition t)

154deriving stock instance Show (Condition t)

158deriving stock instance Show (Condition t)

155

159

156data SomeCondition where

160data SomeCondition where

157− SomeCondition :: Typeable t => Condition t -> SomeCondition

161+ SomeCondition :: Typeable t => Traced OpenApi (Condition t) -> SomeCondition

158

162

159instance Eq SomeCondition where

163instance Eq SomeCondition where

160 SomeCondition x == SomeCondition y = case cast x of

164 SomeCondition x == SomeCondition y = case cast x of

@@ -200,8 +204,8 @@ isSingleton s

200 | otherwise = Nothing

204 | otherwise = Nothing

201

205

202pattern Conjunct :: [Traced r (Condition t)] -> M.Map (Condition t) (Trace r (Condition t))

206pattern Conjunct :: [Traced r (Condition t)] -> M.Map (Condition t) (Trace r (Condition t))

203−pattern Conjunct xs <- (map (uncurry $ flip Traced) . M.toList -> xs)

207+pattern Conjunct xs <- (map (uncurry $ flip traced) . M.toList -> xs)

204− where Conjunct xs = M.fromList [(x, t) | Traced t x <- xs]

208+ where Conjunct xs = M.fromList $ (extract &&& ask) <$> xs

205{-# COMPLETE Conjunct #-}

209{-# COMPLETE Conjunct #-}

206

210

207pattern SingleConjunct :: [Traced r (Condition t)] -> JsonFormula r t

211pattern SingleConjunct :: [Traced r (Condition t)] -> JsonFormula r t

@@ -218,19 +222,16 @@ instance BoundedJoinSemiLattice (JsonFormula r t) where

218instance BoundedMeetSemiLattice (JsonFormula r t) where

222instance BoundedMeetSemiLattice (JsonFormula r t) where

219 top = TopFormula

223 top = TopFormula

220

224

221−singletonFormula :: Trace r (Condition t) -> Condition t -> JsonFormula r t

222−singletonFormula t x = SingleConjunct [Traced t x]

223−

224foldLattice

225foldLattice

225 :: BoundedLattice l

226 :: BoundedLattice l

226 => (Traced r (Condition t) -> l)

227 => (Traced r (Condition t) -> l)

227 -> JsonFormula r t

228 -> JsonFormula r t

228 -> l

229 -> l

229foldLattice f (DNF xss) = S.foldl' (\z w ->

230foldLattice f (DNF xss) = S.foldl' (\z w ->

230− z \/ M.foldlWithKey' (\x y t -> x /\ f (Traced t y)) top w) bottom xss

231+ z \/ M.foldlWithKey' (\x y t -> x /\ f (traced t y)) top w) bottom xss

231

232

232satisfiesFormula :: TypedValue t -> JsonFormula r t -> Bool

233satisfiesFormula :: TypedValue t -> JsonFormula r t -> Bool

233−satisfiesFormula val = foldLattice (satisfiesTyped val . getTraced)

234+satisfiesFormula val = foldLattice (satisfiesTyped val . extract)

234

235

235data ForeachType (f :: JsonType -> Type) = ForeachType

236data ForeachType (f :: JsonType -> Type) = ForeachType

236 { forNull :: f 'Null

237 { forNull :: f 'Null

@@ -345,22 +346,52 @@ instance Steppable Schema (Referenced Schema) where

345 = AllOfStep Int

346 = AllOfStep Int

346 | OneOfStep Int

347 | OneOfStep Int

347 | AnyOfStep Int

348 | AnyOfStep Int

348− | ItemsStep

349+ | ItemsObjectStep

350+ | ItemsArrayStep Int

349 | AdditionalPropertiesStep

351 | AdditionalPropertiesStep

350 | PropertiesStep Text

352 | PropertiesStep Text

351 deriving (Eq, Ord, Show)

353 deriving (Eq, Ord, Show)

352

354

353type ProcessM = ReaderT (Definitions Schema) (Writer (T.TracePrefixTree SubtreeCheckIssue OpenApi))

355type ProcessM = ReaderT (Definitions Schema) (Writer (T.TracePrefixTree SubtreeCheckIssue OpenApi))

354

356

357+warn

358+ :: (Subtree t, ComonadEnv (Trace OpenApi t) w)

355−warn :: Subtree t => Trace OpenApi t -> CheckIssue t -> ProcessM ()

359+ => w x -> CheckIssue t -> ProcessM ()

356−warn t x = tell $ T.singleton $ AnItem t $ SubtreeCheckIssue x

360+warn t issue = tell $ T.singleton $ AnItem (ask t) $ SubtreeCheckIssue issue

357

361

358processRefSchema

362processRefSchema

359 :: Traced OpenApi (Referenced Schema)

363 :: Traced OpenApi (Referenced Schema)

360 -> ProcessM (ForeachType (JsonFormula OpenApi))

364 -> ProcessM (ForeachType (JsonFormula OpenApi))

361processRefSchema x = do

365processRefSchema x = do

362− defs <- ask

366+ defs <- R.ask

363− processSchema $ dereferenceTraced defs x

367+ processSchema $ dereference defs x

368+

369+tracedAllOf :: Traced r Schema -> Maybe [Traced r (Referenced Schema)]

370+tracedAllOf sch = _schemaAllOf (extract sch) <&> \xs ->

371+ [ traced (ask sch >>> step (AllOfStep i)) x | (i, x) <- zip [0..] xs ]

372+

373+tracedAnyOf :: Traced r Schema -> Maybe [Traced r (Referenced Schema)]

374+tracedAnyOf sch = _schemaAnyOf (extract sch) <&> \xs ->

375+ [ traced (ask sch >>> step (AnyOfStep i)) x | (i, x) <- zip [0..] xs ]

376+

377+tracedOneOf :: Traced r Schema -> Maybe [Traced r (Referenced Schema)]

378+tracedOneOf sch = _schemaOneOf (extract sch) <&> \xs ->

379+ [ traced (ask sch >>> step (OneOfStep i)) x | (i, x) <- zip [0..] xs ]

380+

381+tracedItems :: Traced r Schema -> Maybe (Either (Traced r (Referenced Schema)) [Traced r (Referenced Schema)])

382+tracedItems sch = _schemaItems (extract sch) <&> \case

383+ OpenApiItemsObject x -> Left $ traced (ask sch >>> step ItemsObjectStep) x

384+ OpenApiItemsArray xs -> Right

385+ [ traced (ask sch >>> step (ItemsArrayStep i)) x | (i, x) <- zip [0..] xs ]

386+

387+tracedAdditionalProperties :: Traced r Schema -> Maybe (Either Bool (Traced r (Referenced Schema)))

388+tracedAdditionalProperties sch = _schemaAdditionalProperties (extract sch) <&> \case

389+ AdditionalPropertiesAllowed b -> Left b

390+ AdditionalPropertiesSchema x -> Right $ traced (ask sch >>> step AdditionalPropertiesStep) x

391+

392+tracedProperties :: Traced r Schema -> IOHM.InsOrdHashMap Text (Traced r (Referenced Schema))

393+tracedProperties sch = IOHM.mapWithKey (\k -> traced (ask sch >>> step (PropertiesStep k)))

394+ $ _schemaProperties $ extract sch

364

395

365-- | Turn a schema into a tuple of 'JsonFormula's that describes the condition

396-- | Turn a schema into a tuple of 'JsonFormula's that describes the condition

366-- for every possible type of a JSON value. The conditions are independent, and

397-- for every possible type of a JSON value. The conditions are independent, and

@@ -368,36 +399,33 @@ processRefSchema x = do

368processSchema

399processSchema

369 :: Traced OpenApi Schema

400 :: Traced OpenApi Schema

370 -> ProcessM (ForeachType (JsonFormula OpenApi))

401 -> ProcessM (ForeachType (JsonFormula OpenApi))

371−processSchema (Traced t Schema{..}) = do

402+processSchema sch@(extract -> Schema{..}) = do

403+ let

404+ singletonFormula :: Typeable t => Step Schema (Condition t) -> Condition t -> JsonFormula OpenApi t

405+ singletonFormula t f = SingleConjunct [traced (ask sch >>> step t) f]

372

406

373− allClauses <- case _schemaAllOf of

407+ allClauses <- case tracedAllOf sch of

374 Nothing -> pure []

408 Nothing -> pure []

375− Just [] -> [] <$ warn t (InvalidSchema "no items in allOf")

409+ Just [] -> [] <$ warn sch (InvalidSchema "no items in allOf")

376− Just xs -> sequence

377− [ processRefSchema (Traced (t `Snoc` AllOfStep i) rs)

410+ Just xs -> mapM processRefSchema xs

378− | (i, rs) <- zip [0..] xs ]

379

411

380− anyClause <- case _schemaAnyOf of

412+ anyClause <- case tracedAnyOf sch of

381 Nothing -> pure top

413 Nothing -> pure top

382− Just [] -> bottom <$ warn t (InvalidSchema "no items in anyOf")

414+ Just [] -> bottom <$ warn sch (InvalidSchema "no items in anyOf")

383− Just xs -> joins <$> sequence

384− [ processRefSchema (Traced (t `Snoc` AnyOfStep i) rs)

415+ Just xs -> joins <$> mapM processRefSchema xs

385− | (i, rs) <- zip [0..] xs ]

386

416

387− oneClause <- case _schemaOneOf of

417+ oneClause <- case tracedOneOf sch of

388 Nothing -> pure top

418 Nothing -> pure top

389− Just [] -> bottom <$ warn t (InvalidSchema "no items in oneOf")

419+ Just [] -> bottom <$ warn sch (InvalidSchema "no items in oneOf")

390 Just xs -> do

420 Just xs -> do

391 checkOneOfDisjoint xs >>= \case

421 checkOneOfDisjoint xs >>= \case

392 True -> pure ()

422 True -> pure ()

393− False -> warn t (NotSupported "Could not determine that oneOf branches are disjoint")

423+ False -> warn sch (NotSupported "Could not determine that oneOf branches are disjoint")

394− joins <$> sequence

395− [ processRefSchema (Traced (t `Snoc` OneOfStep i) rs)

424+ joins <$> mapM processRefSchema xs

396− | (i, rs) <- zip [0..] xs ]

397

425

398 case _schemaNot of

426 case _schemaNot of

399 Nothing -> pure ()

427 Nothing -> pure ()

400− Just _ -> warn t (NotSupported "not clause is unsupported")

428+ Just _ -> warn sch (NotSupported "not clause is unsupported")

401

429

402 let

430 let

403 typeClause = case _schemaType of

431 typeClause = case _schemaType of

@@ -409,7 +437,7 @@ processSchema (Traced t Schema{..}) = do

409 Just OpenApiNumber -> bottom

437 Just OpenApiNumber -> bottom

410 { forBoolean = top }

438 { forBoolean = top }

411 Just OpenApiInteger -> bottom

439 Just OpenApiInteger -> bottom

412− { forNumber = singletonFormula (t `Snoc` IntegerType) $ MultipleOf 1 }

440+ { forNumber = singletonFormula IntegerType $ MultipleOf 1 }

413 Just OpenApiString -> bottom

441 Just OpenApiString -> bottom

414 { forString = top }

442 { forString = top }

415 Just OpenApiArray -> bottom

443 Just OpenApiArray -> bottom

@@ -419,27 +447,27 @@ processSchema (Traced t Schema{..}) = do

419

447

420 let

448 let

421 valueEnum A.Null = bottom

449 valueEnum A.Null = bottom

422− { forNull = singletonFormula (t `Snoc` EnumField) $ Exactly TNull }

450+ { forNull = singletonFormula EnumField $ Exactly TNull }

423 valueEnum (A.Bool b) = bottom

451 valueEnum (A.Bool b) = bottom

424− { forBoolean = singletonFormula (t `Snoc` EnumField) $ Exactly $ TBool b }

452+ { forBoolean = singletonFormula EnumField $ Exactly $ TBool b }

425 valueEnum (A.Number n) = bottom

453 valueEnum (A.Number n) = bottom

426− { forNumber = singletonFormula (t `Snoc` EnumField) $ Exactly $ TNumber n }

454+ { forNumber = singletonFormula EnumField $ Exactly $ TNumber n }

427 valueEnum (A.String s) = bottom

455 valueEnum (A.String s) = bottom

428− { forString = singletonFormula (t `Snoc` EnumField) $ Exactly $ TString s }

456+ { forString = singletonFormula EnumField $ Exactly $ TString s }

429 valueEnum (A.Array a) = bottom

457 valueEnum (A.Array a) = bottom

430− { forArray = singletonFormula (t `Snoc` EnumField) $ Exactly $ TArray a }

458+ { forArray = singletonFormula EnumField $ Exactly $ TArray a }

431 valueEnum (A.Object o) = bottom

459 valueEnum (A.Object o) = bottom

432− { forObject = singletonFormula (t `Snoc` EnumField) $ Exactly $ TObject o }

460+ { forObject = singletonFormula EnumField $ Exactly $ TObject o }

433 enumClause <- case _schemaEnum of

461 enumClause <- case _schemaEnum of

434 Nothing -> pure top

462 Nothing -> pure top

435− Just [] -> bottom <$ warn t (InvalidSchema "no items in enum")

463+ Just [] -> bottom <$ warn sch (InvalidSchema "no items in enum")

436 Just xs -> pure $ joins (valueEnum <$> xs)

464 Just xs -> pure $ joins (valueEnum <$> xs)

437

465

438 let

466 let

439 maximumClause = case _schemaMaximum of

467 maximumClause = case _schemaMaximum of

440 Nothing -> top

468 Nothing -> top

441 Just n -> top

469 Just n -> top

442− { forNumber = singletonFormula (t `Snoc` MaximumFields) $ Maximum $

470+ { forNumber = singletonFormula MaximumFields $ Maximum $

443 case _schemaExclusiveMaximum of

471 case _schemaExclusiveMaximum of

444 Just True -> Exclusive n

472 Just True -> Exclusive n

445 _ -> Inclusive n }

473 _ -> Inclusive n }

@@ -447,7 +475,7 @@ processSchema (Traced t Schema{..}) = do

447 minimumClause = case _schemaMinimum of

475 minimumClause = case _schemaMinimum of

448 Nothing -> top

476 Nothing -> top

449 Just n -> top

477 Just n -> top

450− { forNumber = singletonFormula (t `Snoc` MinimumFields) $ Minimum $ Down $

478+ { forNumber = singletonFormula MinimumFields $ Minimum $ Down $

451 case _schemaExclusiveMinimum of

479 case _schemaExclusiveMinimum of

452 Just True -> Exclusive $ Down n

480 Just True -> Exclusive $ Down n

453 _ -> Inclusive $ Down n }

481 _ -> Inclusive $ Down n }

@@ -455,72 +483,68 @@ processSchema (Traced t Schema{..}) = do

455 multipleOfClause = case _schemaMultipleOf of

483 multipleOfClause = case _schemaMultipleOf of

456 Nothing -> top

484 Nothing -> top

457 Just n -> top

485 Just n -> top

458− { forNumber = singletonFormula (t `Snoc` MultipleOfField) $ MultipleOf n }

486+ { forNumber = singletonFormula MultipleOfField $ MultipleOf n }

459

487

460 formatClause <- case _schemaFormat of

488 formatClause <- case _schemaFormat of

461 Nothing -> pure top

489 Nothing -> pure top

462 Just f | f `elem` ["int32", "int64", "float", "double"] -> pure top

490 Just f | f `elem` ["int32", "int64", "float", "double"] -> pure top

463− { forNumber = singletonFormula (t `Snoc` FormatField) $ NumberFormat f }

491+ { forNumber = singletonFormula FormatField $ NumberFormat f }

464 Just f | f `elem` ["byte", "binary", "date", "date-time", "password"] -> pure top

492 Just f | f `elem` ["byte", "binary", "date", "date-time", "password"] -> pure top

465− { forString = singletonFormula (t `Snoc` FormatField) $ StringFormat f }

493+ { forString = singletonFormula FormatField $ StringFormat f }

466− Just f -> top <$ warn t (NotSupported $ "Unknown format: " <> f)

494+ Just f -> top <$ warn sch (NotSupported $ "Unknown format: " <> f)

467

495

468 let

496 let

469 maxLengthClause = case _schemaMaxLength of

497 maxLengthClause = case _schemaMaxLength of

470 Nothing -> top

498 Nothing -> top

471 Just n -> top

499 Just n -> top

472− { forString = singletonFormula (t `Snoc` MaxLengthField) $ MaxLength n }

500+ { forString = singletonFormula MaxLengthField $ MaxLength n }

473

501

474 minLengthClause = case _schemaMinLength of

502 minLengthClause = case _schemaMinLength of

475 Nothing -> top

503 Nothing -> top

476 Just n -> top

504 Just n -> top

477− { forString = singletonFormula (t `Snoc` MinLengthField) $ MinLength n }

505+ { forString = singletonFormula MinLengthField $ MinLength n }

478

506

479 patternClause = case _schemaPattern of

507 patternClause = case _schemaPattern of

480 Nothing -> top

508 Nothing -> top

481 Just p -> top

509 Just p -> top

482− { forString = singletonFormula (t `Snoc` PatternField) $ Pattern p }

510+ { forString = singletonFormula PatternField $ Pattern p }

483

511

484− itemsClause <- case _schemaItems of

512+ itemsClause <- case tracedItems sch of

485 Nothing -> pure top

513 Nothing -> pure top

486− Just (OpenApiItemsObject rs) -> do

514+ Just (Left rs) -> do

487− let trs = Traced (t `Snoc` ItemsStep) rs

488− f <- processRefSchema trs

515+ f <- processRefSchema rs

489− pure top { forArray = singletonFormula (t `Snoc` ItemsField) $ Items f trs }

516+ pure top { forArray = singletonFormula ItemsField $ Items f rs }

490− Just (OpenApiItemsArray _) -> top <$ warn t (NotSupported "array in items is not supported")

517+ Just (Right _) -> top <$ warn sch (NotSupported "array in items is not supported")

491

518

492 let

519 let

493 maxItemsClause = case _schemaMaxItems of

520 maxItemsClause = case _schemaMaxItems of

494 Nothing -> top

521 Nothing -> top

495 Just n -> top

522 Just n -> top

496− { forArray = singletonFormula (t `Snoc` MaxItemsField) $ MaxItems n }

523+ { forArray = singletonFormula MaxItemsField $ MaxItems n }

497

524

498 minItemsClause = case _schemaMinItems of

525 minItemsClause = case _schemaMinItems of

499 Nothing -> top

526 Nothing -> top

500 Just n -> top

527 Just n -> top

501− { forArray = singletonFormula (t `Snoc` MinItemsField) $ MinItems n }

528+ { forArray = singletonFormula MinItemsField $ MinItems n }

502

529

503 uniqueItemsClause = case _schemaUniqueItems of

530 uniqueItemsClause = case _schemaUniqueItems of

504 Just True -> top

531 Just True -> top

505− { forArray = singletonFormula (t `Snoc` UniqueItemsField) UniqueItems }

532+ { forArray = singletonFormula UniqueItemsField UniqueItems }

506 _ -> top

533 _ -> top

507

534

508− (addProps, addPropSchema) <- case _schemaAdditionalProperties of

535+ (addProps, addPropSchema) <- case tracedAdditionalProperties sch of

509− Just (AdditionalPropertiesSchema rs) -> do

510− let trs = Traced (t `Snoc` AdditionalPropertiesStep) rs

511− (,Just trs) <$> processRefSchema trs

536+ Just (Right rs) -> (,Just rs) <$> processRefSchema rs

512− Just (AdditionalPropertiesAllowed False) -> pure (bottom, Nothing)

537+ Just (Left False) -> pure (bottom, Nothing)

513− _ -> pure (top, Just $ Traced (t `Snoc` AdditionalPropertiesStep) $ Inline mempty)

538+ _ -> pure (top, Just $ traced (ask sch `Snoc` AdditionalPropertiesStep) $ Inline mempty)

514 propList <- forM (S.toList . S.fromList $ IOHM.keys _schemaProperties <> _schemaRequired) $ \k -> do

539 propList <- forM (S.toList . S.fromList $ IOHM.keys _schemaProperties <> _schemaRequired) $ \k -> do

515− (f, sch) <- case IOHM.lookup k _schemaProperties of

540+ (f, psch) <- case IOHM.lookup k $ tracedProperties sch of

516− Just rs -> do

517− let trs = Traced (t `Snoc` PropertiesStep k) rs

518− (,trs) <$> processRefSchema trs

541+ Just rs -> (,rs) <$> processRefSchema rs

519− Nothing -> pure (addProps, fromMaybe (Traced (t `Snoc` AdditionalPropertiesStep) $ Inline mempty) addPropSchema)

542+ Nothing -> let fakeSchema = traced (ask sch `Snoc` AdditionalPropertiesStep) $ Inline mempty

520 -- The mempty here is incorrect, but if addPropSchema was Nothing, then

543 -- The mempty here is incorrect, but if addPropSchema was Nothing, then

521 -- addProps is bottom, and k is in _schemaRequired. We handle this situation

544 -- addProps is bottom, and k is in _schemaRequired. We handle this situation

522 -- below and short-circuit the entire Properties condition to bottom

545 -- below and short-circuit the entire Properties condition to bottom

546+ in pure (addProps, fromMaybe fakeSchema addPropSchema)

523− pure (k, Property (k `elem` _schemaRequired) f sch)

547+ pure (k, Property (k `elem` _schemaRequired) f psch)

524 let

548 let

525 allBottom f = getAll $ foldType $ \ty -> case ty f of

549 allBottom f = getAll $ foldType $ \ty -> case ty f of

526 BottomFormula -> All True

550 BottomFormula -> All True

@@ -537,21 +561,21 @@ processSchema (Traced t Schema{..}) = do

537 = top -- if all fields are optional and have trivial schemata

561 = top -- if all fields are optional and have trivial schemata

538 | otherwise

562 | otherwise

539 = top

563 = top

540− { forObject = singletonFormula (t `Snoc` PropertiesFields) $ Properties propMap addProps addPropSchema }

564+ { forObject = singletonFormula PropertiesFields $ Properties propMap addProps addPropSchema }

541

565

542 maxPropertiesClause = case _schemaMaxProperties of

566 maxPropertiesClause = case _schemaMaxProperties of

543 Nothing -> top

567 Nothing -> top

544 Just n -> top

568 Just n -> top

545− { forObject = singletonFormula (t `Snoc` MaxPropertiesField) $ MaxProperties n }

569+ { forObject = singletonFormula MaxPropertiesField $ MaxProperties n }

546

570

547 minPropertiesClause = case _schemaMinProperties of

571 minPropertiesClause = case _schemaMinProperties of

548 Nothing -> top

572 Nothing -> top

549 Just n -> top

573 Just n -> top

550− { forObject = singletonFormula (t `Snoc` MinPropertiesField) $ MinProperties n }

574+ { forObject = singletonFormula MinPropertiesField $ MinProperties n }

551

575

552 nullableClause

576 nullableClause

553 | Just True <- _schemaNullable = bottom

577 | Just True <- _schemaNullable = bottom

554− { forNull = singletonFormula (t `Snoc` NullableField) $ Exactly TNull }

578+ { forNull = singletonFormula NullableField $ Exactly TNull }

555 | otherwise = bottom

579 | otherwise = bottom

556

580

557 pure $ nullableClause \/ meets (allClauses <>

581 pure $ nullableClause \/ meets (allClauses <>

@@ -561,7 +585,7 @@ processSchema (Traced t Schema{..}) = do

561 , uniqueItemsClause, propertiesClause, maxPropertiesClause, minPropertiesClause])

585 , uniqueItemsClause, propertiesClause, maxPropertiesClause, minPropertiesClause])

562{- TODO: ReadOnly/WriteOnly -}

586{- TODO: ReadOnly/WriteOnly -}

563

587

564−checkOneOfDisjoint :: [Referenced Schema] -> ProcessM Bool

588+checkOneOfDisjoint :: [Traced OpenApi (Referenced Schema)] -> ProcessM Bool

565checkOneOfDisjoint = const $ pure True -- TODO

589checkOneOfDisjoint = const $ pure True -- TODO

566

590

567schemaToFormula

591schemaToFormula

@@ -575,7 +599,7 @@ checkFormulas

575 => HList xs

599 => HList xs

576 -> Trace OpenApi Schema

600 -> Trace OpenApi Schema

577 -> ProdCons (ForeachType (JsonFormula OpenApi), T.TracePrefixTree SubtreeCheckIssue OpenApi)

601 -> ProdCons (ForeachType (JsonFormula OpenApi), T.TracePrefixTree SubtreeCheckIssue OpenApi)

578− -> CompatFormula Schema ()

602+ -> CompatFormula ()

579checkFormulas env tr (ProdCons (fp, ep) (fc, ec)) =

603checkFormulas env tr (ProdCons (fp, ep) (fc, ec)) =

580 case T.toList ep ++ T.toList ec of

604 case T.toList ep ++ T.toList ec of

581 issues@(_:_) -> F.for_ issues $ \(AnItem t (SubtreeCheckIssue e)) -> issueAtTrace t e

605 issues@(_:_) -> F.for_ issues $ \(AnItem t (SubtreeCheckIssue e)) -> issueAtTrace t e

@@ -613,13 +637,13 @@ checkFormulas env tr (ProdCons (fp, ep) (fc, ec)) =

613 (DNF pss, SingleConjunct cs) -> F.for_ pss $ \(Conjunct ps) -> do

637 (DNF pss, SingleConjunct cs) -> F.for_ pss $ \(Conjunct ps) -> do

614 F.for_ cs $ checkImplication env ps -- avoid disjuntion if there's only one conjunct

638 F.for_ cs $ checkImplication env ps -- avoid disjuntion if there's only one conjunct

615 (DNF pss, DNF css) -> F.for_ pss $ \(Conjunct ps) -> do

639 (DNF pss, DNF css) -> F.for_ pss $ \(Conjunct ps) -> do

616− anyOfM tr (SubtreeCheckIssue $ NoMatchingCondition $ SomeCondition . getTraced <$> ps)

640+ anyOfM tr (NoMatchingCondition $ SomeCondition <$> ps)

617 [F.for_ cs $ checkImplication env ps | Conjunct cs <- S.toList css]

641 [F.for_ cs $ checkImplication env ps | Conjunct cs <- S.toList css]

618

642

619checkContradiction

643checkContradiction

620 :: Trace OpenApi Schema

644 :: Trace OpenApi Schema

621 -> [Traced OpenApi (Condition t)]

645 -> [Traced OpenApi (Condition t)]

622− -> CompatFormula s ()

646+ -> CompatFormula ()

623checkContradiction tr _ = issueAtTrace tr NoContradiction -- TODO

647checkContradiction tr _ = issueAtTrace tr NoContradiction -- TODO

624

648

625checkImplication

649checkImplication

@@ -627,96 +651,93 @@ checkImplication

627 => HList xs

651 => HList xs

628 -> [Traced OpenApi (Condition t)]

652 -> [Traced OpenApi (Condition t)]

629 -> Traced OpenApi (Condition t)

653 -> Traced OpenApi (Condition t)

630− -> CompatFormula s ()

654+ -> CompatFormula ()

631−checkImplication env prods (Traced t cons) = case findExactly prods of

655+checkImplication env prods cons = case findExactly prods of

632 Just e

656 Just e

633− | all (satisfiesTyped e) (getTraced <$> prods) ->

657+ | all (satisfiesTyped e) (extract <$> prods) ->

634− if satisfiesTyped e cons then pure ()

658+ if satisfiesTyped e $ extract cons then pure ()

635− else issueAtTrace t (EnumDoesntSatisfy e)

659+ else issueAt cons (EnumDoesntSatisfy e)

636 | otherwise -> pure () -- vacuously true

660 | otherwise -> pure () -- vacuously true

637− Nothing -> case cons of

661+ Nothing -> case extract cons of

638 -- the above code didn't catch it, so there's no Exactly condition on the lhs

662 -- the above code didn't catch it, so there's no Exactly condition on the lhs

639− Exactly e -> issueAtTrace t (NoMatchingEnum e)

663+ Exactly e -> issueAt cons (NoMatchingEnum e)

640 Maximum m -> case findRelevant min (\case Maximum m' -> Just m'; _ -> Nothing) prods of

664 Maximum m -> case findRelevant min (\case Maximum m' -> Just m'; _ -> Nothing) prods of

641 Just m' -> if m' <= m then pure ()

665 Just m' -> if m' <= m then pure ()

642− else issueAtTrace t (MatchingMaximumWeak m m')

666+ else issueAt cons (MatchingMaximumWeak m m')

643− Nothing -> issueAtTrace t (NoMatchingMaximum m)

667+ Nothing -> issueAt cons (NoMatchingMaximum m)

644 Minimum m -> case findRelevant max (\case Minimum m' -> Just m'; _ -> Nothing) prods of

668 Minimum m -> case findRelevant max (\case Minimum m' -> Just m'; _ -> Nothing) prods of

645 Just m' -> if m' >= m then pure ()

669 Just m' -> if m' >= m then pure ()

646− else issueAtTrace t (MatchingMinimumWeak (coerce m) (coerce m'))

670+ else issueAt cons (MatchingMinimumWeak (coerce m) (coerce m'))

647− Nothing -> issueAtTrace t (NoMatchingMinimum (coerce m))

671+ Nothing -> issueAt cons (NoMatchingMinimum (coerce m))

648 MultipleOf m -> case findRelevant lcmScientific (\case MultipleOf m' -> Just m'; _ -> Nothing) prods of

672 MultipleOf m -> case findRelevant lcmScientific (\case MultipleOf m' -> Just m'; _ -> Nothing) prods of

649 Just m' -> if lcmScientific m m' == m' then pure ()

673 Just m' -> if lcmScientific m m' == m' then pure ()

650− else issueAtTrace t (MatchingMultipleOfWeak m m')

674+ else issueAt cons (MatchingMultipleOfWeak m m')

651− Nothing -> issueAtTrace t (NoMatchingMultipleOf m)

675+ Nothing -> issueAt cons (NoMatchingMultipleOf m)

652− NumberFormat f -> if any (\case NumberFormat f' -> f == f'; _ -> False) $ getTraced <$> prods

676+ NumberFormat f -> if any (\case NumberFormat f' -> f == f'; _ -> False) $ extract <$> prods

653− then pure () else issueAtTrace t (NoMatchingFormat f)

677+ then pure () else issueAt cons (NoMatchingFormat f)

654 MaxLength m -> case findRelevant min (\case MaxLength m' -> Just m'; _ -> Nothing) prods of

678 MaxLength m -> case findRelevant min (\case MaxLength m' -> Just m'; _ -> Nothing) prods of

655 Just m' -> if m' <= m then pure ()

679 Just m' -> if m' <= m then pure ()

656− else issueAtTrace t (MatchingMaxLengthWeak m m')

680+ else issueAt cons (MatchingMaxLengthWeak m m')

657− Nothing -> issueAtTrace t (NoMatchingMaxLength m)

681+ Nothing -> issueAt cons (NoMatchingMaxLength m)

658 MinLength m -> case findRelevant max (\case MinLength m' -> Just m'; _ -> Nothing) prods of

682 MinLength m -> case findRelevant max (\case MinLength m' -> Just m'; _ -> Nothing) prods of

659 Just m' -> if m' >= m then pure ()

683 Just m' -> if m' >= m then pure ()

660− else issueAtTrace t (MatchingMinLengthWeak m m')

684+ else issueAt cons (MatchingMinLengthWeak m m')

661− Nothing -> issueAtTrace t (NoMatchingMinLength m)

685+ Nothing -> issueAt cons (NoMatchingMinLength m)

662− Pattern p -> if any (\case Pattern p' -> p == p'; _ -> False) $ getTraced <$> prods

686+ Pattern p -> if any (\case Pattern p' -> p == p'; _ -> False) $ extract <$> prods

663− then pure () else issueAtTrace t (NoMatchingPattern p)

687+ then pure () else issueAt cons (NoMatchingPattern p)

664− StringFormat f -> if any (\case StringFormat f' -> f == f'; _ -> False) $ getTraced <$> prods

688+ StringFormat f -> if any (\case StringFormat f' -> f == f'; _ -> False) $ extract <$> prods

665− then pure () else issueAtTrace t (NoMatchingFormat f)

689+ then pure () else issueAt cons (NoMatchingFormat f)

666− Items _ (Traced t' cons') -> case findRelevant (<>) (\case Items _ rs -> Just (rs NE.:| []); _ -> Nothing) prods of

690+ Items _ cons' -> case findRelevant (<>) (\case Items _ rs -> Just (rs NE.:| []); _ -> Nothing) prods of

667− Just (rs NE.:| []) -> localTrace' (ProdCons (getTrace rs) t') $ checkCompatibility env $ ProdCons (getTraced rs) cons'

691+ Just (rs NE.:| []) -> checkCompatibility env $ ProdCons rs cons'

668 Just rs -> do

692 Just rs -> do

669− let sch = Inline mempty { _schemaAllOf = Just . NE.toList $ getTraced <$> rs }

693+ let sch = Inline mempty { _schemaAllOf = Just . NE.toList $ extract <$> rs }

670− localTrace' (pure t' {- TODO: what? -}) $ checkCompatibility env $ ProdCons sch cons'

694+ checkCompatibility env $ ProdCons (traced (ask $ NE.head rs) sch) cons' -- TODO: bad trace

671− Nothing -> issueAtTrace t NoMatchingItems

695+ Nothing -> issueAt cons NoMatchingItems

672 MaxItems m -> case findRelevant min (\case MaxItems m' -> Just m'; _ -> Nothing) prods of

696 MaxItems m -> case findRelevant min (\case MaxItems m' -> Just m'; _ -> Nothing) prods of

673 Just m' -> if m' <= m then pure ()

697 Just m' -> if m' <= m then pure ()

674− else issueAtTrace t (MatchingMaxItemsWeak m m')

698+ else issueAt cons (MatchingMaxItemsWeak m m')

675− Nothing -> issueAtTrace t (NoMatchingMaxItems m)

699+ Nothing -> issueAt cons (NoMatchingMaxItems m)

676 MinItems m -> case findRelevant max (\case MinItems m' -> Just m'; _ -> Nothing) prods of

700 MinItems m -> case findRelevant max (\case MinItems m' -> Just m'; _ -> Nothing) prods of

677 Just m' -> if m' >= m then pure ()

701 Just m' -> if m' >= m then pure ()

678− else issueAtTrace t (MatchingMinItemsWeak m m')

702+ else issueAt cons (MatchingMinItemsWeak m m')

679− Nothing -> issueAtTrace t (NoMatchingMinItems m)

703+ Nothing -> issueAt cons (NoMatchingMinItems m)

680− UniqueItems -> if any ((== UniqueItems) . getTraced) prods then pure ()

704+ UniqueItems -> if any (== UniqueItems) $ extract <$> prods then pure ()

681− else issueAtTrace t NoMatchingUniqueItems

705+ else issueAt cons NoMatchingUniqueItems

682 Properties props _ madd -> case findRelevant (<>) (\case Properties props' _ madd' -> Just $ (props', madd') NE.:| []; _ -> Nothing) prods of

706 Properties props _ madd -> case findRelevant (<>) (\case Properties props' _ madd' -> Just $ (props', madd') NE.:| []; _ -> Nothing) prods of

683 Just ((props', madd') NE.:| []) -> do

707 Just ((props', madd') NE.:| []) -> do

684 F.for_ (S.fromList $ M.keys props <> M.keys props') $ \k -> do

708 F.for_ (S.fromList $ M.keys props <> M.keys props') $ \k -> do

685− let

686− go sch' sch = let schs = ProdCons sch' sch

709+ let go sch sch' = checkCompatibility env (ProdCons sch sch')

687− in localTrace' (getTrace <$> schs) $ checkCompatibility env $ getTraced <$> schs

688 case (M.lookup k props', madd', M.lookup k props, madd) of

710 case (M.lookup k props', madd', M.lookup k props, madd) of

689 (Nothing, Nothing, _, _) -> pure () -- vacuously

711 (Nothing, Nothing, _, _) -> pure () -- vacuously

690− (_, _, Nothing, Nothing) -> issueAtTrace t (UnexpectedProperty k)

712+ (_, _, Nothing, Nothing) -> issueAt cons (UnexpectedProperty k)

691 (Just p', _, Just p, _) -> go (propRefSchema p') (propRefSchema p)

713 (Just p', _, Just p, _) -> go (propRefSchema p') (propRefSchema p)

692 (Nothing, Just add', Just p, _) -> go add' (propRefSchema p)

714 (Nothing, Just add', Just p, _) -> go add' (propRefSchema p)

693 (Just p', _, Nothing, Just add) -> go (propRefSchema p') add

715 (Just p', _, Nothing, Just add) -> go (propRefSchema p') add

694 (Nothing, Just _, Nothing, Just _) -> pure ()

716 (Nothing, Just _, Nothing, Just _) -> pure ()

695 case (maybe False propRequired $ M.lookup k props', maybe False propRequired $ M.lookup k props) of

717 case (maybe False propRequired $ M.lookup k props', maybe False propRequired $ M.lookup k props) of

696− (False, True) -> issueAtTrace t (PropertyNowRequired k)

718+ (False, True) -> issueAt cons (PropertyNowRequired k)

697 _ -> pure ()

719 _ -> pure ()

698 pure ()

720 pure ()

699 case (madd', madd) of

721 case (madd', madd) of

700 (Nothing, _) -> pure () -- vacuously

722 (Nothing, _) -> pure () -- vacuously

701− (_, Nothing) -> issueAtTrace t NoAdditionalProperties

723+ (_, Nothing) -> issueAt cons NoAdditionalProperties

702− (Just add', Just add) -> let schs = ProdCons add' add

724+ (Just add', Just add) -> checkCompatibility env (ProdCons add' add)

703− in localTrace' (getTrace <$> schs) $ checkCompatibility env $ getTraced <$> schs

704 pure ()

725 pure ()

705− Nothing -> issueAtTrace t NoMatchingProperties

726+ Nothing -> issueAt cons NoMatchingProperties

706 MaxProperties m -> case findRelevant min (\case MaxProperties m' -> Just m'; _ -> Nothing) prods of

727 MaxProperties m -> case findRelevant min (\case MaxProperties m' -> Just m'; _ -> Nothing) prods of

707 Just m' -> if m' <= m then pure ()

728 Just m' -> if m' <= m then pure ()

708− else issueAtTrace t (MatchingMaxPropertiesWeak m m')

729+ else issueAt cons (MatchingMaxPropertiesWeak m m')

709− Nothing -> issueAtTrace t (NoMatchingMaxProperties m)

730+ Nothing -> issueAt cons (NoMatchingMaxProperties m)

710 MinProperties m -> case findRelevant max (\case MinProperties m' -> Just m'; _ -> Nothing) prods of

731 MinProperties m -> case findRelevant max (\case MinProperties m' -> Just m'; _ -> Nothing) prods of

711 Just m' -> if m' >= m then pure ()

732 Just m' -> if m' >= m then pure ()

712− else issueAtTrace t (MatchingMinPropertiesWeak m m')

733+ else issueAt cons (MatchingMinPropertiesWeak m m')

713− Nothing -> issueAtTrace t (NoMatchingMinProperties m)

734+ Nothing -> issueAt cons (NoMatchingMinProperties m)

714 where

735 where

715− findExactly (Traced _ (Exactly x):_) = Just x

736+ findExactly ((extract -> Exactly x):_) = Just x

716 findExactly (_:xs) = findExactly xs

737 findExactly (_:xs) = findExactly xs

717 findExactly [] = Nothing

738 findExactly [] = Nothing

718− findRelevant combine extract

739+ findRelevant combine extr

719− = fmap (foldr1 combine) . NE.nonEmpty . mapMaybe (extract . getTraced)

740+ = fmap (foldr1 combine) . NE.nonEmpty . mapMaybe (extr . extract)

720 lcmScientific (toRational -> a) (toRational -> b)

741 lcmScientific (toRational -> a) (toRational -> b)

721 = fromRational $ lcm (numerator a) (numerator b) % gcd (denominator a) (denominator b)

742 = fromRational $ lcm (numerator a) (numerator b) % gcd (denominator a) (denominator b)

722

743

@@ -753,9 +774,7 @@ instance Typeable t => Subtree (Condition t) where

753 deriving stock (Eq, Ord, Show)

774 deriving stock (Eq, Ord, Show)

754 type CheckEnv (Condition t) = CheckEnv Schema

775 type CheckEnv (Condition t) = CheckEnv Schema

755 normalizeTrace = undefined

776 normalizeTrace = undefined

756− checkCompatibility env conds = withTrace $ \traces -> do

777+ checkCompatibility env pc = checkImplication env [producer pc] (consumer pc)

757− case Traced <$> traces <*> conds of

758− ProdCons prod cons -> checkImplication env [prod] cons

759

778

760instance Subtree Schema where

779instance Subtree Schema where

761 data CheckIssue Schema

780 data CheckIssue Schema

@@ -765,18 +784,16 @@ instance Subtree Schema where

765 | NoContradiction

784 | NoContradiction

766 deriving stock (Eq, Ord, Show)

785 deriving stock (Eq, Ord, Show)

767 type CheckEnv Schema = '[ProdCons (Definitions Schema)]

786 type CheckEnv Schema = '[ProdCons (Definitions Schema)]

768− checkCompatibility env schs = withTrace $ \traces -> do

787+ checkCompatibility env schs = do

769 let defs = getH env

788 let defs = getH env

770− checkFormulas env (producer traces) $ schemaToFormula <$> defs <*> (Traced <$> traces <*> schs)

789+ checkFormulas env (ask $ producer schs) $ schemaToFormula <$> defs <*> schs

771

790

772instance Subtree (Referenced Schema) where

791instance Subtree (Referenced Schema) where

773 data CheckIssue (Referenced Schema)

792 data CheckIssue (Referenced Schema)

774 deriving stock (Eq, Ord, Show)

793 deriving stock (Eq, Ord, Show)

775 type CheckEnv (Referenced Schema) = CheckEnv Schema

794 type CheckEnv (Referenced Schema) = CheckEnv Schema

776− checkCompatibility env refs = withTrace $ \traces -> do

795+ checkCompatibility env refs = do

777 let

796 let

778 defs = getH env

797 defs = getH env

779 schs = dereference <$> defs <*> refs

798 schs = dereference <$> defs <*> refs

780− schs' = retrace <$> traces <*> schs

781− localTrace (getTrace <$> schs) $ do

782− checkFormulas env (producer $ getTrace <$> schs') $ schemaToFormula <$> defs <*> schs'

799+ checkFormulas env (ask $ producer schs) $ schemaToFormula <$> defs <*> schs

src/OpenAPI/Checker/Validate/SecurityRequirement.hs+3−3

@@ -1,9 +1,8 @@

1{-# OPTIONS_GHC -Wno-orphans #-}

3module OpenAPI.Checker.Validate.SecurityRequirement

4− (

4+ ( CheckIssue (..)

5− )

6−where

5+ ) where

8import Data.OpenApi

7import Data.OpenApi

9import OpenAPI.Checker.Subtree

8import OpenAPI.Checker.Subtree

@@ -14,5 +13,6 @@ instance Subtree SecurityRequirement where

14 '[ ProdCons (Definitions SecurityScheme)

13 '[ ProdCons (Definitions SecurityScheme)

15 ]

14 ]

16 data CheckIssue SecurityRequirement

15 data CheckIssue SecurityRequirement

16+ = SecurityRequirementNotMet

17 deriving (Eq, Ord, Show)

18 checkCompatibility = undefined

src/OpenAPI/Checker/Validate/Server.hs+3−3

@@ -1,9 +1,8 @@

1{-# OPTIONS_GHC -Wno-orphans #-}

3module OpenAPI.Checker.Validate.Server

4− (

4+ ( CheckIssue(..)

5− )

6−where

5+ ) where

8import Data.OpenApi

7import Data.OpenApi

9import OpenAPI.Checker.Subtree

8import OpenAPI.Checker.Subtree

@@ -11,5 +10,6 @@ import OpenAPI.Checker.Subtree

11instance Subtree Server where

10instance Subtree Server where

12 type CheckEnv Server = '[]

11 type CheckEnv Server = '[]

13 data CheckIssue Server

12 data CheckIssue Server

13+ = ServerNotConsumed

14 deriving (Eq, Ord, Show)

15 checkCompatibility = undefined

src/OpenAPI/Checker/Validate/Sums.hs+9−11

@@ -10,19 +10,17 @@ import OpenAPI.Checker.Trace

12checkSums

13− :: forall k root t

13+ :: forall k r t

14− . (Ord k, Subtree root)

14+ . (Ord k, Subtree t)

15− => (k -> CheckIssue root)

15+ => (k -> CheckIssue t)

16− -> (k -> ProdCons t -> CompatFormula t ())

16+ -> (k -> ProdCons (Traced r t) -> CompatFormula' SubtreeCheckIssue r ())

17− -> ProdCons (Map k (Traced root t))

17+ -> ProdCons (Map k (Traced r t))

18− -> CompatFormula root ()

18+ -> CompatFormula' SubtreeCheckIssue r ()

19checkSums noElt check (ProdCons p c) = for_ (M.toList p) $ \(key, prodElt) ->

20 case M.lookup key c of

21− Nothing -> issueAt consumer $ noElt key

21+ Nothing -> issueAt prodElt $ noElt key

22 Just consElt ->

23 let

24− sumElts :: ProdCons (Traced root t)

24+ sumElts :: ProdCons (Traced r t)

25 sumElts = ProdCons prodElt consElt

26− trace = getTrace <$> sumElts

27− elements = getTraced <$> sumElts

28− in localTrace trace $ check key elements

26+ in check key sumElts

test/Spec/Golden/TraceTree.hs+2−1

@@ -7,6 +7,7 @@ import Control.Category

7import Data.HList

8import qualified Data.Yaml as Yaml

9import OpenAPI.Checker.Subtree

10+import OpenAPI.Checker.Trace

10import OpenAPI.Checker.Validate.OpenApi ()

11import OpenAPI.Checker.Validate.OpenApi ()

11import Spec.Golden.Extra

12import Spec.Golden.Extra

12import Test.Tasty (TestTree)

13import Test.Tasty (TestTree)

@@ -20,4 +21,4 @@ tests =

20 "trace-tree.yaml"

21 "trace-tree.yaml"

21 ("a.yaml", "b.yaml")

22 ("a.yaml", "b.yaml")

22 Yaml.decodeFileThrow

23 Yaml.decodeFileThrow

23− (runCompatFormula (pure id) . checkCompatibility HNil . uncurry ProdCons)

24+ (runCompatFormula . checkCompatibility HNil . fmap (traced Root) . uncurry ProdCons)

test/golden/common/maximum-lowered/trace-tree.yaml+1−1

@@ -1,7 +1,7 @@

1Left:

2 OpenApiPathsStep:

3 MatchedPathStep "/test":

4− PostStep:

4+ OperationMethodStep PostMethod:

5 OperationRequestBodyStep:

6 InlineStep:

7 RequestMediaTypeObject application/json:

test/golden/common/pathItem/operation/parameters/allowEmptyValue/reset/trace-tree.yaml+2−2

@@ -1,6 +1,6 @@

1Left:

2 OpenApiPathsStep:

3 MatchedPathStep "/test":

4− PostStep:

4+ OperationMethodStep PostMethod:

5− OperationParamsStep:

5+ OperationParamsStep 0:

6 InlineStep: ParamEmptinessIncompatible

test/golden/common/pathItem/operation/parameters/change/trace-tree.yaml+2−2

@@ -1,8 +1,8 @@

1Left:

2 OpenApiPathsStep:

3 MatchedPathStep "/test":

4− PostStep:

4+ OperationMethodStep PostMethod:

5− OperationParamsStep:

5+ OperationParamsStep 0:

6 InlineStep:

7 ParamSchema:

8 InlineStep: NoContradiction

test/golden/common/pathItem/operation/parameters/required/set/trace-tree.yaml+2−2

@@ -1,6 +1,6 @@

1Left:

2 OpenApiPathsStep:

3 MatchedPathStep "/test":

4− PostStep:

4+ OperationMethodStep PostMethod:

5− OperationParamsStep:

5+ OperationParamsStep 0:

6 InlineStep: ParamRequired

test/golden/common/pathItem/operation/parameters/required/true/add/trace-tree.yaml+3−1

@@ -1,4 +1,6 @@

1Left:

2 OpenApiPathsStep:

3 MatchedPathStep "/test":

4+ OperationMethodStep PostMethod:

5+ OperationParamsStep 1:

4− PostStep: ParamNotMatched ParamQuery "test2"

6+ InlineStep: ParamNotMatched "test2"

test/golden/common/pathItem/operation/requestBody/mediaTypeObject/change/trace-tree.yaml+1−1

@@ -1,7 +1,7 @@

1Left:

2 OpenApiPathsStep:

3 MatchedPathStep "/test":

4− PostStep:

4+ OperationMethodStep PostMethod:

5 OperationRequestBodyStep:

6 InlineStep:

7 RequestMediaTypeObject application/json:

test/golden/common/pathItem/operation/requestBody/mediaTypeObject/del/trace-tree.yaml+3−2

@@ -1,6 +1,7 @@

1Left:

2 OpenApiPathsStep:

3 MatchedPathStep "/test":

4− PostStep:

4+ OperationMethodStep PostMethod:

5 OperationRequestBodyStep:

6+ InlineStep:

6− InlineStep: RequestMediaTypeNotFound application/x-www-form-urlencoded

7+ RequestMediaTypeObject application/x-www-form-urlencoded: RequestMediaTypeNotFound

test/golden/common/pathItem/operation/requestBody/required/set/trace-tree.yaml+1−1

@@ -1,6 +1,6 @@

1Left:

2 OpenApiPathsStep:

3 MatchedPathStep "/test":

4− PostStep:

4+ OperationMethodStep PostMethod:

5 OperationRequestBodyStep:

6 InlineStep: RequestBodyRequired

test/golden/common/pathItem/operation/responses/add/trace-tree.yaml+4−2

@@ -1,5 +1,7 @@

1Left:

2 OpenApiPathsStep:

3 MatchedPathStep "/test":

4− PostStep:

4+ OperationMethodStep PostMethod:

5− OperationResponsesStep: ResponseCodeNotFound 500

5+ OperationResponsesStep:

6+ ResponseCodeStep 500:

7+ InlineStep: ResponseCodeNotFound

test/golden/common/pathItem/operation/responses/change/headers/mandatory/del/trace-tree.yaml+4−2

@@ -1,7 +1,9 @@

1Left:

2 OpenApiPathsStep:

3 MatchedPathStep "/test":

4− PostStep:

4+ OperationMethodStep PostMethod:

5 OperationResponsesStep:

6 ResponseCodeStep 200:

7− InlineStep: ResponseHeaderMissing "Test2"

7+ InlineStep:

8+ ResponseHeader "Test2":

9+ InlineStep: ResponseHeaderMissing

test/golden/common/pathItem/operation/responses/change/mediaTypeObject/add/trace-tree.yaml+3−2

@@ -1,7 +1,8 @@

1Left:

2 OpenApiPathsStep:

3 MatchedPathStep "/test":

4− PostStep:

4+ OperationMethodStep PostMethod:

5 OperationResponsesStep:

6 ResponseCodeStep 200:

7+ InlineStep:

7− InlineStep: ResponseMediaTypeMissing application/x-www-form-urlencoded

8+ ResponseMediaObject application/x-www-form-urlencoded: ResponseMediaTypeMissing

test/golden/common/pathItem/operation/responses/change/mediaTypeObject/change/trace-tree.yaml+1−1

@@ -1,7 +1,7 @@

1Left:

2 OpenApiPathsStep:

3 MatchedPathStep "/test":

4− PostStep:

4+ OperationMethodStep PostMethod:

5 OperationResponsesStep:

6 ResponseCodeStep 200:

7 InlineStep:

test/golden/common/property-removed/trace-tree.yaml+1−1

@@ -1,7 +1,7 @@

1Left:

2 OpenApiPathsStep:

3 MatchedPathStep "/test":

4− PostStep:

4+ OperationMethodStep PostMethod:

5 OperationResponsesStep:

6 ResponseCodeStep 200:

7 InlineStep:

test/golden/common/property-required/trace-tree.yaml+1−1

@@ -1,7 +1,7 @@

1Left:

2 OpenApiPathsStep:

3 MatchedPathStep "/test":

4− PostStep:

4+ OperationMethodStep PostMethod:

5 OperationRequestBodyStep:

6 InlineStep:

7 RequestMediaTypeObject application/json: