From 64b65ca4c6b6c3e6f402b31a682f52124beef4a7 Mon Sep 17 00:00:00 2001
From: Andrew Darqui <andrew.darqui@gmail.com>
Date: Mon, 20 Jun 2016 02:14:11 -0400
Subject: [PATCH] Properly handle empty credsExtra fields

Marks "location" as Maybe in GitHub responses. Without this, users could
experience an InvalidProfileResponse error when missing.

Also fixes cases where fields were Maybe, but the (.:?) combinator was
not being used in the parser.
---
 Yesod/Auth/OAuth2.hs         |  7 +++++++
 Yesod/Auth/OAuth2/Github.hs  | 18 ++++++------------
 Yesod/Auth/OAuth2/Google.hs  |  7 ++-----
 Yesod/Auth/OAuth2/Spotify.hs |  4 ++--
 4 files changed, 17 insertions(+), 19 deletions(-)

diff --git a/Yesod/Auth/OAuth2.hs b/Yesod/Auth/OAuth2.hs
index f5a182c..d69a0dd 100644
--- a/Yesod/Auth/OAuth2.hs
+++ b/Yesod/Auth/OAuth2.hs
@@ -15,6 +15,7 @@ module Yesod.Auth.OAuth2
     , oauth2Url
     , fromProfileURL
     , YesodOAuth2Exception(..)
+    , maybeExtra
     , module Network.OAuth.OAuth2
     ) where
 
@@ -149,3 +150,9 @@ appendQuery url query =
     if '?' `C8.elem` url
         then url <> "&" <> query
         else url <> "?" <> query
+
+-- | A helper for providing an optional value to credsExtra
+--
+maybeExtra :: Text -> Maybe Text -> [(Text, Text)]
+maybeExtra k (Just v) = [(k, v)]
+maybeExtra _ Nothing  = []
diff --git a/Yesod/Auth/OAuth2/Github.hs b/Yesod/Auth/OAuth2/Github.hs
index 7ffee08..4162b32 100644
--- a/Yesod/Auth/OAuth2/Github.hs
+++ b/Yesod/Auth/OAuth2/Github.hs
@@ -37,7 +37,7 @@ data GithubUser = GithubUser
     , githubUserName :: Maybe Text
     , githubUserLogin :: Text
     , githubUserAvatarUrl :: Text
-    , githubUserLocation :: Text
+    , githubUserLocation :: Maybe Text
     , githubUserPublicEmail :: Maybe Text
     }
 
@@ -47,8 +47,8 @@ instance FromJSON GithubUser where
         <*> o .:? "name"
         <*> o .: "login"
         <*> o .: "avatar_url"
-        <*> o .: "location"
-        <*> o .: "email"
+        <*> o .:? "location"
+        <*> o .:? "email"
 
     parseJSON _ = mzero
 
@@ -104,18 +104,12 @@ toCreds user userMails token = Creds
         [ ("email", githubUserEmailAddress email)
         , ("login", githubUserLogin user)
         , ("avatar_url", githubUserAvatarUrl user)
-        , ("location", githubUserLocation user)
         , ("access_token", decodeUtf8 $ accessToken token)
         ]
-        ++ maybeName (githubUserName user)
-        ++ maybePublicEmail (githubUserPublicEmail user)
+        ++ maybeExtra "name" (githubUserName user)
+        ++ maybeExtra "email" (githubUserPublicEmail user)
+        ++ maybeExtra "location" (githubUserLocation user)
     }
 
   where
     email = fromMaybe (head userMails) $ find githubUserEmailPrimary userMails
-
-    maybeName Nothing = []
-    maybeName (Just name) = [("name", name)]
-
-    maybePublicEmail Nothing = []
-    maybePublicEmail (Just e) = [("public_email", e)]
diff --git a/Yesod/Auth/OAuth2/Google.hs b/Yesod/Auth/OAuth2/Google.hs
index 6dd6766..e34db5b 100644
--- a/Yesod/Auth/OAuth2/Google.hs
+++ b/Yesod/Auth/OAuth2/Google.hs
@@ -29,7 +29,6 @@ import Control.Exception.Lifted
 import Control.Monad (mzero)
 import Data.Aeson
 import Data.Monoid ((<>))
-import Data.Maybe (maybeToList)
 import Data.Text (Text)
 import Data.Text.Encoding (encodeUtf8, decodeUtf8)
 import Network.HTTP.Conduit (Manager)
@@ -135,8 +134,6 @@ uidBuilder f user token = Creds
         , ("family_name", googleUserFamilyName user)
         , ("avatar_url", googleUserPicture user)
         , ("access_token", decodeUtf8 $ accessToken token)
-        ] ++ maybeHostedDomain
+        ]
+        ++ maybeExtra "hosted_domain" (googleUserHostedDomain user)
     }
-
-  where
-    maybeHostedDomain = maybeToList $ (,) "hosted_domain" <$> googleUserHostedDomain user
diff --git a/Yesod/Auth/OAuth2/Spotify.hs b/Yesod/Auth/OAuth2/Spotify.hs
index e6dffbe..1039b8b 100644
--- a/Yesod/Auth/OAuth2/Spotify.hs
+++ b/Yesod/Auth/OAuth2/Spotify.hs
@@ -33,8 +33,8 @@ data SpotifyUserImage = SpotifyUserImage
 
 instance FromJSON SpotifyUserImage where
     parseJSON (Object v) = SpotifyUserImage
-        <$> v .: "height"
-        <*> v .: "width"
+        <$> v .:? "height"
+        <*> v .:? "width"
         <*> v .: "url"
 
     parseJSON _ = mzero