@@ -3,14 +3,22 @@ module OpenAPI.Checker.Report
33 )
44where
55
6+import Control.Applicative
7+import Control.Monad.Free hiding (unfoldM)
68import Control.Monad.Reader
79import Control.Monad.Writer
10+import Data.Either
811import Data.Foldable
12+import Data.Function
913import Data.Functor
14+import Data.List.NonEmpty
15+import qualified Data.List.NonEmpty as NE
1016import qualified Data.Map as M
1117import Data.Maybe
18+import Data.OpenUnion
19+import Data.OpenUnion.Extra
20+import Data.Text (Text)
1221import qualified Data.Text as T
13−import Data.Traversable
1422import Data.TypeRepMap hiding (empty)
1523import Data.Typeable
1624import OpenAPI.Checker.Behavior
@@ -18,6 +26,7 @@ import OpenAPI.Checker.Paths
1826import OpenAPI.Checker.PathsPrefixTree hiding (empty)
1927import qualified OpenAPI.Checker.PathsPrefixTree as P hiding (empty)
2028import OpenAPI.Checker.Validate.OpenApi
29+import OpenAPI.Checker.Validate.Schema
2130import Text.Pandoc.Builder
2231
2332generateReport :: Either (P.PathsPrefixTree Behave AnIssue 'APILevel) () -> Pandoc
@@ -25,13 +34,13 @@ generateReport (Right ()) = doc $ header 1 "No breaking changes found ✨"
2534generateReport (Left errs) = doc $ runReportMonad jets $ showErrs errs
2635
2736data ReportState = ReportState
28− { sourceJets :: [SomeReportJet Behave]
37+ { sourceJets :: [ReportJet' Behave Inlines]
2938 , headerLevel :: Int
3039 }
3140
3241type ReportMonad = ReaderT ReportState (Writer Blocks)
3342
34−runReportMonad :: [SomeReportJet Behave] -> ReportMonad () -> Blocks
43+runReportMonad :: [ReportJet' Behave Inlines] -> ReportMonad () -> Blocks
3544runReportMonad jts =
3645 execWriter
3746 . flip
@@ -46,11 +55,11 @@ smartHeader i = do
4655 h <- asks headerLevel
4756 tell $ header h i
4857
49−showErrs :: Typeable a => P.PathsPrefixTree Behave AnIssue a -> ReportMonad ()
58+showErrs :: P.PathsPrefixTree Behave AnIssue a -> ReportMonad ()
5059showErrs x@(P.PathsPrefixNode currentIssues _) = do
5160 jts <- asks sourceJets
5261 for_ currentIssues $ \(AnIssue i) -> tell . describeIssue $ i
53− unfoldM x (observeSomeJetShowErrs <$> jts) $ \(P.PathsPrefixNode _ subIssues) -> do
62+ unfoldM x (observeJetShowErrs <$> jts) $ \(P.PathsPrefixNode _ subIssues) -> do
5463 for_ subIssues $ \(WrapTypeable (AStep m)) ->
5564 for_ (M.toList m) $ \(bhv, subErrors) -> do
5665 unless (P.null subErrors) $ do
@@ -63,74 +72,140 @@ unfoldM a (f : ff) g = do
6372 a' <- f a
6473 unfoldM a' ff g
6574
66−observeSomeJetShowErrs
67− :: forall a.
68− Typeable a
69− => SomeReportJet Behave
75+observeJetShowErrs
76+ :: ReportJet' Behave Inlines
7077 -> P.PathsPrefixTree Behave AnIssue a
7178 -> ReportMonad (P.PathsPrefixTree Behave AnIssue a)
72−observeSomeJetShowErrs (SomeReportJet (Proxy :: Proxy a') f) x
73− | Just Refl <- eqT @a @a' = observeJetShowErrs f x
74−observeSomeJetShowErrs _ x = pure x
75−
76−observeJetShowErrs :: ReportJet Behave a -> P.PathsPrefixTree Behave AnIssue a -> ReportMonad (P.PathsPrefixTree Behave AnIssue a)
77−observeJetShowErrs jet (P.PathsPrefixNode currentIssues subIssues) = do
78− rest <- fmap (fold . join) $
79− for subIssues $ \(WrapTypeable (AStep m)) -> fmap catMaybes $
80− for (M.toList m) $ \(bhv, subErrs) ->
81− case applyReportJet jet bhv of
82− Just (Left h) -> do
83− smartHeader h
84− incrementHeaders $ showErrs subErrs
85− return Nothing
86− Just (Right jet') -> do
87− rest <- observeJetShowErrs jet' subErrs
88− return $ Just $ embed (step bhv) rest
89− Nothing -> return $ Just $ embed (step bhv) subErrs
90− return $ PathsPrefixNode currentIssues mempty <> rest
79+observeJetShowErrs jet p = case observeJetShowErrs' jet p of
80+ Just m -> m
81+ Nothing -> pure p
82+
83+observeJetShowErrs'
84+ :: forall a.
85+ ReportJet' Behave Inlines
86+ -> P.PathsPrefixTree Behave AnIssue a
87+ -> Maybe (ReportMonad (P.PathsPrefixTree Behave AnIssue a))
88+observeJetShowErrs' (ReportJet jet) (P.PathsPrefixNode currentIssues subIssues) =
89+ let results =
90+ subIssues >>= \(WrapTypeable (AStep m)) ->
91+ M.toList m <&> \(bhv, subErrs) ->
92+ maybe (Left $ embed (step bhv) subErrs) Right . listToMaybe $
93+ jet @_ @_ @[] bhv
94+ & mapMaybe
95+ (\case
96+ Free jet' -> fmap (embed $ step bhv) <$> observeJetShowErrs' jet' subErrs
97+ Pure h -> Just $ do
98+ smartHeader h
99+ incrementHeaders $ showErrs subErrs
100+ return mempty)
101+ in (fmap . fmap) (PathsPrefixNode currentIssues mempty <>) $
102+ if any isRight results
103+ then
104+ Just $
105+ catMapM
106+ (\case
107+ Left e -> pure e
108+ Right m -> m)
109+ results
110+ else Nothing
111+
112+catMapM :: (Monad m, Monoid b) => (a -> m b) -> [a] -> m b
113+catMapM f xs = mconcat <$> mapM f xs
91114
92115-- | A "jet" is a way of simplifying expressions from "outside". The "jetted"
93116-- expressions should still be completely valid and correct without the jets.
94117-- Jets just make the expression more "optimized" by identifying patterns and
95118-- replacing the expressions with "better" ones that have the same sematics.
96119--
97−-- The tem "jet" in this context was introduced in the Urbit project:
120+-- The term "jet" in this context was introduced in the Urbit project:
98121-- https://urbit.org/docs/vere/jetting/
99122--
100123-- The pattern fits well for simplifying 'Behaviour' tree paths.
101−class ConstructReportJet f a b c where
102− constructReportJet :: (f a b -> c) -> ReportJet f a
124+class ConstructReportJet x f where
125+ constructReportJet :: x -> ReportJetResult f Inlines
126+
127+instance (ConstructReportJet b f, JetArg a) => ConstructReportJet (a -> b) f where
128+ constructReportJet f = Free (fmap f <$> consumeJetArg @a) >>= constructReportJet
129+
130+instance ConstructReportJet Inlines f where
131+ constructReportJet x = Pure x
132+
133+class JetArg a where
134+ consumeJetArg :: ReportJet' f a
103135
104−instance (ConstructReportJet f b c d, Typeable b) => ConstructReportJet f a b (f b c -> d) where
105− constructReportJet f = ReportJet Proxy $ \x -> constructReportJet $ f x
136+instance Typeable (f a b) => JetArg (f a b) where
137+ consumeJetArg =
138+ ReportJet $ \(x :: x) ->
139+ case eqT @(f a b) @x of
140+ Nothing -> empty
141+ Just Refl -> pure $ Pure x
106142
107−instance Typeable b => ConstructReportJet f a b Inlines where
108− constructReportJet f = TerminalJet Proxy f
143+instance TryLiftUnion xs => JetArg (Union xs) where
144+ consumeJetArg = ReportJet $ fmap Pure . tryLiftUnion
109145
110−constructSomeReportJet :: (ConstructReportJet f a b c, Typeable a) => (f a b -> c) -> SomeReportJet f
111−constructSomeReportJet = SomeReportJet Proxy . constructReportJet
146+instance JetArg x => JetArg (NonEmpty x) where
147+ consumeJetArg =
148+ let (ReportJet f) = (consumeJetArg @x)
149+ in ReportJet $ \a -> do
150+ u <- f a
151+ pure (u >>= \y -> Free $ fmap (NE.cons y) <$> consumeJetArg)
152+ <|> pure (pure <$> u)
112153
113−data ReportJet f a where
114− ReportJet :: Typeable b => Proxy b -> (f a b -> ReportJet f b) -> ReportJet f a
115− TerminalJet :: Typeable b => Proxy b -> (f a b -> Inlines) -> ReportJet f a
154+type ReportJetResult f = Free (ReportJet f)
116155
117−data SomeReportJet f where
118− SomeReportJet :: Typeable a => Proxy a -> ReportJet f a -> SomeReportJet f
156+-- Not a true 'Applicative'
157+newtype ReportJet f x = ReportJet (forall a b m. (Typeable (f a b), Alternative m, Monad m) => f a b -> m x)
158+ deriving stock (Functor)
119159
120−applyReportJet :: forall f a b. Typeable b => ReportJet f a -> f a b -> Maybe (Either Inlines (ReportJet f b))
121−applyReportJet (TerminalJet (Proxy :: Proxy b') f) x = eqT @b @b' <&> \Refl -> Left $ f x
122−applyReportJet (ReportJet (Proxy :: Proxy b') f) x = eqT @b @b' <&> \Refl -> Right $ f x
160+type ReportJet' f a = ReportJet f (Free (ReportJet f) a)
123161
124162incrementHeaders :: ReportMonad x -> ReportMonad x
125163incrementHeaders m = do
126164 l <- asks headerLevel
127165 local (\x -> x {headerLevel = l + 1}) m
128166
129−jets :: [SomeReportJet Behave]
167+jets :: [ReportJet' Behave Inlines]
130168jets =
131− [ constructSomeReportJet $ \p@(AtPath _) op@(InOperation _) ->
132− strong (describeBehaviour op) <> " " <> describeBehaviour p :: Inlines
133− , constructSomeReportJet $ \InRequest InPayload PayloadSchema -> "JSON Request" :: Inlines
134− , constructSomeReportJet $ \(WithStatusCode c) ResponsePayload PayloadSchema ->
135− "JSON Response – " <> str (T.pack . show $ c) :: Inlines
136− ]
169+ unwrapReportJetResult
170+ <$> [ constructReportJet jsonPathJet
171+ , constructReportJet $ \p@(AtPath _) op@(InOperation _) ->
172+ strong (describeBehaviour op) <> " " <> describeBehaviour p :: Inlines
173+ , constructReportJet $ \InRequest InPayload PayloadSchema -> "JSON Request" :: Inlines
174+ , constructReportJet $ \(WithStatusCode c) ResponsePayload PayloadSchema ->
175+ "JSON Response – " <> str (T.pack . show $ c) :: Inlines
176+ ]
177+ where
178+ unwrapReportJetResult :: ReportJetResult Behave x -> ReportJet' Behave x
179+ unwrapReportJetResult (Pure _) = error "There really shouldn't be any results here."
180+ unwrapReportJetResult (Free f) = f
181+
182+ jsonPathJet
183+ :: NonEmpty
184+ ( Union
185+ '[ Behave 'SchemaLevel 'TypedSchemaLevel
186+ , Behave 'TypedSchemaLevel 'SchemaLevel
187+ ]
188+ )
189+ -> Inlines
190+ jsonPathJet x = code $ "$" <> showParts (NE.toList x)
191+ where
192+ showParts
193+ :: [ Union
194+ '[ Behave 'SchemaLevel 'TypedSchemaLevel
195+ , Behave 'TypedSchemaLevel 'SchemaLevel
196+ ]
197+ ]
198+ -> Text
199+ showParts [] = mempty
200+ showParts (SingletonUnion (OfType Object) : xs@((SingletonUnion (InProperty _)) : _)) = showParts xs
201+ showParts (SingletonUnion (OfType Object) : xs@((SingletonUnion InAdditionalProperty) : _)) = showParts xs
202+ showParts (SingletonUnion (OfType Array) : xs@(SingletonUnion InItems : _)) = showParts xs
203+ showParts (y : ys) =
204+ ((\(OfType t) -> "(" <> describeJSONType t <> ")")
205+ @@> (\case
206+ InItems -> "[*]"
207+ InProperty p -> "." <> p
208+ InAdditionalProperty -> ".*")
209+ @@> typesExhausted)
210+ y
211+ <> showParts ys