@@ -1,14 +1,114 @@
1+{-# OPTIONS_GHC -Wno-orphans #-}
2+
13module OpenAPI.Checker.Validate.Responses
24 (
35 )
46where
57
8+import Data.Foldable
9+import Data.HList
10+import Data.HashMap.Strict.InsOrd as IOHM
11+import Data.Maybe
612import Data.OpenApi
13+import Network.HTTP.Media (MediaType)
14+import OpenAPI.Checker.References
715import OpenAPI.Checker.Subtree
16+import OpenAPI.Checker.Trace
17+import OpenAPI.Checker.Validate.MediaTypeObject ()
18+import OpenAPI.Checker.Validate.Schema ()
819
920instance Subtree Responses where
10− type CheckEnv Responses = '[]
11− data CheckIssue Responses
21+ type CheckEnv Responses =
22+ '[ ProdCons (Definitions Response)
23+ , ProdCons (Definitions Header)
24+ , ProdCons (Definitions Schema)
25+ ]
26+ data CheckIssue Responses = ResponseCodeNotFound HttpStatusCode
27+ deriving (Eq, Ord, Show)
28+ -- Here we are checking responses, so, the consumer and producer swap their
29+ -- roles. The consumer now generates the response and producer consumes
30+ -- it. So, the logic is swapped.
31+ checkCompatibility env (ProdCons p c) = do
32+ let defs = getH @(ProdCons (Definitions Response)) env
33+ for_ (IOHM.toList $ _responsesResponses p) $ \ (prodStatus, prodRef) ->
34+ case IOHM.lookup prodStatus $ _responsesResponses c of
35+ Nothing -> issueAt consumer $ ResponseCodeNotFound prodStatus
36+ Just consRef -> do
37+ let tracedRefs = dereference <$> defs <*> ProdCons prodRef consRef
38+ localStep (ResponseCodeStep prodStatus)
39+ $ checkProdCons env tracedRefs
40+ -- FIXME: Do we need to check "default" fields somehow here?
41+
42+instance Subtree Response where
43+ type CheckEnv Response =
44+ '[ ProdCons (Definitions Header)
45+ , ProdCons (Definitions Schema)
46+ ]
47+ data CheckIssue Response
48+ = ResponseMediaTypeMissing MediaType
49+ | ResponseHeaderMissing HeaderName
50+ deriving (Eq, Ord, Show)
51+ -- Here we are checking responses, so, the consumer and producer swap their
52+ -- roles. The consumer now generates the response and producer consumes
53+ -- it. So, the logic is swapped.
54+ checkCompatibility env (ProdCons p c) = do
55+ checkMediaTypes
56+ checkHeaders
57+ pure ()
58+ where
59+ -- Each response type expected by producer must be in the consumer (logic
60+ -- is swapped)
61+ checkMediaTypes = do
62+ for_ (IOHM.toList $ _responseContent p) $ \ (mediaType, prodMediaObject) ->
63+ case IOHM.lookup mediaType $ _responseContent c of
64+ Nothing -> issueAt consumer $ ResponseMediaTypeMissing mediaType
65+ Just consMediaObject -> localStep (ResponseMediaObject mediaType)
66+ $ swapRoles
67+ $ checkCompatibility @MediaTypeObject (HCons mediaType env)
68+ $ ProdCons consMediaObject prodMediaObject
69+ checkHeaders = do
70+ for_ (IOHM.toList $ _responseHeaders p) $ \ (hname, prodRef) ->
71+ case IOHM.lookup hname $ _responseHeaders c of
72+ Nothing -> issueAt consumer $ ResponseHeaderMissing hname
73+ Just consRef -> do
74+ let headerRefs = dereference <$> headerDefs <*> ProdCons prodRef consRef
75+ localStep (ResponseHeader hname)
76+ $ swapRoles
77+ $ checkProdCons env $ swapProdCons headerRefs
78+ headerDefs = getH @(ProdCons (Definitions Header)) env
79+
80+instance Subtree Header where
81+ type CheckEnv Header = '[ProdCons (Definitions Schema)]
82+ data CheckIssue Header
83+ = RequiredHeaderMissing
84+ | NonEmptyHeaderRequired
85+ | HeaderSchemaRequired
86+ deriving (Eq, Ord, Show)
87+ checkCompatibility env (ProdCons p c) = do
88+ if (fromMaybe False $ _headerRequired c) && not (fromMaybe False $ _headerRequired p)
89+ then issueAt producer RequiredHeaderMissing else pure ()
90+ if not (fromMaybe False $ _headerAllowEmptyValue c) && (fromMaybe False $ _headerAllowEmptyValue p)
91+ then issueAt producer NonEmptyHeaderRequired else pure ()
92+ for_ (_headerSchema c) $ \consRef ->
93+ case (_headerSchema p) of
94+ Nothing -> issueAt producer HeaderSchemaRequired
95+ Just prodRef -> do
96+ localStep HeaderSchema
97+ $ checkCompatibility env $ ProdCons prodRef consRef
98+ pure ()
99+
100+instance Steppable Header (Referenced Schema) where
101+ data Step Header (Referenced Schema) = HeaderSchema
102+ deriving (Eq, Ord, Show)
103+
104+instance Steppable Response (Referenced Header) where
105+ data Step Response (Referenced Header) = ResponseHeader HeaderName
106+ deriving (Eq, Ord, Show)
107+
108+instance Steppable Response MediaTypeObject where
109+ data Step Response MediaTypeObject = ResponseMediaObject MediaType
110+ deriving (Eq, Ord, Show)
111+
112+instance Steppable Responses (Referenced Response) where
113+ data Step Responses (Referenced Response) = ResponseCodeStep HttpStatusCode
12114 deriving (Eq, Ord, Show)
13− normalizeTrace = undefined
14− checkCompatibility = undefined