@@ -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+ }