git.iko.soy/compaREST
on master help sign in
Added JSON Path jets (#75)
5fd5a1ciko
.gitignore+1
compare with master
unifiedsplit
@@ -2,3 +2,4 @@
2TAGS
2TAGS
3.vscode
3.vscode
4.dir-locals.el
4.dir-locals.el
5+test/golden/common/prod
openapi-diff.cabal+4
@@ -64,6 +64,9 @@ common common-options
64 , yaml
64 , yaml
65 , hashable
65 , hashable
66 , pandoc-types
66 , pandoc-types
67+ , open-union
68+ , type-fun
69+ , free
67
70
68 default-extensions: ApplicativeDo
71 default-extensions: ApplicativeDo
69 , BangPatterns
72 , BangPatterns
@@ -137,6 +140,7 @@ library
137 , OpenAPI.Checker.Validate.SecurityScheme
140 , OpenAPI.Checker.Validate.SecurityScheme
138 , OpenAPI.Checker.Validate.OAuth2Flows
141 , OpenAPI.Checker.Validate.OAuth2Flows
139 , OpenAPI.Checker.Report
142 , OpenAPI.Checker.Report
143+ , Data.OpenUnion.Extra
140
144
141executable openapi-diff
145executable openapi-diff
142 import: common-options
146 import: common-options
src/Data/OpenUnion/Extra.hsnew file+43
@@ -0,0 +1,43 @@
1+module Data.OpenUnion.Extra
2+ ( (@@>)
3+ , TryLiftUnion (..)
4+ , pattern SingletonUnion
5+ )
6+where
7+
8+import Control.Applicative
9+import Data.Dynamic
10+import Data.OpenUnion.Internal
11+import Data.Typeable
12+import TypeFun.Data.List hiding (Union)
13+
14+class TryLiftUnion xs where
15+ tryLiftUnion :: (Alternative m, Typeable x) => x -> m (Union xs)
16+
17+instance TryLiftUnion '[] where
18+ tryLiftUnion _ = empty
19+
20+instance
21+ (Typeable y, SubList ys (y : ys), TryLiftUnion ys)
22+ => TryLiftUnion (y ': ys)
23+ where
24+ tryLiftUnion (x :: x) = case eqT @x @y of
25+ Nothing -> reUnion <$> tryLiftUnion @ys x
26+ Just Refl -> pure $ liftUnion x
27+
28+-- | Like '@>', but enforces a specific type list order.
29+-- (Useful for deconstruction-directed type inference.)
30+(@@>) :: Typeable a => (a -> b) -> (Union xs -> b) -> Union (a ': xs) -> b
31+r @@> l = either l r . restrict'
32+ where
33+ restrict' :: Typeable a => Union (a ': aa) -> Either (Union aa) a
34+ restrict' (Union d) = maybe (Left $ Union d) Right $ fromDynamic d
35+{-# INLINE (@@>) #-}
36+
37+infixr 2 @@>
38+
39+pattern SingletonUnion :: (Typeable a, Elem a s) => a -> Union s
40+pattern SingletonUnion x <-
41+ ((\(Union y) -> fromDynamic y) -> Just x)
42+ where
43+ SingletonUnion x = liftUnion x
src/OpenAPI/Checker/Report.hs+127−52
@@ -3,14 +3,22 @@ module OpenAPI.Checker.Report
3 )
3 )
4where
4where
5
5
6+import Control.Applicative
7+import Control.Monad.Free hiding (unfoldM)
6import Control.Monad.Reader
8import Control.Monad.Reader
7import Control.Monad.Writer
9import Control.Monad.Writer
10+import Data.Either
8import Data.Foldable
11import Data.Foldable
12+import Data.Function
9import Data.Functor
13import Data.Functor
14+import Data.List.NonEmpty
15+import qualified Data.List.NonEmpty as NE
10import qualified Data.Map as M
16import qualified Data.Map as M
11import Data.Maybe
17import Data.Maybe
18+import Data.OpenUnion
19+import Data.OpenUnion.Extra
20+import Data.Text (Text)
12import qualified Data.Text as T
21import qualified Data.Text as T
13−import Data.Traversable
14import Data.TypeRepMap hiding (empty)
22import Data.TypeRepMap hiding (empty)
15import Data.Typeable
23import Data.Typeable
16import OpenAPI.Checker.Behavior
24import OpenAPI.Checker.Behavior
@@ -18,6 +26,7 @@ import OpenAPI.Checker.Paths
18import OpenAPI.Checker.PathsPrefixTree hiding (empty)
26import OpenAPI.Checker.PathsPrefixTree hiding (empty)
19import qualified OpenAPI.Checker.PathsPrefixTree as P hiding (empty)
27import qualified OpenAPI.Checker.PathsPrefixTree as P hiding (empty)
20import OpenAPI.Checker.Validate.OpenApi
28import OpenAPI.Checker.Validate.OpenApi
29+import OpenAPI.Checker.Validate.Schema
21import Text.Pandoc.Builder
30import Text.Pandoc.Builder
22
31
23generateReport :: Either (P.PathsPrefixTree Behave AnIssue 'APILevel) () -> Pandoc
32generateReport :: Either (P.PathsPrefixTree Behave AnIssue 'APILevel) () -> Pandoc
@@ -25,13 +34,13 @@ generateReport (Right ()) = doc $ header 1 "No breaking changes found ✨"
25generateReport (Left errs) = doc $ runReportMonad jets $ showErrs errs
34generateReport (Left errs) = doc $ runReportMonad jets $ showErrs errs
26
35
27data ReportState = ReportState
36data ReportState = ReportState
28− { sourceJets :: [SomeReportJet Behave]
37+ { sourceJets :: [ReportJet' Behave Inlines]
29 , headerLevel :: Int
38 , headerLevel :: Int
30 }
39 }
31
40
32type ReportMonad = ReaderT ReportState (Writer Blocks)
41type ReportMonad = ReaderT ReportState (Writer Blocks)
33
42
34−runReportMonad :: [SomeReportJet Behave] -> ReportMonad () -> Blocks
43+runReportMonad :: [ReportJet' Behave Inlines] -> ReportMonad () -> Blocks
35runReportMonad jts =
44runReportMonad jts =
36 execWriter
45 execWriter
37 . flip
46 . flip
@@ -46,11 +55,11 @@ smartHeader i = do
46 h <- asks headerLevel
55 h <- asks headerLevel
47 tell $ header h i
56 tell $ header h i
48
57
49−showErrs :: Typeable a => P.PathsPrefixTree Behave AnIssue a -> ReportMonad ()
58+showErrs :: P.PathsPrefixTree Behave AnIssue a -> ReportMonad ()
50showErrs x@(P.PathsPrefixNode currentIssues _) = do
59showErrs x@(P.PathsPrefixNode currentIssues _) = do
51 jts <- asks sourceJets
60 jts <- asks sourceJets
52 for_ currentIssues $ \(AnIssue i) -> tell . describeIssue $ i
61 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
54 for_ subIssues $ \(WrapTypeable (AStep m)) ->
63 for_ subIssues $ \(WrapTypeable (AStep m)) ->
55 for_ (M.toList m) $ \(bhv, subErrors) -> do
64 for_ (M.toList m) $ \(bhv, subErrors) -> do
56 unless (P.null subErrors) $ do
65 unless (P.null subErrors) $ do
@@ -63,74 +72,140 @@ unfoldM a (f : ff) g = do
63 a' <- f a
72 a' <- f a
64 unfoldM a' ff g
73 unfoldM a' ff g
65
74
66−observeSomeJetShowErrs
75+observeJetShowErrs
67− :: forall a.
76+ :: ReportJet' Behave Inlines
68− Typeable a
69− => SomeReportJet Behave
70 -> P.PathsPrefixTree Behave AnIssue a
77 -> P.PathsPrefixTree Behave AnIssue a
71 -> ReportMonad (P.PathsPrefixTree Behave AnIssue a)
78 -> ReportMonad (P.PathsPrefixTree Behave AnIssue a)
72−observeSomeJetShowErrs (SomeReportJet (Proxy :: Proxy a') f) x
79+observeJetShowErrs jet p = case observeJetShowErrs' jet p of
73− | Just Refl <- eqT @a @a' = observeJetShowErrs f x
80+ Just m -> m
74−observeSomeJetShowErrs _ x = pure x
81+ Nothing -> pure p
75−
82+
83+observeJetShowErrs'
84+ :: forall a.
85+ ReportJet' Behave Inlines
86+ -> P.PathsPrefixTree Behave AnIssue a
76−observeJetShowErrs :: ReportJet Behave a -> P.PathsPrefixTree Behave AnIssue a -> ReportMonad (P.PathsPrefixTree Behave AnIssue a)
87+ -> Maybe (ReportMonad (P.PathsPrefixTree Behave AnIssue a))
77−observeJetShowErrs jet (P.PathsPrefixNode currentIssues subIssues) = do
88+observeJetShowErrs' (ReportJet jet) (P.PathsPrefixNode currentIssues subIssues) =
78− rest <- fmap (fold . join) $
89+ let results =
79− for subIssues $ \(WrapTypeable (AStep m)) -> fmap catMaybes $
90+ subIssues >>= \(WrapTypeable (AStep m)) ->
80− for (M.toList m) $ \(bhv, subErrs) ->
91+ M.toList m <&> \(bhv, subErrs) ->
81− case applyReportJet jet bhv of
92+ maybe (Left $ embed (step bhv) subErrs) Right . listToMaybe $
82− Just (Left h) -> do
93+ jet @_ @_ @[] bhv
94+ & mapMaybe
95+ (\case
96+ Free jet' -> fmap (embed $ step bhv) <$> observeJetShowErrs' jet' subErrs
97+ Pure h -> Just $ do
83− smartHeader h
98+ smartHeader h
84− incrementHeaders $ showErrs subErrs
99+ incrementHeaders $ showErrs subErrs
85− return Nothing
100+ return mempty)
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
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
91
114
92-- | A "jet" is a way of simplifying expressions from "outside". The "jetted"
115-- | A "jet" is a way of simplifying expressions from "outside". The "jetted"
93-- expressions should still be completely valid and correct without the jets.
116-- expressions should still be completely valid and correct without the jets.
94-- Jets just make the expression more "optimized" by identifying patterns and
117-- Jets just make the expression more "optimized" by identifying patterns and
95-- replacing the expressions with "better" ones that have the same sematics.
118-- replacing the expressions with "better" ones that have the same sematics.
96--
119--
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:
98-- https://urbit.org/docs/vere/jetting/
121-- https://urbit.org/docs/vere/jetting/
99--
122--
100-- The pattern fits well for simplifying 'Behaviour' tree paths.
123-- The pattern fits well for simplifying 'Behaviour' tree paths.
101−class ConstructReportJet f a b c where
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
102− constructReportJet :: (f a b -> c) -> ReportJet f a
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
103
135
104−instance (ConstructReportJet f b c d, Typeable b) => ConstructReportJet f a b (f b c -> d) where
136+instance Typeable (f a b) => JetArg (f a b) where
105− constructReportJet f = ReportJet Proxy $ \x -> constructReportJet $ f x
137+ consumeJetArg =
138+ ReportJet $ \(x :: x) ->
139+ case eqT @(f a b) @x of
140+ Nothing -> empty
141+ Just Refl -> pure $ Pure x
106
142
107−instance Typeable b => ConstructReportJet f a b Inlines where
143+instance TryLiftUnion xs => JetArg (Union xs) where
108− constructReportJet f = TerminalJet Proxy f
144+ consumeJetArg = ReportJet $ fmap Pure . tryLiftUnion
109
145
110−constructSomeReportJet :: (ConstructReportJet f a b c, Typeable a) => (f a b -> c) -> SomeReportJet f
146+instance JetArg x => JetArg (NonEmpty x) where
111−constructSomeReportJet = SomeReportJet Proxy . constructReportJet
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)
112
153
113−data ReportJet f a where
154+type ReportJetResult f = Free (ReportJet f)
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
116
155
117−data SomeReportJet f where
156+-- Not a true 'Applicative'
118− SomeReportJet :: Typeable a => Proxy a -> ReportJet f a -> SomeReportJet f
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)
119
159
120−applyReportJet :: forall f a b. Typeable b => ReportJet f a -> f a b -> Maybe (Either Inlines (ReportJet f b))
160+type ReportJet' f a = ReportJet f (Free (ReportJet f) a)
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
123
161
124incrementHeaders :: ReportMonad x -> ReportMonad x
162incrementHeaders :: ReportMonad x -> ReportMonad x
125incrementHeaders m = do
163incrementHeaders m = do
126 l <- asks headerLevel
164 l <- asks headerLevel
127 local (\x -> x {headerLevel = l + 1}) m
165 local (\x -> x {headerLevel = l + 1}) m
128
166
129−jets :: [SomeReportJet Behave]
167+jets :: [ReportJet' Behave Inlines]
130jets =
168jets =
169+ unwrapReportJetResult
170+ <$> [ constructReportJet jsonPathJet
131− [ constructSomeReportJet $ \p@(AtPath _) op@(InOperation _) ->
171+ , constructReportJet $ \p@(AtPath _) op@(InOperation _) ->
132− strong (describeBehaviour op) <> " " <> describeBehaviour p :: Inlines
172+ strong (describeBehaviour op) <> " " <> describeBehaviour p :: Inlines
133− , constructSomeReportJet $ \InRequest InPayload PayloadSchema -> "JSON Request" :: Inlines
173+ , constructReportJet $ \InRequest InPayload PayloadSchema -> "JSON Request" :: Inlines
134− , constructSomeReportJet $ \(WithStatusCode c) ResponsePayload PayloadSchema ->
174+ , constructReportJet $ \(WithStatusCode c) ResponsePayload PayloadSchema ->
135− "JSON Response – " <> str (T.pack . show $ c) :: Inlines
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
136− ]
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
src/OpenAPI/Checker/Validate/Schema.hs+4−1
@@ -10,6 +10,8 @@ module OpenAPI.Checker.Validate.Schema
10 , Bound (..)
10 , Bound (..)
11 , schemaToFormula
11 , schemaToFormula
12 , foldLattice
12 , foldLattice
13+ , Behave (..)
14+ , describeJSONType
13 )
15 )
14where
16where
15
17
@@ -39,6 +41,7 @@ import Data.Ord
39import Data.Ratio
41import Data.Ratio
40import Data.Scientific
42import Data.Scientific
41import qualified Data.Set as S
43import qualified Data.Set as S
44+import Data.String
42import Data.Text (Text)
45import Data.Text (Text)
43import qualified Data.Text as T hiding (singleton)
46import qualified Data.Text as T hiding (singleton)
44import qualified Data.Text.Encoding as T
47import qualified Data.Text.Encoding as T
@@ -1110,7 +1113,7 @@ instance Behavable 'SchemaLevel 'TypedSchemaLevel where
1110
1113
1111 describeBehaviour (OfType t) = describeJSONType t
1114 describeBehaviour (OfType t) = describeJSONType t
1112
1115
1113−describeJSONType :: JsonType -> Inlines
1116+describeJSONType :: IsString s => JsonType -> s
1114describeJSONType = \case
1117describeJSONType = \case
1115 Null -> "Null"
1118 Null -> "Null"
1116 Boolean -> "Boolean"
1119 Boolean -> "Boolean"
stack.yaml+4
@@ -1 +1,5 @@
1resolver: nightly-2021-06-01
1resolver: nightly-2021-06-01
2+
3+extra-deps:
4+ - open-union-0.4.0.0
5+ - type-fun-0.1.3
stack.yaml.lock+15−1
@@ -3,7 +3,21 @@
3# For more information, please see the documentation at:
3# For more information, please see the documentation at:
4# https://docs.haskellstack.org/en/stable/lock_files
4# https://docs.haskellstack.org/en/stable/lock_files
5
5
6−packages: []
6+packages:
7+- completed:
8+ hackage: open-union-0.4.0.0@sha256:1c8f8090054b0974e95e44bed88e74fff956ba2120aade6e8deea92d65ef5e49,3503
9+ pantry-tree:
10+ size: 329
11+ sha256: e01838ec41f7aa2a97aa2c3586c8188c4ad093ba0b2be41229ab7b8dbd33869e
12+ original:
13+ hackage: open-union-0.4.0.0
14+- completed:
15+ hackage: type-fun-0.1.3@sha256:336b851757792f201078043210aec180021ac052f0955c71fa330a5fe11b0604,1765
16+ pantry-tree:
17+ size: 583
18+ sha256: b977d42525f0b4223959918d18e7905085283e937493c395077b608cd19b42c1
19+ original:
20+ hackage: type-fun-0.1.3
7snapshots:
21snapshots:
8- completed:
22- completed:
9 size: 587963
23 size: 587963
test/golden/common/maximum-lowered/report.md+1−1
@@ -2,6 +2,6 @@
2
2
3## JSON Request
3## JSON Request
4
4
5−### Number
5+### `$(Number)`
6
6
7Expected upper bound 3.0 inclusive but but found 2.0 inclusive.
7Expected upper bound 3.0 inclusive but but found 2.0 inclusive.
test/golden/common/pathItem/operation/parameters/change/report.md+1−1
@@ -4,6 +4,6 @@
4
4
5### JSON Schema
5### JSON Schema
6
6
7−#### String
7+#### `$(String)`
8
8
9Expected the type to be allowed, but it wasn't.
9Expected the type to be allowed, but it wasn't.
test/golden/common/pathItem/operation/requestBody/mediaTypeObject/change/report.md+1−1
@@ -2,6 +2,6 @@
2
2
3## JSON Request
3## JSON Request
4
4
5−### String
5+### `$(String)`
6
6
7Expected the type to be allowed, but it wasn't.
7Expected the type to be allowed, but it wasn't.
test/golden/common/pathItem/operation/responses/change/mediaTypeObject/change/report.md+1−1
@@ -2,6 +2,6 @@
2
2
3## JSON Response – 200
3## JSON Response – 200
4
4
5−### Number
5+### `$(Number)`
6
6
7Expected the type to be allowed, but it wasn't.
7Expected the type to be allowed, but it wasn't.
test/golden/common/property-removed/report.md+2−2
@@ -2,12 +2,12 @@
2
2
3## JSON Request
3## JSON Request
4
4
5−### Object
5+### `$(Object)`
6
6
7Expected the property `property2` to be allowed, but it wasn't.
7Expected the property `property2` to be allowed, but it wasn't.
8
8
9## JSON Response – 200
9## JSON Response – 200
10
10
11−### Object
11+### `$(Object)`
12
12
13Don't have a required property `property2`.
13Don't have a required property `property2`.
test/golden/common/property-required/report.md+1−1
@@ -2,6 +2,6 @@
2
2
3## JSON Request
3## JSON Request
4
4
5−### Object
5+### `$(Object)`
6
6
7Don't have a required property `property2`.
7Don't have a required property `property2`.