diff --git a/src/Yesod/Auth/OAuth2/Bitbucket.hs b/src/Yesod/Auth/OAuth2/Bitbucket.hs index 4900e66..f00659f 100644 --- a/src/Yesod/Auth/OAuth2/Bitbucket.hs +++ b/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