mirror of
https://github.com/freckle/yesod-auth-oauth2.git
synced 2026-01-17 06:38:30 +01:00
937ad572a3
The largest changes were around the hoauth2 interface: The OAuth2 type replaced all of its ByteString fields with either Text or URI. This is a huge improvement. The fields that are now Text are the type we had them in anyway. The fields that are now URI are type safe and easier to manipulate. For example, we were doing very unsafe query string manipulations looking for raw ? or & values, but now we can work with tuples in a well-typed property. Additionally the AccessToken type was upgraded to OAuth2Token with an accessToken field, and the simple Either ByteString a results were replaced by a real OAuth2Error type. This required changes to our InvalidProfileResponse mechanism to support. To make working with uri-bytestring more convenient, an Extension library was added with some useful instances and helper functions. This library may be upstreamed at some point.
116 lines
3.6 KiB
Haskell
116 lines
3.6 KiB
Haskell
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
-- |
|
|
--
|
|
-- OAuth2 plugin for http://github.com
|
|
--
|
|
-- * Authenticates against github
|
|
-- * Uses github user id as credentials identifier
|
|
-- * Returns first_name, last_name, and email as extras
|
|
--
|
|
module Yesod.Auth.OAuth2.Github
|
|
( oauth2Github
|
|
, oauth2GithubScoped
|
|
, module Yesod.Auth.OAuth2
|
|
) where
|
|
|
|
#if __GLASGOW_HASKELL__ < 710
|
|
import Control.Applicative ((<$>), (<*>))
|
|
#endif
|
|
|
|
import Control.Exception.Lifted
|
|
import Control.Monad (mzero)
|
|
import Data.Aeson
|
|
import Data.Maybe (fromMaybe)
|
|
import Data.List (find)
|
|
import Data.Text (Text)
|
|
import Network.HTTP.Conduit (Manager)
|
|
import Yesod.Auth
|
|
import Yesod.Auth.OAuth2
|
|
|
|
import qualified Data.Text as T
|
|
|
|
data GithubUser = GithubUser
|
|
{ githubUserId :: Int
|
|
, githubUserName :: Maybe Text
|
|
, githubUserLogin :: Text
|
|
, githubUserAvatarUrl :: Text
|
|
, githubUserLocation :: Maybe Text
|
|
, githubUserPublicEmail :: Maybe Text
|
|
}
|
|
|
|
instance FromJSON GithubUser where
|
|
parseJSON (Object o) = GithubUser
|
|
<$> o .: "id"
|
|
<*> o .:? "name"
|
|
<*> o .: "login"
|
|
<*> o .: "avatar_url"
|
|
<*> o .:? "location"
|
|
<*> o .:? "email"
|
|
|
|
parseJSON _ = mzero
|
|
|
|
data GithubUserEmail = GithubUserEmail
|
|
{ githubUserEmailAddress :: Text
|
|
, githubUserEmailPrimary :: Bool
|
|
}
|
|
|
|
instance FromJSON GithubUserEmail where
|
|
parseJSON (Object o) = GithubUserEmail
|
|
<$> o .: "email"
|
|
<*> o .: "primary"
|
|
|
|
parseJSON _ = mzero
|
|
|
|
oauth2Github :: YesodAuth m
|
|
=> Text -- ^ Client ID
|
|
-> Text -- ^ Client Secret
|
|
-> AuthPlugin m
|
|
oauth2Github clientId clientSecret = oauth2GithubScoped clientId clientSecret ["user:email"]
|
|
|
|
oauth2GithubScoped :: YesodAuth m
|
|
=> Text -- ^ Client ID
|
|
-> Text -- ^ Client Secret
|
|
-> [Text] -- ^ List of scopes to request
|
|
-> AuthPlugin m
|
|
oauth2GithubScoped clientId clientSecret scopes = authOAuth2 "github" oauth fetchGithubProfile
|
|
where
|
|
oauth = OAuth2
|
|
{ oauthClientId = clientId
|
|
, oauthClientSecret = clientSecret
|
|
, oauthOAuthorizeEndpoint = "https://github.com/login/oauth/authorize" `withQuery`
|
|
[ scopeParam "," scopes
|
|
]
|
|
, oauthAccessTokenEndpoint = "https://github.com/login/oauth/access_token"
|
|
, oauthCallback = Nothing
|
|
}
|
|
|
|
fetchGithubProfile :: Manager -> OAuth2Token -> IO (Creds m)
|
|
fetchGithubProfile manager token = do
|
|
userResult <- authGetJSON manager (accessToken token) "https://api.github.com/user"
|
|
mailResult <- authGetJSON manager (accessToken token) "https://api.github.com/user/emails"
|
|
|
|
case (userResult, mailResult) of
|
|
(Right _, Right []) -> throwIO $ InvalidProfileResponse "github" "no mail address for user"
|
|
(Right user, Right mails) -> return $ toCreds user mails token
|
|
(Left err, _) -> throwIO $ invalidProfileResponse "github" err
|
|
(_, Left err) -> throwIO $ invalidProfileResponse "github" err
|
|
|
|
toCreds :: GithubUser -> [GithubUserEmail] -> OAuth2Token -> Creds m
|
|
toCreds user userMails token = Creds
|
|
{ credsPlugin = "github"
|
|
, credsIdent = T.pack $ show $ githubUserId user
|
|
, credsExtra =
|
|
[ ("email", githubUserEmailAddress email)
|
|
, ("login", githubUserLogin user)
|
|
, ("avatar_url", githubUserAvatarUrl user)
|
|
, ("access_token", atoken $ accessToken token)
|
|
]
|
|
++ maybeExtra "name" (githubUserName user)
|
|
++ maybeExtra "public_email" (githubUserPublicEmail user)
|
|
++ maybeExtra "location" (githubUserLocation user)
|
|
}
|
|
|
|
where
|
|
email = fromMaybe (head userMails) $ find githubUserEmailPrimary userMails
|