@@ -84,13 +84,17 @@ import qualified Data.Vector as V
84
84
import qualified Network.HTTP.Client as HTTP
85
85
import qualified Network.HTTP.Client.Internal as HTTP
86
86
87
- import GitHub.Auth (Auth ( .. ) )
87
+ import GitHub.Auth (Auth , AuthMethod , endpoint , setAuthRequest )
88
88
import GitHub.Data (Error (.. ))
89
89
import GitHub.Data.PullRequests (MergeResult (.. ))
90
90
import GitHub.Data.Request
91
91
92
92
-- | Execute 'Request' in 'IO'
93
- executeRequest :: ParseResponse mt a => Auth -> GenRequest mt rw a -> IO (Either Error a )
93
+ executeRequest
94
+ :: (AuthMethod am , ParseResponse mt a )
95
+ => am
96
+ -> GenRequest mt rw a
97
+ -> IO (Either Error a )
94
98
executeRequest auth req = do
95
99
manager <- newManager tlsManagerSettings
96
100
executeRequestWithMgr manager auth req
@@ -101,9 +105,9 @@ lessFetchCount i (FetchAtLeast j) = i < fromIntegral j
101
105
102
106
-- | Like 'executeRequest' but with provided 'Manager'.
103
107
executeRequestWithMgr
104
- :: ParseResponse mt a
108
+ :: ( AuthMethod am , ParseResponse mt a )
105
109
=> Manager
106
- -> Auth
110
+ -> am
107
111
-> GenRequest mt rw a
108
112
-> IO (Either Error a )
109
113
executeRequestWithMgr mgr auth req = runExceptT $ do
@@ -140,7 +144,7 @@ executeRequestWithMgr'
140
144
-> GenRequest mt 'RO a
141
145
-> IO (Either Error a )
142
146
executeRequestWithMgr' mgr req = runExceptT $ do
143
- httpReq <- makeHttpRequest Nothing req
147
+ httpReq <- makeHttpRequest ( Nothing :: Maybe Auth ) req
144
148
performHttpReq httpReq req
145
149
where
146
150
httpLbs' :: HTTP. Request -> ExceptT Error IO (Response LBS. ByteString )
@@ -158,7 +162,11 @@ executeRequestWithMgr' mgr req = runExceptT $ do
158
162
-- | Helper for picking between 'executeRequest' and 'executeRequest''.
159
163
--
160
164
-- The use is discouraged.
161
- executeRequestMaybe :: ParseResponse mt a => Maybe Auth -> GenRequest mt 'RO a -> IO (Either Error a )
165
+ executeRequestMaybe
166
+ :: (AuthMethod am , ParseResponse mt a )
167
+ => Maybe am
168
+ -> GenRequest mt 'RO a
169
+ -> IO (Either Error a )
162
170
executeRequestMaybe = maybe executeRequest' executeRequest
163
171
164
172
-- | Partial function to drop authentication need.
@@ -308,8 +316,8 @@ instance a ~ () => ParseResponse 'MtUnit a where
308
316
-- status checking is modifying accordingly.
309
317
--
310
318
makeHttpRequest
311
- :: forall mt rw a m . (MonadThrow m , Accept mt )
312
- => Maybe Auth
319
+ :: forall am mt rw a m . (AuthMethod am , MonadThrow m , Accept mt )
320
+ => Maybe am
313
321
-> GenRequest mt rw a
314
322
-> m HTTP. Request
315
323
makeHttpRequest auth r = case r of
@@ -318,23 +326,23 @@ makeHttpRequest auth r = case r of
318
326
return
319
327
$ setReqHeaders
320
328
. unTagged (modifyRequest :: Tagged mt (HTTP. Request -> HTTP. Request ))
321
- . setAuthRequest auth
329
+ . maybe id setAuthRequest auth
322
330
. setQueryString qs
323
331
$ req
324
332
PagedQuery paths qs _ -> do
325
333
req <- parseUrl' $ url paths
326
334
return
327
335
$ setReqHeaders
328
336
. unTagged (modifyRequest :: Tagged mt (HTTP. Request -> HTTP. Request ))
329
- . setAuthRequest auth
337
+ . maybe id setAuthRequest auth
330
338
. setQueryString qs
331
339
$ req
332
340
Command m paths body -> do
333
341
req <- parseUrl' $ url paths
334
342
return
335
343
$ setReqHeaders
336
344
. unTagged (modifyRequest :: Tagged mt (HTTP. Request -> HTTP. Request ))
337
- . setAuthRequest auth
345
+ . maybe id setAuthRequest auth
338
346
. setBody body
339
347
. setMethod (toMethod m)
340
348
$ req
@@ -343,12 +351,7 @@ makeHttpRequest auth r = case r of
343
351
parseUrl' = HTTP. parseRequest . T. unpack
344
352
345
353
url :: Paths -> Text
346
- url paths = baseUrl <> " /" <> T. intercalate " /" paths
347
-
348
- baseUrl :: Text
349
- baseUrl = case auth of
350
- Just (EnterpriseOAuth endpoint _) -> endpoint
351
- _ -> " https://api.github.com"
354
+ url paths = maybe " https://api.github.com" id (endpoint =<< auth) <> " /" <> T. intercalate " /" paths
352
355
353
356
setReqHeaders :: HTTP. Request -> HTTP. Request
354
357
setReqHeaders req = req { requestHeaders = reqHeaders <> requestHeaders req }
@@ -357,22 +360,12 @@ makeHttpRequest auth r = case r of
357
360
setMethod m req = req { method = m }
358
361
359
362
reqHeaders :: RequestHeaders
360
- reqHeaders = maybe [] getOAuthHeader auth
361
- <> [(" User-Agent" , " github.hs/0.21" )] -- Version
363
+ reqHeaders = [(" User-Agent" , " github.hs/0.21" )] -- Version
362
364
<> [(" Accept" , unTagged (contentType :: Tagged mt BS. ByteString ))]
363
365
364
366
setBody :: LBS. ByteString -> HTTP. Request -> HTTP. Request
365
367
setBody body req = req { requestBody = RequestBodyLBS body }
366
368
367
- setAuthRequest :: Maybe Auth -> HTTP. Request -> HTTP. Request
368
- setAuthRequest (Just (BasicAuth user pass)) = applyBasicAuth user pass
369
- setAuthRequest _ = id
370
-
371
- getOAuthHeader :: Auth -> RequestHeaders
372
- getOAuthHeader (OAuth token) = [(" Authorization" , " token " <> token)]
373
- getOAuthHeader (EnterpriseOAuth _ token) = [(" Authorization" , " token " <> token)]
374
- getOAuthHeader _ = []
375
-
376
369
-- | Query @Link@ header with @rel=next@ from the request headers.
377
370
getNextUrl :: Response a -> Maybe URI
378
371
getNextUrl req = do
0 commit comments