Remove extra fields in Bitbucket provider

New keys:

- accessToken
- userResponseJSON

Removed keys:

- email
- login
- avatar_url
- access_token
- name
- location

src/Yesod/Auth/OAuth2/Bitbucket.hs

@@ -5,7 +5,6 @@
 --
 -- * Authenticates against bitbucket
 -- * Uses bitbucket uuid as credentials identifier
--- * Returns email, username, full name, location and avatar as extras
 --
 module Yesod.Auth.OAuth2.Bitbucket
     ( oauth2Bitbucket
@@ -14,74 +13,46 @@ module Yesod.Auth.OAuth2.Bitbucket
 
 import Yesod.Auth.OAuth2.Prelude
 
-import Data.List (find)
-import Data.Maybe (fromMaybe)
+import qualified Data.ByteString.Lazy as BL
 import qualified Data.Text as T
 
-data BitbucketUser = BitbucketUser
-    { bitbucketUserId :: Text
-    , bitbucketUserName :: Maybe Text
-    , bitbucketUserLogin :: Text
-    , bitbucketUserLocation :: Maybe Text
-    , bitbucketUserLinks :: BitbucketUserLinks
-    }
+newtype User = User Text
 
-instance FromJSON BitbucketUser where
-    parseJSON = withObject "BitbucketUser" $ \o -> BitbucketUser
+instance FromJSON User where
+    parseJSON = withObject "User" $ \o -> User
         <$> o .: "uuid"
-        <*> o .:? "display_name"
-        <*> o .: "username"
-        <*> o .:? "location"
-        <*> o .: "links"
 
-newtype BitbucketUserLinks = BitbucketUserLinks
-    { bitbucketAvatarLink :: BitbucketLink
-    }
+pluginName :: Text
+pluginName = "bitbucket"
 
-instance FromJSON BitbucketUserLinks where
-    parseJSON = withObject "BitbucketUserLinks" $ \o -> BitbucketUserLinks
-        <$> o .: "avatar"
+defaultScopes :: [Text]
+defaultScopes = ["account"]
 
-newtype BitbucketLink = BitbucketLink
-    { bitbucketLinkHref :: Text
-    }
+oauth2Bitbucket :: YesodAuth m => Text -> Text -> AuthPlugin m
+oauth2Bitbucket = oauth2BitbucketScoped defaultScopes
 
-instance FromJSON BitbucketLink where
-    parseJSON = withObject "BitbucketLink" $ \o -> BitbucketLink
-        <$> o .: "href"
+oauth2BitbucketScoped :: YesodAuth m => [Text] -> Text -> Text -> AuthPlugin m
+oauth2BitbucketScoped scopes clientId clientSecret =
+    authOAuth2 pluginName oauth2 $ \manager token -> do
+        (User userId, userResponseJSON) <-
+            authGetProfile pluginName manager token "https://api.bitbucket.com/2.0/user"
 
-newtype BitbucketEmailSearchResults = BitbucketEmailSearchResults
-    { bitbucketEmails :: [BitbucketUserEmail]
-    }
-
-instance FromJSON BitbucketEmailSearchResults where
-    parseJSON = withObject "BitbucketEmailSearchResults" $ \o -> BitbucketEmailSearchResults
-        <$> o .: "values"
-
-data BitbucketUserEmail = BitbucketUserEmail
-    { bitbucketUserEmailAddress :: Text
-    , bitbucketUserEmailPrimary :: Bool
-    }
-
-instance FromJSON BitbucketUserEmail where
-    parseJSON = withObject "BitbucketUserEmail" $ \o -> BitbucketUserEmail
-        <$> o .: "email"
-        <*> o .: "is_primary"
-
-oauth2Bitbucket :: YesodAuth m
-             => Text -- ^ Client ID
-             -> Text -- ^ Client Secret
-             -> AuthPlugin m
-oauth2Bitbucket clientId clientSecret = oauth2BitbucketScoped clientId clientSecret ["account"]
-
-oauth2BitbucketScoped :: YesodAuth m
-             => Text -- ^ Client ID
-             -> Text -- ^ Client Secret
-             -> [Text] -- ^ List of scopes to request
-             -> AuthPlugin m
-oauth2BitbucketScoped clientId clientSecret scopes = authOAuth2 "bitbucket" oauth fetchBitbucketProfile
+        pure Creds
+            { credsPlugin = pluginName
+            -- FIXME: Preserved bug. This should just be userId (it's already
+            -- a Text), but because this code was shipped, folks likely have
+            -- Idents in their database like @"\"...\""@, and if we fixed this
+            -- they would need migrating. We're keeping it for now as it's a
+            -- minor wart. Breaking typed APIs is one thing, causing data to go
+            -- invalid is another.
+            , credsIdent = T.pack $ show userId
+            , credsExtra =
+                [ ("accessToken", atoken $ accessToken token)
+                , ("userResponseJSON", decodeUtf8 $ BL.toStrict userResponseJSON)
+                ]
+            }
   where
-    oauth = OAuth2
+    oauth2 = OAuth2
         { oauthClientId = clientId
         , oauthClientSecret = clientSecret
         , oauthOAuthorizeEndpoint = "https://bitbucket.com/site/oauth2/authorize" `withQuery`
@@ -90,30 +61,3 @@ oauth2BitbucketScoped clientId clientSecret scopes = authOAuth2 "bitbucket" oaut
         , oauthAccessTokenEndpoint = "https://bitbucket.com/site/oauth2/access_token"
         , oauthCallback = Nothing
         }
-
-fetchBitbucketProfile :: Manager -> OAuth2Token -> IO (Creds m)
-fetchBitbucketProfile manager token = do
-    userResult <- authGetJSON manager (accessToken token) "https://api.bitbucket.com/2.0/user"
-    mailResult <- authGetJSON manager (accessToken token) "https://api.bitbucket.com/2.0/user/emails"
-
-    case (userResult, mailResult) of
-        (Right user, Right mails) -> return $ toCreds user (bitbucketEmails mails) token
-        (Left err, _) -> throwIO $ invalidProfileResponse "bitbucket" err
-        (_, Left err) -> throwIO $ invalidProfileResponse "bitbucket" err
-
-toCreds :: BitbucketUser -> [BitbucketUserEmail] -> OAuth2Token -> Creds m
-toCreds user userMails token = Creds
-    { credsPlugin = "bitbucket"
-    , credsIdent = T.pack $ show $ bitbucketUserId user
-    , credsExtra =
-        [ ("email", bitbucketUserEmailAddress email)
-        , ("login", bitbucketUserLogin user)
-        , ("avatar_url", bitbucketLinkHref (bitbucketAvatarLink (bitbucketUserLinks user)))
-        , ("access_token", atoken $ accessToken token)
-        ]
-        ++ maybeExtra "name" (bitbucketUserName user)
-        ++ maybeExtra "location" (bitbucketUserLocation user)
-    }
-
-  where
-    email = fromMaybe (head userMails) $ find bitbucketUserEmailPrimary userMails