git.iko.soy/typeable/mock-server-client
on update-generated-code help sign in
typeable/mock-server-client/src/MockServer/Common.hs
393 lines 15 kB history raw
1{-# LANGUAGE FlexibleInstances #-}
2{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3{-# LANGUAGE LambdaCase #-}
4{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE RecordWildCards #-}
6{-# LANGUAGE TupleSections #-}
7{-# LANGUAGE UndecidableInstances #-}
9-- | This module serves the purpose of defining common functionality which remains the same across all OpenAPI specifications.
10module MockServer.Common
11 ( doCallWithConfiguration,
12 doCallWithConfigurationM,
13 doBodyCallWithConfiguration,
14 doBodyCallWithConfigurationM,
15 runWithConfiguration,
16 textToByte,
17 stringifyModel,
18 anonymousSecurityScheme,
19 Configuration (..),
20 SecurityScheme,
21 MonadHTTP (..),
22 StringifyModel,
23 JsonByteString (..),
24 JsonDateTime (..),
25 RequestBodyEncoding (..),
26 QueryParameter (..),
27 Nullable (..),
28 ClientT (..),
29 ClientM,
30 )
31where
33import qualified Control.Monad.IO.Class as MIO
34import qualified Control.Monad.Reader as MR
35import qualified Control.Monad.Trans.Class as MT
36import qualified Data.Aeson as Aeson
37import qualified Data.Aeson.Encoding as Encoding
38import qualified Data.Bifunctor as BF
39import qualified Data.ByteString.Char8 as B8
40import qualified Data.ByteString.Lazy.Char8 as LB8
41import qualified Data.HashMap.Strict as HMap
42import qualified Data.Maybe as Maybe
43import qualified Data.Scientific as Scientific
44import Data.Text (Text)
45import qualified Data.Text as T
46import qualified Data.Text.Encoding as TE
47import qualified Data.Time.LocalTime as Time
48import qualified Data.Vector as Vector
49import qualified Network.HTTP.Client as HC
50import qualified Network.HTTP.Simple as HS
51import qualified Network.HTTP.Types as HT
53-- | Abstracts the usage of 'Network.HTTP.Simple.httpBS' away,
54-- so that it can be used for testing
55class Monad m => MonadHTTP m where
56 httpBS :: HS.Request -> m (HS.Response B8.ByteString)
58-- | This instance is the default instance used for production code
59instance MonadHTTP IO where
60 httpBS = HS.httpBS
62instance MonadHTTP m => MonadHTTP (MR.ReaderT r m) where
63 httpBS = MT.lift . httpBS
65instance MonadHTTP m => MonadHTTP (ClientT m) where
66 httpBS = MT.lift . httpBS
68-- | The monad in which the operations can be run.
69-- Contains the 'Configuration' to run the requests with.
70--
71-- Run it with 'runWithConfiguration'
72newtype ClientT m a = ClientT (MR.ReaderT Configuration m a)
73 deriving (Functor, Applicative, Monad, MR.MonadReader Configuration)
75instance MT.MonadTrans ClientT where
76 lift = ClientT . MT.lift
78instance MIO.MonadIO m => MIO.MonadIO (ClientT m) where
79 liftIO = ClientT . MIO.liftIO
81-- | Utility type which uses 'IO' as underlying monad
82type ClientM a = ClientT IO a
84-- | Run a 'ClientT' monad transformer in another monad with a specified configuration
85runWithConfiguration :: Configuration -> ClientT m a -> m a
86runWithConfiguration c (ClientT r) = MR.runReaderT r c
88-- | An operation can and must be configured with data, which may be common
89-- for many operations.
90--
91-- This configuration consists of information about the server URL and the used security scheme.
92--
93-- In OpenAPI these information can be defined
94--
95-- * Root level
96-- * Path level
97-- * Operation level
98--
99-- To get started, the 'MockServer.Configuration.defaultConfiguration' can be used and changed accordingly.
100--
101-- Note that it is possible that @bearerAuthenticationSecurityScheme@ is not available because it is not a security scheme in the OpenAPI specification.
102--
103-- > defaultConfiguration
104-- > { configSecurityScheme = bearerAuthenticationSecurityScheme "token" }
105data Configuration = Configuration
106 { -- | The path of the operation is appended to this URL
107 configBaseURL :: Text,
108 -- | The 'SecurityScheme' which is applied to the request
109 -- This is used to set the @Authentication@ header for example
110 configSecurityScheme :: SecurityScheme,
111 -- | This flag indicates if an automatically generated @User-Agent@ header
112 -- should be added to the request. This allows the server to detect with
113 -- which version of the generator the code was generated.
114 configIncludeUserAgent :: Bool,
115 -- | The application name which will be included in the @User-Agent@ header
116 -- if 'configIncludeUserAgent' is set to 'True'
117 configApplicationName :: Text
118 }
120-- | Defines how a request body is encoded
121data RequestBodyEncoding
122 = -- | Encode the body as JSON
123 RequestBodyEncodingJSON
124 | -- | Encode the body as form data
125 RequestBodyEncodingFormData
127-- | Defines a query parameter with the information necessary for serialization
128data QueryParameter = QueryParameter
129 { queryParamName :: Text,
130 queryParamValue :: Maybe Aeson.Value,
131 queryParamStyle :: Text,
132 queryParamExplode :: Bool
133 }
134 deriving (Show, Eq)
136-- | This type specifies a security scheme which can modify a request according to the scheme (e. g. add an Authorization header)
137type SecurityScheme = HS.Request -> HS.Request
139-- | Anonymous security scheme which does not alter the request in any way
140anonymousSecurityScheme :: SecurityScheme
141anonymousSecurityScheme = id
143-- | This is the main functionality of this module
144--
145-- It makes a concrete Call to a Server without a body
146doCallWithConfiguration ::
147 MonadHTTP m =>
148 -- | Configuration options like base URL and security scheme
149 Configuration ->
150 -- | HTTP method (GET, POST, etc.)
151 Text ->
152 -- | Path to append to the base URL (path parameters should already be replaced)
153 Text ->
154 -- | Query parameters
155 [QueryParameter] ->
156 -- | The raw response from the server
157 m (HS.Response B8.ByteString)
158doCallWithConfiguration config method path queryParams =
159 httpBS $ createBaseRequest config method path queryParams
161-- | Same as 'doCallWithConfiguration' but run in a 'MR.ReaderT' environment which contains the configuration.
162-- This is useful if multiple calls have to be executed with the same configuration.
163doCallWithConfigurationM ::
164 MonadHTTP m =>
165 Text ->
166 Text ->
167 [QueryParameter] ->
168 ClientT m (HS.Response B8.ByteString)
169doCallWithConfigurationM method path queryParams = do
170 config <- MR.ask
171 MT.lift $ doCallWithConfiguration config method path queryParams
173-- | This is the main functionality of this module
174--
175-- It makes a concrete Call to a Server with a body
176doBodyCallWithConfiguration ::
177 (MonadHTTP m, Aeson.ToJSON body) =>
178 -- | Configuration options like base URL and security scheme
179 Configuration ->
180 -- | HTTP method (GET, POST, etc.)
181 Text ->
182 -- | Path to append to the base URL (path parameters should already be replaced)
183 Text ->
184 -- | Query parameters
185 [QueryParameter] ->
186 -- | Request body
187 Maybe body ->
188 -- | JSON or form data deepobjects
189 RequestBodyEncoding ->
190 -- | The raw response from the server
191 m (HS.Response B8.ByteString)
192doBodyCallWithConfiguration config method path queryParams Nothing _ = doCallWithConfiguration config method path queryParams
193doBodyCallWithConfiguration config method path queryParams (Just body) RequestBodyEncodingJSON =
194 httpBS $ HS.setRequestMethod (textToByte method) $ HS.setRequestBodyJSON body baseRequest
195 where
196 baseRequest = createBaseRequest config method path queryParams
197doBodyCallWithConfiguration config method path queryParams (Just body) RequestBodyEncodingFormData =
198 httpBS $ HS.setRequestMethod (textToByte method) $ HS.setRequestBodyURLEncoded byteStringData baseRequest
199 where
200 baseRequest = createBaseRequest config method path queryParams
201 byteStringData = createFormData body
203-- | Same as 'doBodyCallWithConfiguration' but run in a 'MR.ReaderT' environment which contains the configuration.
204-- This is useful if multiple calls have to be executed with the same configuration.
205doBodyCallWithConfigurationM ::
206 (MonadHTTP m, Aeson.ToJSON body) =>
207 Text ->
208 Text ->
209 [QueryParameter] ->
210 Maybe body ->
211 RequestBodyEncoding ->
212 ClientT m (HS.Response B8.ByteString)
213doBodyCallWithConfigurationM method path queryParams body encoding = do
214 config <- MR.ask
215 MT.lift $ doBodyCallWithConfiguration config method path queryParams body encoding
217-- | Creates a Base Request
218createBaseRequest ::
219 -- | Configuration options like base URL and security scheme
220 Configuration ->
221 -- | HTTP method (GET, POST, etc.)
222 Text ->
223 -- | The path for which the placeholders have already been replaced
224 Text ->
225 -- | Query Parameters
226 [QueryParameter] ->
227 -- | The Response from the server
228 HS.Request
229createBaseRequest config method path queryParams =
230 configSecurityScheme config $
231 addUserAgent $
232 HS.setRequestMethod (textToByte method) $
233 HS.setRequestQueryString query $
234 HS.setRequestPath
235 (B8.pack (T.unpack $ byteToText basePathModifier <> path))
236 baseRequest
237 where
238 baseRequest = parseURL $ configBaseURL config
239 basePath = HC.path baseRequest
240 basePathModifier =
241 if basePath == B8.pack "/" && T.isPrefixOf "/" path
242 then ""
243 else basePath
244 -- filters all maybe
245 query = BF.second pure <$> serializeQueryParams queryParams
246 userAgent = configApplicationName config <> " openapi3-code-generator/0.1.0.7 (https://github.com/Haskell-OpenAPI-Code-Generator/Haskell-OpenAPI-Client-Code-Generator)"
247 addUserAgent =
248 if configIncludeUserAgent config
249 then HS.addRequestHeader HT.hUserAgent $ textToByte userAgent
250 else id
252serializeQueryParams :: [QueryParameter] -> [(B8.ByteString, B8.ByteString)]
253serializeQueryParams = (>>= serializeQueryParam)
255serializeQueryParam :: QueryParameter -> [(B8.ByteString, B8.ByteString)]
256serializeQueryParam QueryParameter {..} =
257 let concatValues :: B8.ByteString -> [(Maybe Text, B8.ByteString)] -> [(Text, B8.ByteString)]
258 concatValues joinWith =
259 if queryParamExplode
260 then fmap (BF.first $ Maybe.fromMaybe queryParamName)
261 else
262 pure . (queryParamName,) . B8.intercalate joinWith
263 . fmap
264 ( \case
265 (Nothing, value) -> value
266 (Just name, value) -> textToByte name <> joinWith <> value
267 )
268 in BF.first textToByte <$> case queryParamValue of
269 Nothing -> []
270 Just value ->
271 ( case queryParamStyle of
272 "form" -> concatValues ","
273 "spaceDelimited" -> concatValues " "
274 "pipeDelimited" -> concatValues "|"
275 "deepObject" -> const $ BF.second textToByte <$> jsonToFormDataPrefixed queryParamName value
276 _ -> const []
277 )
278 $ jsonToFormDataFlat Nothing value
280encodeStrict :: Aeson.ToJSON a => a -> B8.ByteString
281encodeStrict = LB8.toStrict . Aeson.encode
283jsonToFormDataFlat :: Maybe Text -> Aeson.Value -> [(Maybe Text, B8.ByteString)]
284jsonToFormDataFlat _ Aeson.Null = []
285jsonToFormDataFlat name (Aeson.Number a) = [(name, encodeStrict a)]
286jsonToFormDataFlat name (Aeson.String a) = [(name, textToByte a)]
287jsonToFormDataFlat name (Aeson.Bool a) = [(name, encodeStrict a)]
288jsonToFormDataFlat _ (Aeson.Object object) = HMap.toList object >>= uncurry jsonToFormDataFlat . BF.first Just
289jsonToFormDataFlat name (Aeson.Array vector) = Vector.toList vector >>= jsonToFormDataFlat name
291-- | creates form data bytestring array
292createFormData :: (Aeson.ToJSON a) => a -> [(B8.ByteString, B8.ByteString)]
293createFormData body =
294 let formData = jsonToFormData $ Aeson.toJSON body
295 in fmap (BF.bimap textToByte textToByte) formData
297-- | Convert a 'B8.ByteString' to 'Text'
298byteToText :: B8.ByteString -> Text
299byteToText = TE.decodeUtf8
301-- | Convert 'Text' a to 'B8.ByteString'
302textToByte :: Text -> B8.ByteString
303textToByte = TE.encodeUtf8
305parseURL :: Text -> HS.Request
306parseURL url =
307 Maybe.fromMaybe HS.defaultRequest $
308 HS.parseRequest $
309 T.unpack url
311jsonToFormData :: Aeson.Value -> [(Text, Text)]
312jsonToFormData = jsonToFormDataPrefixed ""
314jsonToFormDataPrefixed :: Text -> Aeson.Value -> [(Text, Text)]
315jsonToFormDataPrefixed prefix (Aeson.Number a) = case Scientific.toBoundedInteger a :: Maybe Int of
316 Just myInt -> [(prefix, T.pack $ show myInt)]
317 Nothing -> [(prefix, T.pack $ show a)]
318jsonToFormDataPrefixed prefix (Aeson.Bool True) = [(prefix, "true")]
319jsonToFormDataPrefixed prefix (Aeson.Bool False) = [(prefix, "false")]
320jsonToFormDataPrefixed _ Aeson.Null = []
321jsonToFormDataPrefixed prefix (Aeson.String a) = [(prefix, a)]
322jsonToFormDataPrefixed "" (Aeson.Object object) =
323 HMap.toList object >>= uncurry jsonToFormDataPrefixed
324jsonToFormDataPrefixed prefix (Aeson.Object object) =
325 HMap.toList object >>= (\(x, y) -> jsonToFormDataPrefixed (prefix <> "[" <> x <> "]") y)
326jsonToFormDataPrefixed prefix (Aeson.Array vector) =
327 Vector.toList vector >>= jsonToFormDataPrefixed (prefix <> "[]")
329-- | This type class makes the code generation for URL parameters easier as it allows to stringify a value
330--
331-- The 'Show' class is not sufficient as strings should not be stringified with quotes.
332class Show a => StringifyModel a where
333 -- | Stringifies a showable value
334 --
335 -- >>> stringifyModel "Test"
336 -- "Test"
337 --
338 -- >>> stringifyModel 123
339 -- "123"
340 stringifyModel :: a -> String
342instance StringifyModel String where
343 -- stringifyModel :: String -> String
344 stringifyModel = id
346instance StringifyModel Text where
347 -- stringifyModel :: Text -> String
348 stringifyModel = T.unpack
350instance {-# OVERLAPS #-} Show a => StringifyModel a where
351 -- stringifyModel :: Show a => a -> String
352 stringifyModel = show
354-- | Wraps a 'B8.ByteString' to implement 'Aeson.ToJSON' and 'Aeson.FromJSON'
355newtype JsonByteString = JsonByteString B8.ByteString
356 deriving (Show, Eq, Ord)
358instance Aeson.ToJSON JsonByteString where
359 toJSON (JsonByteString s) = Aeson.toJSON $ B8.unpack s
361instance Aeson.FromJSON JsonByteString where
362 parseJSON (Aeson.String s) = pure $ JsonByteString $ textToByte s
363 parseJSON _ = fail "Value cannot be converted to a 'JsonByteString'"
365-- | Wraps a 'Time.ZonedTime' to implement 'Aeson.ToJSON' and 'Aeson.FromJSON'
366newtype JsonDateTime = JsonDateTime Time.ZonedTime
367 deriving (Show)
369instance Eq JsonDateTime where
370 (JsonDateTime d1) == (JsonDateTime d2) = Time.zonedTimeToUTC d1 == Time.zonedTimeToUTC d2
372instance Ord JsonDateTime where
373 (JsonDateTime d1) <= (JsonDateTime d2) = Time.zonedTimeToUTC d1 <= Time.zonedTimeToUTC d2
375instance Aeson.ToJSON JsonDateTime where
376 toJSON (JsonDateTime d) = Aeson.toJSON d
378instance Aeson.FromJSON JsonDateTime where
379 parseJSON o = JsonDateTime <$> Aeson.parseJSON o
381data Nullable a = NonNull a | Null
382 deriving (Show, Eq)
384instance Aeson.ToJSON a => Aeson.ToJSON (Nullable a) where
385 toJSON Null = Aeson.Null
386 toJSON (NonNull x) = Aeson.toJSON x
388 toEncoding Null = Encoding.null_
389 toEncoding (NonNull x) = Aeson.toEncoding x
391instance Aeson.FromJSON a => Aeson.FromJSON (Nullable a) where
392 parseJSON Aeson.Null = pure Null
393 parseJSON x = NonNull <$> Aeson.parseJSON x