@@ -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
@@ -106,8 +111,7 @@ twoRowTable x = simpleTable (para . fst <$> x) [para . snd <$> x]
106111
107112generateReport :: 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,45 +120,55 @@ generateReport cfg inp =
116120 OnlyErrors -> False
117121 builder = buildReport cfg
118122 report =
119− header 1 "Summary"
120− <> twoRowTable
121− (when'
122− schemaIssuesPresent
123− [ ( refOpt schemaIssuesPresent schemaIssuesId "❌ Schema issues"
124− , show' $ P.size $ schemaIssues inp
125− )
126− ]
127− ++
128− [ ( 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"
129134 , show' $ P.size $ breakingChanges inp
130135 )
131136 ]
132− ++ when'
133− nonBreakingChangesShown
134− [ ( refOpt nonBreakingChangesPresent nonBreakingChangesId "🙆 Non-breaking changes"
135− , show' $ P.size $ nonBreakingChanges inp
136− )
137− ]
138− ++ [ ( refOpt unsupportedChangesPresent unsupportedChangesId "🤷 Unsupported feature changes"
139− , show' $ P.size $ unsupportedChanges inp
140− )
141− ])
142− <> when'
143− schemaIssuesPresent
144− (header 1 (anchor schemaIssuesId <> "❌ Schema issues")
145− <> builder (showErrs $ schemaIssues inp))
146− <> when'
147− breakingChangesPresent
148− (header 1 (anchor breakingChangesId <> "⚠️ Breaking changes")
149− <> builder (showErrs $ breakingChanges inp))
150− <> when'
151− (nonBreakingChangesPresent && nonBreakingChangesShown)
152− (header 1 (anchor nonBreakingChangesId <> "🙆 Non-breaking changes")
153− <> builder (showErrs $ nonBreakingChanges inp))
154− <> when'
155− unsupportedChangesPresent
156− (header 1 (anchor unsupportedChangesId <> "🤷 Unsupported feature changes")
157− <> 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+ )
158172 status =
159173 if
160174 | breakingChangesPresent -> BreakingChanges
@@ -184,13 +198,14 @@ showErrs x@(P.PathsPrefixNode currentIssues _) =
184198 let -- Extract this pattern if more cases like this arise
185199 ( removedPaths :: Maybe (Orientation, [Issue 'APILevel])
186200 , otherIssues :: Set (AnIssue a)
187− ) = case eqT @a @'APILevel of
201+ ) = case eqT @a @ 'APILevel of
188202 Just Refl
189203 | (S.toList -> p@((AnIssue ori _) : _), o) <-
190204 S.partition
191− (\((AnIssue _ u)) -> case u of
192− NoPathsMatched {} -> True
193− AllPathsFailed {} -> True)
205+ ( \((AnIssue _ u)) -> case u of
206+ NoPathsMatched {} -> True
207+ AllPathsFailed {} -> True
208+ )
194209 currentIssues ->
195210 let p' = p <&> (\(AnIssue _ i) -> i)
196211 in (Just (ori, p'), o)
@@ -201,9 +216,10 @@ showErrs x@(P.PathsPrefixNode currentIssues _) =
201216 paths = case removedPaths of
202217 Just (ori, ps) -> do
203218 singletonHeader
204− (case ori of
205− Forward -> "Removed paths"
206− Backward -> "Added paths")
219+ ( case ori of
220+ Forward -> "Removed paths"
221+ Backward -> "Added paths"
222+ )
207223 $ singletonBody $
208224 bulletList $
209225 ps <&> \case
@@ -239,60 +255,62 @@ jets =
239255 , constructReportJet $ \p@(AtPath _) op@(InOperation _) ->
240256 strong (describeBehavior op) <> " " <> describeBehavior p :: Inlines
241257 , constructReportJet $ \(WithStatusCode c) ResponsePayload PayloadSchema ->
242− "📱⬅️ JSON Response – " <> str (T.pack . show $ c) :: Inlines
243− , constructReportJet $ \InRequest InPayload PayloadSchema -> "📱➡️ JSON Request" :: Inlines
258+ "⬅️☁️ JSON Response – " <> str (T.pack . show $ c) :: Inlines
259+ , constructReportJet $ \InRequest InPayload PayloadSchema -> "➡️☁️ JSON Request" :: Inlines
244260 ]
245261 where
246262 unwrapReportJetResult :: ReportJetResult Behave x -> ReportJet' Behave x
247263 unwrapReportJetResult (Pure _) = error "There really shouldn't be any results here."
248264 unwrapReportJetResult (Free f) = f
249265
250− jsonPathJet
251− :: NonEmpty
252− ( Union
253− '[ Behave 'SchemaLevel 'TypedSchemaLevel
254− , Behave 'TypedSchemaLevel 'SchemaLevel
255− ]
256− )
257− -> Inlines
266+ jsonPathJet ::
267+ NonEmpty
268+ ( Union
269+ '[ Behave 'SchemaLevel 'TypedSchemaLevel
270+ , Behave 'TypedSchemaLevel 'SchemaLevel
271+ ]
272+ ) ->
273+ Inlines
258274 jsonPathJet x = code $ "$" <> showParts (NE.toList x)
259275 where
260− showParts
261− :: [ Union
262− '[ Behave 'SchemaLevel 'TypedSchemaLevel
263− , Behave 'TypedSchemaLevel 'SchemaLevel
264− ]
265− ]
266− -> Text
276+ showParts ::
277+ [ Union
278+ '[ Behave 'SchemaLevel 'TypedSchemaLevel
279+ , Behave 'TypedSchemaLevel 'SchemaLevel
280+ ]
281+ ] ->
282+ Text
267283 showParts [] = mempty
268284 showParts (SingletonUnion (OfType Object) : xs@((SingletonUnion (InProperty _)) : _)) = showParts xs
269285 showParts (SingletonUnion (OfType Object) : xs@((SingletonUnion InAdditionalProperty) : _)) = showParts xs
270286 showParts (SingletonUnion (OfType Array) : xs@(SingletonUnion InItems : _)) = showParts xs
271287 showParts (SingletonUnion (OfType Array) : xs@(SingletonUnion (InItem _) : _)) = showParts xs
272288 showParts (y : ys) =
273− ((\(OfType t) -> "(" <> describeJSONType t <> ")")
274− @@> (\case
275− InItems -> "[*]"
276− InItem i -> "[" <> T.pack (show i) <> "]"
277− InProperty p -> "." <> p
278− InAdditionalProperty -> ".*")
279− @@> 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+ )
280298 y
281299 <> showParts ys
282300
283−observeJetShowErrs
284− :: ReportJet' Behave (Maybe Inlines)
285− -> P.PathsPrefixTree Behave AnIssue a
286− -> (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)
287305observeJetShowErrs jet p = case observeJetShowErrs' jet p of
288306 Just m -> m
289307 Nothing -> (mempty, p)
290308
291−observeJetShowErrs'
292− :: forall a.
293− ReportJet' Behave (Maybe Inlines)
294− -> P.PathsPrefixTree Behave AnIssue a
295− -> 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)
296314observeJetShowErrs' (ReportJet jet) (P.PathsPrefixNode currentIssues subIssues) =
297315 let results =
298316 subIssues >>= \(WrapTypeable (AStep m)) ->
@@ -300,21 +318,23 @@ observeJetShowErrs' (ReportJet jet) (P.PathsPrefixNode currentIssues subIssues)
300318 maybe (Left $ embed (step bhv) subErrs) Right . listToMaybe $
301319 jet @_ @_ @[] bhv
302320 & mapMaybe
303− (\case
304− Free jet' -> fmap (embed $ step bhv) <$> observeJetShowErrs' jet' subErrs
305− Pure (Just h) ->
306− if P.null subErrs
307− then Just mempty
308− else Just (singletonHeader h (showErrs subErrs), mempty)
309− 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+ )
310329 in (fmap . fmap) (PathsPrefixNode currentIssues mempty <>) $
311330 if any isRight results
312331 then
313332 Just $
314333 foldMap
315− (\case
316− Left e -> (mempty, e)
317− Right m -> m)
334+ ( \case
335+ Left e -> (mempty, e)
336+ Right m -> m
337+ )
318338 results
319339 else Nothing
320340
@@ -337,8 +357,9 @@ buildReport cfg = case treeStyle cfg of
337357 body rprt
338358 <> foldOMapWithKey
339359 (headers rprt)
340− (\k v ->
341− header level k <> subBuilder v)
360+ ( \k v ->
361+ header level k <> subBuilder v
362+ )
342363 where
343364 subBuilder = headerStyleBuilder (level + 1)
344365
@@ -347,16 +368,17 @@ buildReport cfg = case treeStyle cfg of
347368 body rprt
348369 <> foldOMapWithKey
349370 (headers rprt)
350− (\k v ->
351− if (OM.size . headers $ rprt) < 2
352− then para k <> blockQuote (subBuilder v)
353− else
354− rawHtml "<details>"
355− <> rawHtml "<summary>"
356− <> plain k
357− <> rawHtml "</summary>"
358− <> blockQuote (subBuilder v)
359− <> 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+ )
360382 where
361383 subBuilder = foldingStyleBuilder
362384