@@ -1,11 +1,13 @@
1−module OpenAPI.Checker.Report
2− ( generateReport
3− , ReportInput (..)
4− , ReportStatus (..)
5− , Pandoc
6− , ReportConfig (..)
7− , ReportTreeStyle (..)
8− , 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 (..),
911 )
1012where
1113
@@ -21,6 +23,15 @@ import qualified Data.Map as M
2123import Data.Map.Ordered (OMap)
2224import qualified Data.Map.Ordered as OM
2325import 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
2435import Data.OpenUnion
2536import Data.OpenUnion.Extra
2637import Data.Set
@@ -30,27 +41,47 @@ import qualified Data.Text as T
3041import Data.TypeRepMap hiding (empty)
3142import Data.Typeable
3243import Generic.Data
33−import OpenAPI.Checker.Behavior
34−import OpenAPI.Checker.Paths
35−import OpenAPI.Checker.PathsPrefixTree hiding (empty)
36−import qualified OpenAPI.Checker.PathsPrefixTree as P hiding (empty)
37−import OpenAPI.Checker.Report.Jet
38−import OpenAPI.Checker.Subtree (invertIssueOrientationP)
39−import OpenAPI.Checker.Validate.OpenApi
40−import OpenAPI.Checker.Validate.Schema.TypedJson
41−import OpenAPI.Checker.Validate.Schema.Issues
4244import Text.Pandoc.Builder
4345
4446type Changes = P.PathsPrefixTree Behave AnIssue 'APILevel
4547
48+data CheckerOutput = CheckerOutput
49+ { forwardChanges :: Changes
50+ , backwardChanges :: Changes
51+ }
52+ deriving stock (Generic)
53+ deriving (Semigroup, Monoid) via (Generically CheckerOutput)
54+ deriving anyclass (ToJSON)
55+
4656data ReportInput = ReportInput
47− { breakingChanges :: Changes
48− , nonBreakingChanges :: Changes
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
4965 }
5066 deriving stock (Generic)
5167 deriving (Semigroup, Monoid) via (Generically ReportInput)
5268 deriving anyclass (ToJSON)
5369
70+segregateIssues :: CheckerOutput -> ReportInput
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+ }
78+ where
79+ isBreaking i = anIssueKind i `elem` [CertainIssue, ProbablyIssue, Comment]
80+ isNonBreaking :: Paths Behave 'APILevel a -> AnIssue a -> Bool
81+ isNonBreaking xs i = isBreaking i && all (\j -> not $ relatedAnIssues i j) (P.lookup xs fwd)
82+ isUnsupported i = anIssueKind i == Unsupported
83+ isSchemaIssue i = anIssueKind i == SchemaInvalid
84+
5485data ReportStatus
5586 = BreakingChanges
5687 | NoBreakingChanges
@@ -78,49 +109,66 @@ data ReportTreeStyle = HeadersTreeStyle | FoldingBlockquotesTreeStyle
78109twoRowTable :: [(Inlines, Inlines)] -> Blocks
79110twoRowTable x = simpleTable (para . fst <$> x) [para . snd <$> x]
80111
81−generateReport :: ReportConfig -> ReportInput -> (Pandoc, ReportStatus)
112+generateReport :: ReportConfig -> ReportInput -> (Blocks, ReportStatus)
82113generateReport cfg inp =
83− let partitionUnsupported = P.partition (\(AnIssue _ i) -> issueIsUnsupported i)
84− (bUnsupported, breaking) = partitionUnsupported $ breakingChanges inp
85− (nbUnsupported, invertIssueOrientationP -> nonBreaking) = partitionUnsupported $ nonBreakingChanges inp
86− unsupported = bUnsupported <> nbUnsupported
87− breakingChangesPresent = not $ P.null breaking
88− nonBreakingChangesPresent = not $ P.null nonBreaking
89− unsupportedChangesPresent = not $ P.null unsupported
114+ let schemaIssuesPresent = not $ P.null $ schemaIssues inp
115+ breakingChangesPresent = not $ P.null $ breakingChanges inp
116+ nonBreakingChangesPresent = not $ P.null $ nonBreakingChanges inp
117+ unsupportedChangesPresent = not $ P.null $ unsupportedChanges inp
90118 nonBreakingChangesShown = case reportMode cfg of
91119 All -> True
92120 OnlyErrors -> False
93121 builder = buildReport cfg
94122 report =
95− doc $
96− header 1 "Summary"
97− <> twoRowTable
98− ([ ( refOpt breakingChangesPresent breakingChangesId "⚠️ Breaking changes"
99− , show' $ P.size breaking
100− )
101− ]
102− ++ when'
103− nonBreakingChangesShown
104− [ ( refOpt nonBreakingChangesPresent nonBreakingChangesId "🙆 Non-breaking changes"
105− , show' $ P.size nonBreaking
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"
134+ , show' $ P.size $ breakingChanges inp
106135 )
107136 ]
108− ++ [ ( refOpt unsupportedChangesPresent unsupportedChangesId "🤷 Unsupported feature changes"
109− , show' $ P.size unsupported
110− )
111− ])
112− <> when'
113− breakingChangesPresent
114− (header 1 (anchor breakingChangesId <> "⚠️ Breaking changes")
115− <> builder (showErrs breaking))
116− <> when'
117− (nonBreakingChangesPresent && nonBreakingChangesShown)
118− (header 1 (anchor nonBreakingChangesId <> "🙆 Non-breaking changes")
119− <> builder (showErrs nonBreaking))
120− <> when'
121− unsupportedChangesPresent
122− (header 1 (anchor unsupportedChangesId <> "🤷 Unsupported feature changes")
123− <> builder (showErrs unsupported))
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+ )
124172 status =
125173 if
126174 | breakingChangesPresent -> BreakingChanges
@@ -135,10 +183,11 @@ generateReport cfg inp =
135183 refOpt False _ i = i
136184 refOpt True a i = link ("#" <> a) "" i
137185
138− breakingChangesId, nonBreakingChangesId, unsupportedChangesId :: Text
186+ breakingChangesId, nonBreakingChangesId, unsupportedChangesId, schemaIssuesId :: Text
139187 breakingChangesId = "breaking-changes"
140188 unsupportedChangesId = "unsupported-changes"
141189 nonBreakingChangesId = "non-breaking-changes"
190+ schemaIssuesId = "schema-issues"
142191
143192 when' :: Monoid m => Bool -> m -> m
144193 when' True m = m
@@ -149,13 +198,14 @@ showErrs x@(P.PathsPrefixNode currentIssues _) =
149198 let -- Extract this pattern if more cases like this arise
150199 ( removedPaths :: Maybe (Orientation, [Issue 'APILevel])
151200 , otherIssues :: Set (AnIssue a)
152− ) = case eqT @a @'APILevel of
201+ ) = case eqT @a @ 'APILevel of
153202 Just Refl
154203 | (S.toList -> p@((AnIssue ori _) : _), o) <-
155204 S.partition
156− (\((AnIssue _ u)) -> case u of
157− NoPathsMatched {} -> True
158− AllPathsFailed {} -> True)
205+ ( \((AnIssue _ u)) -> case u of
206+ NoPathsMatched {} -> True
207+ AllPathsFailed {} -> True
208+ )
159209 currentIssues ->
160210 let p' = p <&> (\(AnIssue _ i) -> i)
161211 in (Just (ori, p'), o)
@@ -166,9 +216,10 @@ showErrs x@(P.PathsPrefixNode currentIssues _) =
166216 paths = case removedPaths of
167217 Just (ori, ps) -> do
168218 singletonHeader
169− (case ori of
170− Forward -> "Removed paths"
171− Backward -> "Added paths")
219+ ( case ori of
220+ Forward -> "Removed paths"
221+ Backward -> "Added paths"
222+ )
172223 $ singletonBody $
173224 bulletList $
174225 ps <&> \case
@@ -180,7 +231,7 @@ showErrs x@(P.PathsPrefixNode currentIssues _) =
180231 flip foldMap (M.toList m) $ \(bhv, subErrors) ->
181232 if P.null subErrors
182233 then mempty
183− else singletonHeader (describeBehaviour bhv) $ showErrs subErrors
234+ else singletonHeader (describeBehavior bhv) $ showErrs subErrors
184235 in issues <> paths <> rest
185236
186237unfoldFunctions :: forall m a. (Monoid m, Eq a) => a -> [a -> (m, a)] -> (a -> m) -> m
@@ -198,66 +249,68 @@ jets =
198249 unwrapReportJetResult
199250 <$> [ constructReportJet $
200251 curry $ \case
201− (OfType Object, p@(InPartition _)) -> Just $ describeBehaviour p :: Maybe Inlines
252+ (OfType Object, p@(InPartition _)) -> Just $ describeBehavior p :: Maybe Inlines
202253 _ -> Nothing
203254 , constructReportJet jsonPathJet
204255 , constructReportJet $ \p@(AtPath _) op@(InOperation _) ->
205− strong (describeBehaviour op) <> " " <> describeBehaviour p :: Inlines
256+ strong (describeBehavior op) <> " " <> describeBehavior p :: Inlines
206257 , constructReportJet $ \(WithStatusCode c) ResponsePayload PayloadSchema ->
207− "📱⬅️ JSON Response – " <> str (T.pack . show $ c) :: Inlines
208− , constructReportJet $ \InRequest InPayload PayloadSchema -> "📱➡️ JSON Request" :: Inlines
258+ "⬅️☁️ JSON Response – " <> str (T.pack . show $ c) :: Inlines
259+ , constructReportJet $ \InRequest InPayload PayloadSchema -> "➡️☁️ JSON Request" :: Inlines
209260 ]
210261 where
211262 unwrapReportJetResult :: ReportJetResult Behave x -> ReportJet' Behave x
212263 unwrapReportJetResult (Pure _) = error "There really shouldn't be any results here."
213264 unwrapReportJetResult (Free f) = f
214265
215− jsonPathJet
216− :: NonEmpty
217− ( Union
218− '[ Behave 'SchemaLevel 'TypedSchemaLevel
219− , Behave 'TypedSchemaLevel 'SchemaLevel
220− ]
221− )
222− -> Inlines
266+ jsonPathJet ::
267+ NonEmpty
268+ ( Union
269+ '[ Behave 'SchemaLevel 'TypedSchemaLevel
270+ , Behave 'TypedSchemaLevel 'SchemaLevel
271+ ]
272+ ) ->
273+ Inlines
223274 jsonPathJet x = code $ "$" <> showParts (NE.toList x)
224275 where
225− showParts
226− :: [ Union
227− '[ Behave 'SchemaLevel 'TypedSchemaLevel
228− , Behave 'TypedSchemaLevel 'SchemaLevel
229− ]
230− ]
231− -> Text
276+ showParts ::
277+ [ Union
278+ '[ Behave 'SchemaLevel 'TypedSchemaLevel
279+ , Behave 'TypedSchemaLevel 'SchemaLevel
280+ ]
281+ ] ->
282+ Text
232283 showParts [] = mempty
233284 showParts (SingletonUnion (OfType Object) : xs@((SingletonUnion (InProperty _)) : _)) = showParts xs
234285 showParts (SingletonUnion (OfType Object) : xs@((SingletonUnion InAdditionalProperty) : _)) = showParts xs
235286 showParts (SingletonUnion (OfType Array) : xs@(SingletonUnion InItems : _)) = showParts xs
236287 showParts (SingletonUnion (OfType Array) : xs@(SingletonUnion (InItem _) : _)) = showParts xs
237288 showParts (y : ys) =
238− ((\(OfType t) -> "(" <> describeJSONType t <> ")")
239− @@> (\case
240− InItems -> "[*]"
241− InItem i -> "[" <> T.pack (show i) <> "]"
242− InProperty p -> "." <> p
243− InAdditionalProperty -> ".*")
244− @@> 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+ )
245298 y
246299 <> showParts ys
247300
248−observeJetShowErrs
249− :: ReportJet' Behave (Maybe Inlines)
250− -> P.PathsPrefixTree Behave AnIssue a
251− -> (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)
252305observeJetShowErrs jet p = case observeJetShowErrs' jet p of
253306 Just m -> m
254307 Nothing -> (mempty, p)
255308
256−observeJetShowErrs'
257− :: forall a.
258− ReportJet' Behave (Maybe Inlines)
259− -> P.PathsPrefixTree Behave AnIssue a
260− -> 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)
261314observeJetShowErrs' (ReportJet jet) (P.PathsPrefixNode currentIssues subIssues) =
262315 let results =
263316 subIssues >>= \(WrapTypeable (AStep m)) ->
@@ -265,21 +318,23 @@ observeJetShowErrs' (ReportJet jet) (P.PathsPrefixNode currentIssues subIssues)
265318 maybe (Left $ embed (step bhv) subErrs) Right . listToMaybe $
266319 jet @_ @_ @[] bhv
267320 & mapMaybe
268− (\case
269− Free jet' -> fmap (embed $ step bhv) <$> observeJetShowErrs' jet' subErrs
270− Pure (Just h) ->
271− if P.null subErrs
272− then Just mempty
273− else Just (singletonHeader h (showErrs subErrs), mempty)
274− 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+ )
275329 in (fmap . fmap) (PathsPrefixNode currentIssues mempty <>) $
276330 if any isRight results
277331 then
278332 Just $
279333 foldMap
280− (\case
281− Left e -> (mempty, e)
282− Right m -> m)
334+ ( \case
335+ Left e -> (mempty, e)
336+ Right m -> m
337+ )
283338 results
284339 else Nothing
285340
@@ -302,8 +357,9 @@ buildReport cfg = case treeStyle cfg of
302357 body rprt
303358 <> foldOMapWithKey
304359 (headers rprt)
305− (\k v ->
306− header level k <> subBuilder v)
360+ ( \k v ->
361+ header level k <> subBuilder v
362+ )
307363 where
308364 subBuilder = headerStyleBuilder (level + 1)
309365
@@ -312,16 +368,17 @@ buildReport cfg = case treeStyle cfg of
312368 body rprt
313369 <> foldOMapWithKey
314370 (headers rprt)
315− (\k v ->
316− if (OM.size . headers $ rprt) < 2
317− then para k <> blockQuote (subBuilder v)
318− else
319− rawHtml "<details>"
320− <> rawHtml "<summary>"
321− <> plain k
322− <> rawHtml "</summary>"
323− <> blockQuote (subBuilder v)
324− <> 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+ )
325382 where
326383 subBuilder = foldingStyleBuilder
327384