@@ -0,0 +1,181 @@
1+{-# OPTIONS_GHC -Wno-orphans #-}
2+
3+module OpenAPI.Checker.Validate.ProcessedPathItem
4+ ( ProcessedPathItem (..)
5+ , ProcessedPathItems (..)
6+ , processPathItems
7+ , Step (..)
8+ )
9+where
10+
11+import Data.Foldable
12+import Data.HList
13+import Data.Maybe
14+import Data.OpenApi
15+import Generic.Data
16+import OpenAPI.Checker.References
17+import OpenAPI.Checker.Subtree
18+import OpenAPI.Checker.Trace
19+import OpenAPI.Checker.Validate.Operation
20+import OpenAPI.Checker.Validate.PathFragment
21+
22+-- FIXME: There's probably a better name for this, but `PathItem` is already taken ;(
23+data ProcessedPathItem = ProcessedPathItem
24+ { path :: FilePath
25+ , item :: PathItem
26+ }
27+
28+processPathItems :: [(FilePath, PathItem)] -> ProcessedPathItems
29+processPathItems = ProcessedPathItems . fmap (uncurry ProcessedPathItem)
30+
31+newtype ProcessedPathItems = ProcessedPathItems {unProcessedPathItems :: [ProcessedPathItem]}
32+
33+instance Subtree ProcessedPathItems where
34+ type
35+ CheckEnv ProcessedPathItems =
36+ '[ ProdCons (Definitions Param)
37+ , ProdCons (Definitions RequestBody)
38+ , ProdCons (Definitions SecurityScheme)
39+ ]
40+ data CheckIssue ProcessedPathItems = NoPathsMatched | WrongNumberOfFragments
41+ deriving (Eq, Ord, Show)
42+ normalizeTrace = undefined
43+ checkCompatibility env prodCons = do
44+ let ProdCons {producer = p, consumer = c} =
45+ (\paramDefs -> fmap (processPathItem paramDefs) . unProcessedPathItems)
46+ <$> getH @(ProdCons (Definitions Param)) env
47+ <*> prodCons
48+ sequenceA_
49+ [ anyOfAt
50+ producer
51+ NoPathsMatched
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+ ]
82+
83+zipAllWith :: (a -> b -> c) -> [a] -> [b] -> Maybe [c]
84+zipAllWith _ [] [] = Just []
85+zipAllWith f (x : xs) (y : ys) = (f x y :) <$> zipAllWith f xs ys
86+zipAllWith _ (_ : _) [] = Nothing
87+zipAllWith _ [] (_ : _) = Nothing
88+
89+processPathItem
90+ :: Definitions Param -- ^ from components
91+ -> ProcessedPathItem
92+ -> ( Step ProcessedPathItems PathItem
93+ , [PathFragment]
94+ , ForeachOperation (Maybe (TracedReferences PathItem Param, Operation))
95+ )
96+processPathItem componentParams ProcessedPathItem {path = pathS, item = pathItem} =
97+ let path = parsePath pathS
98+ commonPathParams =
99+ retrace (step PathItemParametersStep >>>)
100+ <$> getPathParamRefs componentParams (_pathItemParameters pathItem)
101+ processOperation (s :: Step PathItem Operation) op =
102+ let operationParams =
103+ retrace (Root `Snoc` s `Snoc` OperationParamsStep >>>)
104+ <$> getPathParamRefs componentParams (_operationParameters op)
105+ pathParams =
106+ operationParams <> commonPathParams
107+ in (pathParams, op)
108+ in ( PathStep pathS
109+ , path
110+ , fmap . processOperation
111+ <$> stepProcessedPathItem
112+ <*> ForeachOperation
113+ { processedPathItemGet = _pathItemGet pathItem
114+ , processedPathItemPut = _pathItemPut pathItem
115+ , processedPathItemPost = _pathItemPost pathItem
116+ , processedPathItemDelete = _pathItemDelete pathItem
117+ , processedPathItemOptions = _pathItemOptions pathItem
118+ , processedPathItemHead = _pathItemHead pathItem
119+ , processedPathItemPatch = _pathItemPatch pathItem
120+ , processedPathItemTrace = _pathItemTrace pathItem
121+ }
122+ )
123+
124+instance Steppable ProcessedPathItems PathItem where
125+ data Step ProcessedPathItems PathItem = PathStep FilePath
126+ deriving (Eq, Ord, Show)
127+
128+instance Steppable PathItem PathFragment where
129+ data Step PathItem PathFragment
130+ = -- | The index of the path item
131+ PathFragmentStep Int
132+ deriving (Eq, Ord, Show)
133+
134+instance Steppable PathFragment PathItem where
135+ data Step PathFragment PathItem = PathFragmentParentStep
136+ deriving (Eq, Ord, Show)
137+
138+instance Steppable PathItem (Referenced Param) where
139+ data Step PathItem (Referenced Param) = PathItemParametersStep
140+ deriving (Eq, Ord, Show)
141+
142+data ForeachOperation a = ForeachOperation
143+ { processedPathItemGet :: a
144+ , processedPathItemPut :: a
145+ , processedPathItemPost :: a
146+ , processedPathItemDelete :: a
147+ , processedPathItemOptions :: a
148+ , processedPathItemHead :: a
149+ , processedPathItemPatch :: a
150+ , processedPathItemTrace :: a
151+ }
152+ deriving stock (Functor, Generic1)
153+ deriving (Applicative, Foldable) via Generically1 ForeachOperation
154+
155+newtype ProcessedPathItemGetter = ProcessedPathItemGetter (forall a. ForeachOperation a -> a)
156+
157+processedPathItemGetters :: ForeachOperation ProcessedPathItemGetter
158+processedPathItemGetters =
159+ ForeachOperation
160+ { processedPathItemGet = ProcessedPathItemGetter processedPathItemGet
161+ , processedPathItemPut = ProcessedPathItemGetter processedPathItemPut
162+ , processedPathItemPost = ProcessedPathItemGetter processedPathItemPost
163+ , processedPathItemDelete = ProcessedPathItemGetter processedPathItemDelete
164+ , processedPathItemOptions = ProcessedPathItemGetter processedPathItemOptions
165+ , processedPathItemHead = ProcessedPathItemGetter processedPathItemHead
166+ , processedPathItemPatch = ProcessedPathItemGetter processedPathItemPatch
167+ , processedPathItemTrace = ProcessedPathItemGetter processedPathItemTrace
168+ }
169+
170+stepProcessedPathItem :: ForeachOperation (Step PathItem Operation)
171+stepProcessedPathItem =
172+ ForeachOperation
173+ { processedPathItemGet = GetStep
174+ , processedPathItemPut = PutStep
175+ , processedPathItemPost = PostStep
176+ , processedPathItemDelete = DeleteStep
177+ , processedPathItemOptions = OptionsStep
178+ , processedPathItemHead = HeadStep
179+ , processedPathItemPatch = PatchStep
180+ , processedPathItemTrace = TraceStep
181+ }