git.iko.soy/typeable/openapi3
on bb1c64f help sign in
typeable/openapi3/src/Data/OpenApi/Optics.hs
283 lines 7.9 kB history raw
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE MultiParamTypeClasses #-}
4{-# LANGUAGE OverloadedLabels #-}
5{-# LANGUAGE TemplateHaskell #-}
6{-# LANGUAGE TypeFamilies #-}
7{-# LANGUAGE UndecidableInstances #-}
8{-# OPTIONS_GHC -fno-warn-orphans #-}
9-- |
10-- Module: Data.OpenApi.Optics
11-- Maintainer: Andrzej Rybczak <andrzej@rybczak.net>
12-- Stability: experimental
13--
14-- Lenses and prisms for the <https://hackage.haskell.org/package/optics optics>
15-- library.
16--
17-- >>> import Data.Aeson
18-- >>> import Optics.Core
19-- >>> :set -XOverloadedLabels
20-- >>> import qualified Data.ByteString.Lazy.Char8 as BSL
21--
22-- Example from the "Data.OpenApi" module using @optics@:
23--
24-- >>> :{
25-- BSL.putStrLn $ encode $ (mempty :: OpenApi)
26-- & #components % #schemas .~ [ ("User", mempty & #type ?~ OpenApiString) ]
27-- & #paths .~
28-- [ ("/user", mempty & #get ?~ (mempty
29-- & at 200 ?~ ("OK" & #_Inline % #content % at "application/json" ?~ (mempty & #schema ?~ Ref (Reference "User")))
30-- & at 404 ?~ "User info not found")) ]
31-- :}
32-- {"openapi":"3.0.0","info":{"version":"","title":""},"paths":{"/user":{"get":{"responses":{"404":{"description":"User info not found"},"200":{"content":{"application/json":{"schema":{"$ref":"#/components/schemas/User"}}},"description":"OK"}}}}},"components":{"schemas":{"User":{"type":"string"}}}}
33--
34-- For convenience optics are defined as /labels/. It means that field accessor
35-- names can be overloaded for different types. One such common field is
36-- @#description@. Many components of a Swagger specification can have
37-- descriptions, and you can use the same name for them:
38--
39-- >>> BSL.putStrLn $ encode $ (mempty :: Response) & #description .~ "No content"
40-- {"description":"No content"}
41-- >>> :{
42-- BSL.putStrLn $ encode $ (mempty :: Schema)
43-- & #type ?~ OpenApiBoolean
44-- & #description ?~ "To be or not to be"
45-- :}
46-- {"type":"boolean","description":"To be or not to be"}
47--
48-- Additionally, to simplify working with @'Response'@, both @'Operation'@ and
49-- @'Responses'@ have direct access to it via @'Optics.Core.At.at'@. Example:
50--
51-- >>> :{
52-- BSL.putStrLn $ encode $ (mempty :: Operation)
53-- & at 404 ?~ "Not found"
54-- :}
55-- {"responses":{"404":{"description":"Not found"}}}
56--
57module Data.OpenApi.Optics () where
59import Data.Aeson (Value)
60import Data.Scientific (Scientific)
61import Data.OpenApi.Internal
62import Data.Text (Text)
63import Optics.Core
64import Optics.TH
66-- Lenses
68makeFieldLabels ''OpenApi
69makeFieldLabels ''Components
70makeFieldLabels ''Server
71makeFieldLabels ''ServerVariable
72makeFieldLabels ''RequestBody
73makeFieldLabels ''MediaTypeObject
74makeFieldLabels ''Info
75makeFieldLabels ''Contact
76makeFieldLabels ''License
77makeFieldLabels ''PathItem
78makeFieldLabels ''Tag
79makeFieldLabels ''Operation
80makeFieldLabels ''Param
81makeFieldLabels ''Header
82makeFieldLabels ''Schema
83makeFieldLabels ''NamedSchema
84makeFieldLabels ''Xml
85makeFieldLabels ''Responses
86makeFieldLabels ''Response
87makeFieldLabels ''SecurityScheme
88makeFieldLabels ''ApiKeyParams
89makeFieldLabels ''OAuth2ImplicitFlow
90makeFieldLabels ''OAuth2PasswordFlow
91makeFieldLabels ''OAuth2ClientCredentialsFlow
92makeFieldLabels ''OAuth2AuthorizationCodeFlow
93makeFieldLabels ''OAuth2Flow
94makeFieldLabels ''OAuth2Flows
95makeFieldLabels ''ExternalDocs
96makeFieldLabels ''Encoding
97makeFieldLabels ''Example
98makeFieldLabels ''Discriminator
99makeFieldLabels ''Link
101-- Prisms
103makePrismLabels ''SecuritySchemeType
104makePrismLabels ''Referenced
106-- OpenApiItems prisms
108instance
109 ( a ~ [Referenced Schema]
110 , b ~ [Referenced Schema]
111 ) => LabelOptic "_OpenApiItemsArray"
112 A_Review
113 OpenApiItems
114 OpenApiItems
115 a
116 b where
117 labelOptic = unto (\x -> OpenApiItemsArray x)
118 {-# INLINE labelOptic #-}
120instance
121 ( a ~ Referenced Schema
122 , b ~ Referenced Schema
123 ) => LabelOptic "_OpenApiItemsObject"
124 A_Review
125 OpenApiItems
126 OpenApiItems
127 a
128 b where
129 labelOptic = unto (\x -> OpenApiItemsObject x)
130 {-# INLINE labelOptic #-}
132-- =============================================================
133-- More helpful instances for easier access to schema properties
135type instance Index Responses = HttpStatusCode
136type instance Index Operation = HttpStatusCode
138type instance IxValue Responses = Referenced Response
139type instance IxValue Operation = Referenced Response
141instance Ixed Responses where
142 ix n = #responses % ix n
143 {-# INLINE ix #-}
144instance At Responses where
145 at n = #responses % at n
146 {-# INLINE at #-}
148instance Ixed Operation where
149 ix n = #responses % ix n
150 {-# INLINE ix #-}
151instance At Operation where
152 at n = #responses % at n
153 {-# INLINE at #-}
155-- #type
157instance
158 ( a ~ Maybe OpenApiType
159 , b ~ Maybe OpenApiType
160 ) => LabelOptic "type" A_Lens NamedSchema NamedSchema a b where
161 labelOptic = #schema % #type
162 {-# INLINE labelOptic #-}
164-- #default
166instance
167 ( a ~ Maybe Value, b ~ Maybe Value
168 ) => LabelOptic "default" A_Lens NamedSchema NamedSchema a b where
169 labelOptic = #schema % #default
170 {-# INLINE labelOptic #-}
172-- #format
174instance
175 ( a ~ Maybe Format, b ~ Maybe Format
176 ) => LabelOptic "format" A_Lens NamedSchema NamedSchema a b where
177 labelOptic = #schema % #format
178 {-# INLINE labelOptic #-}
180-- #items
182instance
183 ( a ~ Maybe OpenApiItems
184 , b ~ Maybe OpenApiItems
185 ) => LabelOptic "items" A_Lens NamedSchema NamedSchema a b where
186 labelOptic = #schema % #items
187 {-# INLINE labelOptic #-}
189-- #maximum
191instance
192 ( a ~ Maybe Scientific, b ~ Maybe Scientific
193 ) => LabelOptic "maximum" A_Lens NamedSchema NamedSchema a b where
194 labelOptic = #schema % #maximum
195 {-# INLINE labelOptic #-}
197-- #exclusiveMaximum
199instance
200 ( a ~ Maybe Bool, b ~ Maybe Bool
201 ) => LabelOptic "exclusiveMaximum" A_Lens NamedSchema NamedSchema a b where
202 labelOptic = #schema % #exclusiveMaximum
203 {-# INLINE labelOptic #-}
205-- #minimum
207instance
208 ( a ~ Maybe Scientific, b ~ Maybe Scientific
209 ) => LabelOptic "minimum" A_Lens NamedSchema NamedSchema a b where
210 labelOptic = #schema % #minimum
211 {-# INLINE labelOptic #-}
213-- #exclusiveMinimum
215instance
216 ( a ~ Maybe Bool, b ~ Maybe Bool
217 ) => LabelOptic "exclusiveMinimum" A_Lens NamedSchema NamedSchema a b where
218 labelOptic = #schema % #exclusiveMinimum
219 {-# INLINE labelOptic #-}
221-- #maxLength
223instance
224 ( a ~ Maybe Integer, b ~ Maybe Integer
225 ) => LabelOptic "maxLength" A_Lens NamedSchema NamedSchema a b where
226 labelOptic = #schema % #maxLength
227 {-# INLINE labelOptic #-}
229-- #minLength
231instance
232 ( a ~ Maybe Integer, b ~ Maybe Integer
233 ) => LabelOptic "minLength" A_Lens NamedSchema NamedSchema a b where
234 labelOptic = #schema % #minLength
235 {-# INLINE labelOptic #-}
237-- #pattern
239instance
240 ( a ~ Maybe Text, b ~ Maybe Text
241 ) => LabelOptic "pattern" A_Lens NamedSchema NamedSchema a b where
242 labelOptic = #schema % #pattern
243 {-# INLINE labelOptic #-}
245-- #maxItems
247instance
248 ( a ~ Maybe Integer, b ~ Maybe Integer
249 ) => LabelOptic "maxItems" A_Lens NamedSchema NamedSchema a b where
250 labelOptic = #schema % #maxItems
251 {-# INLINE labelOptic #-}
253-- #minItems
255instance
256 ( a ~ Maybe Integer, b ~ Maybe Integer
257 ) => LabelOptic "minItems" A_Lens NamedSchema NamedSchema a b where
258 labelOptic = #schema % #minItems
259 {-# INLINE labelOptic #-}
261-- #uniqueItems
263instance
264 ( a ~ Maybe Bool, b ~ Maybe Bool
265 ) => LabelOptic "uniqueItems" A_Lens NamedSchema NamedSchema a b where
266 labelOptic = #schema % #uniqueItems
267 {-# INLINE labelOptic #-}
269-- #enum
271instance
272 ( a ~ Maybe [Value], b ~ Maybe [Value]
273 ) => LabelOptic "enum" A_Lens NamedSchema NamedSchema a b where
274 labelOptic = #schema % #enum
275 {-# INLINE labelOptic #-}
277-- #multipleOf
279instance
280 ( a ~ Maybe Scientific, b ~ Maybe Scientific
281 ) => LabelOptic "multipleOf" A_Lens NamedSchema NamedSchema a b where
282 labelOptic = #schema % #multipleOf
283 {-# INLINE labelOptic #-}