@@ -1,21 +1,34 @@
11{-# OPTIONS_GHC -Wno-name-shadowing #-}
22{-# OPTIONS_GHC -Wno-orphans #-}
3+{-# OPTIONS_GHC -fconstraint-solver-iterations=0 #-}
34
45module OpenAPI.Checker.Validate.Operation
5− ( MatchedOperation (..)
6+ ( -- * Operation
7+ MatchedOperation (..)
68 , OperationMethod (..)
79 , pathItemMethod
10+
11+ -- * ProcessedPathItem
12+ , ProcessedPathItem (..)
13+ , ProcessedPathItems (..)
14+ , processPathItems
15+ , Step (..)
816 )
917where
1018
19+import Control.Arrow
20+import Control.Comonad.Env
21+import Control.Monad
1122import Data.Foldable as F
1223import Data.Functor
1324import Data.HList
25+import qualified Data.HashMap.Strict.InsOrd as IOHM
1426import qualified Data.List as L
1527import Data.Map.Strict as M
1628import Data.Maybe
1729import Data.OpenApi
1830import Data.Text (Text)
31+import qualified Data.Text as T
1932import OpenAPI.Checker.Behavior
2033import OpenAPI.Checker.References
2134import OpenAPI.Checker.Subtree
@@ -27,6 +40,7 @@ import OpenAPI.Checker.Validate.RequestBody ()
2740import OpenAPI.Checker.Validate.Responses ()
2841import OpenAPI.Checker.Validate.SecurityRequirement ()
2942import OpenAPI.Checker.Validate.Server ()
43+import OpenAPI.Checker.Validate.Sums
3044
3145data MatchedOperation = MatchedOperation
3246 { operation :: !Operation
@@ -62,6 +76,12 @@ tracedSecurity oper =
6276 | (i, x) <- zip [0 ..] $ _operationSecurity . operation $ extract oper
6377 ]
6478
79+tracedCallbacks :: Traced MatchedOperation -> [(Text, Traced (Referenced Callback))]
80+tracedCallbacks (Traced t oper) =
81+ [ (k, Traced (t >>> step (OperationCallbackStep k)) v)
82+ | (k, v) <- IOHM.toList . _operationCallbacks . operation $ oper
83+ ]
84+
6585-- FIXME: https://github.com/typeable/openapi-diff/issues/28
6686getServers
6787 :: [Server] -- ^ Servers from env
@@ -100,6 +120,7 @@ instance Subtree MatchedOperation where
100120 , ProdCons (Traced (Definitions Schema))
101121 , ProdCons [Server]
102122 , ProdCons (Traced (Definitions Link))
123+ , ProdCons (Traced (Definitions Callback))
103124 ]
104125 checkStructuralCompatibility env pc = do
105126 let pParams :: ProdCons [Traced Param]
@@ -216,7 +237,24 @@ instance Subtree MatchedOperation where
216237 resps = tracedResponses <$> prodCons
217238 checkCompatibility respEnv beh $ swapProdCons resps
218239 -- FIXME: https://github.com/typeable/openapi-diff/issues/27
219− checkCallbacks = pure () -- (error "FIXME: not implemented")
240+ checkCallbacks = do
241+ let env' =
242+ HCons (swapProdCons respDefs) $
243+ HCons (swapProdCons headerDefs) $
244+ HCons (swapProdCons schemaDefs) $
245+ HCons (swapProdCons securitySchemeDefs) $
246+ HCons (swapProdCons paramDefs) $
247+ HCons (swapProdCons serversDefs) $
248+ HCons (swapProdCons callbackDefs) $
249+ HCons (swapProdCons bodyDefs) $
250+ HCons (swapProdCons linkDefs) HNil
251+ let ProdCons pCallbacks cCallbacks = swapProdCons $ tracedCallbacks <$> prodCons
252+ for_ pCallbacks $ \(k, pCallback) -> do
253+ let beh' = beh >>> step (OperationCallback k)
254+ anyOfAt beh' CallbacksUnsupported $
255+ cCallbacks <&> \(_, cCallback) -> do
256+ checkCompatibility env' beh' $ ProdCons pCallback cCallback
257+ pure ()
220258 -- FIXME: https://github.com/typeable/openapi-diff/issues/28
221259 checkOperationSecurity = do
222260 let ProdCons pSecs cSecs = tracedSecurity <$> prodCons
@@ -236,6 +274,9 @@ instance Subtree MatchedOperation where
236274 schemaDefs = getH @(ProdCons (Traced (Definitions Schema))) env
237275 paramDefs = getH @(ProdCons (Traced (Definitions Param))) env
238276 linkDefs = getH @(ProdCons (Traced (Definitions Link))) env
277+ callbackDefs = getH @(ProdCons (Traced (Definitions Callback))) env
278+ securitySchemeDefs = getH @(ProdCons (Traced (Definitions SecurityScheme))) env
279+ serversDefs = getH @(ProdCons [Server]) env
239280
240281data OperationMethod
241282 = GetMethod
@@ -275,8 +316,249 @@ instance Steppable MatchedOperation SecurityRequirement where
275316 data Step MatchedOperation SecurityRequirement = OperationSecurityRequirementStep Int
276317 deriving stock (Eq, Ord, Show)
277318
319+instance Steppable MatchedOperation (Referenced Callback) where
320+ data Step MatchedOperation (Referenced Callback) = OperationCallbackStep Text
321+ deriving stock (Eq, Ord, Show)
322+
278323instance Steppable MatchedOperation [Server] where
279324 data Step MatchedOperation [Server]
280325 = OperationServersStep
281326 | EnvServerStep
282327 deriving (Eq, Ord, Show)
328+
329+-- * ProcessedPathItems
330+
331+-- FIXME: There's probably a better name for this, but `PathItem` is already taken ;(
332+data ProcessedPathItem = ProcessedPathItem
333+ { path :: FilePath
334+ , item :: PathItem
335+ }
336+ deriving stock (Eq, Show)
337+
338+processPathItems :: [(FilePath, PathItem)] -> ProcessedPathItems
339+processPathItems = ProcessedPathItems . fmap (uncurry ProcessedPathItem)
340+
341+newtype ProcessedPathItems = ProcessedPathItems {unProcessedPathItems :: [ProcessedPathItem]}
342+ deriving newtype (Eq, Show)
343+
344+instance Issuable 'APILevel where
345+ data Issue 'APILevel
346+ = NoPathsMatched FilePath
347+ | AllPathsFailed FilePath
348+ -- When several paths match given but all checks failed
349+ deriving stock (Eq, Ord, Show)
350+ issueIsUnsupported _ = False
351+
352+instance Behavable 'APILevel 'PathLevel where
353+ data Behave 'APILevel 'PathLevel
354+ = AtPath (ProdCons FilePath) -- TODO: why are there two?
355+ deriving stock (Eq, Ord, Show)
356+
357+instance Subtree ProcessedPathItems where
358+ type SubtreeLevel ProcessedPathItems = 'APILevel
359+ type
360+ CheckEnv ProcessedPathItems =
361+ '[ ProdCons (Traced (Definitions Param))
362+ , ProdCons (Traced (Definitions RequestBody))
363+ , ProdCons (Traced (Definitions SecurityScheme))
364+ , ProdCons (Traced (Definitions Response))
365+ , ProdCons (Traced (Definitions Header))
366+ , ProdCons (Traced (Definitions Schema))
367+ , ProdCons [Server]
368+ , ProdCons (Traced (Definitions Link))
369+ , ProdCons (Traced (Definitions Callback))
370+ ]
371+
372+ -- No real way to check it at this level
373+ checkStructuralCompatibility _ _ = structuralIssue
374+ checkSemanticCompatibility env beh pc@(ProdCons p c) = do
375+ -- Each path generated by producer must be handled by consumer with exactly
376+ -- one way
377+ for_ (unProcessedPathItems . extract $ p) $ \prodItem -> do
378+ let prodPath = path prodItem
379+ matchedItems = do
380+ consItem <- unProcessedPathItems . extract $ c
381+ F.toList $ matchingPathItems $ ProdCons prodItem consItem
382+ case matchedItems of
383+ [] -> issueAt beh $ NoPathsMatched prodPath
384+ [match] -> checkCompatibility env (beh >>> step (AtPath $ matchedPath <$> match)) (retraced <$> pc <*> match)
385+ matches -> anyOfAt beh (AllPathsFailed prodPath) $ do
386+ match <- matches
387+ pure $ checkCompatibility env (beh >>> step (AtPath $ matchedPath <$> match)) (retraced <$> pc <*> match)
388+ where
389+ retraced pc mpi = traced (ask pc >>> step (MatchedPathStep $ matchedPath mpi)) mpi
390+
391+-- | Preliminary checks two paths for compatibility. Returns Nothing if two
392+-- paths obviously do not match: static parts differ or count of path elements
393+-- is not equal
394+matchingPathItems :: ProdCons ProcessedPathItem -> Maybe (ProdCons MatchedPathItem)
395+matchingPathItems prodCons = do
396+ let frags = parsePath . path <$> prodCons
397+ guard $ fragsMatch frags
398+ let mkMatchedItems frag ppi =
399+ MatchedPathItem
400+ { pathItem = item ppi
401+ , matchedPath = path ppi
402+ , pathFragments = frag
403+ }
404+ return $ mkMatchedItems <$> frags <*> prodCons
405+
406+fragsMatch :: ProdCons [PathFragment Text] -> Bool
407+fragsMatch (ProdCons p c) = maybe False and $ zipAllWith check p c
408+ where
409+ check (StaticPath s1) (StaticPath s2) = s1 == s2
410+ check _ _ = True
411+
412+zipAllWith :: (a -> b -> c) -> [a] -> [b] -> Maybe [c]
413+zipAllWith _ [] [] = Just []
414+zipAllWith f (x : xs) (y : ys) = (f x y :) <$> zipAllWith f xs ys
415+zipAllWith _ (_ : _) [] = Nothing
416+zipAllWith _ [] (_ : _) = Nothing
417+
418+data MatchedPathItem = MatchedPathItem
419+ { pathItem :: !PathItem
420+ , matchedPath :: !FilePath
421+ , -- | Pre-parsed path from PathItem
422+ pathFragments :: ![PathFragment Text]
423+ }
424+ deriving stock (Eq)
425+
426+tracedMatchedPathItemParameters :: Traced MatchedPathItem -> [Traced (Referenced Param)]
427+tracedMatchedPathItemParameters mpi =
428+ [ traced (ask mpi >>> step (PathItemParam i)) x
429+ | (i, x) <- L.zip [0 ..] $ _pathItemParameters . pathItem $ extract mpi
430+ ]
431+
432+-- TODO: simplify?
433+tracedFragments :: Traced MatchedPathItem -> [Env (Trace PathFragmentParam) (PathFragment Text)]
434+tracedFragments mpi =
435+ [ env (ask mpi >>> step (PathFragmentStep i)) x
436+ | (i, x) <- L.zip [0 ..] $ pathFragments $ extract mpi
437+ ]
438+
439+tracedMethod
440+ :: OperationMethod
441+ -> Traced MatchedPathItem
442+ -> Maybe (Traced' MatchedOperation Operation)
443+tracedMethod s mpi = env (ask mpi >>> step (OperationMethodStep s)) <$> (pathItemMethod s . pathItem . extract $ mpi)
444+
445+instance Issuable 'PathLevel where
446+ data Issue 'PathLevel
447+ = OperationMissing OperationMethod
448+ deriving stock (Eq, Ord, Show)
449+ issueIsUnsupported _ = False
450+
451+instance Behavable 'PathLevel 'OperationLevel where
452+ data Behave 'PathLevel 'OperationLevel
453+ = InOperation OperationMethod
454+ deriving (Eq, Ord, Show)
455+
456+instance Subtree MatchedPathItem where
457+ type SubtreeLevel MatchedPathItem = 'PathLevel
458+ type
459+ CheckEnv MatchedPathItem =
460+ '[ ProdCons (Traced (Definitions Param))
461+ , ProdCons (Traced (Definitions RequestBody))
462+ , ProdCons (Traced (Definitions SecurityScheme))
463+ , ProdCons (Traced (Definitions Response))
464+ , ProdCons (Traced (Definitions Header))
465+ , ProdCons (Traced (Definitions Schema))
466+ , ProdCons [Server]
467+ , ProdCons (Traced (Definitions Link))
468+ , ProdCons (Traced (Definitions Callback))
469+ ]
470+ checkStructuralCompatibility _ _ = structuralIssue
471+ checkSemanticCompatibility env beh prodCons = do
472+ let paramDefs = getH @(ProdCons (Traced (Definitions Param))) env
473+ pathTracedParams = getPathParams <$> paramDefs <*> prodCons
474+ getPathParams
475+ :: Traced (Definitions Param)
476+ -> Traced MatchedPathItem
477+ -> [Traced Param]
478+ getPathParams defs mpi = do
479+ paramRef <- tracedMatchedPathItemParameters mpi
480+ pure $ dereference defs paramRef
481+ pathTracedFragments = mkPathFragments <$> prodCons
482+ mkPathFragments mpi operationParams =
483+ -- operationParams will be known on Operation check stage, so we give a
484+ -- function, returning fragments
485+ let paramsMap :: Map Text (Traced Param)
486+ paramsMap = M.fromList $ do
487+ tracedParam <- operationParams
488+ let pname = _paramName . extract $ tracedParam
489+ pure (pname, tracedParam)
490+ convertFragment = \case
491+ StaticPath t -> StaticPath t
492+ DynamicPath pname ->
493+ DynamicPath $
494+ fromMaybe (error $ "Param not found " <> T.unpack pname) $
495+ M.lookup pname paramsMap
496+ in tracedFragments mpi <&> fmap convertFragment
497+ operations = getOperations <$> pathTracedParams <*> pathTracedFragments <*> prodCons
498+ getOperations pathParams getPathFragments mpi = M.fromList $ do
499+ (name, getOp) <-
500+ (id &&& tracedMethod)
501+ <$> [GetMethod, PutMethod, PostMethod, DeleteMethod, OptionsMethod, HeadMethod, PatchMethod, DeleteMethod]
502+ operation <- F.toList $ getOp mpi
503+ -- Got only Justs here
504+ let retraced = \op -> MatchedOperation {operation = op, pathParams, getPathFragments}
505+ pure (name, retraced <$> operation)
506+ check name pc = checkCompatibility @MatchedOperation env (beh >>> step (InOperation name)) pc
507+ -- Operations are sum-like entities. Use step to operation as key because
508+ -- why not
509+ checkSums beh OperationMissing check operations
510+
511+instance Steppable ProcessedPathItems MatchedPathItem where
512+ data Step ProcessedPathItems MatchedPathItem = MatchedPathStep FilePath
513+ deriving (Eq, Ord, Show)
514+
515+instance Steppable MatchedPathItem MatchedOperation where
516+ data Step MatchedPathItem MatchedOperation = OperationMethodStep OperationMethod
517+ deriving (Eq, Ord, Show)
518+
519+instance Steppable MatchedPathItem (Referenced Param) where
520+ data Step MatchedPathItem (Referenced Param) = PathItemParam Int
521+ deriving (Eq, Ord, Show)
522+
523+instance Steppable MatchedPathItem PathFragmentParam where
524+ data Step MatchedPathItem PathFragmentParam = PathFragmentStep Int
525+ deriving (Eq, Ord, Show)
526+
527+-- * Callbacks
528+
529+instance Subtree Callback where
530+ type SubtreeLevel Callback = 'CallbackLevel
531+ type
532+ CheckEnv Callback =
533+ '[ ProdCons (Traced (Definitions Param))
534+ , ProdCons (Traced (Definitions RequestBody))
535+ , ProdCons (Traced (Definitions SecurityScheme))
536+ , ProdCons (Traced (Definitions Response))
537+ , ProdCons (Traced (Definitions Header))
538+ , ProdCons (Traced (Definitions Schema))
539+ , ProdCons (Traced (Definitions Link))
540+ , ProdCons [Server]
541+ , ProdCons (Traced (Definitions Callback))
542+ ]
543+ checkStructuralCompatibility env pc =
544+ checkSubstructure env $ tracedCallbackPathItems <$> pc
545+ checkSemanticCompatibility _ bhv _ = issueAt bhv CallbacksUnsupported
546+
547+instance Issuable 'CallbackLevel where
548+ data Issue 'CallbackLevel
549+ = CallbacksUnsupported
550+ deriving (Eq, Ord, Show)
551+ issueIsUnsupported = \case
552+ CallbacksUnsupported -> True
553+
554+tracedCallbackPathItems :: Traced Callback -> Traced ProcessedPathItems
555+tracedCallbackPathItems (Traced t (Callback x)) =
556+ Traced (t >>> step CallbackPathsStep) (processPathItems . fmap (first T.unpack) . IOHM.toList $ x)
557+
558+instance Steppable Callback ProcessedPathItems where
559+ data Step Callback ProcessedPathItems = CallbackPathsStep
560+ deriving (Eq, Ord, Show)
561+
562+instance Behavable 'OperationLevel 'CallbackLevel where
563+ data Behave 'OperationLevel 'CallbackLevel = OperationCallback Text
564+ deriving stock (Eq, Ord, Show)