git.iko.soy/compaREST
on master help sign in
Path fragments and OpenApi (#22)
94d03aciko
.gitignore+1
compare with master
unifiedsplit
@@ -1,2 +1,3 @@
1.stack-work
1.stack-work
2TAGS
2TAGS
3+.vscode
openapi-diff.cabal+17−8
@@ -31,22 +31,24 @@ common common-options
31 default-language: Haskell2010
31 default-language: Haskell2010
32 build-depends: base >= 4.12.0.0 && < 4.15
32 build-depends: base >= 4.12.0.0 && < 4.15
33 , aeson
33 , aeson
34− , deriving-aeson
34+ , attoparsec
35 , containers
35 , containers
36+ , deriving-aeson
37+ , generic-data
36 , generic-monoid
38 , generic-monoid
37 , insert-ordered-containers
39 , insert-ordered-containers
38 , lens
40 , lens
39 , mtl
41 , mtl
40 , openapi3
42 , openapi3
43+ , optparse-applicative
44+ , tagged
41 , text
45 , text
42 , transformers
46 , transformers
43− , yaml
44− , attoparsec
45− , optparse-applicative
46 , typerep-map
47 , typerep-map
47− , tagged
48+ , yaml
48
49
50+ default-extensions: ApplicativeDo
49− default-extensions: BangPatterns
51+ , BangPatterns
50 , ConstraintKinds
52 , ConstraintKinds
51 , DataKinds
53 , DataKinds
52 , DeriveAnyClass
54 , DeriveAnyClass
@@ -57,6 +59,7 @@ common common-options
57 , DerivingStrategies
59 , DerivingStrategies
58 , DerivingVia
60 , DerivingVia
59 , DuplicateRecordFields
61 , DuplicateRecordFields
62+ , EmptyDataDeriving
60 , FlexibleContexts
63 , FlexibleContexts
61 , FlexibleInstances
64 , FlexibleInstances
62 , FunctionalDependencies
65 , FunctionalDependencies
@@ -86,8 +89,12 @@ library
86 import: common-options
89 import: common-options
87 hs-source-dirs: src
90 hs-source-dirs: src
88 exposed-modules: OpenAPI.Checker.Aux
91 exposed-modules: OpenAPI.Checker.Aux
92+ , Data.HList
89 , OpenAPI.Checker.Formula
93 , OpenAPI.Checker.Formula
90 , OpenAPI.Checker.Memo
94 , OpenAPI.Checker.Memo
95+ , OpenAPI.Checker.Options
96+ , OpenAPI.Checker.Orphans
97+ , OpenAPI.Checker.References
91 , OpenAPI.Checker.Report
98 , OpenAPI.Checker.Report
92 , OpenAPI.Checker.Run
99 , OpenAPI.Checker.Run
93 , OpenAPI.Checker.Subtree
100 , OpenAPI.Checker.Subtree
@@ -96,8 +103,10 @@ library
96 , OpenAPI.Checker.Validate
103 , OpenAPI.Checker.Validate
97 , OpenAPI.Checker.Validate.Dereference
104 , OpenAPI.Checker.Validate.Dereference
98 , OpenAPI.Checker.Validate.Monad
105 , OpenAPI.Checker.Validate.Monad
99− , OpenAPI.Checker.Options
106+ , OpenAPI.Checker.Validate.OpenApi
100− , Data.HList
107+ , OpenAPI.Checker.Validate.Operation
108+ , OpenAPI.Checker.Validate.Param
109+ , OpenAPI.Checker.Validate.PathFragment
101
110
102executable openapi-diff
111executable openapi-diff
103 import: common-options
112 import: common-options
src/Data/HList.hs+10−6
@@ -1,8 +1,9 @@
1module Data.HList
1module Data.HList
2− ( Has,
2+ ( Has
3− HasAll,
3+ , HasAll
4− getH,
4+ , getH
5− HList (..),
5+ , HList (..)
6+ , singletonH
6 )
7 )
7where
8where
8
9
@@ -33,7 +34,10 @@ instance (Has' x xs t, HeadEq x (y : xs) ~ 'False) => Has' x (y ': xs) 'False wh
33 getH (HCons _ xs) = getH xs
34 getH (HCons _ xs) = getH xs
34
35
35instance
36instance
36− TypeError ( 'ShowType x ':<>: 'Text " is not a part of the list.") =>
37+ TypeError ('ShowType x ':<>: 'Text " is not a part of the list.")
37− Has' x '[] 'False
38+ => Has' x '[] 'False
38 where
39 where
39 getH HNil = undefined
40 getH HNil = undefined
41+
42+singletonH :: a -> HList '[a]
43+singletonH a = a `HCons` HNil
src/OpenAPI/Checker/Formula.hs+1−1
@@ -42,7 +42,7 @@ mkApply f x h = Apply f x h
42mkSelectFirst :: [SomeFormulaF b] -> AnItem f r -> (b -> a) -> FormulaF f r a
42mkSelectFirst :: [SomeFormulaF b] -> AnItem f r -> (b -> a) -> FormulaF f r a
43mkSelectFirst fs allE h = case foldMap check fs of
43mkSelectFirst fs allE h = case foldMap check fs of
44 (First (Just x), _) -> Result (h x)
44 (First (Just x), _) -> Result (h x)
45− (First Nothing, (x:xs)) -> SelectFirst (x NE.:| xs) allE h
45+ (First Nothing, x:xs) -> SelectFirst (x NE.:| xs) allE h
46 (First Nothing, []) -> Errors $ T.singleton allE
46 (First Nothing, []) -> Errors $ T.singleton allE
47 where
47 where
48 check (SomeFormulaF (Result x)) = (First (Just x), mempty)
48 check (SomeFormulaF (Result x)) = (First (Just x), mempty)
src/OpenAPI/Checker/Orphans.hsnew file+15
@@ -0,0 +1,15 @@
1+{-# OPTIONS_GHC -Wno-orphans #-}
2+
3+module OpenAPI.Checker.Orphans (Step (..)) where
4+
5+import Data.OpenApi
6+import Data.Typeable
7+import OpenAPI.Checker.Trace
8+
9+deriving newtype instance Ord Reference
10+
11+instance Typeable a => Steppable (Referenced a) a where
12+ data Step (Referenced a) a
13+ = InlineStep
14+ | ReferencedStep Reference
15+ deriving (Eq, Ord)
src/OpenAPI/Checker/References.hsnew file+24
@@ -0,0 +1,24 @@
1+module OpenAPI.Checker.References
2+ ( TracedReferences
3+ , dereferenceTraced
4+ )
5+where
6+
7+import qualified Data.HashMap.Strict.InsOrd as IOHM
8+import Data.Map (Map)
9+import Data.Maybe
10+import Data.OpenApi
11+import Data.Typeable
12+import OpenAPI.Checker.Orphans
13+import OpenAPI.Checker.Trace
14+
15+type TracedReferences root a = Map Reference (Traced root a)
16+
17+dereferenceTraced
18+ :: Typeable a
19+ => Definitions a
20+ -> Referenced a
21+ -> Traced (Referenced a) a
22+dereferenceTraced _ (Inline a) = Traced (step InlineStep) a
23+dereferenceTraced defs (Ref r@(Reference ref)) =
24+ Traced (step $ ReferencedStep r) (fromJust $ IOHM.lookup ref defs)
src/OpenAPI/Checker/Subtree.hs+55−30
@@ -1,16 +1,19 @@
1module OpenAPI.Checker.Subtree
1module OpenAPI.Checker.Subtree
2− ( APIStep(..)
2+ ( APIStep (..)
3− , Subtree(..)
3+ , Subtree (..)
4− , CompatM(..)
4+ , CompatM (..)
5 , CompatFormula
5 , CompatFormula
6+ , ProdCons (..)
6 , runCompatFormula
7 , runCompatFormula
7 , localM
8 , localM
8− , local'
9+ , localTrace
9 , anyOfM
10 , anyOfM
11+ , anyOfAt
10 , issueAtTrace
12 , issueAtTrace
11 , issueAt
13 , issueAt
12 , memo
14 , memo
15+ )
13− ) where
16+where
14
17
15import Control.Monad.Identity
18import Control.Monad.Identity
16import Control.Monad.Reader
19import Control.Monad.Reader
@@ -26,57 +29,67 @@ import OpenAPI.Checker.Memo
26import OpenAPI.Checker.Trace
29import OpenAPI.Checker.Trace
27import qualified OpenAPI.Checker.TracePrefixTree as T
30import qualified OpenAPI.Checker.TracePrefixTree as T
28
31
32+class
29−class (Subtree a, Subtree b, Steppable a b)
33+ (Subtree a, Subtree b, Steppable a b) =>
30− => APIStep (a :: Type) (b :: Type) where
34+ APIStep (a :: Type) (b :: Type)
35+ where
31 describeStep :: Step a b -> Text
36 describeStep :: Step a b -> Text
32
37
33data ProdCons a = ProdCons
38data ProdCons a = ProdCons
34 { producer :: a
39 { producer :: a
35 , consumer :: a
40 , consumer :: a
41+ }
36− } deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
42+ deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
37
43
38instance Applicative ProdCons where
44instance Applicative ProdCons where
39 pure x = ProdCons x x
45 pure x = ProdCons x x
40 ProdCons fp fc <*> ProdCons xp xc = ProdCons (fp xp) (fc xc)
46 ProdCons fp fc <*> ProdCons xp xc = ProdCons (fp xp) (fc xc)
41
47
42newtype CompatM t a = CompatM
48newtype CompatM t a = CompatM
43− { unCompatM ::
49+ { unCompatM
50+ :: ReaderT
44− ReaderT (ProdCons (Trace OpenApi t))
51+ (ProdCons (Trace OpenApi t))
45− (StateT (MemoState VarRef) Identity) a
52+ (StateT (MemoState VarRef) Identity)
53+ a
54+ }
46− } deriving newtype
55+ deriving newtype
56+ ( Functor
47− ( Functor, Applicative, Monad
57+ , Applicative
58+ , Monad
48 , MonadReader (ProdCons (Trace OpenApi t))
59 , MonadReader (ProdCons (Trace OpenApi t))
49 , MonadState (MemoState VarRef)
60 , MonadState (MemoState VarRef)
50 )
61 )
51
62
52type CompatFormula t = Compose (CompatM t) (FormulaF CheckIssue OpenApi)
63type CompatFormula t = Compose (CompatM t) (FormulaF CheckIssue OpenApi)
53
64
54−class (Typeable t, Ord t, Ord (CheckIssue t)) => Subtree (t :: Type) where
65+class (Typeable t, Ord (CheckIssue t)) => Subtree (t :: Type) where
55− type family CheckEnv t :: [Type]
66+ type CheckEnv t :: [Type]
56− data family CheckIssue t :: Type
67+ data CheckIssue t :: Type
68+
57 -- | If we ever followed a reference, reroute the path through "components"
69 -- | If we ever followed a reference, reroute the path through "components"
58 normalizeTrace :: Trace OpenApi t -> Trace OpenApi t
70 normalizeTrace :: Trace OpenApi t -> Trace OpenApi t
71+
59 checkCompatibility :: HasAll (CheckEnv t) xs => HList xs -> ProdCons t -> CompatFormula t ()
72 checkCompatibility :: HasAll (CheckEnv t) xs => HList xs -> ProdCons t -> CompatFormula t ()
60
73
61runCompatFormula
74runCompatFormula
62 :: ProdCons (Trace OpenApi t)
75 :: ProdCons (Trace OpenApi t)
63 -> Compose (CompatM t) (FormulaF f r) a
76 -> Compose (CompatM t) (FormulaF f r) a
64 -> Either (T.TracePrefixTree f r) a
77 -> Either (T.TracePrefixTree f r) a
65−runCompatFormula env (Compose f)
78+runCompatFormula env (Compose f) =
66− = calculate . runIdentity . runMemo 0 . (`runReaderT` env) . unCompatM $ f
79+ calculate . runIdentity . runMemo 0 . (`runReaderT` env) . unCompatM $ f
67
80
68localM
81localM
69 :: ProdCons (Trace a b)
82 :: ProdCons (Trace a b)
70 -> CompatM b x
83 -> CompatM b x
71 -> CompatM a x
84 -> CompatM a x
72−localM xs (CompatM k) =
85+localM xs (CompatM k) =
73− CompatM $ ReaderT $ \env -> runReaderT k (catTrace <$> env <*> xs)
86+ CompatM $ ReaderT $ \env -> runReaderT k ((>>>) <$> env <*> xs)
74
87
75−local'
88+localTrace
76 :: ProdCons (Trace a b)
89 :: ProdCons (Trace a b)
77 -> Compose (CompatM b) (FormulaF f r) x
90 -> Compose (CompatM b) (FormulaF f r) x
78 -> Compose (CompatM a) (FormulaF f r) x
91 -> Compose (CompatM a) (FormulaF f r) x
79−local' xs (Compose h) = Compose (localM xs h)
92+localTrace xs (Compose h) = Compose (localM xs h)
80
93
81issueAtTrace
94issueAtTrace
82 :: Subtree t => Trace OpenApi t -> CheckIssue t -> CompatFormula t a
95 :: Subtree t => Trace OpenApi t -> CheckIssue t -> CompatFormula t a
@@ -93,20 +106,32 @@ issueAt f issue = Compose $ do
93
106
94anyOfM
107anyOfM
95 :: Ord (f t)
108 :: Ord (f t)
96− => Trace r t -> f t
109+ => Trace r t
110+ -> f t
97 -> [Compose (CompatM t) (FormulaF f r) a]
111 -> [Compose (CompatM t) (FormulaF f r) a]
98 -> Compose (CompatM t) (FormulaF f r) a
112 -> Compose (CompatM t) (FormulaF f r) a
99−anyOfM xs issue fs
113+anyOfM xs issue fs =
114+ Compose $ (`eitherOf` AnItem xs issue) <$> sequenceA (getCompose <$> fs)
115+
116+anyOfAt
117+ :: Subtree t
118+ => (forall x. ProdCons x -> x)
119+ -> CheckIssue t
120+ -> [CompatFormula t a]
121+ -> CompatFormula t a
122+anyOfAt f issue fs = Compose $ do
123+ xs <- asks f
100− = Compose $ (`eitherOf` AnItem xs issue) <$> sequenceA (getCompose <$> fs)
124+ (`eitherOf` AnItem xs issue) <$> sequenceA (getCompose <$> fs)
101
125
102fixpointKnot
126fixpointKnot
103 :: MonadState (MemoState VarRef) m
127 :: MonadState (MemoState VarRef) m
104 => KnotTier (FormulaF f r ()) VarRef m
128 => KnotTier (FormulaF f r ()) VarRef m
105−fixpointKnot = KnotTier
129+fixpointKnot =
130+ KnotTier
106− { onKnotFound = modifyMemoNonce succ
131+ { onKnotFound = modifyMemoNonce succ
107− , onKnotUsed = \i -> pure $ variable i
132+ , onKnotUsed = \i -> pure $ variable i
108− , tieKnot = \i x -> pure $ maxFixpoint i x
133+ , tieKnot = \i x -> pure $ maxFixpoint i x
109− }
134+ }
110
135
111memo :: Subtree t => CompatFormula t () -> CompatFormula t ()
136memo :: Subtree t => CompatFormula t () -> CompatFormula t ()
112memo (Compose f) = Compose $ do
137memo (Compose f) = Compose $ do
src/OpenAPI/Checker/Trace.hs+58−30
@@ -1,26 +1,38 @@
1-- | Utilities for traversing heterogeneous trees. A heterogeneous tree is a
1-- | Utilities for traversing heterogeneous trees. A heterogeneous tree is a
2-- collection of datatypes that "contain" eachother in some form of tree
2-- collection of datatypes that "contain" eachother in some form of tree
3-- structure.
3-- structure.
4−
5module OpenAPI.Checker.Trace
4module OpenAPI.Checker.Trace
6− ( Steppable(..)
5+ ( Steppable (..)
7− , Trace(..)
6+ , Trace (..)
8− , catTrace
9− , DiffTrace(..)
7+ , DiffTrace (..)
10 , catDiffTrace
8 , catDiffTrace
11 , _DiffTrace
9 , _DiffTrace
12− , AnItem(..)
10+ , AnItem (..)
11+ , step
12+ , Traced (..)
13+ , mapTraced
14+ , retrace
15+ , deTraced
16+
17+ -- * Reexports
18+ , (>>>)
19+ , (<<<)
20+ )
13− ) where
21+where
14−
22+
23+import Control.Category
15import Control.Lens
24import Control.Lens
16import Data.Kind
25import Data.Kind
17import Data.Type.Equality
26import Data.Type.Equality
18import Type.Reflection
27import Type.Reflection
28+import Prelude hiding ((.))
19
29
30+class
20−class (Typeable a, Typeable b, Ord (Step a b))
31+ (Typeable a, Typeable b, Ord (Step a b)) =>
21− => Steppable (a :: k) (b :: k) where
32+ Steppable (a :: k) (b :: k)
33+ where
22 -- | How to get from an @a@ node to a @b@ node
34 -- | How to get from an @a@ node to a @b@ node
23− data family Step (a :: k) (b :: k) :: Type
35+ data Step (a :: k) (b :: k) :: Type
24
36
25-- | How to get from an @a@ node to a @b@ node in possibly multiple steps. Like
37-- | How to get from an @a@ node to a @b@ node in possibly multiple steps. Like
26-- a list, but indexed. The list is in reverse because in practice we append
38-- a list, but indexed. The list is in reverse because in practice we append
@@ -28,8 +40,17 @@ class (Typeable a, Typeable b, Ord (Step a b))
28data Trace (a :: k) (b :: k) where
40data Trace (a :: k) (b :: k) where
29 Root :: Trace a a
41 Root :: Trace a a
30 Snoc :: Steppable b c => Trace a b -> !(Step b c) -> Trace a c
42 Snoc :: Steppable b c => Trace a b -> !(Step b c) -> Trace a c
43+
31infixl 5 `Snoc`
44infixl 5 `Snoc`
32
45
46+step :: Steppable a b => Step a b -> Trace a b
47+step s = Root `Snoc` s
48+
49+instance Category Trace where
50+ id = Root
51+ Root . xs = xs
52+ (Snoc ys y) . xs = Snoc (ys . xs) y
53+
33typeRepRHS :: Typeable b => Trace a b -> TypeRep b
54typeRepRHS :: Typeable b => Trace a b -> TypeRep b
34typeRepRHS _ = typeRep
55typeRepRHS _ = typeRep
35
56
@@ -46,24 +67,19 @@ instance TestEquality (Trace a) where
46instance Eq (Trace a b) where
67instance Eq (Trace a b) where
47 Root == Root = True
68 Root == Root = True
48 Snoc xs x == Snoc ys y
69 Snoc xs x == Snoc ys y
49− | Just Refl <- testEquality (typeRepRHS xs) (typeRepRHS ys)
70+ | Just Refl <- testEquality (typeRepRHS xs) (typeRepRHS ys) =
50− = xs == ys && x == y
71+ xs == ys && x == y
51 _ == _ = False
72 _ == _ = False
52
73
53instance Ord (Trace a b) where
74instance Ord (Trace a b) where
54 compare Root Root = EQ
75 compare Root Root = EQ
55 compare Root (Snoc _ _) = LT
76 compare Root (Snoc _ _) = LT
56 compare (Snoc _ _) Root = GT
77 compare (Snoc _ _) Root = GT
57− compare (Snoc xs x) (Snoc ys y)
78+ compare (Snoc xs x) (Snoc ys y) =
58− = case testEquality (typeRepRHS xs) (typeRepRHS ys) of
79+ case testEquality (typeRepRHS xs) (typeRepRHS ys) of
59 Just Refl -> compare xs ys <> compare x y
80 Just Refl -> compare xs ys <> compare x y
60 Nothing -> compare (someTypeRep xs) (someTypeRep ys)
81 Nothing -> compare (someTypeRep xs) (someTypeRep ys)
61
82
62−catTrace :: Trace a b -> Trace b c -> Trace a c
63−catTrace xs Root = xs
64−catTrace xs (Snoc ys y) = Snoc (catTrace xs ys) y
65−infixl 5 `catTrace`
66−
67-- | Like a differece list, but indexed.
83-- | Like a differece list, but indexed.
68newtype DiffTrace (a :: k) (b :: k)
84newtype DiffTrace (a :: k) (b :: k)
69 = DiffTrace (forall c. Trace c a -> Trace c b)
85 = DiffTrace (forall c. Trace c a -> Trace c b)
@@ -72,30 +88,42 @@ catDiffTrace :: DiffTrace a b -> DiffTrace b c -> DiffTrace a c
72catDiffTrace (DiffTrace f) (DiffTrace g) = DiffTrace (g . f)
88catDiffTrace (DiffTrace f) (DiffTrace g) = DiffTrace (g . f)
73
89
74_DiffTrace :: Iso (DiffTrace a b) (DiffTrace c d) (Trace a b) (Trace c d)
90_DiffTrace :: Iso (DiffTrace a b) (DiffTrace c d) (Trace a b) (Trace c d)
75−_DiffTrace = dimap (\(DiffTrace f) -> f Root)
91+_DiffTrace = dimap (\(DiffTrace f) -> f Root) $
76− $ fmap $ \xs -> DiffTrace (`catTrace` xs)
92+ fmap $ \xs -> DiffTrace (>>> xs)
77
93
78-- | An item related to some path relative to the root @r@.
94-- | An item related to some path relative to the root @r@.
79data AnItem (f :: k -> Type) (r :: k) where
95data AnItem (f :: k -> Type) (r :: k) where
80 AnItem :: Ord (f a) => Trace r a -> !(f a) -> AnItem f r
96 AnItem :: Ord (f a) => Trace r a -> !(f a) -> AnItem f r
97+
81− -- the Ord is yuck but we need it and it should be fine in monomorphic cases
98+-- the Ord is yuck but we need it and it should be fine in monomorphic cases
82
99
83instance Eq (AnItem f r) where
100instance Eq (AnItem f r) where
84 AnItem xs fx == AnItem ys fy
101 AnItem xs fx == AnItem ys fy
85− | Just Refl <- testEquality xs ys
102+ | Just Refl <- testEquality xs ys =
86− = xs == ys && fx == fy
103+ xs == ys && fx == fy
87 _ == _ = False
104 _ == _ = False
88
105
89instance Typeable r => Ord (AnItem f r) where
106instance Typeable r => Ord (AnItem f r) where
90− compare (AnItem xs fx) (AnItem ys fy)
107+ compare (AnItem xs fx) (AnItem ys fy) =
91− = case testEquality xs ys of
108+ case testEquality xs ys of
92 Just Refl -> compare xs ys <> compare fx fy
109 Just Refl -> compare xs ys <> compare fx fy
93 Nothing -> case xs of
110 Nothing -> case xs of
94− Root -> case ys of
111+ Root -> case ys of
95− Root -> compare (someTypeRep xs) (someTypeRep ys)
112+ Root -> compare (someTypeRep xs) (someTypeRep ys)
96 Snoc _ _ -> compare (someTypeRep xs) (someTypeRep ys)
113 Snoc _ _ -> compare (someTypeRep xs) (someTypeRep ys)
97 Snoc _ _ -> case ys of
114 Snoc _ _ -> case ys of
98− Root -> compare (someTypeRep xs) (someTypeRep ys)
115+ Root -> compare (someTypeRep xs) (someTypeRep ys)
99 Snoc _ _ -> compare (someTypeRep xs) (someTypeRep ys)
116 Snoc _ _ -> compare (someTypeRep xs) (someTypeRep ys)
100
117
118+data Traced r a = Traced {getTrace :: Trace r a, getTraced :: a}
119+
120+mapTraced :: (Trace r a -> Trace r b) -> (a -> b) -> Traced r a -> Traced r b
121+mapTraced f g (Traced t a) = Traced (f t) (g a)
122+
123+retrace :: (Trace r a -> Trace r' a) -> Traced r a -> Traced r' a
124+retrace f (Traced t a) = Traced (f t) a
125+
126+deTraced :: Traced r a -> (Trace r a, a)
127+deTraced (Traced a b) = (a, b)
128+
101-- type APath = AnItem Proxy
129-- type APath = AnItem Proxy
src/OpenAPI/Checker/Validate/OpenApi.hsnew file+168
@@ -0,0 +1,168 @@
1+{-# LANGUAGE PartialTypeSignatures #-}
2+{-# OPTIONS_GHC -Wno-orphans #-}
3+
4+module OpenAPI.Checker.Validate.OpenApi
5+ (
6+ )
7+where
8+
9+import Data.Foldable
10+import Data.HList
11+import qualified Data.HashMap.Strict.InsOrd as IOHM
12+import Data.Maybe
13+import Data.OpenApi
14+import Generic.Data
15+import OpenAPI.Checker.Subtree
16+import OpenAPI.Checker.Trace
17+import OpenAPI.Checker.Validate.Operation
18+import OpenAPI.Checker.Validate.PathFragment
19+
20+instance Subtree OpenApi where
21+ type CheckEnv OpenApi = '[]
22+ data CheckIssue OpenApi = NoPathsMatched | WrongNumberOfFragments
23+ deriving (Eq, Ord)
24+ normalizeTrace = undefined
25+ checkCompatibility _ prodCons = do
26+ let ProdCons {producer = p, consumer = c} = processOpenApi <$> prodCons
27+ sequenceA_
28+ [ anyOfAt
29+ producer
30+ NoPathsMatched
31+ [ localTrace (step <$> ProdCons pSPath cSPath) $ do
32+ -- make sure every path fragment is compatible
33+ sequenceA_
34+ [ localTrace (pure . step $ PathFragmentStep i) $
35+ checkCompatibility (singletonH $ ProdCons pPathFragmentParams cPathFragmentParams) pair
36+ | (i, pair) <- zip [0 ..] pathFragments
37+ ]
38+ -- make sure the operation is compatible.
39+ localTrace (pure . step $ getter stepProcessedPathItem) $
40+ checkCompatibility HNil $ ProdCons pOperation cOperation
41+ pure ()
42+ | (cSPath, cPath, cPathItem) <- c
43+ , -- ... and try to match it with every endpoint in the consumer.
44+ --
45+ -- This is required because the meaning of path fragments can change on
46+ -- a per-method basis even within the same 'PathItem'
47+ --
48+ -- Here we only need to look for the method that the current producer
49+ -- endpoint is using.
50+ (cParams, cOperation) <- maybeToList $ getter cPathItem
51+ , let cPathFragmentParams = retrace (step PathFragmentParentStep >>>) <$> cParams
52+ , -- make sure the paths are the same length
53+ pathFragments <- maybeToList $ zipAllWith ProdCons pPath cPath
54+ ]
55+ | (pSPath, pPath, pPathItem) <- p
56+ , -- look at every endpoint in the producer ...
57+ (ProcessedPathItemGetter getter, (pParams, pOperation)) <-
58+ toList (fmap . (,) <$> processedPathItemGetters <*> pPathItem) >>= maybeToList
59+ , let pPathFragmentParams = retrace (step PathFragmentParentStep >>>) <$> pParams
60+ ]
61+
62+zipAllWith :: (a -> b -> c) -> [a] -> [b] -> Maybe [c]
63+zipAllWith _ [] [] = Just []
64+zipAllWith f (x : xs) (y : ys) = (f x y :) <$> zipAllWith f xs ys
65+zipAllWith _ (_ : _) [] = Nothing
66+zipAllWith _ [] (_ : _) = Nothing
67+
68+processOpenApi
69+ :: OpenApi
70+ -> [ ( Step OpenApi PathItem
71+ , [PathFragment]
72+ , ForeachOperation (Maybe (TracedReferences PathItem Param, Operation))
73+ )
74+ ]
75+processOpenApi o = do
76+ let cs = _openApiComponents o
77+ (pathS, pathItem) <- IOHM.toList . _openApiPaths $ o
78+ let path = parsePath pathS
79+ componentParams = _componentsParameters cs
80+ commonPathParams =
81+ retrace (step PathItemParametersStep >>>)
82+ <$> getPathParamRefs componentParams (_pathItemParameters pathItem)
83+ processOperation (s :: Step PathItem Operation) op =
84+ let operationParams =
85+ retrace (Root `Snoc` s `Snoc` OperationParametersStep >>>)
86+ <$> getPathParamRefs componentParams (_operationParameters op)
87+ pathParams =
88+ operationParams <> commonPathParams
89+ in (pathParams, op)
90+ pure
91+ ( PathStep pathS
92+ , path
93+ , fmap . processOperation
94+ <$> stepProcessedPathItem
95+ <*> ForeachOperation
96+ { processedPathItemGet = _pathItemGet pathItem
97+ , processedPathItemPut = _pathItemPut pathItem
98+ , processedPathItemPost = _pathItemPost pathItem
99+ , processedPathItemDelete = _pathItemDelete pathItem
100+ , processedPathItemOptions = _pathItemOptions pathItem
101+ , processedPathItemHead = _pathItemHead pathItem
102+ , processedPathItemPatch = _pathItemPatch pathItem
103+ , processedPathItemTrace = _pathItemTrace pathItem
104+ }
105+ )
106+
107+instance Steppable OpenApi PathItem where
108+ data Step OpenApi PathItem = PathStep FilePath
109+ deriving (Eq, Ord)
110+
111+instance Steppable PathItem PathFragment where
112+ data Step PathItem PathFragment
113+ = -- | The index of the path item
114+ PathFragmentStep Int
115+ deriving (Eq, Ord)
116+
117+instance Steppable PathFragment PathItem where
118+ data Step PathFragment PathItem = PathFragmentParentStep
119+ deriving (Eq, Ord)
120+
121+instance Steppable PathItem (Referenced Param) where
122+ data Step PathItem (Referenced Param) = PathItemParametersStep
123+ deriving (Eq, Ord)
124+
125+instance Steppable Operation (Referenced Param) where
126+ data Step Operation (Referenced Param) = OperationParametersStep
127+ deriving (Eq, Ord)
128+
129+data ForeachOperation a = ForeachOperation
130+ { processedPathItemGet :: a
131+ , processedPathItemPut :: a
132+ , processedPathItemPost :: a
133+ , processedPathItemDelete :: a
134+ , processedPathItemOptions :: a
135+ , processedPathItemHead :: a
136+ , processedPathItemPatch :: a
137+ , processedPathItemTrace :: a
138+ }
139+ deriving stock (Functor, Generic1)
140+ deriving (Applicative, Foldable) via Generically1 ForeachOperation
141+
142+newtype ProcessedPathItemGetter = ProcessedPathItemGetter (forall a. ForeachOperation a -> a)
143+
144+processedPathItemGetters :: ForeachOperation ProcessedPathItemGetter
145+processedPathItemGetters =
146+ ForeachOperation
147+ { processedPathItemGet = ProcessedPathItemGetter processedPathItemGet
148+ , processedPathItemPut = ProcessedPathItemGetter processedPathItemPut
149+ , processedPathItemPost = ProcessedPathItemGetter processedPathItemPost
150+ , processedPathItemDelete = ProcessedPathItemGetter processedPathItemDelete
151+ , processedPathItemOptions = ProcessedPathItemGetter processedPathItemOptions
152+ , processedPathItemHead = ProcessedPathItemGetter processedPathItemHead
153+ , processedPathItemPatch = ProcessedPathItemGetter processedPathItemPatch
154+ , processedPathItemTrace = ProcessedPathItemGetter processedPathItemTrace
155+ }
156+
157+stepProcessedPathItem :: ForeachOperation (Step PathItem Operation)
158+stepProcessedPathItem =
159+ ForeachOperation
160+ { processedPathItemGet = GetStep
161+ , processedPathItemPut = PutStep
162+ , processedPathItemPost = PostStep
163+ , processedPathItemDelete = DeleteStep
164+ , processedPathItemOptions = OptionsStep
165+ , processedPathItemHead = HeadStep
166+ , processedPathItemPatch = PatchStep
167+ , processedPathItemTrace = TraceStep
168+ }
src/OpenAPI/Checker/Validate/Operation.hsnew file+26
@@ -0,0 +1,26 @@
1+{-# OPTIONS_GHC -Wno-orphans #-}
2+
3+module OpenAPI.Checker.Validate.Operation (Step (..)) where
4+
5+import Data.OpenApi
6+import OpenAPI.Checker.Subtree
7+import OpenAPI.Checker.Trace
8+
9+instance Subtree Operation where
10+ type CheckEnv Operation = '[]
11+ data CheckIssue Operation
12+ deriving (Eq, Ord)
13+ normalizeTrace = undefined
14+ checkCompatibility = undefined
15+
16+instance Steppable PathItem Operation where
17+ data Step PathItem Operation
18+ = GetStep
19+ | PutStep
20+ | PostStep
21+ | DeleteStep
22+ | OptionsStep
23+ | HeadStep
24+ | PatchStep
25+ | TraceStep
26+ deriving (Eq, Ord)
src/OpenAPI/Checker/Validate/Param.hsnew file+13
@@ -0,0 +1,13 @@
1+{-# OPTIONS_GHC -Wno-orphans #-}
2+
3+module OpenAPI.Checker.Validate.Param () where
4+
5+import Data.OpenApi
6+import OpenAPI.Checker.Subtree
7+
8+instance Subtree Param where
9+ type CheckEnv Param = '[]
10+ data CheckIssue Param
11+ deriving (Eq, Ord)
12+ normalizeTrace = undefined
13+ checkCompatibility = undefined
src/OpenAPI/Checker/Validate/PathFragment.hsnew file+103
@@ -0,0 +1,103 @@
1+module OpenAPI.Checker.Validate.PathFragment
2+ ( PathParamRefs
3+ , TracedReferences
4+ , getPathParamRefs
5+ , parsePath
6+ , PathFragment (..)
7+ )
8+where
9+
10+import Control.Lens
11+import Control.Monad.Reader
12+import qualified Data.Aeson as A
13+import Data.HList
14+import qualified Data.List.NonEmpty as NE
15+import Data.Map.Strict (Map)
16+import qualified Data.Map.Strict as M
17+import Data.Maybe
18+import Data.OpenApi
19+import Data.Text (Text)
20+import qualified Data.Text as T
21+import OpenAPI.Checker.References
22+import OpenAPI.Checker.Subtree
23+import OpenAPI.Checker.Trace
24+import OpenAPI.Checker.Validate.Param ()
25+
26+getPathParamRefs
27+ :: Definitions Param
28+ -> [Referenced Param]
29+ -> Map Reference (Traced (Referenced Param) Param)
30+getPathParamRefs defs xs =
31+ M.fromList $ do
32+ x <- xs
33+ let (Traced t param) = dereferenceTraced defs x
34+ guard (_paramIn param == ParamPath)
35+ return (Reference $ _paramName param, Traced t param)
36+
37+-- TODO: templates can be only part of the PathFragment. Currently only supports templates as full PathFragment.
38+-- https://github.com/typeable/openapi-diff/issues/23
39+parsePath :: FilePath -> [PathFragment]
40+parsePath = fmap partition . T.splitOn "/" . T.pack
41+ where
42+ partition :: Text -> PathFragment
43+ partition t
44+ | Just ('{', rest) <- T.uncons t
45+ , Just (ref, '}') <- T.unsnoc rest =
46+ DynamicPath $ Reference ref
47+ partition t = StaticPath t
48+
49+data PathFragment
50+ = StaticPath Text
51+ | DynamicPath Reference
52+ deriving stock (Eq, Ord)
53+
54+instance Steppable PathFragment Param where
55+ data Step PathFragment Param = StaticPathParam
56+ deriving (Eq, Ord)
57+
58+type PathParamRefs = TracedReferences PathFragment Param
59+
60+instance Subtree PathFragment where
61+ type CheckEnv PathFragment = '[ProdCons PathParamRefs]
62+ data CheckIssue PathFragment = PathFragmentsDontMatch Text Text
63+ deriving (Eq, Ord)
64+
65+ normalizeTrace = undefined
66+
67+ -- This case isn't strictly needed. It is here for optimization.
68+ checkCompatibility _ ProdCons {producer = (StaticPath x), consumer = (StaticPath y)} =
69+ if x == y
70+ then pure ()
71+ else issueAt consumer (PathFragmentsDontMatch x y)
72+ checkCompatibility env prodCons = do
73+ let (t, param) =
74+ fsplit . fmap deTraced $
75+ dePathFragment
76+ <$> (singletonH <$> getH @(ProdCons PathParamRefs) env)
77+ <*> prodCons
78+ localTrace t $ checkCompatibility env param
79+
80+-- | A clearer name for 'NE.unzip' that can be used without qualifying it.
81+fsplit :: Functor f => f (a, b) -> (f a, f b)
82+fsplit = NE.unzip
83+
84+dePathFragment :: Has PathParamRefs xs => HList xs -> PathFragment -> Traced PathFragment Param
85+dePathFragment (getH @PathParamRefs -> params) = \case
86+ (StaticPath s) ->
87+ Traced (step StaticPathParam) $
88+ mempty
89+ { _paramRequired = Just True
90+ , _paramIn = ParamPath
91+ , _paramAllowEmptyValue = Just False
92+ , _paramAllowReserved = Just False
93+ , _paramSchema = Just $ Inline $ staticStringSchema s
94+ }
95+ (DynamicPath ref) -> M.lookup ref params & fromMaybe (error $ show ref <> " not found.")
96+
97+staticStringSchema :: Text -> Schema
98+staticStringSchema t =
99+ mempty
100+ { _schemaNullable = Just False
101+ , _schemaType = Just OpenApiString
102+ , _schemaEnum = Just [A.String t]
103+ }