haskell/yesod-auth-oauth2
1
0
Fork 0
mirror of https://github.com/freckle/yesod-auth-oauth2.git synced 2026-04-20 01:44:14 +02:00
Code Issues Actions Packages Projects Releases Wiki Activity

fetch github email in a second query to https://api.github.com/user/emails (the query to https://api.github.com/user return a null in the email field)

Browse Source
This commit is contained in:
Freiric Barral 2014-08-31 16:30:45 +02:00
parent e34156dcc3
commit a992fdb6fa
1 changed files with 24 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
Yesod/Auth/OAuth2/Github.hs
View File

@ -17,6 +17,7 @@ import Control.Exception.Lifted
import Control.Monad (mzero) import Control.Monad (mzero)
import Data.Aeson import Data.Aeson
import Data.Text (Text) import Data.Text (Text)
import Data.Monoid (mappend)
import Data.Text.Encoding (encodeUtf8, decodeUtf8) import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Yesod.Auth import Yesod.Auth
import Yesod.Auth.OAuth2 import Yesod.Auth.OAuth2
@ -31,7 +32,6 @@ import qualified Data.Text as T
data GithubUser = GithubUser data GithubUser = GithubUser
{ githubUserId :: Int { githubUserId :: Int
, githubUserName :: Text , githubUserName :: Text
, githubUserEmail :: Text
, githubUserLogin :: Text , githubUserLogin :: Text
, githubUserAvatarUrl :: Text , githubUserAvatarUrl :: Text
} }
@ -40,12 +40,21 @@ instance FromJSON GithubUser where
parseJSON (Object o) = parseJSON (Object o) =
GithubUser <$> o .: "id" GithubUser <$> o .: "id"
<*> o .: "name" <*> o .: "name"
<*> o .: "email"
<*> o .: "login" <*> o .: "login"
<*> o .: "avatar_url" <*> o .: "avatar_url"
parseJSON _ = mzero parseJSON _ = mzero
data GithubUserEmail = GithubUserEmail
{ githubUserEmail :: Text
}
instance FromJSON GithubUserEmail where
parseJSON (Object o) =
GithubUserEmail <$> o .: "email"
parseJSON _ = mzero
oauth2Github :: YesodAuth m oauth2Github :: YesodAuth m
=> Text -- ^ Client ID => Text -- ^ Client ID
-> Text -- ^ Client Secret -> Text -- ^ Client Secret
@ -75,25 +84,30 @@ oauth2Github clientId clientSecret scopes = basicPlugin {apDispatch = dispatch}
dispatch "GET" ["callback"] = do dispatch "GET" ["callback"] = do
state <- lift $ runInputGet $ ireq textField "state" state <- lift $ runInputGet $ ireq textField "state"
savedState <- lookupSession "githubState" savedState <- lookupSession "githubState"
apDispatch basicPlugin "GET" ["callback"]
case savedState of case savedState of
Just saved | saved == state -> apDispatch basicPlugin "GET" ["callback"] Just saved | saved == state -> apDispatch basicPlugin "GET" ["callback"]
_ -> invalidArgs ["state"] Just saved -> invalidArgs ["state: " `mappend` state `mappend` ", and not: " `mappend` saved]
_ -> invalidArgs ["state: " `mappend` state]
dispatch method ps = apDispatch basicPlugin method ps dispatch method ps = apDispatch basicPlugin method ps
fetchGithubProfile :: Manager -> AccessToken -> IO (Creds m) fetchGithubProfile :: Manager -> AccessToken -> IO (Creds m)
fetchGithubProfile manager token = do fetchGithubProfile manager token = do
result <- authGetJSON manager token "https://api.github.com/user" userResult <- authGetJSON manager token "https://api.github.com/user"
mailResult <- authGetJSON manager token "https://api.github.com/user/emails"
case result of case (userResult, mailResult) of
Right user -> return $ toCreds user token (Right user, Right []) -> throwIO $ InvalidProfileResponse "github" "no mail address for user"
Left err -> throwIO $ InvalidProfileResponse "github" err (Right user, Right mails) -> return $ toCreds user mails token
(Left err, _) -> throwIO $ InvalidProfileResponse "github" err
(_, Left err) -> throwIO $ InvalidProfileResponse "github" err
toCreds :: GithubUser -> AccessToken -> Creds m toCreds :: GithubUser -> [GithubUserEmail] -> AccessToken -> Creds m
toCreds user token = Creds "github" toCreds user userMail token = Creds "github"
(T.pack $ show $ githubUserId user) (T.pack $ show $ githubUserId user)
[ ("name", githubUserName user) [ ("name", githubUserName user)
, ("email", githubUserEmail user) , ("email", githubUserEmail $ head userMail)
, ("login", githubUserLogin user) , ("login", githubUserLogin user)
, ("avatar_url", githubUserAvatarUrl user) , ("avatar_url", githubUserAvatarUrl user)
, ("access_token", decodeUtf8 $ accessToken token) , ("access_token", decodeUtf8 $ accessToken token)