@@ -1,4 +1,5 @@
11{-# OPTIONS_GHC -Wno-orphans #-}
2+{-# OPTIONS_GHC -Wno-name-shadowing #-}
23
34module OpenAPI.Checker.Validate.ProcessedPathItem
45 ( ProcessedPathItem (..)
@@ -8,16 +9,21 @@ module OpenAPI.Checker.Validate.ProcessedPathItem
89 )
910where
1011
11−import Data.Foldable
12+import Control.Monad
13+import Data.Foldable as F
14+import Data.Functor
1215import Data.HList
16+import qualified Data.List as L
17+import Data.Map.Strict as M
1318import Data.Maybe
1419import Data.OpenApi
15−import Generic.Data
20+import Data.Text as T
1621import OpenAPI.Checker.References
1722import OpenAPI.Checker.Subtree
1823import OpenAPI.Checker.Trace
1924import OpenAPI.Checker.Validate.Operation
2025import OpenAPI.Checker.Validate.PathFragment
26+import OpenAPI.Checker.Validate.Sums
2127
2228-- FIXME: There's probably a better name for this, but `PathItem` is already taken ;(
2329data ProcessedPathItem = ProcessedPathItem
@@ -28,7 +34,8 @@ data ProcessedPathItem = ProcessedPathItem
2834processPathItems :: [(FilePath, PathItem)] -> ProcessedPathItems
2935processPathItems = ProcessedPathItems . fmap (uncurry ProcessedPathItem)
3036
31−newtype ProcessedPathItems = ProcessedPathItems {unProcessedPathItems :: [ProcessedPathItem]}
37+newtype ProcessedPathItems =
38+ ProcessedPathItems {unProcessedPathItems :: [ProcessedPathItem]}
3239
3340instance Subtree ProcessedPathItems where
3441 type
@@ -40,48 +47,54 @@ instance Subtree ProcessedPathItems where
4047 , ProdCons (Definitions Header)
4148 , ProdCons (Definitions Schema)
4249 ]
43− data CheckIssue ProcessedPathItems = NoPathsMatched | WrongNumberOfFragments
50+ data CheckIssue ProcessedPathItems
51+ = NoPathsMatched FilePath
52+ | AllPathsFailed FilePath
53+ -- When several paths match given but all checks failed
4454 deriving (Eq, Ord, Show)
45− checkCompatibility env prodCons = do
46− let ProdCons {producer = p, consumer = c} =
47− (\paramDefs -> fmap (processPathItem paramDefs) . unProcessedPathItems)
48− <$> getH @(ProdCons (Definitions Param)) env
49− <*> prodCons
50− sequenceA_
51− [ anyOf'
52− [ localTrace (step <$> ProdCons pSPath cSPath) $ do
53− -- make sure every path fragment is compatible
54− sequenceA_
55− [ localTrace (pure . step $ PathFragmentStep i) $
56− checkCompatibility (singletonH $ ProdCons pPathFragmentParams cPathFragmentParams) pair
57− | (i, pair) <- zip [0 ..] pathFragments
58− ]
59− -- make sure the operation is compatible.
60− localTrace (pure . step $ getter stepProcessedPathItem) $
61− checkCompatibility env $ ProdCons pOperation cOperation
62− pure ()
63− | (cSPath, cPath, cPathItem) <- c
64− , -- ... and try to match it with every endpoint in the consumer.
65− --
66− -- This is required because the meaning of path fragments can change on
67− -- a per-method basis even within the same 'PathItem'
68− --
69− -- Here we only need to look for the method that the current producer
70− -- endpoint is using.
71− (cParams, cOperation) <- maybeToList $ getter cPathItem
72− , let cPathFragmentParams = retrace (step PathFragmentParentStep) <$> cParams
73− , -- make sure the paths are the same length
74− pathFragments <- maybeToList $ zipAllWith ProdCons pPath cPath
75− ]
76− | (pSPath, pPath, pPathItem) <- p
77− , -- look at every endpoint in the producer ...
78− (ProcessedPathItemGetter getter, (pParams, pOperation)) <-
79− toList (fmap . (,) <$> processedPathItemGetters <*> pPathItem) >>= maybeToList
80− , let pPathFragmentParams = retrace (step PathFragmentParentStep) <$> pParams
81− ]
55+ checkCompatibility env (ProdCons p c) = do
56+ -- Each path generated by producer must be handled by consumer with exactly
57+ -- one way
58+ for_ (unProcessedPathItems p) $ \ prodItem -> do
59+ let
60+ prodPath = path prodItem
61+ matchedItems = do
62+ consItem <- unProcessedPathItems c
63+ matched <- F.toList $ matchingPathItems $ ProdCons prodItem consItem
64+ return matched
65+ case matchedItems of
66+ [] -> issueAt producer $ NoPathsMatched prodPath
67+ [matched] -> do
68+ -- Checking exact match with no wrapper
69+ let trace = matchedTrace <$> matched
70+ localTrace trace $ checkCompatibility env matched
71+ matches -> anyOfAt consumer (AllPathsFailed prodPath) $ do
72+ match <- matches
73+ let trace = matchedTrace <$> match
74+ pure $ localTrace trace $ checkCompatibility env match
8275 where
83− anyOf' [x] = x -- preserve errors if there's only one choice
84− anyOf' xs = anyOfAt producer NoPathsMatched xs
76+ matchedTrace :: MatchedPathItem -> Trace ProcessedPathItems MatchedPathItem
77+ matchedTrace mpi = step $ MatchedPathStep $ matchedPath mpi
78+
79+-- | Preliminary checks two paths for compatibility. Returns Nothing if two
80+-- paths obviously do not match: static parts differ or count of path elements
81+-- is not equal
82+matchingPathItems :: ProdCons ProcessedPathItem -> Maybe (ProdCons MatchedPathItem)
83+matchingPathItems prodCons = do
84+ let frags = parsePath . path <$> prodCons
85+ guard $ fragsMatch frags
86+ let
87+ mkMatchedItems frag ppi = MatchedPathItem
88+ { pathItem = item ppi
89+ , matchedPath = path ppi
90+ , pathFragments = frag }
91+ return $ mkMatchedItems <$> frags <*> prodCons
92+
93+fragsMatch :: ProdCons [PathFragment Text] -> Bool
94+fragsMatch (ProdCons p c) = maybe False and $ zipAllWith check p c
95+ where
96+ check (StaticPath s1) (StaticPath s2) = s1 == s2
97+ check _ _ = True
8598
8699zipAllWith :: (a -> b -> c) -> [a] -> [b] -> Maybe [c]
87100zipAllWith _ [] [] = Just []
@@ -89,96 +102,102 @@ zipAllWith f (x : xs) (y : ys) = (f x y :) <$> zipAllWith f xs ys
89102zipAllWith _ (_ : _) [] = Nothing
90103zipAllWith _ [] (_ : _) = Nothing
91104
92−processPathItem
93− :: Definitions Param -- ^ from components
94− -> ProcessedPathItem
95− -> ( Step ProcessedPathItems PathItem
96− , [PathFragment]
97− , ForeachOperation (Maybe (TracedReferences PathItem Param, Operation))
98− )
99−processPathItem componentParams ProcessedPathItem {path = pathS, item = pathItem} =
100− let path = parsePath pathS
101− commonPathParams =
102− retrace (step PathItemParametersStep)
103− <$> getPathParamRefs componentParams (_pathItemParameters pathItem)
104− processOperation (s :: Step PathItem Operation) op =
105− let operationParams =
106− retrace (Root `Snoc` s `Snoc` OperationParamsStep)
107− <$> getPathParamRefs componentParams (_operationParameters op)
108− pathParams =
109− operationParams <> commonPathParams
110− in (pathParams, op)
111− in ( PathStep pathS
112− , path
113− , fmap . processOperation
114− <$> stepProcessedPathItem
115− <*> ForeachOperation
116− { processedPathItemGet = _pathItemGet pathItem
117− , processedPathItemPut = _pathItemPut pathItem
118− , processedPathItemPost = _pathItemPost pathItem
119− , processedPathItemDelete = _pathItemDelete pathItem
120− , processedPathItemOptions = _pathItemOptions pathItem
121− , processedPathItemHead = _pathItemHead pathItem
122− , processedPathItemPatch = _pathItemPatch pathItem
123− , processedPathItemTrace = _pathItemTrace pathItem
124− }
125− )
126−
127−instance Steppable ProcessedPathItems PathItem where
128− data Step ProcessedPathItems PathItem = PathStep FilePath
129− deriving (Eq, Ord, Show)
105+data MatchedPathItem = MatchedPathItem
106+ { pathItem :: !PathItem
107+ , matchedPath :: !FilePath
108+ , pathFragments :: ![PathFragment Text]
109+ -- ^ Pre-parsed path from PathItem
110+ }
130111
131−instance Steppable PathItem PathFragment where
132− data Step PathItem PathFragment
133− = -- | The index of the path item
134− PathFragmentStep Int
112+instance Subtree MatchedPathItem where
113+ type CheckEnv MatchedPathItem =
114+ '[ ProdCons (Definitions Param)
115+ , ProdCons (Definitions RequestBody)
116+ , ProdCons (Definitions SecurityScheme)
117+ , ProdCons (Definitions Response)
118+ , ProdCons (Definitions Header)
119+ , ProdCons (Definitions Schema)
120+ ]
121+ data CheckIssue MatchedPathItem
122+ = OperationMissing (Step MatchedPathItem MatchedOperation)
123+ deriving (Eq, Ord, Show)
124+ checkCompatibility env prodCons = withTrace $ \rootTrace -> do
125+ let
126+ paramDefs = getH @(ProdCons (Definitions Param)) env
127+ pathTracedParams = getPathParams <$> rootTrace <*> paramDefs <*> prodCons
128+ getPathParams
129+ :: Trace OpenApi MatchedPathItem
130+ -> Definitions Param
131+ -> MatchedPathItem
132+ -> [Traced OpenApi Param]
133+ getPathParams root defs mpi = do
134+ paramRef <- _pathItemParameters $ pathItem mpi
135+ let
136+ traced = dereferenceTraced defs
137+ $ Traced (step PathItemParam) paramRef
138+ res = retrace root traced
139+ pure res
140+ pathTracedFragments = mkPathFragments <$> rootTrace <*> prodCons
141+ mkPathFragments myRoot mpi operationParams =
142+ -- operationParams will be known on Operation check stage, so we give a
143+ -- function, returning fragments
144+ let
145+ paramsMap :: Map Text (Traced OpenApi Param)
146+ paramsMap = M.fromList $ do
147+ tracedParam <- operationParams
148+ let pname = _paramName $ getTraced tracedParam
149+ pure (pname, tracedParam)
150+ fragments :: [PathFragmentParam]
151+ fragments = (pathFragments mpi) <&> \case
152+ StaticPath t -> StaticPath t
153+ DynamicPath pname -> DynamicPath
154+ $ fromMaybe (error $ "Param not found " <> T.unpack pname)
155+ $ M.lookup pname paramsMap
156+ tracedFragments :: [Traced OpenApi PathFragmentParam]
157+ tracedFragments = L.zip [0..] fragments <&> \(pos, frag) ->
158+ retrace myRoot $ Traced (step $ PathFragmentStep pos) frag
159+ in tracedFragments
160+ operations = getOperations <$> pathTracedParams <*> pathTracedFragments <*> prodCons
161+ getOperations pathParams getPathFragments mpi = M.fromList $ do
162+ (getOp, s) <-
163+ [ (_pathItemGet, GetStep)
164+ , (_pathItemPut, PutStep)
165+ , (_pathItemPost, PostStep)
166+ , (_pathItemDelete, DeleteStep)
167+ , (_pathItemOptions, OptionsStep)
168+ , (_pathItemHead, HeadStep)
169+ , (_pathItemPatch, PatchStep)
170+ , (_pathItemTrace, TraceStep) ]
171+ operation <- F.toList $ getOp $ pathItem mpi
172+ -- Got only Justs here
173+ let mop = MatchedOperation { operation , pathParams, getPathFragments }
174+ pure (s, Traced (step s) mop)
175+ check _ pc = checkCompatibility @MatchedOperation env pc
176+ -- Operations are sum-like entities. Use step to operation as key because
177+ -- why not
178+ checkSums OperationMissing check operations
179+
180+
181+instance Steppable ProcessedPathItems MatchedPathItem where
182+ data Step ProcessedPathItems MatchedPathItem = MatchedPathStep FilePath
135183 deriving (Eq, Ord, Show)
136184
137−instance Steppable PathFragment PathItem where
138− data Step PathFragment PathItem = PathFragmentParentStep
185+instance Steppable MatchedPathItem MatchedOperation where
186+ data Step MatchedPathItem MatchedOperation
187+ = GetStep
188+ | PutStep
189+ | PostStep
190+ | DeleteStep
191+ | OptionsStep
192+ | HeadStep
193+ | PatchStep
194+ | TraceStep
139195 deriving (Eq, Ord, Show)
140196
141−instance Steppable PathItem (Referenced Param) where
142− data Step PathItem (Referenced Param) = PathItemParametersStep
197+instance Steppable MatchedPathItem (Referenced Param) where
198+ data Step MatchedPathItem (Referenced Param) = PathItemParam
143199 deriving (Eq, Ord, Show)
144200
145−data ForeachOperation a = ForeachOperation
146− { processedPathItemGet :: a
147− , processedPathItemPut :: a
148− , processedPathItemPost :: a
149− , processedPathItemDelete :: a
150− , processedPathItemOptions :: a
151− , processedPathItemHead :: a
152− , processedPathItemPatch :: a
153− , processedPathItemTrace :: a
154− }
155− deriving stock (Functor, Generic1)
156− deriving (Applicative, Foldable) via Generically1 ForeachOperation
157−
158−newtype ProcessedPathItemGetter = ProcessedPathItemGetter (forall a. ForeachOperation a -> a)
159−
160−processedPathItemGetters :: ForeachOperation ProcessedPathItemGetter
161−processedPathItemGetters =
162− ForeachOperation
163− { processedPathItemGet = ProcessedPathItemGetter processedPathItemGet
164− , processedPathItemPut = ProcessedPathItemGetter processedPathItemPut
165− , processedPathItemPost = ProcessedPathItemGetter processedPathItemPost
166− , processedPathItemDelete = ProcessedPathItemGetter processedPathItemDelete
167− , processedPathItemOptions = ProcessedPathItemGetter processedPathItemOptions
168− , processedPathItemHead = ProcessedPathItemGetter processedPathItemHead
169− , processedPathItemPatch = ProcessedPathItemGetter processedPathItemPatch
170− , processedPathItemTrace = ProcessedPathItemGetter processedPathItemTrace
171− }
172−
173−stepProcessedPathItem :: ForeachOperation (Step PathItem Operation)
174−stepProcessedPathItem =
175− ForeachOperation
176− { processedPathItemGet = GetStep
177− , processedPathItemPut = PutStep
178− , processedPathItemPost = PostStep
179− , processedPathItemDelete = DeleteStep
180− , processedPathItemOptions = OptionsStep
181− , processedPathItemHead = HeadStep
182− , processedPathItemPatch = PatchStep
183− , processedPathItemTrace = TraceStep
184− }
201+instance Steppable MatchedPathItem PathFragmentParam where
202+ data Step MatchedPathItem PathFragmentParam = PathFragmentStep Int
203+ deriving (Eq, Ord, Show)