From 631d9a3ca1dad732352ea8824525f9d271b67080 Mon Sep 17 00:00:00 2001
From: silky <noonsilk+github@gmail.com>
Date: Mon, 4 Jan 2016 07:52:20 +1100
Subject: [PATCH] Use primary email as email, if one is set.

If we couldn't find a primary email, then use the first email returned from
the list. This fixes #51.
---
 Yesod/Auth/OAuth2/Github.hs | 11 ++++++++---
 1 file changed, 8 insertions(+), 3 deletions(-)

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