1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
|
{-
FastAPI
No description provided (generated by Openapi Generator https://github.com/openapitools/openapi-generator)
OpenAPI Version: 3.1.0
FastAPI API version: 0.1.0
Generated by OpenAPI Generator (https://openapi-generator.tech)
-}
{-|
Module : G4fClient.Client
-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-unused-imports #-}
module G4fClient.Client where
import G4fClient.Core
import G4fClient.Logging
import G4fClient.MimeTypes
import qualified Control.Exception.Safe as E
import qualified Control.Monad.IO.Class as P
import qualified Control.Monad as P
import qualified Data.Aeson.Types as A
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BCL
import qualified Data.Proxy as P (Proxy(..))
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Network.HTTP.Client as NH
import qualified Network.HTTP.Client.MultipartFormData as NH
import qualified Network.HTTP.Types as NH
import qualified Web.FormUrlEncoded as WH
import qualified Web.HttpApiData as WH
import Data.Function ((&))
import Data.Monoid ((<>))
import Data.Text (Text)
import GHC.Exts (IsString(..))
-- * Dispatch
-- ** Lbs
-- | send a request returning the raw http response
dispatchLbs
:: (Produces req accept, MimeType contentType)
=> NH.Manager -- ^ http-client Connection manager
-> G4fClientConfig -- ^ config
-> G4fClientRequest req contentType res accept -- ^ request
-> IO (NH.Response BCL.ByteString) -- ^ response
dispatchLbs manager config request = do
initReq <- _toInitRequest config request
dispatchInitUnsafe manager config initReq
-- ** Mime
-- | pair of decoded http body and http response
data MimeResult res =
MimeResult { mimeResult :: Either MimeError res -- ^ decoded http body
, mimeResultResponse :: NH.Response BCL.ByteString -- ^ http response
}
deriving (Show, Functor, Foldable, Traversable)
-- | pair of unrender/parser error and http response
data MimeError =
MimeError {
mimeError :: String -- ^ unrender/parser error
, mimeErrorResponse :: NH.Response BCL.ByteString -- ^ http response
} deriving (Show)
-- | send a request returning the 'MimeResult'
dispatchMime
:: forall req contentType res accept. (Produces req accept, MimeUnrender accept res, MimeType contentType)
=> NH.Manager -- ^ http-client Connection manager
-> G4fClientConfig -- ^ config
-> G4fClientRequest req contentType res accept -- ^ request
-> IO (MimeResult res) -- ^ response
dispatchMime manager config request = do
httpResponse <- dispatchLbs manager config request
let statusCode = NH.statusCode . NH.responseStatus $ httpResponse
parsedResult <-
runConfigLogWithExceptions "Client" config $
do if (statusCode >= 400 && statusCode < 600)
then do
let s = "error statusCode: " ++ show statusCode
_log "Client" levelError (T.pack s)
pure (Left (MimeError s httpResponse))
else case mimeUnrender (P.Proxy :: P.Proxy accept) (NH.responseBody httpResponse) of
Left s -> do
_log "Client" levelError (T.pack s)
pure (Left (MimeError s httpResponse))
Right r -> pure (Right r)
return (MimeResult parsedResult httpResponse)
-- | like 'dispatchMime', but only returns the decoded http body
dispatchMime'
:: (Produces req accept, MimeUnrender accept res, MimeType contentType)
=> NH.Manager -- ^ http-client Connection manager
-> G4fClientConfig -- ^ config
-> G4fClientRequest req contentType res accept -- ^ request
-> IO (Either MimeError res) -- ^ response
dispatchMime' manager config request = do
MimeResult parsedResult _ <- dispatchMime manager config request
return parsedResult
-- ** Unsafe
-- | like 'dispatchReqLbs', but does not validate the operation is a 'Producer' of the "accept" 'MimeType'. (Useful if the server's response is undocumented)
dispatchLbsUnsafe
:: (MimeType accept, MimeType contentType)
=> NH.Manager -- ^ http-client Connection manager
-> G4fClientConfig -- ^ config
-> G4fClientRequest req contentType res accept -- ^ request
-> IO (NH.Response BCL.ByteString) -- ^ response
dispatchLbsUnsafe manager config request = do
initReq <- _toInitRequest config request
dispatchInitUnsafe manager config initReq
-- | dispatch an InitRequest
dispatchInitUnsafe
:: NH.Manager -- ^ http-client Connection manager
-> G4fClientConfig -- ^ config
-> InitRequest req contentType res accept -- ^ init request
-> IO (NH.Response BCL.ByteString) -- ^ response
dispatchInitUnsafe manager config (InitRequest req) = do
runConfigLogWithExceptions src config $
do _log src levelInfo requestLogMsg
_log src levelDebug requestDbgLogMsg
res <- P.liftIO $ NH.httpLbs req manager
_log src levelInfo (responseLogMsg res)
_log src levelDebug ((T.pack . show) res)
return res
where
src = "Client"
endpoint =
T.pack $
BC.unpack $
NH.method req <> " " <> NH.host req <> NH.path req <> NH.queryString req
requestLogMsg = "REQ:" <> endpoint
requestDbgLogMsg =
"Headers=" <> (T.pack . show) (NH.requestHeaders req) <> " Body=" <>
(case NH.requestBody req of
NH.RequestBodyLBS xs -> T.decodeUtf8 (BL.toStrict xs)
_ -> "<RequestBody>")
responseStatusCode = (T.pack . show) . NH.statusCode . NH.responseStatus
responseLogMsg res =
"RES:statusCode=" <> responseStatusCode res <> " (" <> endpoint <> ")"
-- * InitRequest
-- | wraps an http-client 'Request' with request/response type parameters
newtype InitRequest req contentType res accept = InitRequest
{ unInitRequest :: NH.Request
} deriving (Show)
-- | Build an http-client 'Request' record from the supplied config and request
_toInitRequest
:: (MimeType accept, MimeType contentType)
=> G4fClientConfig -- ^ config
-> G4fClientRequest req contentType res accept -- ^ request
-> IO (InitRequest req contentType res accept) -- ^ initialized request
_toInitRequest config req0 =
runConfigLogWithExceptions "Client" config $ do
parsedReq <- P.liftIO $ NH.parseRequest $ BCL.unpack $ BCL.append (configHost config) (BCL.concat (rUrlPath req0))
req1 <- P.liftIO $ _applyAuthMethods req0 config
P.when
(configValidateAuthMethods config && (not . null . rAuthTypes) req1)
(E.throw $ AuthMethodException $ "AuthMethod not configured: " <> (show . head . rAuthTypes) req1)
let req2 = req1 & _setContentTypeHeader & _setAcceptHeader
params = rParams req2
reqHeaders = ("User-Agent", WH.toHeader (configUserAgent config)) : paramsHeaders params
reqQuery = let query = paramsQuery params
queryExtraUnreserved = configQueryExtraUnreserved config
in if B.null queryExtraUnreserved
then NH.renderQuery True query
else NH.renderQueryPartialEscape True (toPartialEscapeQuery queryExtraUnreserved query)
pReq = parsedReq { NH.method = rMethod req2
, NH.requestHeaders = reqHeaders
, NH.queryString = reqQuery
}
outReq <- case paramsBody params of
ParamBodyNone -> pure (pReq { NH.requestBody = mempty })
ParamBodyB bs -> pure (pReq { NH.requestBody = NH.RequestBodyBS bs })
ParamBodyBL bl -> pure (pReq { NH.requestBody = NH.RequestBodyLBS bl })
ParamBodyFormUrlEncoded form -> pure (pReq { NH.requestBody = NH.RequestBodyLBS (WH.urlEncodeForm form) })
ParamBodyMultipartFormData parts -> NH.formDataBody parts pReq
pure (InitRequest outReq)
-- | modify the underlying Request
modifyInitRequest :: InitRequest req contentType res accept -> (NH.Request -> NH.Request) -> InitRequest req contentType res accept
modifyInitRequest (InitRequest req) f = InitRequest (f req)
-- | modify the underlying Request (monadic)
modifyInitRequestM :: Monad m => InitRequest req contentType res accept -> (NH.Request -> m NH.Request) -> m (InitRequest req contentType res accept)
modifyInitRequestM (InitRequest req) f = fmap InitRequest (f req)
-- ** Logging
-- | Run a block using the configured logger instance
runConfigLog
:: P.MonadIO m
=> G4fClientConfig -> LogExec m a
runConfigLog config = configLogExecWithContext config (configLogContext config)
-- | Run a block using the configured logger instance (logs exceptions)
runConfigLogWithExceptions
:: (E.MonadCatch m, P.MonadIO m)
=> T.Text -> G4fClientConfig -> LogExec m a
runConfigLogWithExceptions src config = runConfigLog config . logExceptions src
|
