@@ -1,15 +1,20 @@
11module OpenAPI.Checker.Report
22 ( generateReport
3+ , ReportInput (..)
4+ , ReportStatus (..)
5+ , Pandoc
36 )
47where
58
69import Control.Monad.Free hiding (unfoldM)
710import Control.Monad.Reader
811import Control.Monad.Writer
12+import Data.Aeson (ToJSON)
913import Data.Either
1014import Data.Foldable
1115import Data.Function
1216import Data.Functor
17+import Data.Functor.Const
1318import Data.List.NonEmpty
1419import qualified Data.List.NonEmpty as NE
1520import qualified Data.Map as M
@@ -22,6 +27,7 @@ import Data.Text (Text)
2227import qualified Data.Text as T
2328import Data.TypeRepMap hiding (empty)
2429import Data.Typeable
30+import Generic.Data
2531import OpenAPI.Checker.Behavior
2632import OpenAPI.Checker.Paths
2733import OpenAPI.Checker.PathsPrefixTree hiding (empty)
@@ -31,27 +37,79 @@ import OpenAPI.Checker.Validate.OpenApi
3137import OpenAPI.Checker.Validate.Schema
3238import Text.Pandoc.Builder
3339
34−generateReport :: Either (P.PathsPrefixTree Behave AnIssue 'APILevel) () -> Pandoc
35−generateReport (Right ()) = doc $ header 1 "No breaking changes found ✨"
36−generateReport (Left errs) = doc $
37− runReportMonad jets $ do
38− let (unsupported, breaking) = P.partition (\(AnIssue i) -> issueIsUnsupported i) errs
39− breakingChangesPresent = not $ P.null breaking
40− unsupportedChangesPresent = not $ P.null unsupported
41− smartHeader "Summary"
42− tell $
43− simpleTable
44− (para
45− <$> [ refOpt breakingChangesPresent breakingChangesId "⚠️ Breaking changes"
46− , refOpt unsupportedChangesPresent unsupportedChangesId "🤷 Unsupported feature changes"
47− ])
48− [para . show' <$> [P.size breaking, P.size unsupported]]
49− when breakingChangesPresent $ do
50− smartHeader $ anchor breakingChangesId <> "⚠️ Breaking changes"
51− incrementHeaders $ showErrs breaking
52− when unsupportedChangesPresent $ do
53− smartHeader $ anchor unsupportedChangesId <> "🤷 Unsupported feature changes"
54− incrementHeaders $ showErrs unsupported
40+type Changes = P.PathsPrefixTree Behave AnIssue 'APILevel
41+
42+type ProcessedChanges a = P.PathsPrefixTree Behave (FunctorTuple (Const Orientation) AnIssue) a
43+
44+data FunctorTuple f g a = FunctorTuple (f a) (g a)
45+ deriving stock (Eq, Ord)
46+
47+data ReportInput = ReportInput
48+ { breakingChanges :: Changes
49+ , nonBreakingChanges :: Changes
50+ }
51+ deriving stock (Generic)
52+ deriving (Semigroup, Monoid) via (Generically ReportInput)
53+ deriving anyclass (ToJSON)
54+
55+data ReportStatus
56+ = BreakingChanges
57+ | NoBreakingChanges
58+ | -- | All changes that could be breaking are unsupported – we don't know if
59+ -- there actually are any breaking changes.
60+ OnlyUnsupportedChanges
61+
62+preprocessChanges :: Orientation -> Changes -> ProcessedChanges 'APILevel
63+preprocessChanges initialO = P.fromList . fmap process . P.toList
64+ where
65+ process :: AnItem Behave AnIssue 'APILevel -> AnItem Behave (FunctorTuple (Const Orientation) AnIssue) 'APILevel
66+ process (AnItem paths issue) = AnItem paths $ FunctorTuple (Const $ toggle initialO) issue
67+ where
68+ (Endo toggle) = togglePaths paths
69+
70+ togglePaths :: Paths Behave a c -> Endo Orientation
71+ togglePaths Root = mempty
72+ togglePaths (rest `Snoc` (_ :: Behave b c)) = case eqT @c @'ResponseLevel of
73+ Just Refl -> Endo toggleOrientation <> togglePaths rest
74+ Nothing -> togglePaths rest
75+
76+generateReport :: ReportInput -> (Pandoc, ReportStatus)
77+generateReport inp =
78+ let partitionUnsupported = P.partition (\(AnIssue i) -> issueIsUnsupported i)
79+ (bUnsupported, preprocessChanges Forward -> breaking) =
80+ partitionUnsupported $ breakingChanges inp
81+ (nbUnsupported, preprocessChanges Backward -> nonBreaking) =
82+ partitionUnsupported $ nonBreakingChanges inp
83+ unsupported = preprocessChanges Forward $ bUnsupported <> nbUnsupported
84+ breakingChangesPresent = not $ P.null breaking
85+ nonBreakingChangesPresent = not $ P.null nonBreaking
86+ unsupportedChangesPresent = not $ P.null unsupported
87+ report = doc $
88+ runReportMonad jets $ do
89+ smartHeader "Summary"
90+ tell $
91+ simpleTable
92+ (para
93+ <$> [ refOpt breakingChangesPresent breakingChangesId "⚠️ Breaking changes"
94+ , refOpt nonBreakingChangesPresent nonBreakingChangesId "🙆 Non-breaking changes"
95+ , refOpt unsupportedChangesPresent unsupportedChangesId "🤷 Unsupported feature changes"
96+ ])
97+ [para . show' <$> [P.size breaking, P.size nonBreaking, P.size unsupported]]
98+ when breakingChangesPresent $ do
99+ smartHeader $ anchor breakingChangesId <> "⚠️ Breaking changes"
100+ incrementHeaders $ showErrs breaking
101+ when nonBreakingChangesPresent $ do
102+ smartHeader $ anchor nonBreakingChangesId <> "🙆 Non-breaking changes"
103+ incrementHeaders $ showErrs nonBreaking
104+ when unsupportedChangesPresent $ do
105+ smartHeader $ anchor unsupportedChangesId <> "🤷 Unsupported feature changes"
106+ incrementHeaders $ showErrs unsupported
107+ status =
108+ if
109+ | breakingChangesPresent -> BreakingChanges
110+ | unsupportedChangesPresent -> OnlyUnsupportedChanges
111+ | otherwise -> NoBreakingChanges
112+ in (report, status)
55113 where
56114 anchor :: Text -> Inlines
57115 anchor a = spanWith (a, [], []) mempty
@@ -60,11 +118,10 @@ generateReport (Left errs) = doc $
60118 refOpt False _ i = i
61119 refOpt True a i = link ("#" <> a) "" i
62120
63− breakingChangesId :: Text
121+ breakingChangesId, nonBreakingChangesId, unsupportedChangesId :: Text
64122 breakingChangesId = "breaking-changes"
65−
66− unsupportedChangesId :: Text
67123 unsupportedChangesId = "unsupported-changes"
124+ nonBreakingChangesId = "non-breaking-changes"
68125
69126data ReportState = ReportState
70127 { sourceJets :: [ReportJet' Behave Inlines]
@@ -88,22 +145,24 @@ smartHeader i = do
88145 h <- asks headerLevel
89146 tell $ header h i
90147
91−showErrs :: forall a. Typeable a => P.PathsPrefixTree Behave AnIssue a -> ReportMonad ()
148+showErrs :: forall a. Typeable a => ProcessedChanges a -> ReportMonad ()
92149showErrs x@(P.PathsPrefixNode currentIssues _) = do
93150 let -- Extract this pattern if more cases like this arise
94− (removedPaths :: [Issue 'APILevel], otherIssues :: Set (AnIssue a)) = case eqT @a @'APILevel of
95− Just Refl ->
96− let (p, o) =
97− S.partition
98− (\(AnIssue u) -> case u of
99− NoPathsMatched {} -> True
100− AllPathsFailed {} -> True)
101− currentIssues
102− p' = S.toList p <&> (\(AnIssue i) -> i)
103− in (p', o)
104− Nothing -> (mempty, currentIssues)
151+ ( removedPaths :: [Issue 'APILevel]
152+ , otherIssues :: Set (FunctorTuple (Const Orientation) AnIssue a)
153+ ) = case eqT @a @'APILevel of
154+ Just Refl ->
155+ let (p, o) =
156+ S.partition
157+ (\(FunctorTuple _ (AnIssue u)) -> case u of
158+ NoPathsMatched {} -> True
159+ AllPathsFailed {} -> True)
160+ currentIssues
161+ p' = S.toList p <&> (\(FunctorTuple _ (AnIssue i)) -> i)
162+ in (p', o)
163+ Nothing -> (mempty, currentIssues)
105164 jts <- asks sourceJets
106− for_ otherIssues $ \(AnIssue i) -> tell . describeIssue $ i
165+ for_ otherIssues $ \(FunctorTuple (Const ori) (AnIssue i)) -> tell . describeIssue ori $ i
107166 unless ([] == removedPaths) $ do
108167 smartHeader "Removed paths"
109168 tell $
@@ -135,9 +194,9 @@ jets =
135194 <$> [ constructReportJet jsonPathJet
136195 , constructReportJet $ \p@(AtPath _) op@(InOperation _) ->
137196 strong (describeBehaviour op) <> " " <> describeBehaviour p :: Inlines
138− , constructReportJet $ \InRequest InPayload PayloadSchema -> "JSON Request" :: Inlines
197+ , constructReportJet $ \InRequest InPayload PayloadSchema -> "📱➡️ JSON Request" :: Inlines
139198 , constructReportJet $ \(WithStatusCode c) ResponsePayload PayloadSchema ->
140− "JSON Response – " <> str (T.pack . show $ c) :: Inlines
199+ "📱⬅️ JSON Response – " <> str (T.pack . show $ c) :: Inlines
141200 ]
142201 where
143202 unwrapReportJetResult :: ReportJetResult Behave x -> ReportJet' Behave x
@@ -177,8 +236,8 @@ jets =
177236
178237observeJetShowErrs
179238 :: ReportJet' Behave Inlines
180− -> P.PathsPrefixTree Behave AnIssue a
181− -> ReportMonad (P.PathsPrefixTree Behave AnIssue a)
239+ -> ProcessedChanges a
240+ -> ReportMonad (ProcessedChanges a)
182241observeJetShowErrs jet p = case observeJetShowErrs' jet p of
183242 Just m -> m
184243 Nothing -> pure p
@@ -186,8 +245,8 @@ observeJetShowErrs jet p = case observeJetShowErrs' jet p of
186245observeJetShowErrs'
187246 :: forall a.
188247 ReportJet' Behave Inlines
189− -> P.PathsPrefixTree Behave AnIssue a
190− -> Maybe (ReportMonad (P.PathsPrefixTree Behave AnIssue a))
248+ -> ProcessedChanges a
249+ -> Maybe (ReportMonad (ProcessedChanges a))
191250observeJetShowErrs' (ReportJet jet) (P.PathsPrefixNode currentIssues subIssues) =
192251 let results =
193252 subIssues >>= \(WrapTypeable (AStep m)) ->