@@ -1,13 +1,13 @@
1−module OpenAPI.Checker.Report
2− ( generateReport
3− , CheckerOutput(..)
4− , ReportInput (..)
5− , segregateIssues
6− , ReportStatus (..)
7− , Pandoc
8− , ReportConfig (..)
9− , ReportTreeStyle (..)
10− , ReportMode (..)
1+module Data.OpenApi.Compare.Report
2+ ( generateReport,
3+ CheckerOutput (..),
4+ ReportInput (..),
5+ segregateIssues,
6+ ReportStatus (..),
7+ Pandoc,
8+ ReportConfig (..),
9+ ReportTreeStyle (..),
10+ ReportMode (..),
1111 )
1212where
1313
@@ -23,6 +23,15 @@ import qualified Data.Map as M
2323import Data.Map.Ordered (OMap)
2424import qualified Data.Map.Ordered as OM
2525import 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
2635import Data.OpenUnion
2736import Data.OpenUnion.Extra
2837import Data.Set
@@ -32,15 +41,6 @@ import qualified Data.Text as T
3241import Data.TypeRepMap hiding (empty)
3342import Data.Typeable
3443import 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
4444import Text.Pandoc.Builder
4545
4646type Changes = P.PathsPrefixTree Behave AnIssue 'APILevel
@@ -54,22 +54,27 @@ data CheckerOutput = CheckerOutput
5454 deriving anyclass (ToJSON)
5555
5656data ReportInput = ReportInput
57− { breakingChanges :: Changes -- ^ forward 'CertainIssue', 'ProbablyIssue' and 'Comment'
58− , nonBreakingChanges :: Changes -- ^ backward 'CertainIssue', 'ProbablyIssue' and 'Comment', except those shadowed by 'relatedIssues'
59− , unsupportedChanges :: Changes -- ^ forward and backward 'Unsupported' (assumed to be the same anyway)
60− , schemaIssues :: Changes -- ^ forward and backward 'SchemaInvalid' (assumed to be the same anyway)
57+ { -- | forward 'CertainIssue', 'ProbablyIssue' and 'Comment'
58+ breakingChanges :: Changes
59+ , -- | backward 'CertainIssue', 'ProbablyIssue' and 'Comment', except those shadowed by 'relatedIssues'
60+ nonBreakingChanges :: Changes
61+ , -- | 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
6165 }
6266 deriving stock (Generic)
6367 deriving (Semigroup, Monoid) via (Generically ReportInput)
6468 deriving anyclass (ToJSON)
6569
6670segregateIssues :: CheckerOutput -> ReportInput
67−segregateIssues CheckerOutput {forwardChanges = fwd, backwardChanges = bck} = ReportInput
68− { breakingChanges = P.filter isBreaking fwd
69− , nonBreakingChanges = invertIssueOrientationP $ P.filterWithKey isNonBreaking bck
70− , unsupportedChanges = P.filter isUnsupported fwd <> P.filter isUnsupported bck
71− , schemaIssues = P.filter isSchemaIssue fwd <> P.filter isSchemaIssue bck
72− }
71+segregateIssues CheckerOutput {forwardChanges = fwd, backwardChanges = bck} =
72+ ReportInput
73+ { breakingChanges = P.filter isBreaking fwd
74+ , nonBreakingChanges = invertIssueOrientationP $ P.filterWithKey isNonBreaking bck
75+ , unsupportedChanges = P.filter isUnsupported fwd <> P.filter isUnsupported bck
76+ , schemaIssues = P.filter isSchemaIssue fwd <> P.filter isSchemaIssue bck
77+ }
7378 where
7479 isBreaking i = anIssueKind i `elem` [CertainIssue, ProbablyIssue, Comment]
7580 isNonBreaking :: Paths Behave 'APILevel a -> AnIssue a -> Bool
@@ -104,10 +109,9 @@ data ReportTreeStyle = HeadersTreeStyle | FoldingBlockquotesTreeStyle
104109twoRowTable :: [(Inlines, Inlines)] -> Blocks
105110twoRowTable x = simpleTable (para . fst <$> x) [para . snd <$> x]
106111
107−generateReport :: ReportConfig -> ReportInput -> (Pandoc, ReportStatus)
112+generateReport :: ReportConfig -> ReportInput -> (Blocks, ReportStatus)
108113generateReport cfg inp =
109− let
110− schemaIssuesPresent = not $ P.null $ schemaIssues inp
114+ let schemaIssuesPresent = not $ P.null $ schemaIssues inp
111115 breakingChangesPresent = not $ P.null $ breakingChanges inp
112116 nonBreakingChangesPresent = not $ P.null $ nonBreakingChanges inp
113117 unsupportedChangesPresent = not $ P.null $ unsupportedChanges inp
@@ -116,46 +120,55 @@ generateReport cfg inp =
116120 OnlyErrors -> False
117121 builder = buildReport cfg
118122 report =
119− doc $
120− header 1 "Summary"
121− <> twoRowTable
122− (when'
123− schemaIssuesPresent
124− [ ( refOpt schemaIssuesPresent schemaIssuesId "❌ Schema issues"
125− , show' $ P.size $ schemaIssues inp
126− )
127− ]
128− ++
129− [ ( refOpt breakingChangesPresent breakingChangesId "⚠️ Breaking changes"
123+ header 1 "Summary"
124+ <> twoRowTable
125+ ( when'
126+ schemaIssuesPresent
127+ [
128+ ( refOpt schemaIssuesPresent schemaIssuesId "‼️ Schema issues"
129+ , show' $ P.size $ schemaIssues inp
130+ )
131+ ]
132+ ++ [
133+ ( refOpt breakingChangesPresent breakingChangesId "❌ Breaking changes"
130134 , show' $ P.size $ breakingChanges inp
131135 )
132136 ]
133− ++ when'
134− nonBreakingChangesShown
135− [ ( refOpt nonBreakingChangesPresent nonBreakingChangesId "🙆 Non-breaking changes"
136− , show' $ P.size $ nonBreakingChanges inp
137− )
138− ]
139− ++ [ ( refOpt unsupportedChangesPresent unsupportedChangesId "🤷 Unsupported feature changes"
140− , show' $ P.size $ unsupportedChanges inp
141− )
142− ])
143− <> when'
144− schemaIssuesPresent
145− (header 1 (anchor schemaIssuesId <> "❌ Schema issues")
146− <> builder (showErrs $ schemaIssues inp))
147− <> when'
148− breakingChangesPresent
149− (header 1 (anchor breakingChangesId <> "⚠️ Breaking changes")
150− <> builder (showErrs $ breakingChanges inp))
151− <> when'
152− (nonBreakingChangesPresent && nonBreakingChangesShown)
153− (header 1 (anchor nonBreakingChangesId <> "🙆 Non-breaking changes")
154− <> builder (showErrs $ nonBreakingChanges inp))
155− <> when'
156− unsupportedChangesPresent
157− (header 1 (anchor unsupportedChangesId <> "🤷 Unsupported feature changes")
158− <> builder (showErrs $ unsupportedChanges inp))
137+ ++ when'
138+ nonBreakingChangesShown
139+ [
140+ ( refOpt nonBreakingChangesPresent nonBreakingChangesId "⚠️ Non-breaking changes"
141+ , show' $ P.size $ nonBreakingChanges inp
142+ )
143+ ]
144+ ++ when'
145+ unsupportedChangesPresent
146+ [
147+ ( refOpt unsupportedChangesPresent unsupportedChangesId "❓ Unsupported feature changes"
148+ , show' $ P.size $ unsupportedChanges inp
149+ )
150+ ]
151+ )
152+ <> when'
153+ schemaIssuesPresent
154+ ( header 1 (anchor schemaIssuesId <> "‼️ Schema issues")
155+ <> builder (showErrs $ schemaIssues inp)
156+ )
157+ <> when'
158+ breakingChangesPresent
159+ ( header 1 (anchor breakingChangesId <> "❌ Breaking changes")
160+ <> builder (showErrs $ breakingChanges inp)
161+ )
162+ <> when'
163+ (nonBreakingChangesPresent && nonBreakingChangesShown)
164+ ( header 1 (anchor nonBreakingChangesId <> "⚠️ Non-breaking changes")
165+ <> builder (showErrs $ nonBreakingChanges inp)
166+ )
167+ <> when'
168+ unsupportedChangesPresent
169+ ( header 1 (anchor unsupportedChangesId <> "❓ Unsupported feature changes")
170+ <> builder (showErrs $ unsupportedChanges inp)
171+ )
159172 status =
160173 if
161174 | breakingChangesPresent -> BreakingChanges
@@ -185,13 +198,14 @@ showErrs x@(P.PathsPrefixNode currentIssues _) =
185198 let -- Extract this pattern if more cases like this arise
186199 ( removedPaths :: Maybe (Orientation, [Issue 'APILevel])
187200 , otherIssues :: Set (AnIssue a)
188− ) = case eqT @a @'APILevel of
201+ ) = case eqT @a @ 'APILevel of
189202 Just Refl
190203 | (S.toList -> p@((AnIssue ori _) : _), o) <-
191204 S.partition
192− (\((AnIssue _ u)) -> case u of
193− NoPathsMatched {} -> True
194− AllPathsFailed {} -> True)
205+ ( \((AnIssue _ u)) -> case u of
206+ NoPathsMatched {} -> True
207+ AllPathsFailed {} -> True
208+ )
195209 currentIssues ->
196210 let p' = p <&> (\(AnIssue _ i) -> i)
197211 in (Just (ori, p'), o)
@@ -202,9 +216,10 @@ showErrs x@(P.PathsPrefixNode currentIssues _) =
202216 paths = case removedPaths of
203217 Just (ori, ps) -> do
204218 singletonHeader
205− (case ori of
206− Forward -> "Removed paths"
207− Backward -> "Added paths")
219+ ( case ori of
220+ Forward -> "Removed paths"
221+ Backward -> "Added paths"
222+ )
208223 $ singletonBody $
209224 bulletList $
210225 ps <&> \case
@@ -240,60 +255,62 @@ jets =
240255 , constructReportJet $ \p@(AtPath _) op@(InOperation _) ->
241256 strong (describeBehavior op) <> " " <> describeBehavior p :: Inlines
242257 , constructReportJet $ \(WithStatusCode c) ResponsePayload PayloadSchema ->
243− "📱⬅️ JSON Response – " <> str (T.pack . show $ c) :: Inlines
244− , constructReportJet $ \InRequest InPayload PayloadSchema -> "📱➡️ JSON Request" :: Inlines
258+ "⬅️☁️ JSON Response – " <> str (T.pack . show $ c) :: Inlines
259+ , constructReportJet $ \InRequest InPayload PayloadSchema -> "➡️☁️ JSON Request" :: Inlines
245260 ]
246261 where
247262 unwrapReportJetResult :: ReportJetResult Behave x -> ReportJet' Behave x
248263 unwrapReportJetResult (Pure _) = error "There really shouldn't be any results here."
249264 unwrapReportJetResult (Free f) = f
250265
251− jsonPathJet
252− :: NonEmpty
253− ( Union
254− '[ Behave 'SchemaLevel 'TypedSchemaLevel
255− , Behave 'TypedSchemaLevel 'SchemaLevel
256− ]
257− )
258− -> Inlines
266+ jsonPathJet ::
267+ NonEmpty
268+ ( Union
269+ '[ Behave 'SchemaLevel 'TypedSchemaLevel
270+ , Behave 'TypedSchemaLevel 'SchemaLevel
271+ ]
272+ ) ->
273+ Inlines
259274 jsonPathJet x = code $ "$" <> showParts (NE.toList x)
260275 where
261− showParts
262− :: [ Union
263− '[ Behave 'SchemaLevel 'TypedSchemaLevel
264− , Behave 'TypedSchemaLevel 'SchemaLevel
265− ]
266− ]
267− -> Text
276+ showParts ::
277+ [ Union
278+ '[ Behave 'SchemaLevel 'TypedSchemaLevel
279+ , Behave 'TypedSchemaLevel 'SchemaLevel
280+ ]
281+ ] ->
282+ Text
268283 showParts [] = mempty
269284 showParts (SingletonUnion (OfType Object) : xs@((SingletonUnion (InProperty _)) : _)) = showParts xs
270285 showParts (SingletonUnion (OfType Object) : xs@((SingletonUnion InAdditionalProperty) : _)) = showParts xs
271286 showParts (SingletonUnion (OfType Array) : xs@(SingletonUnion InItems : _)) = showParts xs
272287 showParts (SingletonUnion (OfType Array) : xs@(SingletonUnion (InItem _) : _)) = showParts xs
273288 showParts (y : ys) =
274− ((\(OfType t) -> "(" <> describeJSONType t <> ")")
275− @@> (\case
276− InItems -> "[*]"
277− InItem i -> "[" <> T.pack (show i) <> "]"
278− InProperty p -> "." <> p
279− InAdditionalProperty -> ".*")
280− @@> typesExhausted)
289+ ( (\(OfType t) -> "(" <> describeJSONType t <> ")")
290+ @@> ( \case
291+ InItems -> "[*]"
292+ InItem i -> "[" <> T.pack (show i) <> "]"
293+ InProperty p -> "." <> p
294+ InAdditionalProperty -> ".*"
295+ )
296+ @@> typesExhausted
297+ )
281298 y
282299 <> showParts ys
283300
284−observeJetShowErrs
285− :: ReportJet' Behave (Maybe Inlines)
286− -> P.PathsPrefixTree Behave AnIssue a
287− -> (Report, P.PathsPrefixTree Behave AnIssue a)
301+observeJetShowErrs ::
302+ ReportJet' Behave (Maybe Inlines) ->
303+ P.PathsPrefixTree Behave AnIssue a ->
304+ (Report, P.PathsPrefixTree Behave AnIssue a)
288305observeJetShowErrs jet p = case observeJetShowErrs' jet p of
289306 Just m -> m
290307 Nothing -> (mempty, p)
291308
292−observeJetShowErrs'
293− :: forall a.
294− ReportJet' Behave (Maybe Inlines)
295− -> P.PathsPrefixTree Behave AnIssue a
296− -> Maybe (Report, P.PathsPrefixTree Behave AnIssue a)
309+observeJetShowErrs' ::
310+ forall a.
311+ ReportJet' Behave (Maybe Inlines) ->
312+ P.PathsPrefixTree Behave AnIssue a ->
313+ Maybe (Report, P.PathsPrefixTree Behave AnIssue a)
297314observeJetShowErrs' (ReportJet jet) (P.PathsPrefixNode currentIssues subIssues) =
298315 let results =
299316 subIssues >>= \(WrapTypeable (AStep m)) ->
@@ -301,21 +318,23 @@ observeJetShowErrs' (ReportJet jet) (P.PathsPrefixNode currentIssues subIssues)
301318 maybe (Left $ embed (step bhv) subErrs) Right . listToMaybe $
302319 jet @_ @_ @[] bhv
303320 & mapMaybe
304− (\case
305− Free jet' -> fmap (embed $ step bhv) <$> observeJetShowErrs' jet' subErrs
306− Pure (Just h) ->
307− if P.null subErrs
308− then Just mempty
309− else Just (singletonHeader h (showErrs subErrs), mempty)
310− Pure Nothing -> Nothing)
321+ ( \case
322+ Free jet' -> fmap (embed $ step bhv) <$> observeJetShowErrs' jet' subErrs
323+ Pure (Just h) ->
324+ if P.null subErrs
325+ then Just mempty
326+ else Just (singletonHeader h (showErrs subErrs), mempty)
327+ Pure Nothing -> Nothing
328+ )
311329 in (fmap . fmap) (PathsPrefixNode currentIssues mempty <>) $
312330 if any isRight results
313331 then
314332 Just $
315333 foldMap
316− (\case
317− Left e -> (mempty, e)
318− Right m -> m)
334+ ( \case
335+ Left e -> (mempty, e)
336+ Right m -> m
337+ )
319338 results
320339 else Nothing
321340
@@ -338,8 +357,9 @@ buildReport cfg = case treeStyle cfg of
338357 body rprt
339358 <> foldOMapWithKey
340359 (headers rprt)
341− (\k v ->
342− header level k <> subBuilder v)
360+ ( \k v ->
361+ header level k <> subBuilder v
362+ )
343363 where
344364 subBuilder = headerStyleBuilder (level + 1)
345365
@@ -348,16 +368,17 @@ buildReport cfg = case treeStyle cfg of
348368 body rprt
349369 <> foldOMapWithKey
350370 (headers rprt)
351− (\k v ->
352− if (OM.size . headers $ rprt) < 2
353− then para k <> blockQuote (subBuilder v)
354− else
355− rawHtml "<details>"
356− <> rawHtml "<summary>"
357− <> plain k
358− <> rawHtml "</summary>"
359− <> blockQuote (subBuilder v)
360− <> rawHtml "</details>")
371+ ( \k v ->
372+ if (OM.size . headers $ rprt) < 2
373+ then para k <> blockQuote (subBuilder v)
374+ else
375+ rawHtml "<details>"
376+ <> rawHtml "<summary>"
377+ <> plain k
378+ <> rawHtml "</summary>"
379+ <> blockQuote (subBuilder v)
380+ <> rawHtml "</details>"
381+ )
361382 where
362383 subBuilder = foldingStyleBuilder
363384