4f254f4 · compaREST · git.iko.soy

git.iko.soy/compaREST

on master help sign in

Initial memoization (#56)

4f254f4iko5 years ago

src/OpenAPI/Checker/Paths.hs+1−1

compare with master

unifiedsplit

@@ -24,7 +24,7 @@ import Data.Type.Equality

24import Type.Reflection

25import Prelude hiding ((.))

27−type NiceQuiver q a b = (Typeable q, Typeable a, Typeable b, Ord (q a b), Show (q a b))

27+type NiceQuiver (q :: k -> j -> Type) (a :: k) (b :: j) = (Typeable q, Typeable a, Typeable b, Ord (q a b), Show (q a b))

29-- | All the possible ways to navigate between nodes in a heterogeneous tree

30-- form a quiver. The hom-sets of the free category constructed from this quiver

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

@@ -10,7 +10,6 @@ import Data.HList

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

11import Data.Maybe

12import Data.OpenApi

13−import qualified Data.OpenApi.Schema.Generator as G

14import Data.Typeable

13import Data.Typeable

15import OpenAPI.Checker.Orphans ()

14import OpenAPI.Checker.Orphans ()

16import OpenAPI.Checker.Subtree

15import OpenAPI.Checker.Subtree

@@ -19,10 +18,6 @@ instance Typeable a => Steppable (Referenced a) a where

19 data Step (Referenced a) a = InlineStep

18 data Step (Referenced a) a = InlineStep

20 deriving stock (Eq, Ord, Show)

19 deriving stock (Eq, Ord, Show)

22−instance Typeable a => Steppable (Definitions a) a where

23− data Step (Definitions a) a = ReferencedStep Reference

24− deriving stock (Eq, Ord, Show)

25−

26dereference

21dereference

27 :: Typeable a

22 :: Typeable a

28 => Traced (Definitions a)

23 => Traced (Definitions a)

@@ -31,8 +26,8 @@ dereference

31dereference defs x = case extract x of

26dereference defs x = case extract x of

32 Inline a ->

27 Inline a ->

33 traced (ask x >>> step InlineStep) a

28 traced (ask x >>> step InlineStep) a

34− Ref r@(Reference ref) ->

29+ Ref (Reference ref) ->

35− traced (ask defs >>> step (ReferencedStep r)) (fromJust $ IOHM.lookup ref $ extract defs)

30+ traced (ask defs >>> step (InsOrdHashMapKeyStep ref)) (fromJust $ IOHM.lookup ref $ extract defs)

37instance Subtree a => Subtree (Referenced a) where

32instance Subtree a => Subtree (Referenced a) where

38 type CheckEnv (Referenced a) = ProdCons (Traced (Definitions a)) ': CheckEnv a

33 type CheckEnv (Referenced a) = ProdCons (Traced (Definitions a)) ': CheckEnv a

@@ -41,9 +36,9 @@ instance Subtree a => Subtree (Referenced a) where

41 checkStructuralCompatibility env pc' = do

36 checkStructuralCompatibility env pc' = do

42 let pc = do

37 let pc = do

43 x <- pc'

38 x <- pc'

44− defs <- extract <$> getH @(ProdCons (Traced (Definitions a))) env

39+ defs <- getH @(ProdCons (Traced (Definitions a))) env

45− pure (G.dereference defs x)

40+ pure (dereference defs x)

46− checkStructuralCompatibility env pc

41+ checkSubstructure env pc

48 checkSemanticCompatibility env bhv pc' = do

43 checkSemanticCompatibility env bhv pc' = do

49 let pc = do

44 let pc = do

src/OpenAPI/Checker/Subtree.hs+54−25

@@ -2,13 +2,17 @@

3module OpenAPI.Checker.Subtree

4 ( Steppable (..)

5+ , Step (..)

5 , Trace

6 , Trace

6 , Traced

7 , Traced

7 , Traced'

8 , Traced'

8 , pattern Traced

9 , pattern Traced

9 , traced

10 , traced

11+ , retraced

12+ , stepTraced

10 , Subtree (..)

13 , Subtree (..)

11 , checkCompatibility

14 , checkCompatibility

15+ , checkSubstructure

12 , CompatM (..)

16 , CompatM (..)

13 , CompatFormula'

17 , CompatFormula'

14 , SemanticCompatFormula

18 , SemanticCompatFormula

@@ -19,7 +23,6 @@ module OpenAPI.Checker.Subtree

19 , issueAt

23 , issueAt

20 , anyOfAt

24 , anyOfAt

21 , structuralIssue

25 , structuralIssue

22− , memo

24 -- * Structural helpers

27 -- * Structural helpers

25 , structuralMaybe

28 , structuralMaybe

@@ -59,7 +62,7 @@ import OpenAPI.Checker.Paths

59import qualified OpenAPI.Checker.PathsPrefixTree as P

62import qualified OpenAPI.Checker.PathsPrefixTree as P

61class

64class

62− (Typeable a, Typeable b, Ord (Step a b), Show (Step a b)) =>

65+ NiceQuiver Step a b =>

63 Steppable (a :: Type) (b :: Type)

66 Steppable (a :: Type) (b :: Type)

64 where

67 where

65 -- | How to get from an @a@ node to a @b@ node

68 -- | How to get from an @a@ node to a @b@ node

@@ -79,6 +82,12 @@ pattern Traced t x = EnvT t (Identity x)

79traced :: Trace a -> a -> Traced a

82traced :: Trace a -> a -> Traced a

80traced = env

83traced = env

85+retraced :: (Trace a -> Trace a') -> Traced' a b -> Traced' a' b

86+retraced f (Traced a b) = Traced (f a) b

87+

88+stepTraced :: Steppable a a' => Step a a' -> Traced' a b -> Traced' a' b

89+stepTraced s = retraced (>>> step s)

90+

82data ProdCons a = ProdCons

91data ProdCons a = ProdCons

83 { producer :: a

92 { producer :: a

84 , consumer :: a

93 , consumer :: a

@@ -125,7 +134,7 @@ class (Typeable t, Issuable (SubtreeLevel t)) => Subtree (t :: Type) where

125 checkStructuralCompatibility

134 checkStructuralCompatibility

126 :: (HasAll (CheckEnv t) xs)

135 :: (HasAll (CheckEnv t) xs)

127 => HList xs

136 => HList xs

128− -> ProdCons t

137+ -> ProdCons (Traced t)

129 -> StructuralCompatFormula ()

138 -> StructuralCompatFormula ()

130

139

131 checkSemanticCompatibility

140 checkSemanticCompatibility

@@ -135,23 +144,34 @@ class (Typeable t, Issuable (SubtreeLevel t)) => Subtree (t :: Type) where

135 -> ProdCons (Traced t)

144 -> ProdCons (Traced t)

136 -> SemanticCompatFormula ()

145 -> SemanticCompatFormula ()

137

146

147+{-# WARNING checkStructuralCompatibility "You should not be calling this directly. Use 'checkSubstructure'" #-}

148+

149+{-# WARNING checkSemanticCompatibility "You should not be calling this directly. Use 'checkCompatibility'" #-}

150+

138checkCompatibility

151checkCompatibility

139 :: (HasAll (CheckEnv t) xs, Subtree t)

152 :: (HasAll (CheckEnv t) xs, Subtree t)

140 => HList xs

153 => HList xs

141 -> Behavior (SubtreeLevel t)

154 -> Behavior (SubtreeLevel t)

142 -> ProdCons (Traced t)

155 -> ProdCons (Traced t)

143 -> SemanticCompatFormula ()

156 -> SemanticCompatFormula ()

144−checkCompatibility e bhv pc =

157+checkCompatibility e bhv = memo SemanticMemoKey $ \pc ->

145− case runCompatFormula $ checkStructuralCompatibility e $ fmap extract pc of

158+ case runCompatFormula $ checkSubstructure e pc of

146 Left _ -> checkSemanticCompatibility e bhv pc

159 Left _ -> checkSemanticCompatibility e bhv pc

147 Right () -> pure ()

160 Right () -> pure ()

148

161

162+checkSubstructure

163+ :: (HasAll (CheckEnv t) xs, Subtree t)

164+ => HList xs

165+ -> ProdCons (Traced t)

166+ -> StructuralCompatFormula ()

167+checkSubstructure e = memo SemanticMemoKey $ checkStructuralCompatibility e

168+

149structuralMaybe

169structuralMaybe

150 :: (Subtree a, HasAll (CheckEnv a) xs)

170 :: (Subtree a, HasAll (CheckEnv a) xs)

151 => HList xs

171 => HList xs

152− -> ProdCons (Maybe a)

172+ -> ProdCons (Maybe (Traced a))

153 -> StructuralCompatFormula ()

173 -> StructuralCompatFormula ()

154−structuralMaybe e = structuralMaybeWith (checkStructuralCompatibility e)

174+structuralMaybe e = structuralMaybeWith (checkSubstructure e)

155

175

156structuralMaybeWith

176structuralMaybeWith

157 :: (ProdCons a -> StructuralCompatFormula ())

177 :: (ProdCons a -> StructuralCompatFormula ())

@@ -163,38 +183,44 @@ structuralMaybeWith _ _ = structuralIssue

163

183

164structuralList

184structuralList

165 :: (Subtree a, HasAll (CheckEnv a) xs)

185 :: (Subtree a, HasAll (CheckEnv a) xs)

186+ => HList xs

187+ -> ProdCons [Traced a]

166− => HList xs -> ProdCons [a] -> StructuralCompatFormula ()

188+ -> StructuralCompatFormula ()

167structuralList _ (ProdCons [] []) = pure ()

189structuralList _ (ProdCons [] []) = pure ()

168−structuralList e (ProdCons (a:aa) (b:bb)) = do

190+structuralList e (ProdCons (a : aa) (b : bb)) = do

169− checkStructuralCompatibility e $ ProdCons a b

191+ checkSubstructure e $ ProdCons a b

170 structuralList e $ ProdCons aa bb

192 structuralList e $ ProdCons aa bb

171 pure ()

193 pure ()

172structuralList _ _ = structuralIssue

194structuralList _ _ = structuralIssue

173

195

174−structuralEq :: Eq a => ProdCons a -> StructuralCompatFormula ()

196+structuralEq :: (Eq a, Comonad w) => ProdCons (w a) -> StructuralCompatFormula ()

175−structuralEq (ProdCons a b) = if a == b then pure () else structuralIssue

197+structuralEq (ProdCons a b) = if extract a == extract b then pure () else structuralIssue

176

198

177iohmStructural

199iohmStructural

178− :: (HasAll (CheckEnv v) (k ': xs), Ord k, Subtree v, Hashable k)

200+ :: (HasAll (CheckEnv v) (k ': xs), Ord k, Subtree v, Hashable k, Typeable k, Show k)

179 => HList xs

201 => HList xs

180− -> ProdCons (IOHM.InsOrdHashMap k v)

202+ -> ProdCons (Traced (IOHM.InsOrdHashMap k v))

181 -> StructuralCompatFormula ()

203 -> StructuralCompatFormula ()

182iohmStructural e =

204iohmStructural e =

183− iohmStructuralWith (\k -> checkStructuralCompatibility (k `HCons` e))

205+ iohmStructuralWith (\k -> checkSubstructure (k `HCons` e))

206+

207+instance (Typeable k, Typeable v, Ord k, Show k) => Steppable (IOHM.InsOrdHashMap k v) v where

208+ data Step (IOHM.InsOrdHashMap k v) v = InsOrdHashMapKeyStep k

209+ deriving (Eq, Ord, Show)

184

210

185iohmStructuralWith

211iohmStructuralWith

186− :: (Ord k, Hashable k)

212+ :: (Ord k, Hashable k, Typeable k, Typeable v, Show k)

187− => (k -> ProdCons v -> StructuralCompatFormula ())

213+ => (k -> ProdCons (Traced v) -> StructuralCompatFormula ())

188− -> ProdCons (IOHM.InsOrdHashMap k v)

214+ -> ProdCons (Traced (IOHM.InsOrdHashMap k v))

189 -> StructuralCompatFormula ()

215 -> StructuralCompatFormula ()

190iohmStructuralWith f pc = do

216iohmStructuralWith f pc = do

191− let ProdCons pEKeys cEKeys = S.fromList . IOHM.keys <$> pc

217+ let ProdCons pEKeys cEKeys = S.fromList . IOHM.keys . extract <$> pc

192 if pEKeys == cEKeys

218 if pEKeys == cEKeys

193 then

219 then

194 for_

220 for_

195 pEKeys

221 pEKeys

196 (\eKey ->

222 (\eKey ->

197− f eKey $ IOHM.lookupDefault (error "impossible") eKey <$> pc)

223+ f eKey $ stepTraced (InsOrdHashMapKeyStep eKey) . fmap (IOHM.lookupDefault (error "impossible") eKey) <$> pc)

198 else structuralIssue

224 else structuralIssue

199

225

200class HasUnsupportedFeature x where

226class HasUnsupportedFeature x where

@@ -256,8 +282,11 @@ fixpointKnot =

256 }

282 }

257

283

258memo

284memo

259− :: (Typeable q, Typeable f, NiceQuiver p r t)

285+ :: (Typeable (r :: k), Typeable q, Typeable f, Typeable k, Typeable a)

286+ => MemoKey

260− => (ProdCons (Env (Paths p r t) t) -> CompatFormula' q f r ())

287+ -> (ProdCons (Traced a) -> CompatFormula' q f r ())

261− -> (ProdCons (Env (Paths p r t) t) -> CompatFormula' q f r ())

288+ -> (ProdCons (Traced a) -> CompatFormula' q f r ())

262−memo f pc = Compose $ do

263− memoWithKnot fixpointKnot (getCompose $ f pc) (ask <$> pc)

289+memo k f pc = Compose $ memoWithKnot fixpointKnot (getCompose $ f pc) (k, ask <$> pc)

290+

291+data MemoKey = SemanticMemoKey | StructuralMemoKey

292+ deriving stock (Eq, Ord)

src/OpenAPI/Checker/Validate/Header.hs+4−4

@@ -18,10 +18,10 @@ instance Subtree Header where

18 type SubtreeLevel Header = 'HeaderLevel

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

20 checkStructuralCompatibility env pc = do

21− structuralEq $ _headerRequired <$> pc

21+ structuralEq $ fmap _headerRequired <$> pc

22− structuralEq $ _headerAllowEmptyValue <$> pc

22+ structuralEq $ fmap _headerAllowEmptyValue <$> pc

23− structuralEq $ _headerExplode <$> pc

23+ structuralEq $ fmap _headerExplode <$> pc

24− structuralMaybe env $ _headerSchema <$> pc

24+ structuralMaybe env $ tracedSchema <$> pc

25 pure ()

26 checkSemanticCompatibility env beh (ProdCons p c) = do

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

src/OpenAPI/Checker/Validate/MediaTypeObject.hs+17−8

@@ -23,6 +23,7 @@ import OpenAPI.Checker.Validate.Header ()

23tracedSchema :: Traced MediaTypeObject -> Maybe (Traced (Referenced Schema))

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

26+-- FIXME: This should be done through 'MediaTypeEncodingMapping'

26tracedEncoding :: Traced MediaTypeObject -> InsOrdHashMap Text (Traced Encoding)

27tracedEncoding :: Traced MediaTypeObject -> InsOrdHashMap Text (Traced Encoding)

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

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

28 $ _mediaTypeObjectEncoding $ extract mto

29 $ _mediaTypeObjectEncoding $ extract mto

@@ -52,9 +53,9 @@ instance Subtree MediaTypeObject where

52 , ProdCons (Traced (Definitions Header))

53 , ProdCons (Traced (Definitions Header))

53 ]

54 ]

54 checkStructuralCompatibility env pc = do

55 checkStructuralCompatibility env pc = do

55− structuralMaybe env $ _mediaTypeObjectSchema <$> pc

56+ structuralMaybe env $ tracedSchema <$> pc

56− structuralEq $ _mediaTypeObjectExample <$> pc

57+ structuralEq $ fmap _mediaTypeObjectExample <$> pc

57− iohmStructural env $ _mediaTypeObjectEncoding <$> pc

58+ iohmStructural env $ stepTraced MediaTypeEncodingMapping . fmap _mediaTypeObjectEncoding <$> pc

58 pure ()

59 pure ()

59 checkSemanticCompatibility env beh prodCons@(ProdCons p c) = do

60 checkSemanticCompatibility env beh prodCons@(ProdCons p c) = do

60 if | "multipart" == mainType mediaType -> checkEncoding

61 if | "multipart" == mainType mediaType -> checkEncoding

@@ -92,11 +93,11 @@ instance Subtree Encoding where

92 , ProdCons (Traced (Definitions Schema))

93 , ProdCons (Traced (Definitions Schema))

93 ]

94 ]

94 checkStructuralCompatibility env pc = do

95 checkStructuralCompatibility env pc = do

95− structuralEq $ _encodingContentType <$> pc

96+ structuralEq $ fmap _encodingContentType <$> pc

96− iohmStructural env $ _encodingHeaders <$> pc

97+ iohmStructural env $ stepTraced EncodingHeaderStep . fmap _encodingHeaders <$> pc

97− structuralEq $ _encodingStyle <$> pc

98+ structuralEq $ fmap _encodingStyle <$> pc

98− structuralEq $ _encodingExplode <$> pc

99+ structuralEq $ fmap _encodingExplode <$> pc

99− structuralEq $ _encodingAllowReserved <$> pc

100+ structuralEq $ fmap _encodingAllowReserved <$> pc

100 pure ()

101 pure ()

101

102

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

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

@@ -109,10 +110,18 @@ instance Steppable MediaTypeObject (Referenced Schema) where

109 data Step MediaTypeObject (Referenced Schema) = MediaTypeSchema

110 data Step MediaTypeObject (Referenced Schema) = MediaTypeSchema

110 deriving (Eq, Ord, Show)

111 deriving (Eq, Ord, Show)

111

112

113+instance Steppable MediaTypeObject (Definitions Encoding) where

114+ data Step MediaTypeObject (Definitions Encoding) = MediaTypeEncodingMapping

115+ deriving (Eq, Ord, Show)

116+

112instance Steppable MediaTypeObject Encoding where

117instance Steppable MediaTypeObject Encoding where

113 data Step MediaTypeObject Encoding = MediaTypeParamEncoding Text

118 data Step MediaTypeObject Encoding = MediaTypeParamEncoding Text

114 deriving (Eq, Ord, Show)

119 deriving (Eq, Ord, Show)

115

120

121+instance Steppable Encoding (Definitions (Referenced Header)) where

122+ data Step Encoding (Definitions (Referenced Header)) = EncodingHeaderStep

123+ deriving (Eq, Ord, Show)

124+

116instance Behavable 'OperationLevel 'ResponseLevel where

125instance Behavable 'OperationLevel 'ResponseLevel where

117 data Behave 'OperationLevel 'ResponseLevel

126 data Behave 'OperationLevel 'ResponseLevel

118 = WithStatusCode HttpStatusCode

127 = WithStatusCode HttpStatusCode

src/OpenAPI/Checker/Validate/Operation.hs+14−15

@@ -15,10 +15,8 @@ import qualified Data.List as L

15import Data.Map.Strict as M

16import Data.Maybe

17import Data.OpenApi

18−import qualified Data.OpenApi.Schema.Generator as G

19import Data.Text (Text)

18import Data.Text (Text)

20import OpenAPI.Checker.Behavior

19import OpenAPI.Checker.Behavior

21−import OpenAPI.Checker.Common

22import OpenAPI.Checker.References

20import OpenAPI.Checker.References

23import OpenAPI.Checker.Subtree

21import OpenAPI.Checker.Subtree

24import OpenAPI.Checker.Validate.MediaTypeObject

22import OpenAPI.Checker.Validate.MediaTypeObject

@@ -97,26 +95,27 @@ instance Subtree MatchedOperation where

97 , ProdCons (Traced (Definitions Link))

95 , ProdCons (Traced (Definitions Link))

98 ]

96 ]

99 checkStructuralCompatibility env pc = do

97 checkStructuralCompatibility env pc = do

100− let pParams :: ProdCons [Param]

98+ let pParams :: ProdCons [Traced Param]

101 pParams = do

99 pParams = do

102− defs <- extract <$> getH @(ProdCons (Traced (Definitions Param))) env

100+ defs <- getH @(ProdCons (Traced (Definitions Param))) env

103− op' <- _operationParameters . operation <$> pc

101+ op' <- tracedParameters <$> pc

104− pp <- fmap extract . pathParams <$> pc

102+ pp <- pathParams . extract <$> pc

105 pure $

103 pure $

106 let o = M.fromList $ do

104 let o = M.fromList $ do

107− param <- G.dereference defs <$> op'

105+ param <- dereference defs <$> op'

108− let key = paramKey param

106+ let key = paramKey . extract $ param

109 pure (key, param)

107 pure (key, param)

110 p = M.fromList $ do

108 p = M.fromList $ do

111 param <- pp

109 param <- pp

112− pure (paramKey param, param)

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

113 in M.elems $ o <> p

111 in M.elems $ o <> p

114− case zipAll (producer pParams) (consumer pParams) of

112+ structuralList env pParams

115− Nothing -> structuralIssue

113+ structuralMaybe env $ tracedRequestBody <$> pc

116− Just xs -> for_ xs $ \(p, c) -> checkStructuralCompatibility env $ ProdCons p c

114+ checkSubstructure env $ tracedResponses <$> pc

117− structuralMaybe env $ _operationRequestBody . operation <$> pc

115+ checkSubstructure env $ do

118− checkStructuralCompatibility env $ _operationResponses . operation <$> pc

116+ x <- pc

119− checkStructuralCompatibility env $ getServers <$> getH env <*> pc

117+ se <- getH @(ProdCons [Server]) env

118+ pure $ Traced (ask x >>> step OperationServersStep) (getServers se (extract x))

120 -- TODO: Callbacks

119 -- TODO: Callbacks

121 -- TODO: Security

120 -- TODO: Security

122 pure ()

121 pure ()

src/OpenAPI/Checker/Validate/Param.hs+8−8

@@ -72,14 +72,14 @@ instance Subtree Param where

72 type SubtreeLevel Param = 'PathFragmentLevel

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

74 checkStructuralCompatibility env pc = do

75− structuralEq $ _paramName <$> pc

75+ structuralEq $ fmap _paramName <$> pc

76− structuralEq $ _paramRequired <$> pc

76+ structuralEq $ fmap _paramRequired <$> pc

77− structuralEq $ _paramIn <$> pc

77+ structuralEq $ fmap _paramIn <$> pc

78− structuralEq $ _paramAllowEmptyValue <$> pc

78+ structuralEq $ fmap _paramAllowEmptyValue <$> pc

79− structuralEq $ _paramAllowReserved <$> pc

79+ structuralEq $ fmap _paramAllowReserved <$> pc

80− structuralMaybe env $ _paramSchema <$> pc

80+ structuralMaybe env $ tracedSchema <$> pc

81− structuralEq $ _paramStyle <$> pc

81+ structuralEq $ fmap _paramStyle <$> pc

82− structuralEq $ _paramExplode <$> pc

82+ structuralEq $ fmap _paramExplode <$> pc

83 pure ()

84 checkSemanticCompatibility env beh pc@(ProdCons p c) = do

85 when (_paramName (extract p) /= _paramName (extract c))

src/OpenAPI/Checker/Validate/RequestBody.hs+8−2

@@ -16,6 +16,7 @@ import OpenAPI.Checker.Subtree

16import OpenAPI.Checker.Validate.MediaTypeObject

17import OpenAPI.Checker.Validate.Sums

19+-- TODO: Use RequestMediaTypeObjectMapping

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

20tracedContent :: Traced RequestBody -> IOHM.InsOrdHashMap MediaType (Traced MediaTypeObject)

20tracedContent resp =

21tracedContent resp =

21 IOHM.mapWithKey (\k -> traced (ask resp >>> step (RequestMediaTypeObject k))) $

22 IOHM.mapWithKey (\k -> traced (ask resp >>> step (RequestMediaTypeObject k))) $

@@ -41,8 +42,9 @@ instance Subtree RequestBody where

41 , ProdCons (Traced (Definitions Header))

42 , ProdCons (Traced (Definitions Header))

42 ]

43 ]

43 checkStructuralCompatibility env pc = do

44 checkStructuralCompatibility env pc = do

44− structuralEq $ _requestBodyRequired <$> pc

45+ structuralEq $ fmap _requestBodyRequired <$> pc

45− iohmStructural env $ _requestBodyContent <$> pc

46+ iohmStructural env $

47+ stepTraced RequestMediaTypeObjectMapping . fmap _requestBodyContent <$> pc

46 pure ()

48 pure ()

47 checkSemanticCompatibility env beh prodCons@(ProdCons p c) =

49 checkSemanticCompatibility env beh prodCons@(ProdCons p c) =

48 if not (fromMaybe False . _requestBodyRequired . extract $ p)

50 if not (fromMaybe False . _requestBodyRequired . extract $ p)

@@ -58,3 +60,7 @@ instance Subtree RequestBody where

58instance Steppable RequestBody MediaTypeObject where

60instance Steppable RequestBody MediaTypeObject where

59 data Step RequestBody MediaTypeObject = RequestMediaTypeObject MediaType

61 data Step RequestBody MediaTypeObject = RequestMediaTypeObject MediaType

60 deriving (Eq, Ord, Show)

62 deriving (Eq, Ord, Show)

63+

64+instance Steppable RequestBody (IOHM.InsOrdHashMap MediaType MediaTypeObject) where

65+ data Step RequestBody (IOHM.InsOrdHashMap MediaType MediaTypeObject) = RequestMediaTypeObjectMapping

66+ deriving (Eq, Ord, Show)

src/OpenAPI/Checker/Validate/Responses.hs+24−6

@@ -38,8 +38,8 @@ instance Subtree Responses where

38 ]

40 checkStructuralCompatibility env pc = do

41− structuralMaybe env $ _responsesDefault <$> pc

41+ structuralMaybe env $ sequence . stepTraced ResponseDefaultStep . fmap _responsesDefault <$> pc

42− iohmStructural env $ _responsesResponses <$> pc

42+ iohmStructural env $ stepTraced ResponsesStep . fmap _responsesResponses <$> pc

43 pure ()

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

@@ -90,9 +90,9 @@ instance Subtree Response where

90 , ProdCons (Traced (Definitions Link))

91 ]

92 checkStructuralCompatibility env pc = do

93− iohmStructural env $ _responseContent <$> pc

93+ iohmStructural env $ stepTraced ResponseMediaObjects . fmap _responseContent <$> pc

94− iohmStructural env $ _responseHeaders <$> pc

94+ iohmStructural env $ stepTraced ResponseHeaders . fmap _responseHeaders <$> pc

95− iohmStructural env $ _responseLinks <$> pc

95+ iohmStructural env $ stepTraced ResponseLinks . fmap _responseLinks <$> pc

96 pure ()

97 checkSemanticCompatibility env beh prodCons = do

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

@@ -127,13 +127,31 @@ instance Subtree Response where

127 headerDefs = getH @(ProdCons (Traced (Definitions Header))) env

128

129instance Steppable Responses (Referenced Response) where

130− data Step Responses (Referenced Response) = ResponseCodeStep HttpStatusCode

130+ data Step Responses (Referenced Response)

131+ = ResponseCodeStep HttpStatusCode

132+ | ResponseDefaultStep

131 deriving stock (Eq, Ord, Show)

133 deriving stock (Eq, Ord, Show)

132

134

133instance Steppable Response MediaTypeObject where

135instance Steppable Response MediaTypeObject where

134 data Step Response MediaTypeObject = ResponseMediaObject MediaType

136 data Step Response MediaTypeObject = ResponseMediaObject MediaType

135 deriving stock (Eq, Ord, Show)

137 deriving stock (Eq, Ord, Show)

136

138

139+instance Steppable Response (IOHM.InsOrdHashMap MediaType MediaTypeObject) where

140+ data Step Response (IOHM.InsOrdHashMap MediaType MediaTypeObject) = ResponseMediaObjects

141+ deriving stock (Eq, Ord, Show)

142+

143+instance Steppable Response (Definitions (Referenced Header)) where

144+ data Step Response (Definitions (Referenced Header)) = ResponseHeaders

145+ deriving stock (Eq, Ord, Show)

146+

147+instance Steppable Response (Definitions (Referenced Link)) where

148+ data Step Response (Definitions (Referenced Link)) = ResponseLinks

149+ deriving stock (Eq, Ord, Show)

150+

137instance Steppable Response (Referenced Header) where

151instance Steppable Response (Referenced Header) where

138 data Step Response (Referenced Header) = ResponseHeader HeaderName

152 data Step Response (Referenced Header) = ResponseHeader HeaderName

139 deriving stock (Eq, Ord, Show)

153 deriving stock (Eq, Ord, Show)

154+

155+instance Steppable Responses (IOHM.InsOrdHashMap HttpStatusCode (Referenced Response)) where

156+ data Step Responses (IOHM.InsOrdHashMap HttpStatusCode (Referenced Response)) = ResponsesStep

157+ deriving stock (Eq, Ord, Show)

src/OpenAPI/Checker/Validate/Schema.hs+464−306

@@ -1,4 +1,5 @@

1{-# OPTIONS_GHC -fno-warn-orphans #-}

2module OpenAPI.Checker.Validate.Schema

3module OpenAPI.Checker.Validate.Schema

3 ( JsonType (..)

4 ( JsonType (..)

4 , ForeachType (..)

5 , ForeachType (..)

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

10 , schemaToFormula

11 , schemaToFormula

11 , foldLattice

12 , foldLattice

12 )

13 )

13− where

14+where

15import Algebra.Lattice

16import Algebra.Lattice

16import Control.Applicative

17import Control.Applicative

@@ -23,9 +24,9 @@ import Control.Monad.Writer

23import qualified Data.Aeson as A

24import qualified Data.Aeson as A

24import Data.Coerce

25import Data.Coerce

25import qualified Data.Foldable as F

26import qualified Data.Foldable as F

27+import Data.HList

26import qualified Data.HashMap.Strict as HM

28import qualified Data.HashMap.Strict as HM

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

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

28−import Data.HList

29import Data.Int

30import Data.Int

30import Data.Kind

31import Data.Kind

31import qualified Data.List.NonEmpty as NE

32import qualified Data.List.NonEmpty as NE

@@ -38,15 +39,13 @@ import Data.Scientific

38import qualified Data.Set as S

39import qualified Data.Set as S

39import Data.Text (Text)

40import Data.Text (Text)

40import qualified Data.Text as T hiding (singleton)

41import qualified Data.Text as T hiding (singleton)

41−import qualified Data.Text.Encoding as T

42import Data.Typeable

43import OpenAPI.Checker.Behavior

44import OpenAPI.Checker.Orphans ()

45−import OpenAPI.Checker.References

46import OpenAPI.Checker.Paths

45import OpenAPI.Checker.Paths

47import qualified OpenAPI.Checker.PathsPrefixTree as P

46import qualified OpenAPI.Checker.PathsPrefixTree as P

47+import OpenAPI.Checker.References

48import OpenAPI.Checker.Subtree

49−import Debug.Trace

51-- | Type of a JSON value

50-- | Type of a JSON value

52data JsonType

51data JsonType

@@ -68,7 +67,9 @@ data TypedValue :: JsonType -> Type where

68 TObject :: !A.Object -> TypedValue 'Object

67 TObject :: !A.Object -> TypedValue 'Object

70deriving stock instance Eq (TypedValue t)

69deriving stock instance Eq (TypedValue t)

70+

71deriving stock instance Ord (TypedValue t)

72+

72deriving stock instance Show (TypedValue t)

73deriving stock instance Show (TypedValue t)

74untypeValue :: TypedValue t -> A.Value

75untypeValue :: TypedValue t -> A.Value

@@ -100,8 +101,9 @@ data Property = Property

100data Condition :: JsonType -> Type where

101data Condition :: JsonType -> Type where

101 Exactly :: TypedValue t -> Condition t

102 Exactly :: TypedValue t -> Condition t

102 Maximum :: !(Bound Scientific) -> Condition 'Number

103 Maximum :: !(Bound Scientific) -> Condition 'Number

104+ Minimum

103− Minimum :: !(Down (Bound (Down Scientific))) -> Condition 'Number

105+ :: !(Down (Bound (Down Scientific)))

104− -- ^ this has the right Ord

106+ -> Condition 'Number -- ^ this has the right Ord

105 MultipleOf :: !Scientific -> Condition 'Number

107 MultipleOf :: !Scientific -> Condition 'Number

106 NumberFormat :: !Format -> Condition 'Number

108 NumberFormat :: !Format -> Condition 'Number

107 MaxLength :: !Integer -> Condition 'String

109 MaxLength :: !Integer -> Condition 'String

@@ -117,10 +119,8 @@ data Condition :: JsonType -> Type where

117 UniqueItems :: Condition 'Array

119 UniqueItems :: Condition 'Array

118 Properties

120 Properties

119 :: !(M.Map Text Property)

121 :: !(M.Map Text Property)

120− -> !(ForeachType JsonFormula)

121− -- ^ formula for additional properties

122+ -> !(ForeachType JsonFormula) -- ^ formula for additional properties

122− -> !(Maybe (Traced (Referenced Schema)))

123− -- ^ schema for additional properties, Nothing means bottom

123+ -> !(Maybe (Traced (Referenced Schema))) -- ^ schema for additional properties, Nothing means bottom

124 -> Condition 'Object

125 MaxProperties :: !Integer -> Condition 'Object

126 MinProperties :: !Integer -> Condition 'Object

@@ -136,28 +136,34 @@ satisfiesTyped (TNumber n) (NumberFormat f) = checkNumberFormat f n

136satisfiesTyped (TString s) (MaxLength m) = fromIntegral (T.length s) <= m

137satisfiesTyped (TString s) (MinLength m) = fromIntegral (T.length s) >= m

138satisfiesTyped (TString s) (Pattern p) = undefined s p -- TODO: regex stuff

139−satisfiesTyped (TString s) (StringFormat f) = undefined s f-- TODO: string format

139+satisfiesTyped (TString s) (StringFormat f) = undefined s f -- TODO: string format

140satisfiesTyped (TArray a) (Items f _) = all (`satisfies` f) a

141satisfiesTyped (TArray a) (MaxItems m) = fromIntegral (F.length a) <= m

142satisfiesTyped (TArray a) (MinItems m) = fromIntegral (F.length a) >= m

143satisfiesTyped (TArray a) UniqueItems = S.size (S.fromList $ F.toList a) == F.length a -- TODO: could be better

144−satisfiesTyped (TObject o) (Properties props additional _)

144+satisfiesTyped (TObject o) (Properties props additional _) =

145− = all (`HM.member` o) (M.keys (M.filter propRequired props))

145+ all (`HM.member` o) (M.keys (M.filter propRequired props))

146− && all (\(k, v) -> satisfies v $ maybe additional propFormula $ M.lookup k props) (HM.toList o)

146+ && all (\(k, v) -> satisfies v $ maybe additional propFormula $ M.lookup k props) (HM.toList o)

147satisfiesTyped (TObject o) (MaxProperties m) = fromIntegral (HM.size o) <= m

148satisfiesTyped (TObject o) (MinProperties m) = fromIntegral (HM.size o) >= m

149

150checkNumberFormat :: Format -> Scientific -> Bool

151−checkNumberFormat "int32" (toRational -> n) = denominator n == 1

151+checkNumberFormat "int32" (toRational -> n) =

152+ denominator n == 1

152− && n >= toRational (minBound :: Int32) && n <= toRational (maxBound :: Int32)

153+ && n >= toRational (minBound :: Int32)

154+ && n <= toRational (maxBound :: Int32)

153−checkNumberFormat "int64" (toRational -> n) = denominator n == 1

155+checkNumberFormat "int64" (toRational -> n) =

156+ denominator n == 1

154− && n >= toRational (minBound :: Int64) && n <= toRational (maxBound :: Int64)

157+ && n >= toRational (minBound :: Int64)

158+ && n <= toRational (maxBound :: Int64)

155checkNumberFormat "float" _n = True

159checkNumberFormat "float" _n = True

156checkNumberFormat "double" _n = True

160checkNumberFormat "double" _n = True

157checkNumberFormat f _n = error $ "Invalid number format: " <> T.unpack f

161checkNumberFormat f _n = error $ "Invalid number format: " <> T.unpack f

158

162

159deriving stock instance Eq (Condition t)

163deriving stock instance Eq (Condition t)

164+

160deriving stock instance Ord (Condition t)

165deriving stock instance Ord (Condition t)

166+

161deriving stock instance Show (Condition t)

167deriving stock instance Show (Condition t)

162

168

163data SomeCondition where

169data SomeCondition where

@@ -192,12 +198,15 @@ disjAdd (DNF yss) xs

192

198

193instance Lattice (JsonFormula t) where

199instance Lattice (JsonFormula t) where

194 xss \/ DNF yss = S.foldl' disjAdd xss yss

200 xss \/ DNF yss = S.foldl' disjAdd xss yss

201+ DNF xss /\ DNF yss =

195− DNF xss /\ DNF yss = F.foldl' disjAdd bottom $

202+ F.foldl' disjAdd bottom $

196− liftA2 S.union (S.toList xss) (S.toList yss)

203+ liftA2 S.union (S.toList xss) (S.toList yss)

197

204

198pattern BottomFormula :: JsonFormula t

205pattern BottomFormula :: JsonFormula t

199−pattern BottomFormula <- DNF (S.null -> True)

206+pattern BottomFormula <-

207+ DNF (S.null -> True)

208+ where

200− where BottomFormula = DNF S.empty

209+ BottomFormula = DNF S.empty

201

210

202isSingleton :: S.Set a -> Maybe a

211isSingleton :: S.Set a -> Maybe a

203isSingleton s

212isSingleton s

@@ -205,17 +214,24 @@ isSingleton s

205 | otherwise = Nothing

214 | otherwise = Nothing

206

215

207pattern Conjunct :: [Condition t] -> S.Set (Condition t)

216pattern Conjunct :: [Condition t] -> S.Set (Condition t)

208−pattern Conjunct xs <- (S.toList -> xs)

217+pattern Conjunct xs <-

218+ (S.toList -> xs)

219+ where

209− where Conjunct = S.fromList

220+ Conjunct = S.fromList

221+

210{-# COMPLETE Conjunct #-}

222{-# COMPLETE Conjunct #-}

211

223

212pattern SingleConjunct :: [Condition t] -> JsonFormula t

224pattern SingleConjunct :: [Condition t] -> JsonFormula t

225+pattern SingleConjunct xs <-

213−pattern SingleConjunct xs <- DNF (isSingleton -> Just (Conjunct xs))

226+ DNF (isSingleton -> Just (Conjunct xs))

227+ where

214− where SingleConjunct xs = DNF $ S.singleton $ Conjunct xs

228+ SingleConjunct xs = DNF $ S.singleton $ Conjunct xs

215

229

216pattern TopFormula :: JsonFormula t

230pattern TopFormula :: JsonFormula t

231+pattern TopFormula <-

217−pattern TopFormula <- DNF (isSingleton -> Just (S.null -> True))

232+ DNF (isSingleton -> Just (S.null -> True))

233+ where

218− where TopFormula = DNF $ S.singleton S.empty

234+ TopFormula = DNF $ S.singleton S.empty

219

235

220instance BoundedJoinSemiLattice (JsonFormula t) where

236instance BoundedJoinSemiLattice (JsonFormula t) where

221 bottom = BottomFormula

237 bottom = BottomFormula

@@ -228,8 +244,12 @@ foldLattice

228 => (Condition t -> l)

244 => (Condition t -> l)

229 -> JsonFormula t

245 -> JsonFormula t

230 -> l

246 -> l

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

247+foldLattice f (DNF xss) =

248+ S.foldl'

249+ (\z w ->

232− z \/ S.foldl' (\x y -> x /\ f y) top w) bottom xss

250+ z \/ S.foldl' (\x y -> x /\ f y) top w)

251+ bottom

252+ xss

233

253

234satisfiesFormula :: TypedValue t -> JsonFormula t -> Bool

254satisfiesFormula :: TypedValue t -> JsonFormula t -> Bool

235satisfiesFormula val = foldLattice (satisfiesTyped val)

255satisfiesFormula val = foldLattice (satisfiesTyped val)

@@ -253,7 +273,9 @@ satisfies val p = case val of

253 A.Object o -> satisfiesFormula (TObject o) $ forObject p

273 A.Object o -> satisfiesFormula (TObject o) $ forObject p

254

274

255deriving stock instance (forall x. Typeable x => Eq (f x)) => Eq (ForeachType f)

275deriving stock instance (forall x. Typeable x => Eq (f x)) => Eq (ForeachType f)

276+

256deriving stock instance (forall x. Typeable x => Ord (f x)) => Ord (ForeachType f)

277deriving stock instance (forall x. Typeable x => Ord (f x)) => Ord (ForeachType f)

278+

257deriving stock instance (forall x. Typeable x => Show (f x)) => Show (ForeachType f)

279deriving stock instance (forall x. Typeable x => Show (f x)) => Show (ForeachType f)

258

280

259foldType

281foldType

@@ -261,12 +283,12 @@ foldType

261 => (forall x. Typeable x => JsonType -> (ForeachType f -> f x) -> m)

283 => (forall x. Typeable x => JsonType -> (ForeachType f -> f x) -> m)

262 -> m

284 -> m

263foldType k =

285foldType k =

264− k Null forNull <>

286+ k Null forNull

265− k Boolean forBoolean <>

287+ <> k Boolean forBoolean

266− k Number forNumber <>

288+ <> k Number forNumber

267− k String forString <>

289+ <> k String forString

268− k Array forArray <>

290+ <> k Array forArray

269− k Object forObject

291+ <> k Object forObject

270

292

271forType_

293forType_

272 :: Applicative m

294 :: Applicative m

@@ -282,44 +304,52 @@ forType_ k = do

282 pure ()

304 pure ()

283

305

284instance (forall x. Lattice (f x)) => Lattice (ForeachType f) where

306instance (forall x. Lattice (f x)) => Lattice (ForeachType f) where

285− f1 \/ f2 = ForeachType

307+ f1 \/ f2 =

308+ ForeachType

286− { forNull = forNull f1 \/ forNull f2

309+ { forNull = forNull f1 \/ forNull f2

287− , forBoolean = forBoolean f1 \/ forBoolean f2

310+ , forBoolean = forBoolean f1 \/ forBoolean f2

288− , forNumber = forNumber f1 \/ forNumber f2

311+ , forNumber = forNumber f1 \/ forNumber f2

289− , forString = forString f1 \/ forString f2

312+ , forString = forString f1 \/ forString f2

290− , forArray = forArray f1 \/ forArray f2

313+ , forArray = forArray f1 \/ forArray f2

291− , forObject = forObject f1 \/ forObject f2

314+ , forObject = forObject f1 \/ forObject f2

292− }

315+ }

316+ f1 /\ f2 =

293− f1 /\ f2 = ForeachType

317+ ForeachType

294− { forNull = forNull f1 /\ forNull f2

318+ { forNull = forNull f1 /\ forNull f2

295− , forBoolean = forBoolean f1 /\ forBoolean f2

319+ , forBoolean = forBoolean f1 /\ forBoolean f2

296− , forNumber = forNumber f1 /\ forNumber f2

320+ , forNumber = forNumber f1 /\ forNumber f2

297− , forString = forString f1 /\ forString f2

321+ , forString = forString f1 /\ forString f2

298− , forArray = forArray f1 /\ forArray f2

322+ , forArray = forArray f1 /\ forArray f2

299− , forObject = forObject f1 /\ forObject f2

323+ , forObject = forObject f1 /\ forObject f2

300− }

324+ }

301−

325+

326+instance

302−instance (forall x. BoundedJoinSemiLattice (f x))

327+ (forall x. BoundedJoinSemiLattice (f x))

303− => BoundedJoinSemiLattice (ForeachType f) where

328+ => BoundedJoinSemiLattice (ForeachType f)

329+ where

304− bottom = ForeachType

330+ bottom =

331+ ForeachType

305− { forNull = bottom

332+ { forNull = bottom

306− , forBoolean = bottom

333+ , forBoolean = bottom

307− , forNumber = bottom

334+ , forNumber = bottom

308− , forString = bottom

335+ , forString = bottom

309− , forArray = bottom

336+ , forArray = bottom

310− , forObject = bottom

337+ , forObject = bottom

311− }

338+ }

312−

339+

340+instance

313−instance (forall x. BoundedMeetSemiLattice (f x))

341+ (forall x. BoundedMeetSemiLattice (f x))

314− => BoundedMeetSemiLattice (ForeachType f) where

342+ => BoundedMeetSemiLattice (ForeachType f)

343+ where

344+ top =

315− top = ForeachType

345+ ForeachType

316− { forNull = top

346+ { forNull = top

317− , forBoolean = top

347+ , forBoolean = top

318− , forNumber = top

348+ , forNumber = top

319− , forString = top

349+ , forString = top

320− , forArray = top

350+ , forArray = top

321− , forObject = top

351+ , forObject = top

322− }

352+ }

323

353

324{- TODO: remove

354{- TODO: remove

325instance Typeable t => Steppable Schema (Condition t) where

355instance Typeable t => Steppable Schema (Condition t) where

@@ -356,9 +386,26 @@ instance Steppable Schema (Referenced Schema) where

356 | ItemsObjectStep

386 | ItemsObjectStep

357 | ItemsArrayStep Int

387 | ItemsArrayStep Int

358 | AdditionalPropertiesStep

388 | AdditionalPropertiesStep

359− | PropertiesStep Text

389+ | NotStep

390+ deriving (Eq, Ord, Show)

391+

392+instance Steppable Schema (Definitions (Referenced Schema)) where

393+ data Step Schema (Definitions (Referenced Schema)) = PropertiesStep

394+ deriving (Eq, Ord, Show)

395+

396+instance Steppable Schema Discriminator where

397+ data Step Schema Discriminator = DiscriminatorStep

398+ deriving (Eq, Ord, Show)

399+

400+instance Steppable Discriminator (Definitions (Referenced Schema)) where

401+ data Step Discriminator (Definitions (Referenced Schema)) = DiscriminatorMapping

360 deriving (Eq, Ord, Show)

402 deriving (Eq, Ord, Show)

361

403

404+parseDiscriminatorValue :: Text -> Referenced Schema

405+parseDiscriminatorValue v = case A.fromJSON @(Referenced Schema) $ A.object ["$ref" A..= v] of

406+ A.Success x -> x

407+ A.Error _ -> Ref $ Reference v

408+

362type ProcessM = ReaderT (Traced (Definitions Schema)) (Writer (P.PathsPrefixTree Behave AnIssue 'SchemaLevel))

409type ProcessM = ReaderT (Traced (Definitions Schema)) (Writer (P.PathsPrefixTree Behave AnIssue 'SchemaLevel))

363

410

364warn :: Issue 'SchemaLevel -> ProcessM ()

411warn :: Issue 'SchemaLevel -> ProcessM ()

@@ -372,31 +419,42 @@ processRefSchema x = do

372 processSchema $ dereference defs x

419 processSchema $ dereference defs x

373

420

374tracedAllOf :: Traced Schema -> Maybe [Traced (Referenced Schema)]

421tracedAllOf :: Traced Schema -> Maybe [Traced (Referenced Schema)]

422+tracedAllOf sch =

375−tracedAllOf sch = _schemaAllOf (extract sch) <&> \xs ->

423+ _schemaAllOf (extract sch) <&> \xs ->

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

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

377

425

378tracedAnyOf :: Traced Schema -> Maybe [Traced (Referenced Schema)]

426tracedAnyOf :: Traced Schema -> Maybe [Traced (Referenced Schema)]

427+tracedAnyOf sch =

379−tracedAnyOf sch = _schemaAnyOf (extract sch) <&> \xs ->

428+ _schemaAnyOf (extract sch) <&> \xs ->

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

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

381

430

382tracedOneOf :: Traced Schema -> Maybe [Traced (Referenced Schema)]

431tracedOneOf :: Traced Schema -> Maybe [Traced (Referenced Schema)]

432+tracedOneOf sch =

383−tracedOneOf sch = _schemaOneOf (extract sch) <&> \xs ->

433+ _schemaOneOf (extract sch) <&> \xs ->

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

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

385

435

386tracedItems :: Traced Schema -> Maybe (Either (Traced (Referenced Schema)) [Traced (Referenced Schema)])

436tracedItems :: Traced Schema -> Maybe (Either (Traced (Referenced Schema)) [Traced (Referenced Schema)])

437+tracedItems sch =

387−tracedItems sch = _schemaItems (extract sch) <&> \case

438+ _schemaItems (extract sch) <&> \case

388− OpenApiItemsObject x -> Left $ traced (ask sch >>> step ItemsObjectStep) x

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

389− OpenApiItemsArray xs -> Right

440+ OpenApiItemsArray xs ->

441+ Right

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

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

391

443

392tracedAdditionalProperties :: Traced Schema -> Maybe (Either Bool (Traced (Referenced Schema)))

444tracedAdditionalProperties :: Traced Schema -> Maybe (Either Bool (Traced (Referenced Schema)))

445+tracedAdditionalProperties sch =

393−tracedAdditionalProperties sch = _schemaAdditionalProperties (extract sch) <&> \case

446+ _schemaAdditionalProperties (extract sch) <&> \case

394− AdditionalPropertiesAllowed b -> Left b

447+ AdditionalPropertiesAllowed b -> Left b

395− AdditionalPropertiesSchema x -> Right $ traced (ask sch >>> step AdditionalPropertiesStep) x

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

449+

450+tracedDiscriminator :: Traced Schema -> Maybe (Traced Discriminator)

451+tracedDiscriminator = sequence . stepTraced DiscriminatorStep . fmap _schemaDiscriminator

396

452

397tracedProperties :: Traced Schema -> IOHM.InsOrdHashMap Text (Traced (Referenced Schema))

453tracedProperties :: Traced Schema -> IOHM.InsOrdHashMap Text (Traced (Referenced Schema))

454+tracedProperties sch =

455+ IOHM.mapWithKey

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

456+ (\k -> traced (ask sch >>> step PropertiesStep >>> step (InsOrdHashMapKeyStep k)))

399− $ _schemaProperties $ extract sch

457+ (_schemaProperties $ extract sch)

400

458

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

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

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

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

@@ -404,10 +462,9 @@ tracedProperties sch = IOHM.mapWithKey (\k -> traced (ask sch >>> step (Properti

404processSchema

462processSchema

405 :: Traced Schema

463 :: Traced Schema

406 -> ProcessM (ForeachType JsonFormula)

464 -> ProcessM (ForeachType JsonFormula)

407−processSchema sch@(extract -> Schema{..}) = do

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

408− let

409− singletonFormula :: Condition t -> JsonFormula t

466+ let singletonFormula :: Condition t -> JsonFormula t

410− singletonFormula f = SingleConjunct [f]

467+ singletonFormula f = SingleConjunct [f]

411

468

412 allClauses <- case tracedAllOf sch of

469 allClauses <- case tracedAllOf sch of

413 Nothing -> pure []

470 Nothing -> pure []

@@ -432,110 +489,160 @@ processSchema sch@(extract -> Schema{..}) = do

432 Nothing -> pure ()

489 Nothing -> pure ()

433 Just _ -> warn (NotSupported "not clause is unsupported")

490 Just _ -> warn (NotSupported "not clause is unsupported")

434

491

435− let

436− typeClause = case _schemaType of

492+ let typeClause = case _schemaType of

437− Nothing -> top

493+ Nothing -> top

438− Just OpenApiNull -> bottom

494+ Just OpenApiNull ->

495+ bottom

439− { forNull = top }

496+ { forNull = top

497+ }

440− Just OpenApiBoolean -> bottom

498+ Just OpenApiBoolean ->

499+ bottom

441− { forBoolean = top }

500+ { forBoolean = top

501+ }

442− Just OpenApiNumber -> bottom

502+ Just OpenApiNumber ->

503+ bottom

443− { forBoolean = top }

504+ { forBoolean = top

505+ }

444− Just OpenApiInteger -> bottom

506+ Just OpenApiInteger ->

507+ bottom

445− { forNumber = singletonFormula $ MultipleOf 1 }

508+ { forNumber = singletonFormula $ MultipleOf 1

509+ }

446− Just OpenApiString -> bottom

510+ Just OpenApiString ->

511+ bottom

447− { forString = top }

512+ { forString = top

513+ }

448− Just OpenApiArray -> bottom

514+ Just OpenApiArray ->

515+ bottom

449− { forArray = top }

516+ { forArray = top

517+ }

450− Just OpenApiObject -> bottom

518+ Just OpenApiObject ->

519+ bottom

451− { forObject = top }

520+ { forObject = top

452−

521+ }

453− let

522+

454− valueEnum A.Null = bottom

523+ let valueEnum A.Null =

524+ bottom

455− { forNull = singletonFormula $ Exactly TNull }

525+ { forNull = singletonFormula $ Exactly TNull

526+ }

456− valueEnum (A.Bool b) = bottom

527+ valueEnum (A.Bool b) =

528+ bottom

457− { forBoolean = singletonFormula $ Exactly $ TBool b }

529+ { forBoolean = singletonFormula $ Exactly $ TBool b

530+ }

458− valueEnum (A.Number n) = bottom

531+ valueEnum (A.Number n) =

532+ bottom

459− { forNumber = singletonFormula $ Exactly $ TNumber n }

533+ { forNumber = singletonFormula $ Exactly $ TNumber n

534+ }

460− valueEnum (A.String s) = bottom

535+ valueEnum (A.String s) =

536+ bottom

461− { forString = singletonFormula $ Exactly $ TString s }

537+ { forString = singletonFormula $ Exactly $ TString s

538+ }

462− valueEnum (A.Array a) = bottom

539+ valueEnum (A.Array a) =

540+ bottom

463− { forArray = singletonFormula $ Exactly $ TArray a }

541+ { forArray = singletonFormula $ Exactly $ TArray a

542+ }

464− valueEnum (A.Object o) = bottom

543+ valueEnum (A.Object o) =

544+ bottom

465− { forObject = singletonFormula $ Exactly $ TObject o }

545+ { forObject = singletonFormula $ Exactly $ TObject o

546+ }

466 enumClause <- case _schemaEnum of

547 enumClause <- case _schemaEnum of

467 Nothing -> pure top

548 Nothing -> pure top

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

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

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

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

470

551

471− let

472− maximumClause = case _schemaMaximum of

552+ let maximumClause = case _schemaMaximum of

473− Nothing -> top

553+ Nothing -> top

474− Just n -> top

554+ Just n ->

555+ top

475− { forNumber = singletonFormula $ Maximum $

556+ { forNumber = singletonFormula $

557+ Maximum $

476− case _schemaExclusiveMaximum of

558+ case _schemaExclusiveMaximum of

477− Just True -> Exclusive n

559+ Just True -> Exclusive n

478− _ -> Inclusive n }

560+ _ -> Inclusive n

479−

561+ }

562+

480− minimumClause = case _schemaMinimum of

563+ minimumClause = case _schemaMinimum of

481− Nothing -> top

564+ Nothing -> top

482− Just n -> top

565+ Just n ->

566+ top

483− { forNumber = singletonFormula $ Minimum $ Down $

567+ { forNumber = singletonFormula $

568+ Minimum $

569+ Down $

484− case _schemaExclusiveMinimum of

570+ case _schemaExclusiveMinimum of

485− Just True -> Exclusive $ Down n

571+ Just True -> Exclusive $ Down n

486− _ -> Inclusive $ Down n }

572+ _ -> Inclusive $ Down n

487−

573+ }

574+

488− multipleOfClause = case _schemaMultipleOf of

575+ multipleOfClause = case _schemaMultipleOf of

489− Nothing -> top

576+ Nothing -> top

490− Just n -> top

577+ Just n ->

578+ top

491− { forNumber = singletonFormula $ MultipleOf n }

579+ { forNumber = singletonFormula $ MultipleOf n

580+ }

492

581

493 formatClause <- case _schemaFormat of

582 formatClause <- case _schemaFormat of

494 Nothing -> pure top

583 Nothing -> pure top

584+ Just f

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

585+ | f `elem` ["int32", "int64", "float", "double"] ->

586+ pure

587+ top

496− { forNumber = singletonFormula $ NumberFormat f }

588+ { forNumber = singletonFormula $ NumberFormat f

589+ }

590+ Just f

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

591+ | f `elem` ["byte", "binary", "date", "date-time", "password"] ->

592+ pure

593+ top

498− { forString = singletonFormula $ StringFormat f }

594+ { forString = singletonFormula $ StringFormat f

595+ }

499 Just f -> top <$ warn (NotSupported $ "Unknown format: " <> f)

596 Just f -> top <$ warn (NotSupported $ "Unknown format: " <> f)

500

597

501− let

502− maxLengthClause = case _schemaMaxLength of

598+ let maxLengthClause = case _schemaMaxLength of

503− Nothing -> top

599+ Nothing -> top

504− Just n -> top

600+ Just n ->

601+ top

505− { forString = singletonFormula $ MaxLength n }

602+ { forString = singletonFormula $ MaxLength n

506−

603+ }

604+

507− minLengthClause = case _schemaMinLength of

605+ minLengthClause = case _schemaMinLength of

508− Nothing -> top

606+ Nothing -> top

509− Just n -> top

607+ Just n ->

608+ top

510− { forString = singletonFormula $ MinLength n }

609+ { forString = singletonFormula $ MinLength n

511−

610+ }

611+

512− patternClause = case _schemaPattern of

612+ patternClause = case _schemaPattern of

513− Nothing -> top

613+ Nothing -> top

514− Just p -> top

614+ Just p ->

615+ top

515− { forString = singletonFormula $ Pattern p }

616+ { forString = singletonFormula $ Pattern p

617+ }

516

618

517 itemsClause <- case tracedItems sch of

619 itemsClause <- case tracedItems sch of

518 Nothing -> pure top

620 Nothing -> pure top

519 Just (Left rs) -> do

621 Just (Left rs) -> do

520 f <- processRefSchema rs

622 f <- processRefSchema rs

521− pure top { forArray = singletonFormula $ Items f rs }

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

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

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

523

625

524− let

525− maxItemsClause = case _schemaMaxItems of

626+ let maxItemsClause = case _schemaMaxItems of

526− Nothing -> top

627+ Nothing -> top

527− Just n -> top

628+ Just n ->

629+ top

528− { forArray = singletonFormula $ MaxItems n }

630+ { forArray = singletonFormula $ MaxItems n

529−

631+ }

632+

530− minItemsClause = case _schemaMinItems of

633+ minItemsClause = case _schemaMinItems of

531− Nothing -> top

634+ Nothing -> top

532− Just n -> top

635+ Just n ->

636+ top

533− { forArray = singletonFormula $ MinItems n }

637+ { forArray = singletonFormula $ MinItems n

534−

638+ }

639+

535− uniqueItemsClause = case _schemaUniqueItems of

640+ uniqueItemsClause = case _schemaUniqueItems of

536− Just True -> top

641+ Just True ->

642+ top

537− { forArray = singletonFormula UniqueItems }

643+ { forArray = singletonFormula UniqueItems

644+ }

538− _ -> top

645+ _ -> top

539

646

540 (addProps, addPropSchema) <- case tracedAdditionalProperties sch of

647 (addProps, addPropSchema) <- case tracedAdditionalProperties sch of

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

648 Just (Right rs) -> (,Just rs) <$> processRefSchema rs

@@ -544,50 +651,79 @@ processSchema sch@(extract -> Schema{..}) = do

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

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

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

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

546 Just rs -> (,rs) <$> processRefSchema rs

653 Just rs -> (,rs) <$> processRefSchema rs

654+ Nothing ->

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

655+ let fakeSchema = traced (ask sch `Snoc` AdditionalPropertiesStep) $ Inline mempty

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

656+ in -- The mempty here is incorrect, but if addPropSchema was Nothing, then

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

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

550− -- below and short-circuit the entire Properties condition to bottom

658+ -- below and short-circuit the entire Properties condition to bottom

551− in pure (addProps, fromMaybe fakeSchema addPropSchema)

659+ pure (addProps, fromMaybe fakeSchema addPropSchema)

552 pure (k, Property (k `elem` _schemaRequired) f psch)

660 pure (k, Property (k `elem` _schemaRequired) f psch)

553− let

661+ let allBottom f = getAll $

554− allBottom f = getAll $ foldType $ \_ ty -> case ty f of

662+ foldType $ \_ ty -> case ty f of

555− BottomFormula -> All True

663+ BottomFormula -> All True

556− _ -> All False

664+ _ -> All False

665+ allTop f = getAll $

557− allTop f = getAll $ foldType $ \_ ty -> case ty f of

666+ foldType $ \_ ty -> case ty f of

558− TopFormula -> All True

667+ TopFormula -> All True

559− _ -> All False

668+ _ -> All False

560− -- remove optional fields whose schemata match that of additional props

669+ -- remove optional fields whose schemata match that of additional props

561− propMap = M.filter (\p -> propRequired p || propFormula p /= addProps) $ M.fromList propList

670+ propMap = M.filter (\p -> propRequired p || propFormula p /= addProps) $ M.fromList propList

562− propertiesClause

671+ propertiesClause

563− | any (\p -> propRequired p && allBottom (propFormula p)) propMap

672+ | any (\p -> propRequired p && allBottom (propFormula p)) propMap =

564− = bottom -- if any required field has unsatisfiable schema

673+ bottom -- if any required field has unsatisfiable schema

674+ | M.null propMap

565− | M.null propMap, allTop addProps

675+ , allTop addProps =

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

676+ top -- if all fields are optional and have trivial schemata

567− | otherwise

677+ | otherwise =

568− = top

678+ top

569− { forObject = singletonFormula $ Properties propMap addProps addPropSchema }

679+ { forObject = singletonFormula $ Properties propMap addProps addPropSchema

570−

680+ }

681+

571− maxPropertiesClause = case _schemaMaxProperties of

682+ maxPropertiesClause = case _schemaMaxProperties of

572− Nothing -> top

683+ Nothing -> top

573− Just n -> top

684+ Just n ->

685+ top

574− { forObject = singletonFormula $ MaxProperties n }

686+ { forObject = singletonFormula $ MaxProperties n

575−

687+ }

688+

576− minPropertiesClause = case _schemaMinProperties of

689+ minPropertiesClause = case _schemaMinProperties of

577− Nothing -> top

690+ Nothing -> top

578− Just n -> top

691+ Just n ->

692+ top

579− { forObject = singletonFormula $ MinProperties n }

693+ { forObject = singletonFormula $ MinProperties n

580−

694+ }

695+

696+ nullableClause

697+ | Just True <- _schemaNullable =

698+ bottom

699+ { forNull = singletonFormula $ Exactly TNull

700+ }

701+ | otherwise = bottom

702+

703+ pure $

581 nullableClause

704 nullableClause

582− | Just True <- _schemaNullable = bottom

705+ \/ meets

583− { forNull = singletonFormula $ Exactly TNull }

584− | otherwise = bottom

585−

586− pure $ nullableClause \/ meets (allClauses <>

706+ (allClauses

587− [ anyClause, oneClause, typeClause, enumClause, maximumClause, minimumClause

707+ <> [ anyClause

708+ , oneClause

709+ , typeClause

710+ , enumClause

711+ , maximumClause

712+ , minimumClause

588− , multipleOfClause, formatClause, maxLengthClause, minLengthClause

713+ , multipleOfClause

714+ , formatClause

715+ , maxLengthClause

716+ , minLengthClause

717+ , patternClause

718+ , itemsClause

589− , patternClause, itemsClause, maxItemsClause, minItemsClause

719+ , maxItemsClause

720+ , minItemsClause

721+ , uniqueItemsClause

722+ , propertiesClause

590− , uniqueItemsClause, propertiesClause, maxPropertiesClause, minPropertiesClause])

723+ , maxPropertiesClause

724+ , minPropertiesClause

725+ ])

726+

591{- TODO: ReadOnly/WriteOnly -}

727{- TODO: ReadOnly/WriteOnly -}

592

728

593checkOneOfDisjoint :: [Traced (Referenced Schema)] -> ProcessM Bool

729checkOneOfDisjoint :: [Traced (Referenced Schema)] -> ProcessM Bool

@@ -607,7 +743,7 @@ checkFormulas

607 -> SemanticCompatFormula ()

743 -> SemanticCompatFormula ()

608checkFormulas env beh (ProdCons (fp, ep) (fc, ec)) =

744checkFormulas env beh (ProdCons (fp, ep) (fc, ec)) =

609 case P.toList ep ++ P.toList ec of

745 case P.toList ep ++ P.toList ec of

610− issues@(_:_) -> F.for_ issues $ \(AnItem t (AnIssue e)) -> issueAt (beh >>> t) e

746+ issues@(_ : _) -> F.for_ issues $ \(AnItem t (AnIssue e)) -> issueAt (beh >>> t) e

611 [] -> do

747 [] -> do

612 -- We have the following isomorphisms:

748 -- We have the following isomorphisms:

613 -- (A ⊂ X ∪ Y) = (A ⊂ X) \/ (A ⊂ Y)

749 -- (A ⊂ X ∪ Y) = (A ⊂ X) \/ (A ⊂ Y)

@@ -643,7 +779,9 @@ checkFormulas env beh (ProdCons (fp, ep) (fc, ec)) =

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

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

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

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

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

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

782+ anyOfAt

783+ beh'

646− anyOfAt beh' (NoMatchingCondition $ SomeCondition <$> ps)

784+ (NoMatchingCondition $ SomeCondition <$> ps)

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

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

648

786

649checkContradiction

787checkContradiction

@@ -662,54 +800,77 @@ checkImplication

662checkImplication env beh prods cons = case findExactly prods of

800checkImplication env beh prods cons = case findExactly prods of

663 Just e

801 Just e

664 | all (satisfiesTyped e) prods ->

802 | all (satisfiesTyped e) prods ->

665− if satisfiesTyped e cons then pure ()

803+ if satisfiesTyped e cons

804+ then pure ()

666 else issueAt beh (EnumDoesntSatisfy $ untypeValue e)

805 else issueAt beh (EnumDoesntSatisfy $ untypeValue e)

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

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

668 Nothing -> case cons of

807 Nothing -> case cons of

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

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

670 Exactly e -> issueAt beh (NoMatchingEnum $ untypeValue e)

809 Exactly e -> issueAt beh (NoMatchingEnum $ untypeValue e)

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

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

811+ Just m' ->

812+ if m' <= m

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

813+ then pure ()

673− else issueAt beh (MatchingMaximumWeak m m')

814+ else issueAt beh (MatchingMaximumWeak m m')

674 Nothing -> issueAt beh (NoMatchingMaximum m)

815 Nothing -> issueAt beh (NoMatchingMaximum m)

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

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

817+ Just m' ->

818+ if m' >= m

676− Just m' -> if m' >= m then pure ()

819+ then pure ()

677− else issueAt beh (MatchingMinimumWeak (coerce m) (coerce m'))

820+ else issueAt beh (MatchingMinimumWeak (coerce m) (coerce m'))

678 Nothing -> issueAt beh (NoMatchingMinimum (coerce m))

821 Nothing -> issueAt beh (NoMatchingMinimum (coerce m))

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

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

823+ Just m' ->

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

824+ if lcmScientific m m' == m'

825+ then pure ()

681− else issueAt beh (MatchingMultipleOfWeak m m')

826+ else issueAt beh (MatchingMultipleOfWeak m m')

682 Nothing -> issueAt beh (NoMatchingMultipleOf m)

827 Nothing -> issueAt beh (NoMatchingMultipleOf m)

828+ NumberFormat f ->

683− NumberFormat f -> if any (\case NumberFormat f' -> f == f'; _ -> False) prods

829+ if any (\case NumberFormat f' -> f == f'; _ -> False) prods

830+ then pure ()

684− then pure () else issueAt beh (NoMatchingFormat f)

831+ else issueAt beh (NoMatchingFormat f)

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

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

833+ Just m' ->

834+ if m' <= m

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

835+ then pure ()

687− else issueAt beh (MatchingMaxLengthWeak m m')

836+ else issueAt beh (MatchingMaxLengthWeak m m')

688 Nothing -> issueAt beh (NoMatchingMaxLength m)

837 Nothing -> issueAt beh (NoMatchingMaxLength m)

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

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

839+ Just m' ->

840+ if m' >= m

690− Just m' -> if m' >= m then pure ()

841+ then pure ()

691− else issueAt beh (MatchingMinLengthWeak m m')

842+ else issueAt beh (MatchingMinLengthWeak m m')

692 Nothing -> issueAt beh (NoMatchingMinLength m)

843 Nothing -> issueAt beh (NoMatchingMinLength m)

844+ Pattern p ->

693− Pattern p -> if any (\case Pattern p' -> p == p'; _ -> False) prods

845+ if any (\case Pattern p' -> p == p'; _ -> False) prods

846+ then pure ()

694− then pure () else issueAt beh (NoMatchingPattern p) -- TODO: regex comparison

847+ else issueAt beh (NoMatchingPattern p) -- TODO: regex comparison

848+ StringFormat f ->

695− StringFormat f -> if any (\case StringFormat f' -> f == f'; _ -> False) prods

849+ if any (\case StringFormat f' -> f == f'; _ -> False) prods

850+ then pure ()

696− then pure () else issueAt beh (NoMatchingFormat f)

851+ else issueAt beh (NoMatchingFormat f)

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

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

698 Just (rs NE.:| []) -> checkCompatibility env (beh >>> step InItems) $ ProdCons rs cons'

853 Just (rs NE.:| []) -> checkCompatibility env (beh >>> step InItems) $ ProdCons rs cons'

699 Just rs -> do

854 Just rs -> do

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

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

701 checkCompatibility env (beh >>> step InItems) $ ProdCons (traced (ask $ NE.head rs) sch) cons' -- TODO: bad trace

856 checkCompatibility env (beh >>> step InItems) $ ProdCons (traced (ask $ NE.head rs) sch) cons' -- TODO: bad trace

702 Nothing -> issueAt beh NoMatchingItems

857 Nothing -> issueAt beh NoMatchingItems

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

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

859+ Just m' ->

860+ if m' <= m

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

861+ then pure ()

705− else issueAt beh (MatchingMaxItemsWeak m m')

862+ else issueAt beh (MatchingMaxItemsWeak m m')

706 Nothing -> issueAt beh (NoMatchingMaxItems m)

863 Nothing -> issueAt beh (NoMatchingMaxItems m)

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

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

865+ Just m' ->

866+ if m' >= m

708− Just m' -> if m' >= m then pure ()

867+ then pure ()

709− else issueAt beh (MatchingMinItemsWeak m m')

868+ else issueAt beh (MatchingMinItemsWeak m m')

710 Nothing -> issueAt beh (NoMatchingMinItems m)

869 Nothing -> issueAt beh (NoMatchingMinItems m)

870+ UniqueItems ->

711− UniqueItems -> if any (== UniqueItems) $ prods then pure ()

871+ if any (== UniqueItems) $ prods

872+ then pure ()

712− else issueAt beh NoMatchingUniqueItems

873+ else issueAt beh NoMatchingUniqueItems

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

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

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

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

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

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

@@ -732,21 +893,25 @@ checkImplication env beh prods cons = case findExactly prods of

732 pure ()

893 pure ()

733 Nothing -> issueAt beh NoMatchingProperties

894 Nothing -> issueAt beh NoMatchingProperties

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

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

896+ Just m' ->

897+ if m' <= m

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

898+ then pure ()

736− else issueAt beh (MatchingMaxPropertiesWeak m m')

899+ else issueAt beh (MatchingMaxPropertiesWeak m m')

737 Nothing -> issueAt beh (NoMatchingMaxProperties m)

900 Nothing -> issueAt beh (NoMatchingMaxProperties m)

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

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

902+ Just m' ->

903+ if m' >= m

739− Just m' -> if m' >= m then pure ()

904+ then pure ()

740− else issueAt beh (MatchingMinPropertiesWeak m m')

905+ else issueAt beh (MatchingMinPropertiesWeak m m')

741 Nothing -> issueAt beh (NoMatchingMinProperties m)

906 Nothing -> issueAt beh (NoMatchingMinProperties m)

742 where

907 where

743− findExactly (Exactly x:_) = Just x

908+ findExactly (Exactly x : _) = Just x

744− findExactly (_:xs) = findExactly xs

909+ findExactly (_ : xs) = findExactly xs

745 findExactly [] = Nothing

910 findExactly [] = Nothing

746− findRelevant combine extr

911+ findRelevant combine extr =

747− = fmap (foldr1 combine) . NE.nonEmpty . mapMaybe extr

912+ fmap (foldr1 combine) . NE.nonEmpty . mapMaybe extr

748− lcmScientific (toRational -> a) (toRational -> b)

913+ lcmScientific (toRational -> a) (toRational -> b) =

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

914+ fromRational $ lcm (numerator a) (numerator b) % gcd (denominator a) (denominator b)

750

915

751instance Issuable 'TypedSchemaLevel where

916instance Issuable 'TypedSchemaLevel where

752 data Issue 'TypedSchemaLevel

917 data Issue 'TypedSchemaLevel

@@ -806,59 +971,52 @@ instance Subtree Schema where

806 type SubtreeLevel Schema = 'SchemaLevel

971 type SubtreeLevel Schema = 'SchemaLevel

807 type CheckEnv Schema = '[ProdCons (Traced (Definitions Schema))]

972 type CheckEnv Schema = '[ProdCons (Traced (Definitions Schema))]

808 checkStructuralCompatibility env pc = do

973 checkStructuralCompatibility env pc = do

809− traceShowM pc

810− structuralEq $ _schemaRequired <$> pc

974+ structuralEq $ fmap _schemaRequired <$> pc

811− structuralMaybeWith structuralEq $ _schemaNullable <$> pc

975+ structuralEq $ fmap _schemaNullable <$> pc

812− structuralMaybeWith (structuralList env) $ _schemaAllOf <$> pc

976+ structuralMaybeWith (structuralList env) $ tracedAllOf <$> pc

813− structuralMaybeWith (structuralList env) $ _schemaOneOf <$> pc

977+ structuralMaybeWith (structuralList env) $ tracedOneOf <$> pc

814− structuralMaybe env $ _schemaNot <$> pc

978+ structuralMaybe env $ sequence . stepTraced NotStep . fmap _schemaNot <$> pc

815− structuralMaybeWith (structuralList env) $ _schemaAnyOf <$> pc

979+ structuralMaybeWith (structuralList env) $ tracedAnyOf <$> pc

816− iohmStructural env $ _schemaProperties <$> pc

980+ iohmStructural env $ stepTraced PropertiesStep . fmap _schemaProperties <$> pc

817− structuralMaybeWith structuralAdditionalProperties $ _schemaAdditionalProperties <$> pc

981+ structuralMaybeWith structuralAdditionalProperties $ tracedAdditionalProperties <$> pc

818− structuralMaybeWith structuralDiscriminator $ _schemaDiscriminator <$> pc

982+ structuralMaybeWith structuralDiscriminator $ tracedDiscriminator <$> pc

819− structuralEq $ _schemaReadOnly <$> pc

983+ structuralEq $ fmap _schemaReadOnly <$> pc

820− structuralEq $ _schemaWriteOnly <$> pc

984+ structuralEq $ fmap _schemaWriteOnly <$> pc

821− structuralEq $ _schemaXml <$> pc

985+ structuralEq $ fmap _schemaXml <$> pc

822− structuralEq $ _schemaMaxProperties <$> pc

986+ structuralEq $ fmap _schemaMaxProperties <$> pc

823− structuralEq $ _schemaMinProperties <$> pc

987+ structuralEq $ fmap _schemaMinProperties <$> pc

824− structuralEq $ _schemaDefault <$> pc

988+ structuralEq $ fmap _schemaDefault <$> pc

825− structuralEq $ _schemaType <$> pc

989+ structuralEq $ fmap _schemaType <$> pc

826− structuralEq $ _schemaFormat <$> pc

990+ structuralEq $ fmap _schemaFormat <$> pc

827− structuralMaybeWith structuralItems $ _schemaItems <$> pc

991+ structuralMaybeWith structuralItems $ tracedItems <$> pc

828− structuralEq $ _schemaMaximum <$> pc

992+ structuralEq $ fmap _schemaMaximum <$> pc

829− structuralEq $ _schemaExclusiveMaximum <$> pc

993+ structuralEq $ fmap _schemaExclusiveMaximum <$> pc

830− structuralEq $ _schemaMinimum <$> pc

994+ structuralEq $ fmap _schemaMinimum <$> pc

831− structuralEq $ _schemaExclusiveMinimum <$> pc

995+ structuralEq $ fmap _schemaExclusiveMinimum <$> pc

832− structuralEq $ _schemaMaxLength <$> pc

996+ structuralEq $ fmap _schemaMaxLength <$> pc

833− structuralEq $ _schemaMinLength <$> pc

997+ structuralEq $ fmap _schemaMinLength <$> pc

834− structuralEq $ _schemaPattern <$> pc

998+ structuralEq $ fmap _schemaPattern <$> pc

835− structuralEq $ _schemaMaxItems <$> pc

999+ structuralEq $ fmap _schemaMaxItems <$> pc

836− structuralEq $ _schemaMinItems <$> pc

1000+ structuralEq $ fmap _schemaMinItems <$> pc

837− structuralEq $ _schemaUniqueItems <$> pc

1001+ structuralEq $ fmap _schemaUniqueItems <$> pc

838− structuralEq $ _schemaEnum <$> pc

1002+ structuralEq $ fmap _schemaEnum <$> pc

839− structuralEq $ _schemaMultipleOf <$> pc

1003+ structuralEq $ fmap _schemaMultipleOf <$> pc

840 pure ()

1004 pure ()

841 where

1005 where

842 structuralAdditionalProperties

1006 structuralAdditionalProperties

843− (ProdCons (AdditionalPropertiesAllowed x) (AdditionalPropertiesAllowed y)) =

1007+ (ProdCons (Left x) (Left y)) = unless (x == y) structuralIssue

844− structuralEq $ ProdCons x y

845 structuralAdditionalProperties

1008 structuralAdditionalProperties

846− (ProdCons (AdditionalPropertiesSchema x) (AdditionalPropertiesSchema y)) =

1009+ (ProdCons (Right x) (Right y)) =

847− checkStructuralCompatibility env $ ProdCons x y

1010+ checkSubstructure env $ ProdCons x y

848 structuralAdditionalProperties _ = structuralIssue

1011 structuralAdditionalProperties _ = structuralIssue

849 structuralDiscriminator pc' = do

1012 structuralDiscriminator pc' = do

850− structuralEq $ _discriminatorPropertyName <$> pc'

1013+ structuralEq $ fmap _discriminatorPropertyName <$> pc'

851− iohmStructuralWith

1014+ iohmStructural env $

852− (\_ mappingPC -> case A.decodeStrict @(Referenced Schema) . T.encodeUtf8 <$> mappingPC of

853− ProdCons (Just a) (Just b) -> checkStructuralCompatibility env $ ProdCons a b

854− ProdCons Nothing Nothing -> structuralEq mappingPC

855− _ -> structuralIssue

856− )

857− (_discriminatorMapping <$> pc')

1015+ stepTraced DiscriminatorMapping . fmap (fmap parseDiscriminatorValue . _discriminatorMapping) <$> pc'

858 pure ()

1016 pure ()

859− structuralItems (ProdCons (OpenApiItemsObject a) (OpenApiItemsObject b)) =

1017+ structuralItems (ProdCons (Left a) (Left b)) =

860− checkStructuralCompatibility env $ ProdCons a b

1018+ checkSubstructure env $ ProdCons a b

861− structuralItems (ProdCons (OpenApiItemsArray a) (OpenApiItemsArray b)) =

1019+ structuralItems (ProdCons (Right a) (Right b)) =

862 structuralList env $ ProdCons a b

1020 structuralList env $ ProdCons a b

863 structuralItems _ = structuralIssue

1021 structuralItems _ = structuralIssue

864 checkSemanticCompatibility env beh schs = do

1022 checkSemanticCompatibility env beh schs = do

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

@@ -49,7 +49,7 @@ instance Subtree [Server] where

49 type SubtreeLevel [Server] = 'OperationLevel

50 type CheckEnv [Server] = '[]

51 checkStructuralCompatibility _ pc =

52− structuralEq $ S.fromList . fmap reduceServer <$> pc

52+ structuralEq $ fmap S.fromList . (fmap . fmap) reduceServer <$> pc

53 where

54 reducerServerVariable =

55 fmap IOHM.toHashSet . _serverVariableEnum &&& _serverVariableDefault

@@ -136,7 +136,7 @@ instance Subtree ProcessedServer where

136 type SubtreeLevel ProcessedServer = 'ServerLevel

137 type CheckEnv ProcessedServer = '[]

138 checkStructuralCompatibility _ pc =

139− structuralEq $ (fmap . fmap . fmap) reducerServerVariable pc

139+ structuralEq $ (fmap . fmap . fmap . fmap) reducerServerVariable pc

140 where

141 reducerServerVariable =

142 fmap IOHM.toHashSet . _serverVariableEnum &&& _serverVariableDefault

test/Spec.hs+1−1

@@ -9,7 +9,7 @@ main = defaultMain =<< tests

9tests :: IO TestTree

10tests = do

11 goldenReportTree <- Spec.Golden.TraceTree.tests

12− return $

12+ return . localOption (mkTimeout 1000000) $

13 testGroup

14 "Golden tests"

15 [ goldenReportTree

test/golden/common/json/recursive/a.yamlnew file+44

@@ -0,0 +1,44 @@

1+openapi: 3.0.0

2+info:

3+ title: ""

4+ version: ""

5+servers:

6+- url: /

7+paths:

8+ /api/foo:

9+ get:

10+ responses:

11+ 200:

12+ description: ""

13+ content:

14+ application/json;charset=utf-8:

15+ schema:

16+ $ref: '#/components/schemas/Tree'

17+components:

18+ schemas:

19+ Tree:

20+ type: object

21+ properties:

22+ node:

23+ required:

24+ - children

25+ type: object

26+ properties:

27+ children:

28+ type: array

29+ items:

30+ $ref: '#/components/schemas/Tree'

31+ leaf:

32+ required:

33+ - value

34+ type: object

35+ properties:

36+ value:

37+ $ref: '#/components/schemas/Item'

38+ Item:

39+ required:

40+ - foo

41+ type: object

42+ properties:

43+ foo:

44+ type: string

test/golden/common/json/recursive/b.yamlnew file+44