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

Use primary email as email, if one is set.

Browse Source 
If we couldn't find a primary email, then use the first email returned from
the list. This fixes #51.
This commit is contained in:
silky 2016-01-04 07:52:20 +11:00 committed by Joe Ferris
parent 2e5ebbb917
commit 631d9a3ca1
1 changed files with 8 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -21,6 +21,8 @@ import Control.Applicative ((<$>), (<*>))
import Control.Exception.Lifted import Control.Exception.Lifted
import Control.Monad (mzero) import Control.Monad (mzero)
import Data.Aeson import Data.Aeson
import Data.Maybe (fromMaybe)
import Data.List (find)
import Data.Monoid ((<>)) import Data.Monoid ((<>))
import Data.Text (Text) import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8, decodeUtf8) import Data.Text.Encoding (encodeUtf8, decodeUtf8)
@ -49,12 +51,14 @@ instance FromJSON GithubUser where
parseJSON _ = mzero parseJSON _ = mzero
data GithubUserEmail = GithubUserEmail data GithubUserEmail = GithubUserEmail
{ githubUserEmail :: Text { githubUserEmailAddress :: Text
, githubUserEmailPrimary :: Bool
} }
instance FromJSON GithubUserEmail where instance FromJSON GithubUserEmail where
parseJSON (Object o) = GithubUserEmail parseJSON (Object o) = GithubUserEmail
<$> o .: "email" <$> o .: "email"
<*> o .: "primary"
parseJSON _ = mzero parseJSON _ = mzero
@ -91,11 +95,11 @@ fetchGithubProfile manager token = do
(_, Left err) -> throwIO $ InvalidProfileResponse "github" err (_, Left err) -> throwIO $ InvalidProfileResponse "github" err
toCreds :: GithubUser -> [GithubUserEmail] -> AccessToken -> Creds m toCreds :: GithubUser -> [GithubUserEmail] -> AccessToken -> Creds m
toCreds user userMail token = Creds toCreds user userMails token = Creds
{ credsPlugin = "github" { credsPlugin = "github"
, credsIdent = T.pack $ show $ githubUserId user , credsIdent = T.pack $ show $ githubUserId user
, credsExtra = , credsExtra =
[ ("email", githubUserEmail $ head userMail) [ ("email", githubUserEmailAddress email)
, ("login", githubUserLogin user) , ("login", githubUserLogin user)
, ("avatar_url", githubUserAvatarUrl user) , ("avatar_url", githubUserAvatarUrl user)
, ("location", githubUserLocation user) , ("location", githubUserLocation user)
@ -104,5 +108,6 @@ toCreds user userMail token = Creds
} }
where where
email = fromMaybe (head userMails) $ find githubUserEmailPrimary userMails
maybeName Nothing = [] maybeName Nothing = []
maybeName (Just name) = [("name", name)] maybeName (Just name) = [("name", name)]