From 5fd5a1cd78e830c8e81c173576714e7897303093 Mon Sep 17 00:00:00 2001 From: iko Date: Tue, 8 Jun 2021 17:57:13 +0300 Subject: [PATCH] Added JSON Path jets (#75) * Updated ConstructReportJet variables * changed ConstructReportJet yet more * Added support for Union in jets * Extracted jet args * observeJetShowErrs' * Complex Arguments * Added branching * Added JSON path jets * Simplified things * Better type rendering in report --- .gitignore | 1 + openapi-diff.cabal | 4 + src/Data/OpenUnion/Extra.hs | 43 +++++ src/OpenAPI/Checker/Report.hs | 177 +++++++++++++----- src/OpenAPI/Checker/Validate/Schema.hs | 5 +- stack.yaml | 4 + stack.yaml.lock | 16 +- test/golden/common/maximum-lowered/report.md | 2 +- .../operation/parameters/change/report.md | 2 +- .../mediaTypeObject/change/report.md | 2 +- .../change/mediaTypeObject/change/report.md | 2 +- test/golden/common/property-removed/report.md | 4 +- .../golden/common/property-required/report.md | 2 +- 13 files changed, 204 insertions(+), 60 deletions(-) create mode 100644 src/Data/OpenUnion/Extra.hs diff --git a/.gitignore b/.gitignore index 822a9ac..5bc7adb 100644 --- a/.gitignore +++ b/.gitignore @@ -2,3 +2,4 @@ TAGS .vscode .dir-locals.el +test/golden/common/prod diff --git a/openapi-diff.cabal b/openapi-diff.cabal index fccec93..b911efd 100644 --- a/openapi-diff.cabal +++ b/openapi-diff.cabal @@ -64,6 +64,9 @@ common common-options , yaml , hashable , pandoc-types + , open-union + , type-fun + , free default-extensions: ApplicativeDo , BangPatterns @@ -137,6 +140,7 @@ library , OpenAPI.Checker.Validate.SecurityScheme , OpenAPI.Checker.Validate.OAuth2Flows , OpenAPI.Checker.Report + , Data.OpenUnion.Extra executable openapi-diff import: common-options diff --git a/src/Data/OpenUnion/Extra.hs b/src/Data/OpenUnion/Extra.hs new file mode 100644 index 0000000..c4b518d --- /dev/null +++ b/src/Data/OpenUnion/Extra.hs @@ -0,0 +1,43 @@ +module Data.OpenUnion.Extra + ( (@@>) + , TryLiftUnion (..) + , pattern SingletonUnion + ) +where + +import Control.Applicative +import Data.Dynamic +import Data.OpenUnion.Internal +import Data.Typeable +import TypeFun.Data.List hiding (Union) + +class TryLiftUnion xs where + tryLiftUnion :: (Alternative m, Typeable x) => x -> m (Union xs) + +instance TryLiftUnion '[] where + tryLiftUnion _ = empty + +instance + (Typeable y, SubList ys (y : ys), TryLiftUnion ys) + => TryLiftUnion (y ': ys) + where + tryLiftUnion (x :: x) = case eqT @x @y of + Nothing -> reUnion <$> tryLiftUnion @ys x + Just Refl -> pure $ liftUnion x + +-- | Like '@>', but enforces a specific type list order. +-- (Useful for deconstruction-directed type inference.) +(@@>) :: Typeable a => (a -> b) -> (Union xs -> b) -> Union (a ': xs) -> b +r @@> l = either l r . restrict' + where + restrict' :: Typeable a => Union (a ': aa) -> Either (Union aa) a + restrict' (Union d) = maybe (Left $ Union d) Right $ fromDynamic d +{-# INLINE (@@>) #-} + +infixr 2 @@> + +pattern SingletonUnion :: (Typeable a, Elem a s) => a -> Union s +pattern SingletonUnion x <- + ((\(Union y) -> fromDynamic y) -> Just x) + where + SingletonUnion x = liftUnion x diff --git a/src/OpenAPI/Checker/Report.hs b/src/OpenAPI/Checker/Report.hs index af8591f..749f450 100644 --- a/src/OpenAPI/Checker/Report.hs +++ b/src/OpenAPI/Checker/Report.hs @@ -3,14 +3,22 @@ module OpenAPI.Checker.Report ) where +import Control.Applicative +import Control.Monad.Free hiding (unfoldM) import Control.Monad.Reader import Control.Monad.Writer +import Data.Either import Data.Foldable +import Data.Function import Data.Functor +import Data.List.NonEmpty +import qualified Data.List.NonEmpty as NE import qualified Data.Map as M import Data.Maybe +import Data.OpenUnion +import Data.OpenUnion.Extra +import Data.Text (Text) import qualified Data.Text as T -import Data.Traversable import Data.TypeRepMap hiding (empty) import Data.Typeable import OpenAPI.Checker.Behavior @@ -18,6 +26,7 @@ import OpenAPI.Checker.Paths import OpenAPI.Checker.PathsPrefixTree hiding (empty) import qualified OpenAPI.Checker.PathsPrefixTree as P hiding (empty) import OpenAPI.Checker.Validate.OpenApi +import OpenAPI.Checker.Validate.Schema import Text.Pandoc.Builder generateReport :: Either (P.PathsPrefixTree Behave AnIssue 'APILevel) () -> Pandoc @@ -25,13 +34,13 @@ generateReport (Right ()) = doc $ header 1 "No breaking changes found ✨" generateReport (Left errs) = doc $ runReportMonad jets $ showErrs errs data ReportState = ReportState - { sourceJets :: [SomeReportJet Behave] + { sourceJets :: [ReportJet' Behave Inlines] , headerLevel :: Int } type ReportMonad = ReaderT ReportState (Writer Blocks) -runReportMonad :: [SomeReportJet Behave] -> ReportMonad () -> Blocks +runReportMonad :: [ReportJet' Behave Inlines] -> ReportMonad () -> Blocks runReportMonad jts = execWriter . flip @@ -46,11 +55,11 @@ smartHeader i = do h <- asks headerLevel tell $ header h i -showErrs :: Typeable a => P.PathsPrefixTree Behave AnIssue a -> ReportMonad () +showErrs :: P.PathsPrefixTree Behave AnIssue a -> ReportMonad () showErrs x@(P.PathsPrefixNode currentIssues _) = do jts <- asks sourceJets for_ currentIssues $ \(AnIssue i) -> tell . describeIssue $ i - unfoldM x (observeSomeJetShowErrs <$> jts) $ \(P.PathsPrefixNode _ subIssues) -> do + unfoldM x (observeJetShowErrs <$> jts) $ \(P.PathsPrefixNode _ subIssues) -> do for_ subIssues $ \(WrapTypeable (AStep m)) -> for_ (M.toList m) $ \(bhv, subErrors) -> do unless (P.null subErrors) $ do @@ -63,74 +72,140 @@ unfoldM a (f : ff) g = do a' <- f a unfoldM a' ff g -observeSomeJetShowErrs - :: forall a. - Typeable a - => SomeReportJet Behave +observeJetShowErrs + :: ReportJet' Behave Inlines -> P.PathsPrefixTree Behave AnIssue a -> ReportMonad (P.PathsPrefixTree Behave AnIssue a) -observeSomeJetShowErrs (SomeReportJet (Proxy :: Proxy a') f) x - | Just Refl <- eqT @a @a' = observeJetShowErrs f x -observeSomeJetShowErrs _ x = pure x +observeJetShowErrs jet p = case observeJetShowErrs' jet p of + Just m -> m + Nothing -> pure p -observeJetShowErrs :: ReportJet Behave a -> P.PathsPrefixTree Behave AnIssue a -> ReportMonad (P.PathsPrefixTree Behave AnIssue a) -observeJetShowErrs jet (P.PathsPrefixNode currentIssues subIssues) = do - rest <- fmap (fold . join) $ - for subIssues $ \(WrapTypeable (AStep m)) -> fmap catMaybes $ - for (M.toList m) $ \(bhv, subErrs) -> - case applyReportJet jet bhv of - Just (Left h) -> do - smartHeader h - incrementHeaders $ showErrs subErrs - return Nothing - Just (Right jet') -> do - rest <- observeJetShowErrs jet' subErrs - return $ Just $ embed (step bhv) rest - Nothing -> return $ Just $ embed (step bhv) subErrs - return $ PathsPrefixNode currentIssues mempty <> rest +observeJetShowErrs' + :: forall a. + ReportJet' Behave Inlines + -> P.PathsPrefixTree Behave AnIssue a + -> Maybe (ReportMonad (P.PathsPrefixTree Behave AnIssue a)) +observeJetShowErrs' (ReportJet jet) (P.PathsPrefixNode currentIssues subIssues) = + let results = + subIssues >>= \(WrapTypeable (AStep m)) -> + M.toList m <&> \(bhv, subErrs) -> + maybe (Left $ embed (step bhv) subErrs) Right . listToMaybe $ + jet @_ @_ @[] bhv + & mapMaybe + (\case + Free jet' -> fmap (embed $ step bhv) <$> observeJetShowErrs' jet' subErrs + Pure h -> Just $ do + smartHeader h + incrementHeaders $ showErrs subErrs + return mempty) + in (fmap . fmap) (PathsPrefixNode currentIssues mempty <>) $ + if any isRight results + then + Just $ + catMapM + (\case + Left e -> pure e + Right m -> m) + results + else Nothing + +catMapM :: (Monad m, Monoid b) => (a -> m b) -> [a] -> m b +catMapM f xs = mconcat <$> mapM f xs -- | A "jet" is a way of simplifying expressions from "outside". The "jetted" -- expressions should still be completely valid and correct without the jets. -- Jets just make the expression more "optimized" by identifying patterns and -- replacing the expressions with "better" ones that have the same sematics. -- --- The tem "jet" in this context was introduced in the Urbit project: +-- The term "jet" in this context was introduced in the Urbit project: -- https://urbit.org/docs/vere/jetting/ -- -- The pattern fits well for simplifying 'Behaviour' tree paths. -class ConstructReportJet f a b c where - constructReportJet :: (f a b -> c) -> ReportJet f a +class ConstructReportJet x f where + constructReportJet :: x -> ReportJetResult f Inlines -instance (ConstructReportJet f b c d, Typeable b) => ConstructReportJet f a b (f b c -> d) where - constructReportJet f = ReportJet Proxy $ \x -> constructReportJet $ f x +instance (ConstructReportJet b f, JetArg a) => ConstructReportJet (a -> b) f where + constructReportJet f = Free (fmap f <$> consumeJetArg @a) >>= constructReportJet -instance Typeable b => ConstructReportJet f a b Inlines where - constructReportJet f = TerminalJet Proxy f +instance ConstructReportJet Inlines f where + constructReportJet x = Pure x -constructSomeReportJet :: (ConstructReportJet f a b c, Typeable a) => (f a b -> c) -> SomeReportJet f -constructSomeReportJet = SomeReportJet Proxy . constructReportJet +class JetArg a where + consumeJetArg :: ReportJet' f a -data ReportJet f a where - ReportJet :: Typeable b => Proxy b -> (f a b -> ReportJet f b) -> ReportJet f a - TerminalJet :: Typeable b => Proxy b -> (f a b -> Inlines) -> ReportJet f a +instance Typeable (f a b) => JetArg (f a b) where + consumeJetArg = + ReportJet $ \(x :: x) -> + case eqT @(f a b) @x of + Nothing -> empty + Just Refl -> pure $ Pure x -data SomeReportJet f where - SomeReportJet :: Typeable a => Proxy a -> ReportJet f a -> SomeReportJet f +instance TryLiftUnion xs => JetArg (Union xs) where + consumeJetArg = ReportJet $ fmap Pure . tryLiftUnion -applyReportJet :: forall f a b. Typeable b => ReportJet f a -> f a b -> Maybe (Either Inlines (ReportJet f b)) -applyReportJet (TerminalJet (Proxy :: Proxy b') f) x = eqT @b @b' <&> \Refl -> Left $ f x -applyReportJet (ReportJet (Proxy :: Proxy b') f) x = eqT @b @b' <&> \Refl -> Right $ f x +instance JetArg x => JetArg (NonEmpty x) where + consumeJetArg = + let (ReportJet f) = (consumeJetArg @x) + in ReportJet $ \a -> do + u <- f a + pure (u >>= \y -> Free $ fmap (NE.cons y) <$> consumeJetArg) + <|> pure (pure <$> u) + +type ReportJetResult f = Free (ReportJet f) + +-- Not a true 'Applicative' +newtype ReportJet f x = ReportJet (forall a b m. (Typeable (f a b), Alternative m, Monad m) => f a b -> m x) + deriving stock (Functor) + +type ReportJet' f a = ReportJet f (Free (ReportJet f) a) incrementHeaders :: ReportMonad x -> ReportMonad x incrementHeaders m = do l <- asks headerLevel local (\x -> x {headerLevel = l + 1}) m -jets :: [SomeReportJet Behave] +jets :: [ReportJet' Behave Inlines] jets = - [ constructSomeReportJet $ \p@(AtPath _) op@(InOperation _) -> - strong (describeBehaviour op) <> " " <> describeBehaviour p :: Inlines - , constructSomeReportJet $ \InRequest InPayload PayloadSchema -> "JSON Request" :: Inlines - , constructSomeReportJet $ \(WithStatusCode c) ResponsePayload PayloadSchema -> - "JSON Response – " <> str (T.pack . show $ c) :: Inlines - ] + unwrapReportJetResult + <$> [ constructReportJet jsonPathJet + , constructReportJet $ \p@(AtPath _) op@(InOperation _) -> + strong (describeBehaviour op) <> " " <> describeBehaviour p :: Inlines + , constructReportJet $ \InRequest InPayload PayloadSchema -> "JSON Request" :: Inlines + , constructReportJet $ \(WithStatusCode c) ResponsePayload PayloadSchema -> + "JSON Response – " <> str (T.pack . show $ c) :: Inlines + ] + where + unwrapReportJetResult :: ReportJetResult Behave x -> ReportJet' Behave x + unwrapReportJetResult (Pure _) = error "There really shouldn't be any results here." + unwrapReportJetResult (Free f) = f + + jsonPathJet + :: NonEmpty + ( Union + '[ Behave 'SchemaLevel 'TypedSchemaLevel + , Behave 'TypedSchemaLevel 'SchemaLevel + ] + ) + -> Inlines + jsonPathJet x = code $ "$" <> showParts (NE.toList x) + where + showParts + :: [ Union + '[ Behave 'SchemaLevel 'TypedSchemaLevel + , Behave 'TypedSchemaLevel 'SchemaLevel + ] + ] + -> Text + showParts [] = mempty + showParts (SingletonUnion (OfType Object) : xs@((SingletonUnion (InProperty _)) : _)) = showParts xs + showParts (SingletonUnion (OfType Object) : xs@((SingletonUnion InAdditionalProperty) : _)) = showParts xs + showParts (SingletonUnion (OfType Array) : xs@(SingletonUnion InItems : _)) = showParts xs + showParts (y : ys) = + ((\(OfType t) -> "(" <> describeJSONType t <> ")") + @@> (\case + InItems -> "[*]" + InProperty p -> "." <> p + InAdditionalProperty -> ".*") + @@> typesExhausted) + y + <> showParts ys diff --git a/src/OpenAPI/Checker/Validate/Schema.hs b/src/OpenAPI/Checker/Validate/Schema.hs index 62f81ef..d7a9ff1 100644 --- a/src/OpenAPI/Checker/Validate/Schema.hs +++ b/src/OpenAPI/Checker/Validate/Schema.hs @@ -10,6 +10,8 @@ module OpenAPI.Checker.Validate.Schema , Bound (..) , schemaToFormula , foldLattice + , Behave (..) + , describeJSONType ) where @@ -39,6 +41,7 @@ import Data.Ord import Data.Ratio import Data.Scientific import qualified Data.Set as S +import Data.String import Data.Text (Text) import qualified Data.Text as T hiding (singleton) import qualified Data.Text.Encoding as T @@ -1110,7 +1113,7 @@ instance Behavable 'SchemaLevel 'TypedSchemaLevel where describeBehaviour (OfType t) = describeJSONType t -describeJSONType :: JsonType -> Inlines +describeJSONType :: IsString s => JsonType -> s describeJSONType = \case Null -> "Null" Boolean -> "Boolean" diff --git a/stack.yaml b/stack.yaml index 034398f..622e6b6 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1 +1,5 @@ resolver: nightly-2021-06-01 + +extra-deps: + - open-union-0.4.0.0 + - type-fun-0.1.3 diff --git a/stack.yaml.lock b/stack.yaml.lock index 360dd4a..da13531 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -3,7 +3,21 @@ # For more information, please see the documentation at: # https://docs.haskellstack.org/en/stable/lock_files -packages: [] +packages: +- completed: + hackage: open-union-0.4.0.0@sha256:1c8f8090054b0974e95e44bed88e74fff956ba2120aade6e8deea92d65ef5e49,3503 + pantry-tree: + size: 329 + sha256: e01838ec41f7aa2a97aa2c3586c8188c4ad093ba0b2be41229ab7b8dbd33869e + original: + hackage: open-union-0.4.0.0 +- completed: + hackage: type-fun-0.1.3@sha256:336b851757792f201078043210aec180021ac052f0955c71fa330a5fe11b0604,1765 + pantry-tree: + size: 583 + sha256: b977d42525f0b4223959918d18e7905085283e937493c395077b608cd19b42c1 + original: + hackage: type-fun-0.1.3 snapshots: - completed: size: 587963 diff --git a/test/golden/common/maximum-lowered/report.md b/test/golden/common/maximum-lowered/report.md index 4952135..322ca61 100644 --- a/test/golden/common/maximum-lowered/report.md +++ b/test/golden/common/maximum-lowered/report.md @@ -2,6 +2,6 @@ ## JSON Request -### Number +### `$(Number)` Expected upper bound 3.0 inclusive but but found 2.0 inclusive. diff --git a/test/golden/common/pathItem/operation/parameters/change/report.md b/test/golden/common/pathItem/operation/parameters/change/report.md index c8bb963..9cba092 100644 --- a/test/golden/common/pathItem/operation/parameters/change/report.md +++ b/test/golden/common/pathItem/operation/parameters/change/report.md @@ -4,6 +4,6 @@ ### JSON Schema -#### String +#### `$(String)` Expected the type to be allowed, but it wasn't. diff --git a/test/golden/common/pathItem/operation/requestBody/mediaTypeObject/change/report.md b/test/golden/common/pathItem/operation/requestBody/mediaTypeObject/change/report.md index 637da11..645ba6f 100644 --- a/test/golden/common/pathItem/operation/requestBody/mediaTypeObject/change/report.md +++ b/test/golden/common/pathItem/operation/requestBody/mediaTypeObject/change/report.md @@ -2,6 +2,6 @@ ## JSON Request -### String +### `$(String)` Expected the type to be allowed, but it wasn't. diff --git a/test/golden/common/pathItem/operation/responses/change/mediaTypeObject/change/report.md b/test/golden/common/pathItem/operation/responses/change/mediaTypeObject/change/report.md index 01bafbc..68af1a3 100644 --- a/test/golden/common/pathItem/operation/responses/change/mediaTypeObject/change/report.md +++ b/test/golden/common/pathItem/operation/responses/change/mediaTypeObject/change/report.md @@ -2,6 +2,6 @@ ## JSON Response – 200 -### Number +### `$(Number)` Expected the type to be allowed, but it wasn't. diff --git a/test/golden/common/property-removed/report.md b/test/golden/common/property-removed/report.md index 17200d0..3f8533a 100644 --- a/test/golden/common/property-removed/report.md +++ b/test/golden/common/property-removed/report.md @@ -2,12 +2,12 @@ ## JSON Request -### Object +### `$(Object)` Expected the property `property2` to be allowed, but it wasn't. ## JSON Response – 200 -### Object +### `$(Object)` Don't have a required property `property2`. diff --git a/test/golden/common/property-required/report.md b/test/golden/common/property-required/report.md index 5a87db2..66e457d 100644 --- a/test/golden/common/property-required/report.md +++ b/test/golden/common/property-required/report.md @@ -2,6 +2,6 @@ ## JSON Request -### Object +### `$(Object)` Don't have a required property `property2`.