@@ -1,13 +1,13 @@
1−module Data.OpenApi.Compare.Report
1+module OpenAPI.Checker.Report
2− ( generateReport,
2+ ( generateReport
3− CheckerOutput (..),
3+ , CheckerOutput(..)
4− ReportInput (..),
4+ , ReportInput (..)
5− segregateIssues,
5+ , segregateIssues
6− ReportStatus (..),
6+ , ReportStatus (..)
8− ReportConfig (..),
8+ , ReportConfig (..)
9− ReportTreeStyle (..),
9+ , ReportTreeStyle (..)
10− ReportMode (..),
10+ , ReportMode (..)
@@ -23,15 +23,6 @@ import qualified Data.Map as M
23import Data.Map.Ordered (OMap)
23import Data.Map.Ordered (OMap)
24import qualified Data.Map.Ordered as OM
24import qualified Data.Map.Ordered as OM
25import Data.Maybe
25import Data.Maybe
26−import Data.OpenApi.Compare.Behavior
27−import Data.OpenApi.Compare.Paths
28−import Data.OpenApi.Compare.PathsPrefixTree hiding (empty)
29−import qualified Data.OpenApi.Compare.PathsPrefixTree as P hiding (empty)
30−import Data.OpenApi.Compare.Report.Jet
31−import Data.OpenApi.Compare.Subtree (invertIssueOrientationP)
32−import Data.OpenApi.Compare.Validate.OpenApi
33−import Data.OpenApi.Compare.Validate.Schema.Issues
34−import Data.OpenApi.Compare.Validate.Schema.TypedJson
35import Data.OpenUnion
26import Data.OpenUnion
36import Data.OpenUnion.Extra
27import Data.OpenUnion.Extra
37import Data.Set
28import Data.Set
@@ -41,6 +32,15 @@ import qualified Data.Text as T
41import Data.TypeRepMap hiding (empty)
32import Data.TypeRepMap hiding (empty)
42import Data.Typeable
33import Data.Typeable
43import Generic.Data
34import Generic.Data
35+import OpenAPI.Checker.Behavior
36+import OpenAPI.Checker.Paths
37+import OpenAPI.Checker.PathsPrefixTree hiding (empty)
38+import qualified OpenAPI.Checker.PathsPrefixTree as P hiding (empty)
39+import OpenAPI.Checker.Report.Jet
40+import OpenAPI.Checker.Subtree (invertIssueOrientationP)
41+import OpenAPI.Checker.Validate.OpenApi
42+import OpenAPI.Checker.Validate.Schema.TypedJson
43+import OpenAPI.Checker.Validate.Schema.Issues
44import Text.Pandoc.Builder
44import Text.Pandoc.Builder
46type Changes = P.PathsPrefixTree Behave AnIssue 'APILevel
46type Changes = P.PathsPrefixTree Behave AnIssue 'APILevel
@@ -54,27 +54,22 @@ data CheckerOutput = CheckerOutput
54 deriving anyclass (ToJSON)
54 deriving anyclass (ToJSON)
56data ReportInput = ReportInput
56data ReportInput = ReportInput
57− { -- | forward 'CertainIssue', 'ProbablyIssue' and 'Comment'
58− breakingChanges :: Changes
57+ { breakingChanges :: Changes -- ^ forward 'CertainIssue', 'ProbablyIssue' and 'Comment'
59− , -- | backward 'CertainIssue', 'ProbablyIssue' and 'Comment', except those shadowed by 'relatedIssues'
58+ , nonBreakingChanges :: Changes -- ^ backward 'CertainIssue', 'ProbablyIssue' and 'Comment', except those shadowed by 'relatedIssues'
60− nonBreakingChanges :: Changes
61− , -- | forward and backward 'Unsupported' (assumed to be the same anyway)
59+ , unsupportedChanges :: Changes -- ^ forward and backward 'Unsupported' (assumed to be the same anyway)
62− unsupportedChanges :: Changes
63− , -- | forward and backward 'SchemaInvalid' (assumed to be the same anyway)
64− schemaIssues :: Changes
60+ , schemaIssues :: Changes -- ^ forward and backward 'SchemaInvalid' (assumed to be the same anyway)
66 deriving stock (Generic)
62 deriving stock (Generic)
67 deriving (Semigroup, Monoid) via (Generically ReportInput)
63 deriving (Semigroup, Monoid) via (Generically ReportInput)
68 deriving anyclass (ToJSON)
64 deriving anyclass (ToJSON)
70segregateIssues :: CheckerOutput -> ReportInput
66segregateIssues :: CheckerOutput -> ReportInput
71−segregateIssues CheckerOutput {forwardChanges = fwd, backwardChanges = bck} =
67+segregateIssues CheckerOutput {forwardChanges = fwd, backwardChanges = bck} = ReportInput
73− { breakingChanges = P.filter isBreaking fwd
68+ { breakingChanges = P.filter isBreaking fwd
74− , nonBreakingChanges = invertIssueOrientationP $ P.filterWithKey isNonBreaking bck
69+ , nonBreakingChanges = invertIssueOrientationP $ P.filterWithKey isNonBreaking bck
75− , unsupportedChanges = P.filter isUnsupported fwd <> P.filter isUnsupported bck
70+ , unsupportedChanges = P.filter isUnsupported fwd <> P.filter isUnsupported bck
76− , schemaIssues = P.filter isSchemaIssue fwd <> P.filter isSchemaIssue bck
71+ , schemaIssues = P.filter isSchemaIssue fwd <> P.filter isSchemaIssue bck
79 isBreaking i = anIssueKind i `elem` [CertainIssue, ProbablyIssue, Comment]
74 isBreaking i = anIssueKind i `elem` [CertainIssue, ProbablyIssue, Comment]
80 isNonBreaking :: Paths Behave 'APILevel a -> AnIssue a -> Bool
75 isNonBreaking :: Paths Behave 'APILevel a -> AnIssue a -> Bool
@@ -109,9 +104,10 @@ data ReportTreeStyle = HeadersTreeStyle | FoldingBlockquotesTreeStyle
109twoRowTable :: [(Inlines, Inlines)] -> Blocks
104twoRowTable :: [(Inlines, Inlines)] -> Blocks
110twoRowTable x = simpleTable (para . fst <$> x) [para . snd <$> x]
105twoRowTable x = simpleTable (para . fst <$> x) [para . snd <$> x]
112−generateReport :: ReportConfig -> ReportInput -> (Blocks, ReportStatus)
107+generateReport :: ReportConfig -> ReportInput -> (Pandoc, ReportStatus)
113generateReport cfg inp =
108generateReport cfg inp =
114− let schemaIssuesPresent = not $ P.null $ schemaIssues inp
110+ schemaIssuesPresent = not $ P.null $ schemaIssues inp
115 breakingChangesPresent = not $ P.null $ breakingChanges inp
111 breakingChangesPresent = not $ P.null $ breakingChanges inp
116 nonBreakingChangesPresent = not $ P.null $ nonBreakingChanges inp
112 nonBreakingChangesPresent = not $ P.null $ nonBreakingChanges inp
117 unsupportedChangesPresent = not $ P.null $ unsupportedChanges inp
113 unsupportedChangesPresent = not $ P.null $ unsupportedChanges inp
@@ -120,55 +116,46 @@ generateReport cfg inp =
120 OnlyErrors -> False
116 OnlyErrors -> False
121 builder = buildReport cfg
117 builder = buildReport cfg
123− header 1 "Summary"
120+ header 1 "Summary"
124− <> twoRowTable
121+ <> twoRowTable
126− schemaIssuesPresent
123+ schemaIssuesPresent
128− ( refOpt schemaIssuesPresent schemaIssuesId "‼️ Schema issues"
124+ [ ( refOpt schemaIssuesPresent schemaIssuesId "❌ Schema issues"
129− , show' $ P.size $ schemaIssues inp
125+ , show' $ P.size $ schemaIssues inp
133− ( refOpt breakingChangesPresent breakingChangesId "❌ Breaking changes"
129+ [ ( refOpt breakingChangesPresent breakingChangesId "⚠️ Breaking changes"
134 , show' $ P.size $ breakingChanges inp
130 , show' $ P.size $ breakingChanges inp
137− ++ when'
133+ ++ when'
138− nonBreakingChangesShown
134+ nonBreakingChangesShown
140− ( refOpt nonBreakingChangesPresent nonBreakingChangesId "⚠️ Non-breaking changes"
135+ [ ( refOpt nonBreakingChangesPresent nonBreakingChangesId "🙆 Non-breaking changes"
141− , show' $ P.size $ nonBreakingChanges inp
136+ , show' $ P.size $ nonBreakingChanges inp
145− unsupportedChangesPresent
147− ( refOpt unsupportedChangesPresent unsupportedChangesId "❓ Unsupported feature changes"
139+ ++ [ ( refOpt unsupportedChangesPresent unsupportedChangesId "🤷 Unsupported feature changes"
148− , show' $ P.size $ unsupportedChanges inp
140+ , show' $ P.size $ unsupportedChanges inp
152− <> when'
143+ <> when'
153− schemaIssuesPresent
144+ schemaIssuesPresent
154− ( header 1 (anchor schemaIssuesId <> "‼️ Schema issues")
145+ (header 1 (anchor schemaIssuesId <> "❌ Schema issues")
155− <> builder (showErrs $ schemaIssues inp)
146+ <> builder (showErrs $ schemaIssues inp))
157− <> when'
147+ <> when'
158− breakingChangesPresent
148+ breakingChangesPresent
159− ( header 1 (anchor breakingChangesId <> "❌ Breaking changes")
149+ (header 1 (anchor breakingChangesId <> "⚠️ Breaking changes")
160− <> builder (showErrs $ breakingChanges inp)
150+ <> builder (showErrs $ breakingChanges inp))
162− <> when'
151+ <> when'
163− (nonBreakingChangesPresent && nonBreakingChangesShown)
152+ (nonBreakingChangesPresent && nonBreakingChangesShown)
164− ( header 1 (anchor nonBreakingChangesId <> "⚠️ Non-breaking changes")
153+ (header 1 (anchor nonBreakingChangesId <> "🙆 Non-breaking changes")
165− <> builder (showErrs $ nonBreakingChanges inp)
154+ <> builder (showErrs $ nonBreakingChanges inp))
167− <> when'
155+ <> when'
168− unsupportedChangesPresent
156+ unsupportedChangesPresent
169− ( header 1 (anchor unsupportedChangesId <> "❓ Unsupported feature changes")
157+ (header 1 (anchor unsupportedChangesId <> "🤷 Unsupported feature changes")
170− <> builder (showErrs $ unsupportedChanges inp)
158+ <> builder (showErrs $ unsupportedChanges inp))
174 | breakingChangesPresent -> BreakingChanges
161 | breakingChangesPresent -> BreakingChanges
@@ -198,14 +185,13 @@ showErrs x@(P.PathsPrefixNode currentIssues _) =
198 let -- Extract this pattern if more cases like this arise
185 let -- Extract this pattern if more cases like this arise
199 ( removedPaths :: Maybe (Orientation, [Issue 'APILevel])
186 ( removedPaths :: Maybe (Orientation, [Issue 'APILevel])
200 , otherIssues :: Set (AnIssue a)
187 , otherIssues :: Set (AnIssue a)
201− ) = case eqT @a @ 'APILevel of
188+ ) = case eqT @a @'APILevel of
202 Just Refl
189 Just Refl
203 | (S.toList -> p@((AnIssue ori _) : _), o) <-
190 | (S.toList -> p@((AnIssue ori _) : _), o) <-
204 S.partition
191 S.partition
205− ( \((AnIssue _ u)) -> case u of
192+ (\((AnIssue _ u)) -> case u of
206− NoPathsMatched {} -> True
193+ NoPathsMatched {} -> True
207− AllPathsFailed {} -> True
194+ AllPathsFailed {} -> True)
209 currentIssues ->
195 currentIssues ->
210 let p' = p <&> (\(AnIssue _ i) -> i)
196 let p' = p <&> (\(AnIssue _ i) -> i)
211 in (Just (ori, p'), o)
197 in (Just (ori, p'), o)
@@ -216,10 +202,9 @@ showErrs x@(P.PathsPrefixNode currentIssues _) =
216 paths = case removedPaths of
202 paths = case removedPaths of
217 Just (ori, ps) -> do
203 Just (ori, ps) -> do
218 singletonHeader
204 singletonHeader
219− ( case ori of
205+ (case ori of
220− Forward -> "Removed paths"
206+ Forward -> "Removed paths"
221− Backward -> "Added paths"
207+ Backward -> "Added paths")
223 $ singletonBody $
208 $ singletonBody $
224 bulletList $
209 bulletList $
225 ps <&> \case
210 ps <&> \case
@@ -255,62 +240,60 @@ jets =
255 , constructReportJet $ \p@(AtPath _) op@(InOperation _) ->
240 , constructReportJet $ \p@(AtPath _) op@(InOperation _) ->
256 strong (describeBehavior op) <> " " <> describeBehavior p :: Inlines
241 strong (describeBehavior op) <> " " <> describeBehavior p :: Inlines
257 , constructReportJet $ \(WithStatusCode c) ResponsePayload PayloadSchema ->
242 , constructReportJet $ \(WithStatusCode c) ResponsePayload PayloadSchema ->
258− "⬅️☁️ JSON Response – " <> str (T.pack . show $ c) :: Inlines
243+ "📱⬅️ JSON Response – " <> str (T.pack . show $ c) :: Inlines
259− , constructReportJet $ \InRequest InPayload PayloadSchema -> "➡️☁️ JSON Request" :: Inlines
244+ , constructReportJet $ \InRequest InPayload PayloadSchema -> "📱➡️ JSON Request" :: Inlines
262 unwrapReportJetResult :: ReportJetResult Behave x -> ReportJet' Behave x
247 unwrapReportJetResult :: ReportJetResult Behave x -> ReportJet' Behave x
263 unwrapReportJetResult (Pure _) = error "There really shouldn't be any results here."
248 unwrapReportJetResult (Pure _) = error "There really shouldn't be any results here."
264 unwrapReportJetResult (Free f) = f
249 unwrapReportJetResult (Free f) = f
266− jsonPathJet ::
251+ jsonPathJet
267− NonEmpty
252+ :: NonEmpty
269− '[ Behave 'SchemaLevel 'TypedSchemaLevel
254+ '[ Behave 'SchemaLevel 'TypedSchemaLevel
270− , Behave 'TypedSchemaLevel 'SchemaLevel
255+ , Behave 'TypedSchemaLevel 'SchemaLevel
273− Inlines
258+ -> Inlines
274 jsonPathJet x = code $ "$" <> showParts (NE.toList x)
259 jsonPathJet x = code $ "$" <> showParts (NE.toList x)
276− showParts ::
261+ showParts
277− [ Union
262+ :: [ Union
278− '[ Behave 'SchemaLevel 'TypedSchemaLevel
263+ '[ Behave 'SchemaLevel 'TypedSchemaLevel
279− , Behave 'TypedSchemaLevel 'SchemaLevel
264+ , Behave 'TypedSchemaLevel 'SchemaLevel
283 showParts [] = mempty
268 showParts [] = mempty
284 showParts (SingletonUnion (OfType Object) : xs@((SingletonUnion (InProperty _)) : _)) = showParts xs
269 showParts (SingletonUnion (OfType Object) : xs@((SingletonUnion (InProperty _)) : _)) = showParts xs
285 showParts (SingletonUnion (OfType Object) : xs@((SingletonUnion InAdditionalProperty) : _)) = showParts xs
270 showParts (SingletonUnion (OfType Object) : xs@((SingletonUnion InAdditionalProperty) : _)) = showParts xs
286 showParts (SingletonUnion (OfType Array) : xs@(SingletonUnion InItems : _)) = showParts xs
271 showParts (SingletonUnion (OfType Array) : xs@(SingletonUnion InItems : _)) = showParts xs
287 showParts (SingletonUnion (OfType Array) : xs@(SingletonUnion (InItem _) : _)) = showParts xs
272 showParts (SingletonUnion (OfType Array) : xs@(SingletonUnion (InItem _) : _)) = showParts xs
288 showParts (y : ys) =
273 showParts (y : ys) =
289− ( (\(OfType t) -> "(" <> describeJSONType t <> ")")
274+ ((\(OfType t) -> "(" <> describeJSONType t <> ")")
290− @@> ( \case
275+ @@> (\case
291− InItems -> "[*]"
276+ InItems -> "[*]"
292− InItem i -> "[" <> T.pack (show i) <> "]"
277+ InItem i -> "[" <> T.pack (show i) <> "]"
293− InProperty p -> "." <> p
278+ InProperty p -> "." <> p
294− InAdditionalProperty -> ".*"
279+ InAdditionalProperty -> ".*")
296− @@> typesExhausted
280+ @@> typesExhausted)
299 <> showParts ys
282 <> showParts ys
301−observeJetShowErrs ::
284+observeJetShowErrs
302− ReportJet' Behave (Maybe Inlines) ->
285+ :: ReportJet' Behave (Maybe Inlines)
303− P.PathsPrefixTree Behave AnIssue a ->
286+ -> P.PathsPrefixTree Behave AnIssue a
304− (Report, P.PathsPrefixTree Behave AnIssue a)
287+ -> (Report, P.PathsPrefixTree Behave AnIssue a)
305observeJetShowErrs jet p = case observeJetShowErrs' jet p of
288observeJetShowErrs jet p = case observeJetShowErrs' jet p of
306 Just m -> m
289 Just m -> m
307 Nothing -> (mempty, p)
290 Nothing -> (mempty, p)
309−observeJetShowErrs' ::
292+observeJetShowErrs'
310− forall a.
293+ :: forall a.
311− ReportJet' Behave (Maybe Inlines) ->
294+ ReportJet' Behave (Maybe Inlines)
312− P.PathsPrefixTree Behave AnIssue a ->
295+ -> P.PathsPrefixTree Behave AnIssue a
313− Maybe (Report, P.PathsPrefixTree Behave AnIssue a)
296+ -> Maybe (Report, P.PathsPrefixTree Behave AnIssue a)
314observeJetShowErrs' (ReportJet jet) (P.PathsPrefixNode currentIssues subIssues) =
297observeJetShowErrs' (ReportJet jet) (P.PathsPrefixNode currentIssues subIssues) =
315 let results =
298 let results =
316 subIssues >>= \(WrapTypeable (AStep m)) ->
299 subIssues >>= \(WrapTypeable (AStep m)) ->
@@ -318,23 +301,21 @@ observeJetShowErrs' (ReportJet jet) (P.PathsPrefixNode currentIssues subIssues)
318 maybe (Left $ embed (step bhv) subErrs) Right . listToMaybe $
301 maybe (Left $ embed (step bhv) subErrs) Right . listToMaybe $
319 jet @_ @_ @[] bhv
302 jet @_ @_ @[] bhv
320 & mapMaybe
303 & mapMaybe
322− Free jet' -> fmap (embed $ step bhv) <$> observeJetShowErrs' jet' subErrs
305+ Free jet' -> fmap (embed $ step bhv) <$> observeJetShowErrs' jet' subErrs
323− Pure (Just h) ->
306+ Pure (Just h) ->
324− if P.null subErrs
307+ if P.null subErrs
325− then Just mempty
308+ then Just mempty
326− else Just (singletonHeader h (showErrs subErrs), mempty)
309+ else Just (singletonHeader h (showErrs subErrs), mempty)
327− Pure Nothing -> Nothing
310+ Pure Nothing -> Nothing)
329 in (fmap . fmap) (PathsPrefixNode currentIssues mempty <>) $
311 in (fmap . fmap) (PathsPrefixNode currentIssues mempty <>) $
330 if any isRight results
312 if any isRight results
335− Left e -> (mempty, e)
317+ Left e -> (mempty, e)
336− Right m -> m
318+ Right m -> m)
339 else Nothing
320 else Nothing
@@ -357,9 +338,8 @@ buildReport cfg = case treeStyle cfg of
357 body rprt
338 body rprt
358 <> foldOMapWithKey
339 <> foldOMapWithKey
359 (headers rprt)
340 (headers rprt)
360− ( \k v ->
341+ (\k v ->
361− header level k <> subBuilder v
342+ header level k <> subBuilder v)
364 subBuilder = headerStyleBuilder (level + 1)
344 subBuilder = headerStyleBuilder (level + 1)
@@ -368,17 +348,16 @@ buildReport cfg = case treeStyle cfg of
368 body rprt
348 body rprt
369 <> foldOMapWithKey
349 <> foldOMapWithKey
370 (headers rprt)
350 (headers rprt)
371− ( \k v ->
351+ (\k v ->
372− if (OM.size . headers $ rprt) < 2
352+ if (OM.size . headers $ rprt) < 2
373− then para k <> blockQuote (subBuilder v)
353+ then para k <> blockQuote (subBuilder v)
375− rawHtml "<details>"
355+ rawHtml "<details>"
376− <> rawHtml "<summary>"
356+ <> rawHtml "<summary>"
377− <> plain k
357+ <> plain k
378− <> rawHtml "</summary>"
358+ <> rawHtml "</summary>"
379− <> blockQuote (subBuilder v)
359+ <> blockQuote (subBuilder v)
380− <> rawHtml "</details>"
360+ <> rawHtml "</details>")
383 subBuilder = foldingStyleBuilder
362 subBuilder = foldingStyleBuilder