Skip to content

Commit c969f0a

Browse files
authored
Merge pull request #365 from robbiemcmichael/auth-method
Type class for different auth methods
2 parents 9fa0b01 + 8b0ddfd commit c969f0a

File tree

2 files changed

+52
-35
lines changed

2 files changed

+52
-35
lines changed

src/GitHub/Auth.hs

Lines changed: 31 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -3,24 +3,48 @@
33
-- License : BSD-3-Clause
44
-- Maintainer : Oleg Grenrus <[email protected]>
55
--
6-
module GitHub.Auth where
6+
module GitHub.Auth (
7+
Auth (..),
8+
AuthMethod,
9+
endpoint,
10+
setAuthRequest
11+
) where
712

813
import GitHub.Internal.Prelude
914
import Prelude ()
1015

11-
import qualified Data.ByteString as BS
16+
import qualified Data.ByteString as BS
17+
import qualified Network.HTTP.Client as HTTP
1218

1319
type Token = BS.ByteString
1420

1521
-- | The Github auth data type
1622
data Auth
17-
= BasicAuth BS.ByteString BS.ByteString
18-
| OAuth Token -- ^ token
19-
| EnterpriseOAuth Text -- custom API endpoint without
20-
-- trailing slash
21-
Token -- token
23+
= BasicAuth BS.ByteString BS.ByteString -- ^ Username and password
24+
| OAuth Token -- ^ OAuth token
25+
| EnterpriseOAuth Text Token -- ^ Custom endpoint and OAuth token
2226
deriving (Show, Data, Typeable, Eq, Ord, Generic)
2327

2428
instance NFData Auth where rnf = genericRnf
2529
instance Binary Auth
2630
instance Hashable Auth
31+
32+
-- | A type class for different authentication methods
33+
class AuthMethod a where
34+
-- | Custom API endpoint without trailing slash
35+
endpoint :: a -> Maybe Text
36+
-- | A function which sets authorisation on an HTTP request
37+
setAuthRequest :: a -> HTTP.Request -> HTTP.Request
38+
39+
instance AuthMethod Auth where
40+
endpoint (BasicAuth _ _) = Nothing
41+
endpoint (OAuth _) = Nothing
42+
endpoint (EnterpriseOAuth e _) = Just e
43+
44+
setAuthRequest (BasicAuth u p) = HTTP.applyBasicAuth u p
45+
setAuthRequest (OAuth t) = setAuthHeader $ "token " <> t
46+
setAuthRequest (EnterpriseOAuth _ t) = setAuthHeader $ "token " <> t
47+
48+
setAuthHeader :: BS.ByteString -> HTTP.Request -> HTTP.Request
49+
setAuthHeader auth req =
50+
req { HTTP.requestHeaders = ("Authorization", auth) : HTTP.requestHeaders req }

src/GitHub/Request.hs

Lines changed: 21 additions & 28 deletions
Original file line numberDiff line numberDiff line change
@@ -84,13 +84,17 @@ import qualified Data.Vector as V
8484
import qualified Network.HTTP.Client as HTTP
8585
import qualified Network.HTTP.Client.Internal as HTTP
8686

87-
import GitHub.Auth (Auth (..))
87+
import GitHub.Auth (Auth, AuthMethod, endpoint, setAuthRequest)
8888
import GitHub.Data (Error (..))
8989
import GitHub.Data.PullRequests (MergeResult (..))
9090
import GitHub.Data.Request
9191

9292
-- | 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)
9498
executeRequest auth req = do
9599
manager <- newManager tlsManagerSettings
96100
executeRequestWithMgr manager auth req
@@ -101,9 +105,9 @@ lessFetchCount i (FetchAtLeast j) = i < fromIntegral j
101105

102106
-- | Like 'executeRequest' but with provided 'Manager'.
103107
executeRequestWithMgr
104-
:: ParseResponse mt a
108+
:: (AuthMethod am, ParseResponse mt a)
105109
=> Manager
106-
-> Auth
110+
-> am
107111
-> GenRequest mt rw a
108112
-> IO (Either Error a)
109113
executeRequestWithMgr mgr auth req = runExceptT $ do
@@ -140,7 +144,7 @@ executeRequestWithMgr'
140144
-> GenRequest mt 'RO a
141145
-> IO (Either Error a)
142146
executeRequestWithMgr' mgr req = runExceptT $ do
143-
httpReq <- makeHttpRequest Nothing req
147+
httpReq <- makeHttpRequest (Nothing :: Maybe Auth) req
144148
performHttpReq httpReq req
145149
where
146150
httpLbs' :: HTTP.Request -> ExceptT Error IO (Response LBS.ByteString)
@@ -158,7 +162,11 @@ executeRequestWithMgr' mgr req = runExceptT $ do
158162
-- | Helper for picking between 'executeRequest' and 'executeRequest''.
159163
--
160164
-- 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)
162170
executeRequestMaybe = maybe executeRequest' executeRequest
163171

164172
-- | Partial function to drop authentication need.
@@ -308,8 +316,8 @@ instance a ~ () => ParseResponse 'MtUnit a where
308316
-- status checking is modifying accordingly.
309317
--
310318
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
313321
-> GenRequest mt rw a
314322
-> m HTTP.Request
315323
makeHttpRequest auth r = case r of
@@ -318,23 +326,23 @@ makeHttpRequest auth r = case r of
318326
return
319327
$ setReqHeaders
320328
. unTagged (modifyRequest :: Tagged mt (HTTP.Request -> HTTP.Request))
321-
. setAuthRequest auth
329+
. maybe id setAuthRequest auth
322330
. setQueryString qs
323331
$ req
324332
PagedQuery paths qs _ -> do
325333
req <- parseUrl' $ url paths
326334
return
327335
$ setReqHeaders
328336
. unTagged (modifyRequest :: Tagged mt (HTTP.Request -> HTTP.Request))
329-
. setAuthRequest auth
337+
. maybe id setAuthRequest auth
330338
. setQueryString qs
331339
$ req
332340
Command m paths body -> do
333341
req <- parseUrl' $ url paths
334342
return
335343
$ setReqHeaders
336344
. unTagged (modifyRequest :: Tagged mt (HTTP.Request -> HTTP.Request))
337-
. setAuthRequest auth
345+
. maybe id setAuthRequest auth
338346
. setBody body
339347
. setMethod (toMethod m)
340348
$ req
@@ -343,12 +351,7 @@ makeHttpRequest auth r = case r of
343351
parseUrl' = HTTP.parseRequest . T.unpack
344352

345353
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
352355

353356
setReqHeaders :: HTTP.Request -> HTTP.Request
354357
setReqHeaders req = req { requestHeaders = reqHeaders <> requestHeaders req }
@@ -357,22 +360,12 @@ makeHttpRequest auth r = case r of
357360
setMethod m req = req { method = m }
358361

359362
reqHeaders :: RequestHeaders
360-
reqHeaders = maybe [] getOAuthHeader auth
361-
<> [("User-Agent", "github.hs/0.21")] -- Version
363+
reqHeaders = [("User-Agent", "github.hs/0.21")] -- Version
362364
<> [("Accept", unTagged (contentType :: Tagged mt BS.ByteString))]
363365

364366
setBody :: LBS.ByteString -> HTTP.Request -> HTTP.Request
365367
setBody body req = req { requestBody = RequestBodyLBS body }
366368

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-
376369
-- | Query @Link@ header with @rel=next@ from the request headers.
377370
getNextUrl :: Response a -> Maybe URI
378371
getNextUrl req = do

0 commit comments

Comments
 (0)