git.iko.soy/typeable/compaREST
on master help sign in
Dropped unused modules (#25)

* Changed main and tests * Removed unused modules * replace instances with standalone deriving * SomeCheckIssue -> SubtreeCheckIssue

commit7dface810178ad211f69062717280a7174beafdc authoriko <ilyakooo0@gmail.com> dateThu 25 Mar 2021, 19:06 (6 years ago) parent94d03ac
20 files changed+242−440
compare with master
unifiedsplit
openapi-diff.cabal+6−8 src/OpenAPI/Checker/Aux.hs−7 src/OpenAPI/Checker/Orphans.hs+1−1 src/OpenAPI/Checker/Report.hs−118 src/OpenAPI/Checker/Run.hs+9−4 src/OpenAPI/Checker/Subtree.hs+50−5 src/OpenAPI/Checker/Trace.hs+1−1 src/OpenAPI/Checker/TracePrefixTree.hs+92−35 src/OpenAPI/Checker/Validate.hs−96 src/OpenAPI/Checker/Validate/Dereference.hs−8 src/OpenAPI/Checker/Validate/Monad.hs−52 src/OpenAPI/Checker/Validate/OpenApi.hs+6−6 src/OpenAPI/Checker/Validate/Operation.hs+2−2 src/OpenAPI/Checker/Validate/Param.hs+1−1 src/OpenAPI/Checker/Validate/PathFragment.hs+2−2 test/Spec.hs+3−6 test/Spec/Golden/Extra.hs+46−50 test/Spec/Golden/Report.hs−19 test/Spec/Golden/ReportTree.hs−19 test/Spec/Golden/TraceTree.hs+23
openapi-diff.cabal+6−8
@@ -46,6 +46,9 @@ common common-options
4646 , transformers
4747 , typerep-map
4848 , yaml
49+ , unordered-containers
50+ , vector
51+ , bytestring
4952
5053 default-extensions: ApplicativeDo
5154 , BangPatterns
@@ -84,25 +87,21 @@ common common-options
8487 , TypeOperators
8588 , UndecidableInstances
8689 , ViewPatterns
90+ , QuantifiedConstraints
8791
8892library
8993 import: common-options
9094 hs-source-dirs: src
91− exposed-modules: OpenAPI.Checker.Aux
92− , Data.HList
95+ exposed-modules: Data.HList
9396 , OpenAPI.Checker.Formula
9497 , OpenAPI.Checker.Memo
9598 , OpenAPI.Checker.Options
9699 , OpenAPI.Checker.Orphans
97100 , OpenAPI.Checker.References
98− , OpenAPI.Checker.Report
99101 , OpenAPI.Checker.Run
100102 , OpenAPI.Checker.Subtree
101103 , OpenAPI.Checker.Trace
102104 , OpenAPI.Checker.TracePrefixTree
103− , OpenAPI.Checker.Validate
104− , OpenAPI.Checker.Validate.Dereference
105− , OpenAPI.Checker.Validate.Monad
106105 , OpenAPI.Checker.Validate.OpenApi
107106 , OpenAPI.Checker.Validate.Operation
108107 , OpenAPI.Checker.Validate.Param
@@ -123,9 +122,8 @@ test-suite openapi-diff-test
123122 hs-source-dirs: test
124123 main-is: Spec.hs
125124 other-modules:
126− Spec.Golden.Report
127125 Spec.Golden.Extra
128− Spec.Golden.ReportTree
126+ Spec.Golden.TraceTree
129127 build-depends:
130128 , openapi-diff
131129 , tasty-golden
src/OpenAPI/Checker/Aux.hsdeleted−7
@@ -1,7 +0,0 @@
1−module OpenAPI.Checker.Aux where
2−
3−import Data.OpenApi.Internal
4−
5−-- | Megre servers from parent (like PathItem) and child (like Operation)
6−mergeServers :: [Server] -> [Server] -> [Server]
7−mergeServers parent child = (error "FIXME: not implemented")
src/OpenAPI/Checker/Orphans.hs+1−1
@@ -12,4 +12,4 @@ instance Typeable a => Steppable (Referenced a) a where
1212 data Step (Referenced a) a
1313 = InlineStep
1414 | ReferencedStep Reference
15− deriving (Eq, Ord)
15+ deriving (Eq, Ord, Show)
src/OpenAPI/Checker/Report.hsdeleted−118
@@ -1,118 +0,0 @@
1−module OpenAPI.Checker.Report where
2−
3−import Data.Aeson
4−import Data.Aeson.Types
5−import qualified Data.Attoparsec.Text as A
6−import Data.Functor
7−import Data.Map.Strict as M
8−import Data.Maybe
9−import Data.Monoid.Generic
10−import Data.OpenApi.Internal
11−import Data.Text (Text)
12−import Deriving.Aeson.Stock
13−import OpenAPI.Checker.Validate.Monad
14−import Prelude as P
15−
16−printReport :: Report -> IO ()
17−printReport = error "FIXME: printReport not implemented"
18−
19−class HasUnsupportedFeature x where
20− hasUnsupportedFeature :: x -> Bool
21−
22−data Report = Report
23− { status :: Status
24− , tree :: ReportTree
25− }
26− deriving stock (Eq, Ord, Show, Generic)
27− deriving (ToJSON, FromJSON) via Snake Report
28−
29−instance HasUnsupportedFeature Report
30−
31−instance HasUnsupportedFeature x => HasUnsupportedFeature (Either e x) where
32− hasUnsupportedFeature (Left _) = False
33− hasUnsupportedFeature (Right x) = hasUnsupportedFeature x
34−
35−data Status = Success | Fail Text
36− deriving stock (Eq, Ord, Show, Generic)
37− deriving (ToJSON, FromJSON) via Snake Status
38−
39−type Path = FilePath -- From the library
40−
41−newtype ReportTree = ReportTree
42− { paths :: Map Path (Errorable PathItemTree)
43− }
44− deriving stock (Show, Generic)
45− deriving newtype (Eq, Ord, Semigroup, Monoid)
46− deriving (ToJSON, FromJSON) via Snake ReportTree
47−
48−instance HasUnsupportedFeature ReportTree
49−
50−data PathItemTree = PathItemTree
51− { operations :: Map OperationName (Errorable OperationTree)
52− , server :: Maybe (Errorable ServerTree)
53− }
54− deriving stock (Eq, Ord, Show, Generic)
55− deriving (ToJSON, FromJSON) via Snake PathItemTree
56−
57−instance Semigroup PathItemTree where
58− (<>) = genericMappend
59−
60−instance Monoid PathItemTree where
61− mempty = genericMempty
62−
63−instance Nested PathItemTree where
64− type Parent PathItemTree = ReportTree
65− type Key PathItemTree = Path
66− nest key p = ReportTree $ M.singleton key p
67−
68−data OperationName
69− = Get | Put | Post | Delete | Options | Head | Patch | Trace
70− deriving (Eq, Ord, Show, Generic)
71− deriving (ToJSON, FromJSON) via Snake OperationName
72− deriving anyclass (ToJSONKey, FromJSONKey)
73−
74−newtype OperationTree = OperationTree
75− { parameters :: Map ParamKey (Errorable ParamTree)
76− }
77− deriving stock (Show, Generic)
78− deriving newtype (Eq, Ord, Semigroup, Monoid, FromJSON, ToJSON)
79−
80−instance Nested OperationTree where
81− type Parent OperationTree = PathItemTree
82− type Key OperationTree = OperationName
83− nest key p = PathItemTree (M.singleton key p) mempty
84−
85−data ServerTree = ServerTree
86− deriving stock (Eq, Ord, Show, Generic)
87− deriving (ToJSON, FromJSON) via Snake ServerTree
88−
89−data ParamTree = ParamTree
90− deriving stock (Eq, Ord, Show, Generic)
91− deriving (ToJSON, FromJSON) via Snake ParamTree
92−
93−instance Semigroup ParamTree where
94− (<>) = error "Not implemented"
95−instance Monoid ParamTree where
96− mappend = (<>)
97− mempty = error "Not implemented"
98−
99−instance Nested ParamTree where
100− type Key ParamTree = ParamKey
101− type Parent ParamTree = OperationTree
102− nest key p = OperationTree $ M.singleton key p
103−
104−deriving instance Ord ParamLocation
105−
106−data ParamKey = ParamKey
107− { name :: Text
108− , paramIn :: ParamLocation
109− }
110− deriving stock (Eq, Ord, Show, Generic)
111− deriving (FromJSON, ToJSON) via Snake ParamKey
112− deriving anyclass (ToJSONKey, FromJSONKey)
113−
114−getParamKey :: Param -> ParamKey
115−getParamKey p = ParamKey
116− { name = _paramName p
117− , paramIn = _paramIn p
118− }
src/OpenAPI/Checker/Run.hs+9−4
@@ -1,9 +1,14 @@
11module OpenAPI.Checker.Run (runChecker) where
22
3+import Control.Category
34import Data.Aeson
5+import qualified Data.ByteString.Char8 as BSC
6+import Data.HList
7+import qualified Data.Yaml as Yaml
48import OpenAPI.Checker.Options
5−import OpenAPI.Checker.Report
6−import OpenAPI.Checker.Validate
9+import OpenAPI.Checker.Subtree
10+import OpenAPI.Checker.Validate.OpenApi ()
11+import Prelude hiding (id, (.))
712
813runChecker :: IO ()
914runChecker = do
@@ -16,5 +21,5 @@ runChecker = do
1621 Right s -> pure s
1722 a <- parseSchema (clientFile opts)
1823 b <- parseSchema (serverFile opts)
19− let report = reportCompat a b
20− printReport report
24+ let report = runCompatFormula (pure id) $ checkCompatibility HNil (ProdCons a b)
25+ BSC.putStrLn $ Yaml.encode report
src/OpenAPI/Checker/Subtree.hs+50−5
@@ -4,6 +4,7 @@ module OpenAPI.Checker.Subtree
44 , CompatM (..)
55 , CompatFormula
66 , ProdCons (..)
7+ , HasUnsupportedFeature (..)
78 , runCompatFormula
89 , localM
910 , localTrace
@@ -18,9 +19,11 @@ where
1819import Control.Monad.Identity
1920import Control.Monad.Reader
2021import Control.Monad.State
22+import Data.Aeson
2123import Data.Functor.Compose
2224import Data.HList
2325import Data.Kind
26+import Data.Monoid
2427import Data.OpenApi
2528import Data.Text
2629import Data.Typeable
@@ -60,17 +63,59 @@ newtype CompatM t a = CompatM
6063 , MonadState (MemoState VarRef)
6164 )
6265
63−type CompatFormula t = Compose (CompatM t) (FormulaF CheckIssue OpenApi)
66+type CompatFormula t = Compose (CompatM t) (FormulaF SubtreeCheckIssue OpenApi)
6467
65−class (Typeable t, Ord (CheckIssue t)) => Subtree (t :: Type) where
68+class (Typeable t, Ord (CheckIssue t), Show (CheckIssue t)) => Subtree (t :: Type) where
6669 type CheckEnv t :: [Type]
6770 data CheckIssue t :: Type
6871
72+ issueIsUnsupported :: CheckIssue t -> Bool
73+ issueIsUnsupported = const False
74+
6975 -- | If we ever followed a reference, reroute the path through "components"
7076 normalizeTrace :: Trace OpenApi t -> Trace OpenApi t
7177
7278 checkCompatibility :: HasAll (CheckEnv t) xs => HList xs -> ProdCons t -> CompatFormula t ()
7379
80+class HasUnsupportedFeature x where
81+ hasUnsupportedFeature :: x -> Bool
82+
83+instance HasUnsupportedFeature () where
84+ hasUnsupportedFeature () = False
85+
86+instance
87+ (HasUnsupportedFeature a, HasUnsupportedFeature b)
88+ => HasUnsupportedFeature (Either a b)
89+ where
90+ hasUnsupportedFeature (Left x) = hasUnsupportedFeature x
91+ hasUnsupportedFeature (Right x) = hasUnsupportedFeature x
92+
93+instance Subtree t => HasUnsupportedFeature (CheckIssue t) where
94+ hasUnsupportedFeature = issueIsUnsupported
95+
96+instance
97+ (forall x. HasUnsupportedFeature (f x))
98+ => HasUnsupportedFeature (T.TracePrefixTree f r)
99+ where
100+ hasUnsupportedFeature =
101+ getAny . T.foldWith (\_ fa -> Any $ hasUnsupportedFeature fa)
102+
103+data SubtreeCheckIssue t where
104+ SubtreeCheckIssue :: Subtree t => CheckIssue t -> SubtreeCheckIssue t
105+
106+deriving stock instance Eq (SubtreeCheckIssue t)
107+
108+deriving stock instance Ord (SubtreeCheckIssue t)
109+
110+instance Subtree t => ToJSON (CheckIssue t) where
111+ toJSON = toJSON . show
112+
113+instance HasUnsupportedFeature (SubtreeCheckIssue t) where
114+ hasUnsupportedFeature (SubtreeCheckIssue i) = hasUnsupportedFeature i
115+
116+instance ToJSON (SubtreeCheckIssue t) where
117+ toJSON (SubtreeCheckIssue i) = toJSON i
118+
74119runCompatFormula
75120 :: ProdCons (Trace OpenApi t)
76121 -> Compose (CompatM t) (FormulaF f r) a
@@ -93,7 +138,7 @@ localTrace xs (Compose h) = Compose (localM xs h)
93138
94139issueAtTrace
95140 :: Subtree t => Trace OpenApi t -> CheckIssue t -> CompatFormula t a
96−issueAtTrace xs issue = Compose $ pure $ anError $ AnItem xs issue
141+issueAtTrace xs issue = Compose $ pure $ anError $ AnItem xs $ SubtreeCheckIssue issue
97142
98143issueAt
99144 :: Subtree t
@@ -102,7 +147,7 @@ issueAt
102147 -> CompatFormula t a
103148issueAt f issue = Compose $ do
104149 xs <- asks f
105− pure $ anError $ AnItem xs issue
150+ pure $ anError $ AnItem xs $ SubtreeCheckIssue issue
106151
107152anyOfM
108153 :: Ord (f t)
@@ -121,7 +166,7 @@ anyOfAt
121166 -> CompatFormula t a
122167anyOfAt f issue fs = Compose $ do
123168 xs <- asks f
124− (`eitherOf` AnItem xs issue) <$> sequenceA (getCompose <$> fs)
169+ (`eitherOf` AnItem xs (SubtreeCheckIssue issue)) <$> sequenceA (getCompose <$> fs)
125170
126171fixpointKnot
127172 :: MonadState (MemoState VarRef) m
src/OpenAPI/Checker/Trace.hs+1−1
@@ -28,7 +28,7 @@ import Type.Reflection
2828import Prelude hiding ((.))
2929
3030class
31− (Typeable a, Typeable b, Ord (Step a b)) =>
31+ (Typeable a, Typeable b, Ord (Step a b), Show (Step a b)) =>
3232 Steppable (a :: k) (b :: k)
3333 where
3434 -- | How to get from an @a@ node to a @b@ node
src/OpenAPI/Checker/TracePrefixTree.hs+92−35
@@ -1,4 +1,5 @@
11{-# LANGUAGE QuantifiedConstraints #-}
2+
23module OpenAPI.Checker.TracePrefixTree
34 ( TracePrefixTree
45 , empty
@@ -8,65 +9,87 @@ module OpenAPI.Checker.TracePrefixTree
89 , foldWith
910 , toList
1011 , filter
11− ) where
12+ )
13+where
1214
13−import qualified GHC.Exts as T
15+import Data.Aeson
1416import Data.Foldable hiding (null, toList)
17+import qualified Data.HashMap.Strict as HM
1518import Data.Kind
1619import qualified Data.Map as M
1720import Data.Monoid
1821import qualified Data.Set as S
19−import qualified Data.TypeRepMap as T
22+import qualified Data.Text as T
23+import Data.Type.Equality
24+import qualified Data.TypeRepMap as TRM
25+import qualified Data.Vector as V
26+import qualified GHC.Exts as TRM
2027import OpenAPI.Checker.Trace
21−import Prelude hiding (null, filter)
2228import Type.Reflection
23−import Data.Type.Equality
29+import Prelude hiding (filter, null)
2430
2531-- | A list of @AnItem r f@, but optimized into a prefix tree.
2632data TracePrefixTree (f :: k -> Type) (r :: k) = TracePrefixTree
2733 { rootItems :: !(ASet (f r))
28− , snocItems :: !(T.TypeRepMap (AStep f r))
34+ , snocItems :: !(TRM.TypeRepMap (AStep f r))
2935 }
3036
37+instance (forall a. ToJSON (f a)) => ToJSON (TracePrefixTree f r) where
38+ toJSON =
39+ Object . getMergableObject
40+ . foldWith (\t x -> MergableObject . traceObject t $ toJSON x)
41+
3142deriving instance Eq (TracePrefixTree f a)
3243
3344-- Kind of orphan. Treat the map as an infinite tuple of @Maybe (f a)@'s, where
3445-- the components are ordered by the @SomeTypeRep@ of the @a@.
3546compareTRM
3647 :: (forall a. Typeable a => Ord (f a))
37− => T.TypeRepMap f -> T.TypeRepMap f -> Ordering
38−compareTRM s1 s2
39− = foldMap (\k -> compareMaybe compareW (M.lookup k m1) (M.lookup k m2)) mKeys
48+ => TRM.TypeRepMap f
49+ -> TRM.TypeRepMap f
50+ -> Ordering
51+compareTRM s1 s2 =
52+ foldMap (\k -> compareMaybe compareW (M.lookup k m1) (M.lookup k m2)) mKeys
4053 where
4154 (m1, m2) = (toMap s1, toMap s2)
4255 mKeys = S.toAscList $ M.keysSet m1 `S.union` M.keysSet m2
43− compareMaybe _ Nothing Nothing = EQ
44− compareMaybe _ Nothing (Just _) = LT
45− compareMaybe _ (Just _) Nothing = GT
56+ compareMaybe _ Nothing Nothing = EQ
57+ compareMaybe _ Nothing (Just _) = LT
58+ compareMaybe _ (Just _) Nothing = GT
4659 compareMaybe cmp (Just x) (Just y) = cmp x y
4760 compareW
4861 :: (forall a. Typeable a => Ord (f a))
49− => T.WrapTypeable f -> T.WrapTypeable f -> Ordering
50− compareW (T.WrapTypeable (x :: f a)) (T.WrapTypeable (y :: f b))
62+ => TRM.WrapTypeable f
63+ -> TRM.WrapTypeable f
64+ -> Ordering
65+ compareW (TRM.WrapTypeable (x :: f a)) (TRM.WrapTypeable (y :: f b))
5166 | Just Refl <- testEquality (typeRep @a) (typeRep @b) = compare x y
5267 | otherwise = EQ -- unreachable
53− toMap s = M.fromList
54− [(someTypeRep x, w) | w@(T.WrapTypeable x) <- T.toList s]
68+ toMap s =
69+ M.fromList
70+ [(someTypeRep x, w) | w@(TRM.WrapTypeable x) <- TRM.toList s]
5571
5672instance Ord (TracePrefixTree f a) where
57− compare (TracePrefixTree r1 s1) (TracePrefixTree r2 s2)
58− = compare r1 r2 <> compareTRM s1 s2
73+ compare (TracePrefixTree r1 s1) (TracePrefixTree r2 s2) =
74+ compare r1 r2 <> compareTRM s1 s2
5975
6076data ASet (a :: Type) where
6177 AnEmptySet :: ASet a
6278 ASet :: Ord a => S.Set a -> ASet a
6379
80+instance ToJSON a => ToJSON (ASet a) where
81+ toJSON =
82+ toJSON . \case
83+ AnEmptySet -> S.empty
84+ ASet s -> s
85+
6486instance Semigroup (ASet a) where
6587 AnEmptySet <> s = s
6688 s <> AnEmptySet = s
6789 ASet s1 <> ASet s2 = ASet $ S.union s1 s2
6890
6991deriving instance Eq (ASet a)
92+
7093deriving instance Ord (ASet a)
7194
7295-- type traceprefixset = traceprefixtree proxy
@@ -76,26 +99,33 @@ instance Monoid (ASet a) where
7699
77100data AStep (f :: k -> Type) (r :: k) (a :: k) where
78101 AStep
79− :: Steppable r a => !(M.Map (Step r a) (TracePrefixTree f a)) -> AStep f r a
102+ :: Steppable r a =>
103+ !(M.Map (Step r a) (TracePrefixTree f a))
104+ -> AStep f r a
80105
81106deriving instance Eq (AStep f r a)
107+
82108deriving instance Ord (AStep f r a)
83109
84110singleton :: AnItem f r -> TracePrefixTree f r
85−singleton (AnItem ys v) = go ys $ TracePrefixTree (ASet $ S.singleton v) T.empty
111+singleton (AnItem ys v) = go ys $ TracePrefixTree (ASet $ S.singleton v) TRM.empty
86112 where
87113 go :: Trace r a -> TracePrefixTree f a -> TracePrefixTree f r
88114 go Root !t = t
89− go (Snoc xs x) !t = go xs $ TracePrefixTree AnEmptySet $ T.one
90− $ AStep $ M.singleton x t
115+ go (Snoc xs x) !t =
116+ go xs $
117+ TracePrefixTree AnEmptySet $
118+ TRM.one $
119+ AStep $ M.singleton x t
91120
92121instance Semigroup (TracePrefixTree f r) where
93122 TracePrefixTree r1 s1 <> TracePrefixTree r2 s2 =
94− TracePrefixTree (r1 <> r2) (T.unionWith joinSteps s1 s2)
95− where joinSteps (AStep m1) (AStep m2) = AStep $ M.unionWith (<>) m1 m2
123+ TracePrefixTree (r1 <> r2) (TRM.unionWith joinSteps s1 s2)
124+ where
125+ joinSteps (AStep m1) (AStep m2) = AStep $ M.unionWith (<>) m1 m2
96126
97127instance Monoid (TracePrefixTree f r) where
98− mempty = TracePrefixTree mempty T.empty
128+ mempty = TracePrefixTree mempty TRM.empty
99129
100130empty :: TracePrefixTree f r
101131empty = mempty
@@ -104,12 +134,15 @@ fromList :: [AnItem f r] -> TracePrefixTree f r
104134fromList = foldMap singleton
105135
106136null :: TracePrefixTree f r -> Bool
107−null (TracePrefixTree AnEmptySet s) = T.size s == 0
137+null (TracePrefixTree AnEmptySet s) = TRM.size s == 0
108138null _ = False
109139
110140foldWith
111− :: forall f m r. Monoid m
112− => (forall a. Ord (f a) => Trace r a -> f a -> m) -> TracePrefixTree f r -> m
141+ :: forall f m r.
142+ Monoid m
143+ => (forall a. Ord (f a) => Trace r a -> f a -> m)
144+ -> TracePrefixTree f r
145+ -> m
113146foldWith k = goTPT Root
114147 where
115148 goTPT :: forall a. Trace r a -> TracePrefixTree f a -> m
@@ -117,17 +150,41 @@ foldWith k = goTPT Root
117150 goASet :: forall a. Trace r a -> ASet (f a) -> m
118151 goASet _ AnEmptySet = mempty
119152 goASet xs (ASet rs) = foldMap (k xs) rs
120− goTRM :: forall a. Trace r a -> T.TypeRepMap (AStep f a) -> m
121− goTRM xs s = foldMap (\(T.WrapTypeable f) -> goAStep xs f) $ T.toList s
153+ goTRM :: forall a. Trace r a -> TRM.TypeRepMap (AStep f a) -> m
154+ goTRM xs s = foldMap (\(TRM.WrapTypeable f) -> goAStep xs f) $ TRM.toList s
122155 goAStep :: forall a b. Trace r a -> AStep f a b -> m
123− goAStep xs (AStep m)
124− = M.foldrWithKey (\x t -> (goTPT (Snoc xs x) t <>)) mempty m
156+ goAStep xs (AStep m) =
157+ M.foldrWithKey (\x t -> (goTPT (Snoc xs x) t <>)) mempty m
125158
126159toList :: TracePrefixTree f r -> [AnItem f r]
127−toList t = appEndo (foldWith (\xs f -> Endo (AnItem xs f:)) t) []
160+toList t = appEndo (foldWith (\xs f -> Endo (AnItem xs f :)) t) []
128161
129162-- | Select a subtree by prefix
130163filter :: Trace r a -> TracePrefixTree f r -> TracePrefixTree f a
131164filter Root t = t
132−filter (Snoc xs x) t = foldMap (\(AStep m) -> fold $ M.lookup x m)
133− $ T.lookup $ snocItems $ filter xs t
165+filter (Snoc xs x) t =
166+ foldMap (\(AStep m) -> fold $ M.lookup x m) $
167+ TRM.lookup $ snocItems $ filter xs t
168+
169+newtype MergableObject = MergableObject {getMergableObject :: Object}
170+
171+instance Semigroup MergableObject where
172+ (MergableObject x) <> (MergableObject y) =
173+ MergableObject $ HM.unionWith mergeValue x y
174+ where
175+ mergeValue :: Value -> Value -> Value
176+ mergeValue (Object a) (Object b) =
177+ Object . getMergableObject $ MergableObject a <> MergableObject b
178+ mergeValue (Array a) (Array b) = Array $ a <> b
179+ mergeValue (Array a) b = Array $ V.snoc a b
180+ mergeValue a (Array b) = Array $ V.cons a b
181+ mergeValue a b = toJSON [a, b]
182+
183+instance Monoid MergableObject where
184+ mempty = MergableObject mempty
185+
186+traceObject :: Trace r a -> Value -> Object
187+traceObject Root (Object o) = o
188+traceObject Root v = HM.singleton "root" v
189+traceObject (root `Snoc` s) v =
190+ traceObject root . Object $ HM.singleton (T.pack . show $ s) v
src/OpenAPI/Checker/Validate.hsdeleted−96
@@ -1,96 +0,0 @@
1−module OpenAPI.Checker.Validate where
2−
3−import Control.Monad
4−import Control.Monad.Reader
5−import Data.Functor
6−import Data.HashMap.Strict.InsOrd as InsMap
7−import Data.HashSet.InsOrd as InsSet
8−import Data.Map.Strict as M
9−import Data.OpenApi
10−import Data.OpenApi.Internal
11−import Data.Traversable
12−import OpenAPI.Checker.Aux
13−import OpenAPI.Checker.Report
14−import OpenAPI.Checker.Validate.Dereference
15−import OpenAPI.Checker.Validate.Monad
16−
17−reportCompat :: OpenApi -> OpenApi -> Report
18−reportCompat = error "FIXME: reportCompat not implemented"
19−
20−forwardCompatible :: OpenApi -> OpenApi -> Errorable ReportTree
21−forwardCompatible old new
22− = fmap snd
23− $ runTreeM emptyEnv
24− $ openApiCompatible old new
25−
26−openApiCompatible :: OpenApi -> OpenApi -> TreeM ReportTree ()
27−openApiCompatible old new = do
28− local (const servers) $ do
29− follow $ (InsMap.toList $ _openApiPaths old) <&> \(path, oldItem) ->
30− (path, checkItem path oldItem)
31− where
32− servers = Env
33− { oldServers = _openApiServers old
34− , newServers = _openApiServers new }
35− checkItem path oldItem = do
36− case (InsMap.lookup path $ _openApiPaths new) of
37− Nothing -> treeError $ "Path deleted"
38− Just newItem ->
39− pathItemsCompatible oldItem newItem
40−
41−
42−mergeEnvServers :: [Server] -> [Server] -> TreeM t Env
43−mergeEnvServers olds news = do
44− env <- ask
45− return $ Env
46− { oldServers = mergeServers (oldServers env) olds
47− , newServers = mergeServers (newServers env) news }
48−
49−pathItemsCompatible
50− :: PathItem
51− -> PathItem
52− -> TreeM PathItemTree ()
53−pathItemsCompatible old new = do
54− newEnv <- mergeEnvServers (_pathItemServers old) (_pathItemServers new)
55− local (const newEnv) $ do
56− follow
57− [ (Get, go _pathItemGet)
58− , (Put, go _pathItemPut)
59− , (Post, go _pathItemPost)
60− , (Delete, go _pathItemDelete)
61− , (Options, go _pathItemOptions)
62− , (Head, go _pathItemHead)
63− , (Patch, go _pathItemPatch)
64− , (Trace, go _pathItemTrace) ]
65− where
66− go :: (PathItem -> Maybe Operation) -> TreeM OperationTree ()
67− go getOp = case getOp old of
68− Nothing -> return ()
69− -- Operation is not in old schema, so any addition is Ok
70− Just oldOp -> case getOp new of
71− Nothing -> do
72− -- Operation was in old schema, but no in new one.
73− treeError "Operation was deleted. Old client may try to use it."
74− Just newOp ->
75− operationsCompatible oldOp newOp
76−
77−operationsCompatible
78− :: Operation
79− -> Operation
80− -> TreeM OperationTree ()
81−operationsCompatible old new = do
82− oldParams <- traverse dereferenceParam $ _operationParameters old
83− newParams <- traverse dereferenceParam $ _operationParameters new
84− let
85− newPMap = M.fromList $ newParams <&> \p -> (getParamKey p, p)
86− checkParam pkey oldP = case M.lookup pkey newPMap of
87− Nothing ->
88− treeError "Param was deleted in new interface, but exists in old"
89− Just newP -> do
90− paramsCompatible oldP newP
91− follow $ oldParams <&> \oldP ->
92− let pkey = getParamKey oldP
93− in (pkey , checkParam pkey oldP)
94−
95−paramsCompatible :: Param -> Param -> TreeM ParamTree ()
96−paramsCompatible = error "FIXME: paramsCompatible not implemented"
src/OpenAPI/Checker/Validate/Dereference.hsdeleted−8
@@ -1,8 +0,0 @@
1−module OpenAPI.Checker.Validate.Dereference where
2−
3−import Data.OpenApi.Internal
4−import OpenAPI.Checker.Validate.Monad
5−
6−-- | Throws error if param not found
7−dereferenceParam :: Referenced Param -> TreeM t Param
8−dereferenceParam = error "FIXME: dereferenceParam not implemented"
src/OpenAPI/Checker/Validate/Monad.hsdeleted−52
@@ -1,52 +0,0 @@
1−module OpenAPI.Checker.Validate.Monad where
2−
3−import Control.Lens
4−import Control.Monad.Except
5−import Control.Monad.Trans.Except
6−import Control.Monad.Trans.Reader
7−import Control.Monad.Trans.State.Strict
8−import Data.Foldable
9−import Data.Functor.Identity
10−import Data.OpenApi.Internal
11−import Data.Text (Text)
12−import Data.Traversable
13−import GHC.Generics (Generic)
14−
15−type TreeM t = ReaderT Env (StateT t Errorable)
16−
17−data Env = Env
18− { oldServers :: [Server]
19− , newServers :: [Server]
20− } deriving (Eq, Generic)
21−
22−emptyEnv :: Env
23−emptyEnv = Env [] []
24−
25−-- | Might be different type in future
26−type Errorable = Either Err
27−
28−type Err = Text
29−
30−-- | Class of trees nested into another trees
31−class (Monoid (Parent t)) => Nested t where
32− type Parent t
33− type Key t
34− nest :: Key t -> Errorable t -> Parent t
35−
36−runTreeM :: (Monoid t) => Env -> TreeM t a -> Errorable (a, t)
37−runTreeM env ma = runStateT (runReaderT ma env) mempty
38−
39−-- | Throws error in current tree
40−treeError :: Err -> TreeM t a
41−treeError = throwError
42−
43−-- | Runs several computations in different paths in subtrees
44−follow
45− :: (Foldable f, Nested t, Monoid t)
46− => f (Key t, TreeM t a)
47− -> TreeM (Parent t) ()
48−follow tree = do
49− env <- ask
50− for_ tree $ \(key, sub) -> do
51− let p = nest key $ fmap snd $ runTreeM env sub
52− id <>= p
src/OpenAPI/Checker/Validate/OpenApi.hs+6−6
@@ -20,7 +20,7 @@ import OpenAPI.Checker.Validate.PathFragment
2020instance Subtree OpenApi where
2121 type CheckEnv OpenApi = '[]
2222 data CheckIssue OpenApi = NoPathsMatched | WrongNumberOfFragments
23− deriving (Eq, Ord)
23+ deriving (Eq, Ord, Show)
2424 normalizeTrace = undefined
2525 checkCompatibility _ prodCons = do
2626 let ProdCons {producer = p, consumer = c} = processOpenApi <$> prodCons
@@ -106,25 +106,25 @@ processOpenApi o = do
106106
107107instance Steppable OpenApi PathItem where
108108 data Step OpenApi PathItem = PathStep FilePath
109− deriving (Eq, Ord)
109+ deriving (Eq, Ord, Show)
110110
111111instance Steppable PathItem PathFragment where
112112 data Step PathItem PathFragment
113113 = -- | The index of the path item
114114 PathFragmentStep Int
115− deriving (Eq, Ord)
115+ deriving (Eq, Ord, Show)
116116
117117instance Steppable PathFragment PathItem where
118118 data Step PathFragment PathItem = PathFragmentParentStep
119− deriving (Eq, Ord)
119+ deriving (Eq, Ord, Show)
120120
121121instance Steppable PathItem (Referenced Param) where
122122 data Step PathItem (Referenced Param) = PathItemParametersStep
123− deriving (Eq, Ord)
123+ deriving (Eq, Ord, Show)
124124
125125instance Steppable Operation (Referenced Param) where
126126 data Step Operation (Referenced Param) = OperationParametersStep
127− deriving (Eq, Ord)
127+ deriving (Eq, Ord, Show)
128128
129129data ForeachOperation a = ForeachOperation
130130 { processedPathItemGet :: a
src/OpenAPI/Checker/Validate/Operation.hs+2−2
@@ -9,7 +9,7 @@ import OpenAPI.Checker.Trace
99instance Subtree Operation where
1010 type CheckEnv Operation = '[]
1111 data CheckIssue Operation
12− deriving (Eq, Ord)
12+ deriving (Eq, Ord, Show)
1313 normalizeTrace = undefined
1414 checkCompatibility = undefined
1515
@@ -23,4 +23,4 @@ instance Steppable PathItem Operation where
2323 | HeadStep
2424 | PatchStep
2525 | TraceStep
26− deriving (Eq, Ord)
26+ deriving (Eq, Ord, Show)
src/OpenAPI/Checker/Validate/Param.hs+1−1
@@ -8,6 +8,6 @@ import OpenAPI.Checker.Subtree
88instance Subtree Param where
99 type CheckEnv Param = '[]
1010 data CheckIssue Param
11− deriving (Eq, Ord)
11+ deriving (Eq, Ord, Show)
1212 normalizeTrace = undefined
1313 checkCompatibility = undefined
src/OpenAPI/Checker/Validate/PathFragment.hs+2−2
@@ -53,14 +53,14 @@ data PathFragment
5353
5454instance Steppable PathFragment Param where
5555 data Step PathFragment Param = StaticPathParam
56− deriving (Eq, Ord)
56+ deriving (Eq, Ord, Show)
5757
5858type PathParamRefs = TracedReferences PathFragment Param
5959
6060instance Subtree PathFragment where
6161 type CheckEnv PathFragment = '[ProdCons PathParamRefs]
6262 data CheckIssue PathFragment = PathFragmentsDontMatch Text Text
63− deriving (Eq, Ord)
63+ deriving (Eq, Ord, Show)
6464
6565 normalizeTrace = undefined
6666
test/Spec.hs+3−6
@@ -1,7 +1,6 @@
11module Main (main) where
22
3−import qualified Spec.Golden.Report
4−import qualified Spec.Golden.ReportTree
3+import qualified Spec.Golden.TraceTree
54import Test.Tasty
65
76main :: IO ()
@@ -9,11 +8,9 @@ main = defaultMain =<< tests
98
109tests :: IO TestTree
1110tests = do
12− goldenReport <- Spec.Golden.Report.tests
13− goldenReportTree <- Spec.Golden.ReportTree.tests
11+ goldenReportTree <- Spec.Golden.TraceTree.tests
1412 return $
1513 testGroup
1614 "Golden tests"
17− [ goldenReport,
18− goldenReportTree
15+ [ goldenReportTree
1916 ]
test/Spec/Golden/Extra.hs+46−50
@@ -1,8 +1,8 @@
11module Spec.Golden.Extra
2− ( getGoldenInputs,
3− getGoldenInputsUniform,
4− goldenInputsTree,
5− goldenInputsTreeUniform,
2+ ( getGoldenInputs
3+ , getGoldenInputsUniform
4+ , goldenInputsTree
5+ , goldenInputsTreeUniform
66 )
77where
88
@@ -11,7 +11,7 @@ import Control.Monad
1111import Data.Aeson hiding (Result)
1212import qualified Data.ByteString.Lazy as BSL
1313import qualified Data.Yaml as Yaml
14−import OpenAPI.Checker.Report
14+import OpenAPI.Checker.Subtree
1515import System.Directory
1616import System.FilePath
1717import Test.Tasty
@@ -23,12 +23,12 @@ data TestInput t
2323 | TestInputLeaf TestName t FilePath
2424 deriving (Functor)
2525
26−getGoldenInputs ::
27− (Each s t (FilePath, FilePath -> IO a) a) =>
28− TestName ->
29− FilePath ->
30− s ->
31− IO (TestInput t)
26+getGoldenInputs
27+ :: (Each s t (FilePath, FilePath -> IO a) a)
28+ => TestName
29+ -> FilePath
30+ -> s
31+ -> IO (TestInput t)
3232getGoldenInputs name filepath inp = do
3333 dirs' <- listDirectory filepath >>= filterM (doesDirectoryExist . (filepath </>))
3434 case dirs' of
@@ -43,35 +43,33 @@ getGoldenInputs name filepath inp = do
4343 TestInputNode name
4444 <$> forM dirs (\dir -> getGoldenInputs dir (filepath </> dir) inp)
4545
46−getGoldenInputsUniform ::
47− (Each t h (FilePath, FilePath -> IO a) a) =>
48− (Each s t FilePath (FilePath, FilePath -> IO a)) =>
49− TestName ->
50− (FilePath -> IO a) ->
51− FilePath ->
52− s ->
53− IO (TestInput h)
46+getGoldenInputsUniform
47+ :: (Each t h (FilePath, FilePath -> IO a) a)
48+ => (Each s t FilePath (FilePath, FilePath -> IO a))
49+ => TestName
50+ -> (FilePath -> IO a)
51+ -> FilePath
52+ -> s
53+ -> IO (TestInput h)
5454getGoldenInputsUniform name f filepath inp = getGoldenInputs name filepath $ inp & each %~ (,f)
5555
56−goldenInputsTree ::
57− (Each s t (FilePath, FilePath -> IO a) a, ToJSON x, HasUnsupportedFeature x) =>
58− TestName ->
59− -- | Root path
60− FilePath ->
61− -- | Name of golden file
62− FilePath ->
63− s ->
64− (t -> x) ->
65− IO TestTree
56+goldenInputsTree
57+ :: (Each s t (FilePath, FilePath -> IO a) a, ToJSON x, HasUnsupportedFeature x)
58+ => TestName
59+ -> FilePath -- ^ Root path
60+ -> FilePath -- ^ Name of golden file
61+ -> s
62+ -> (t -> x)
63+ -> IO TestTree
6664goldenInputsTree name filepath golden inp f = do
6765 runTestInputTree golden f <$> getGoldenInputs name filepath inp
6866
69−runTestInputTree ::
70− (ToJSON x, HasUnsupportedFeature x) =>
71− FilePath ->
72− (t -> x) ->
73− TestInput t ->
74− TestTree
67+runTestInputTree
68+ :: (ToJSON x, HasUnsupportedFeature x)
69+ => FilePath
70+ -> (t -> x)
71+ -> TestInput t
72+ -> TestTree
7573runTestInputTree golden f (TestInputNode name rest) =
7674 testGroup name (runTestInputTree golden f <$> rest)
7775runTestInputTree golden f (TestInputLeaf name t path)
@@ -100,20 +98,18 @@ testSupported :: TestName -> Bool
10098testSupported ('x' : ' ' : _) = False
10199testSupported _ = True
102100
103−goldenInputsTreeUniform ::
104− ( Each t h (FilePath, FilePath -> IO a) a,
105− ToJSON x,
106− Each s t FilePath (FilePath, FilePath -> IO a),
107− HasUnsupportedFeature x
108− ) =>
109− String ->
110− -- | Root path
111− FilePath ->
112− -- | Name of golden file
113− FilePath ->
114− s ->
115− (FilePath -> IO a) ->
116− (h -> x) ->
117− IO TestTree
101+goldenInputsTreeUniform
102+ :: ( Each t h (FilePath, FilePath -> IO a) a
103+ , ToJSON x
104+ , Each s t FilePath (FilePath, FilePath -> IO a)
105+ , HasUnsupportedFeature x
106+ )
107+ => String
108+ -> FilePath -- ^ Root path
109+ -> FilePath -- ^ Name of golden file
110+ -> s
111+ -> (FilePath -> IO a)
112+ -> (h -> x)
113+ -> IO TestTree
118114goldenInputsTreeUniform name filepath golden inp h =
119115 goldenInputsTree name filepath golden (inp & each %~ (,h))
test/Spec/Golden/Report.hsdeleted−19
@@ -1,19 +0,0 @@
1−module Spec.Golden.Report
2− ( tests,
3− )
4−where
5−
6−import qualified Data.Yaml as Yaml
7−import OpenAPI.Checker.Validate
8−import Spec.Golden.Extra
9−import Test.Tasty
10−
11−tests :: IO TestTree
12−tests =
13− goldenInputsTreeUniform
14− "Golden Reports"
15− "test/golden/common"
16− "report.yaml"
17− ("a.yaml", "b.yaml")
18− Yaml.decodeFileThrow
19− (uncurry reportCompat)
test/Spec/Golden/ReportTree.hsdeleted−19
@@ -1,19 +0,0 @@
1−module Spec.Golden.ReportTree
2− ( tests,
3− )
4−where
5−
6−import qualified Data.Yaml as Yaml
7−import OpenAPI.Checker.Validate
8−import Spec.Golden.Extra
9−import Test.Tasty
10−
11−tests :: IO TestTree
12−tests =
13− goldenInputsTreeUniform
14− "Golden ReportTrees"
15− "test/golden/common"
16− "report-tree.yaml"
17− ("a.yaml", "b.yaml")
18− Yaml.decodeFileThrow
19− (uncurry forwardCompatible)
test/Spec/Golden/TraceTree.hsnew file+23
@@ -0,0 +1,23 @@
1+module Spec.Golden.TraceTree
2+ ( tests
3+ )
4+where
5+
6+import Control.Category
7+import Data.HList
8+import qualified Data.Yaml as Yaml
9+import OpenAPI.Checker.Subtree
10+import OpenAPI.Checker.Validate.OpenApi ()
11+import Spec.Golden.Extra
12+import Test.Tasty (TestTree)
13+import Prelude hiding (id, (.))
14+
15+tests :: IO TestTree
16+tests =
17+ goldenInputsTreeUniform
18+ "Golden TraceTree"
19+ "test/golden/common"
20+ "trace-tree.yaml"
21+ ("a.yaml", "b.yaml")
22+ Yaml.decodeFileThrow
23+ (runCompatFormula (pure id) . checkCompatibility HNil . uncurry ProdCons)