From 7988569b2e41708f701f3b152b8e731e7f0ecbc8 Mon Sep 17 00:00:00 2001 From: patrick brisbin Date: Fri, 3 Apr 2015 17:43:56 -0400 Subject: [PATCH] Introduce OAuth2Plugin, extracted from GitHub - Extract generic OAuth2Plugin construct - Define GitHub in terms of it - The scopes argument is now in first position - access_token is now always added to credsExtra --- Yesod/Auth/OAuth2.hs | 47 ++++++++++++++++++++++- Yesod/Auth/OAuth2/Github.hs | 75 +++++++++++++++++-------------------- 2 files changed, 79 insertions(+), 43 deletions(-) diff --git a/Yesod/Auth/OAuth2.hs b/Yesod/Auth/OAuth2.hs index 63e9800..8d3a151 100644 --- a/Yesod/Auth/OAuth2.hs +++ b/Yesod/Auth/OAuth2.hs @@ -10,8 +10,10 @@ -- * See Yesod.Auth.OAuth2.GitHub for example usage. -- module Yesod.Auth.OAuth2 - ( authOAuth2 + ( OAuth2Plugin(..) , oauth2Url + , oauth2Plugin + , authOAuth2 , YesodOAuth2Exception(..) , module Network.OAuth.OAuth2 ) where @@ -43,9 +45,45 @@ data YesodOAuth2Exception = InvalidProfileResponse Text BL.ByteString instance Exception YesodOAuth2Exception +data OAuth2Plugin a = OAuth2Plugin + { oapName :: Text + , oapAuthEndpoint :: Text + , oapTokenEndpoint :: Text + , oapFetchProfile :: Manager -> AccessToken -> IO (Either BL.ByteString a) + , oapToCredsIdent :: a -> Text + , oapToCredsExtra :: a -> [(Text, Text)] + } + oauth2Url :: Text -> AuthRoute oauth2Url name = PluginR name ["forward"] +oauth2Plugin :: YesodAuth m + => OAuth2Plugin a + -> Text -- ^ Client ID + -> Text -- ^ Client Secret + -> AuthPlugin m +oauth2Plugin oap clientId clientSecret = + authOAuth2 (oapName oap) oapOauth $ \manager token -> do + result <- oapFetchProfile oap manager token + + case result of + Left err -> throwIO $ InvalidProfileResponse (oapName oap) err + Right user -> return Creds + { credsIdent = oapToCredsIdent oap user + , credsPlugin = oapName oap + , credsExtra = oapToCredsExtra oap user + } + + where + oapOauth :: OAuth2 + oapOauth = OAuth2 + { oauthClientId = encodeUtf8 clientId + , oauthClientSecret = encodeUtf8 clientSecret + , oauthOAuthorizeEndpoint = encodeUtf8 $ oapAuthEndpoint oap + , oauthAccessTokenEndpoint = encodeUtf8 $ oapTokenEndpoint oap + , oauthCallback = Nothing + } + authOAuth2 :: YesodAuth m => Text -- ^ Service name -> OAuth2 -- ^ Service details @@ -89,7 +127,7 @@ authOAuth2 name oauth getCreds = AuthPlugin name dispatch login Left _ -> permissionDenied "Unable to retreive OAuth2 token" Right token -> do creds <- liftIO $ getCreds (authHttpManager master) token - lift $ setCredsRedirect creds + lift $ setCredsRedirect $ addAccessToken token creds _ -> permissionDenied "Invalid OAuth2 state token" @@ -104,5 +142,10 @@ authOAuth2 name oauth getCreds = AuthPlugin name dispatch login Login via #{name} |] + addAccessToken token creds = creds + { credsExtra = + ("access_token", bsToText $ accessToken token) : credsExtra creds + } + bsToText :: ByteString -> Text bsToText = decodeUtf8With lenientDecode diff --git a/Yesod/Auth/OAuth2/Github.hs b/Yesod/Auth/OAuth2/Github.hs index 1c41acf..dd23c77 100644 --- a/Yesod/Auth/OAuth2/Github.hs +++ b/Yesod/Auth/OAuth2/Github.hs @@ -18,13 +18,10 @@ module Yesod.Auth.OAuth2.Github import Control.Applicative ((<$>), (<*>), pure) #endif -import Control.Exception.Lifted import Control.Monad (mzero) import Data.Aeson import Data.Monoid ((<>)) import Data.Text (Text) -import Data.Text.Encoding (encodeUtf8, decodeUtf8) -import Network.HTTP.Conduit (Manager) import Yesod.Auth import Yesod.Auth.OAuth2 @@ -56,50 +53,46 @@ instance FromJSON GithubUserEmail where parseJSON _ = mzero +data GithubProfile = GithubProfile GithubUser (Maybe GithubUserEmail) + +githubProfileIdent :: GithubProfile -> Text +githubProfileIdent (GithubProfile user _) = T.pack $ show $ githubUserId user + oauth2Github :: YesodAuth m => Text -- ^ Client ID -> Text -- ^ Client Secret -> AuthPlugin m -oauth2Github clientId clientSecret = oauth2GithubScoped clientId clientSecret ["user:email"] +oauth2Github = oauth2GithubScoped ["user:email"] oauth2GithubScoped :: YesodAuth m - => Text -- ^ Client ID - -> Text -- ^ Client Secret - -> [Text] -- ^ List of scopes to request - -> AuthPlugin m -oauth2GithubScoped clientId clientSecret scopes = authOAuth2 "github" oauth fetchGithubProfile - where - oauth = OAuth2 - { oauthClientId = encodeUtf8 clientId - , oauthClientSecret = encodeUtf8 clientSecret - , oauthOAuthorizeEndpoint = encodeUtf8 $ "https://github.com/login/oauth/authorize?scope=" <> T.intercalate "," scopes - , oauthAccessTokenEndpoint = "https://github.com/login/oauth/access_token" - , oauthCallback = Nothing - } - -fetchGithubProfile :: Manager -> AccessToken -> IO (Creds m) -fetchGithubProfile manager token = do - userResult <- authGetJSON manager token "https://api.github.com/user" - mailResult <- authGetJSON manager token "https://api.github.com/user/emails" - - case (userResult, mailResult) of - (Right _, Right []) -> throwIO $ InvalidProfileResponse "github" "no mail address for user" - (Right user, Right mails) -> return $ toCreds user mails token - (Left err, _) -> throwIO $ InvalidProfileResponse "github" err - (_, Left err) -> throwIO $ InvalidProfileResponse "github" err - -toCreds :: GithubUser -> [GithubUserEmail] -> AccessToken -> Creds m -toCreds user userMail token = Creds - { credsPlugin = "github" - , credsIdent = T.pack $ show $ githubUserId user - , credsExtra = - [ ("email", githubUserEmail $ head userMail) - , ("login", githubUserLogin user) - , ("avatar_url", githubUserAvatarUrl user) - , ("access_token", decodeUtf8 $ accessToken token) - ] ++ maybeName (githubUserName user) + => [Text] -- ^ Scopes to request + -> Text -- ^ Client ID + -> Text -- ^ Client Secret + -> AuthPlugin m +oauth2GithubScoped scopes = oauth2Plugin OAuth2Plugin + { oapName = "github" + , oapAuthEndpoint = "https://github.com/login/oauth/authorize?scope=" <> T.intercalate "," scopes + , oapTokenEndpoint = "https://github.com/login/oauth/access_token" + , oapFetchProfile = fetchProfile + , oapToCredsIdent = githubProfileIdent + , oapToCredsExtra = toCredsExtra } where - maybeName Nothing = [] - maybeName (Just name) = [("name", name)] + fetchProfile manager token = do + user <- authGetJSON manager token "https://api.github.com/user" + emails <- authGetJSON manager token "https://api.github.com/user/emails" + + return $ case emails of + Right (email:_) -> GithubProfile <$> user <*> pure (Just email) + _ -> Left "user has no email" + + toCredsExtra (GithubProfile user email) = + [ ("login", githubUserLogin user) + , ("avatar_url", githubUserAvatarUrl user) + ] + ++ maybeToTuple "name" (githubUserName user) + ++ maybeToTuple "email" (githubUserEmail <$> email) + + maybeToTuple _ Nothing = [] + maybeToTuple k (Just x) = [(k, x)]