From 393334370c073ddc33820264340b1ef6a1252401 Mon Sep 17 00:00:00 2001 From: Calen Pennington Date: Mon, 28 Jul 2014 06:35:00 -0400 Subject: [PATCH 1/9] Update to hauth2 0.4.* --- yesod-auth-oauth2.cabal | 2 ++ 1 file changed, 2 insertions(+) diff --git a/yesod-auth-oauth2.cabal b/yesod-auth-oauth2.cabal index eeb05b9..b2487ce 100644 --- a/yesod-auth-oauth2.cabal +++ b/yesod-auth-oauth2.cabal @@ -32,6 +32,8 @@ library , transformers >= 0.2.2 && < 0.4 , hoauth2 >= 0.4.1 && < 0.5 , lifted-base >= 0.2 && < 0.4 + , http-client >= 0.3 && < 0.4 + , http-client-tls >= 0.2 && < 0.3 exposed-modules: Yesod.Auth.OAuth2 Yesod.Auth.OAuth2.Google From 7c002e167cf6a137ee93cc0f5cf7d77647bd9f66 Mon Sep 17 00:00:00 2001 From: Calen Pennington Date: Mon, 28 Jul 2014 06:35:24 -0400 Subject: [PATCH 2/9] Add a github OAuth2 provider --- Yesod/Auth/OAuth2/Github.hs | 102 ++++++++++++++++++++++++++++++++++++ yesod-auth-oauth2.cabal | 2 + 2 files changed, 104 insertions(+) create mode 100644 Yesod/Auth/OAuth2/Github.hs diff --git a/Yesod/Auth/OAuth2/Github.hs b/Yesod/Auth/OAuth2/Github.hs new file mode 100644 index 0000000..5827775 --- /dev/null +++ b/Yesod/Auth/OAuth2/Github.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | +-- +-- OAuth2 plugin for http://github.com +-- +-- * Authenticates against github +-- * Uses github user id as credentials identifier +-- * Returns first_name, last_name, and email as extras +-- +module Yesod.Auth.OAuth2.Github + ( oauth2Github + , module Yesod.Auth.OAuth2 + ) where + +import Control.Applicative ((<$>), (<*>)) +import Control.Exception.Lifted +import Control.Monad (mzero) +import Data.Aeson +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8, decodeUtf8) +import Yesod.Auth +import Yesod.Auth.OAuth2 +import Yesod.Core +import Yesod.Form +import Network.HTTP.Client (newManager) +import Network.HTTP.Client.TLS (tlsManagerSettings) +import Data.UUID (toString) +import Data.UUID.V4 (nextRandom) +import qualified Data.ByteString as BS +import qualified Data.Text as T + +data GithubUser = GithubUser + { githubUserId :: Int + , githubUserName :: Text + , githubUserEmail :: Text + , githubUserLogin :: Text + , githubUserAvatarUrl :: Text + } + +instance FromJSON GithubUser where + parseJSON (Object o) = + GithubUser <$> o .: "id" + <*> o .: "name" + <*> o .: "email" + <*> o .: "login" + <*> o .: "avatar_url" + + parseJSON _ = mzero + +oauth2Github :: YesodAuth m + => Text -- ^ Client ID + -> Text -- ^ Client Secret + -> [Text] -- ^ List of scopes to request + -> AuthPlugin m +oauth2Github clientId clientSecret scopes = basicPlugin {apDispatch = dispatch} + where + oauth = OAuth2 + { oauthClientId = encodeUtf8 clientId + , oauthClientSecret = encodeUtf8 clientSecret + , oauthOAuthorizeEndpoint = encodeUtf8 $ "https://github.com/login/oauth/authorize?scopes=" `T.append` (T.intercalate "," scopes) + , oauthAccessTokenEndpoint = "https://github.com/login/oauth/access_token" + , oauthCallback = Nothing + } + + withState state = authOAuth2 "github" + (oauth {oauthOAuthorizeEndpoint = oauthOAuthorizeEndpoint oauth `BS.append` "&state=" `BS.append` encodeUtf8 state}) + fetchGithubProfile + + basicPlugin = authOAuth2 "github" oauth fetchGithubProfile + + dispatch "GET" ["forward"] = do + state <- liftIO $ fmap (T.pack . toString) nextRandom + setSession "githubState" state + (apDispatch (withState state)) "GET" ["forward"] + + dispatch "GET" ["callback"] = do + state <- lift $ runInputGet $ ireq textField "state" + savedState <- lookupSession "githubState" + case savedState of + Just saved | saved == state -> (apDispatch basicPlugin) "GET" ["callback"] + _ -> invalidArgs ["state"] + + dispatch method ps = (apDispatch basicPlugin) method ps + +fetchGithubProfile :: AccessToken -> IO (Creds m) +fetchGithubProfile token = do + manager <- newManager tlsManagerSettings + result <- authGetJSON manager token "https://api.github.com/user" + + case result of + Right user -> return $ toCreds user token + Left err -> throwIO $ InvalidProfileResponse "github" err + +toCreds :: GithubUser -> AccessToken -> Creds m +toCreds user token = Creds "github" + (T.pack $ show $ githubUserId user) + [ ("name", githubUserName user) + , ("email", githubUserEmail user) + , ("login", githubUserLogin user) + , ("avatar_url", githubUserAvatarUrl user) + , ("access_token", decodeUtf8 $ accessToken token) + ] diff --git a/yesod-auth-oauth2.cabal b/yesod-auth-oauth2.cabal index b2487ce..4250d32 100644 --- a/yesod-auth-oauth2.cabal +++ b/yesod-auth-oauth2.cabal @@ -34,10 +34,12 @@ library , lifted-base >= 0.2 && < 0.4 , http-client >= 0.3 && < 0.4 , http-client-tls >= 0.2 && < 0.3 + , uuid >= 1.3 && < 1.4 exposed-modules: Yesod.Auth.OAuth2 Yesod.Auth.OAuth2.Google Yesod.Auth.OAuth2.Learn + Yesod.Auth.OAuth2.Github ghc-options: -Wall From ec80c8f75e0bb5184dcc059c60c5375783d13bd7 Mon Sep 17 00:00:00 2001 From: Freiric Barral Date: Fri, 29 Aug 2014 18:43:39 +0200 Subject: [PATCH 3/9] fix cabal file: take into account the split of network from version 2.6, and avoid authenticate 1.3.2.6 which gave the following strange error: ... Building authenticate-1.3.2.6... Preprocessing library authenticate-1.3.2.6... [1 of 9] Compiling OpenId2.XRDS ( OpenId2/XRDS.hs, dist/dist-sandbox-a1429708/build/OpenId2/XRDS.o ) [2 of 9] Compiling Web.Authenticate.OpenId.Providers ( Web/Authenticate/OpenId/Providers.hs, dist/dist-sandbox-a1429708/build/Web/Authenticate/OpenId/Providers.o ) [3 of 9] Compiling Web.Authenticate.BrowserId ( Web/Authenticate/BrowserId.hs, dist/dist-sandbox-a1429708/build/Web/Authenticate/BrowserId.o ) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Web/Authenticate/BrowserId.hs:15:22: Module ‘Data.Conduit’ does not export ‘MonadBaseControl’ Web/Authenticate/BrowserId.hs:15:40: Module ‘Data.Conduit’ does not export ‘MonadResource’ Failed to install authenticate-1.3.2.6 --- yesod-auth-oauth2.cabal | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/yesod-auth-oauth2.cabal b/yesod-auth-oauth2.cabal index 4250d32..aef15aa 100644 --- a/yesod-auth-oauth2.cabal +++ b/yesod-auth-oauth2.cabal @@ -14,7 +14,16 @@ homepage: http://github.com/scan/yesod-auth-oauth2 flag ghc7 +flag network-uri + description: Get Network.URI from the network-uri package + default: True + library + if flag(network-uri) + build-depends: network-uri >= 2.6 + else + build-depends: network < 2.6 + if flag(ghc7) build-depends: base >= 4.3 && < 5 cpp-options: -DGHC7 @@ -26,6 +35,7 @@ library , http-types >= 0.8 && < 0.9 , aeson >= 0.6 && < 0.8 , yesod-core >= 1.2 && < 1.4 + , authenticate >= 1.3.2.7 && < 1.4 , yesod-auth >= 1.3 && < 1.4 , text >= 0.7 && < 2.0 , yesod-form >= 1.3 && < 1.4 From 165713c350829a90679d18e92331aaf86811dee7 Mon Sep 17 00:00:00 2001 From: Freiric Barral Date: Fri, 29 Aug 2014 18:54:04 +0200 Subject: [PATCH 4/9] use tls manager argument in fetchGithubProfile (introduced in 'Version upgrade (hoauth2 0.4.1)'.) --- Yesod/Auth/OAuth2/Github.hs | 8 +++----- yesod-auth-oauth2.cabal | 2 -- 2 files changed, 3 insertions(+), 7 deletions(-) diff --git a/Yesod/Auth/OAuth2/Github.hs b/Yesod/Auth/OAuth2/Github.hs index 5827775..f998819 100644 --- a/Yesod/Auth/OAuth2/Github.hs +++ b/Yesod/Auth/OAuth2/Github.hs @@ -22,8 +22,7 @@ import Yesod.Auth import Yesod.Auth.OAuth2 import Yesod.Core import Yesod.Form -import Network.HTTP.Client (newManager) -import Network.HTTP.Client.TLS (tlsManagerSettings) +import Network.HTTP.Conduit(Manager) import Data.UUID (toString) import Data.UUID.V4 (nextRandom) import qualified Data.ByteString as BS @@ -82,9 +81,8 @@ oauth2Github clientId clientSecret scopes = basicPlugin {apDispatch = dispatch} dispatch method ps = (apDispatch basicPlugin) method ps -fetchGithubProfile :: AccessToken -> IO (Creds m) -fetchGithubProfile token = do - manager <- newManager tlsManagerSettings +fetchGithubProfile :: Manager -> AccessToken -> IO (Creds m) +fetchGithubProfile manager token = do result <- authGetJSON manager token "https://api.github.com/user" case result of diff --git a/yesod-auth-oauth2.cabal b/yesod-auth-oauth2.cabal index aef15aa..2151ee0 100644 --- a/yesod-auth-oauth2.cabal +++ b/yesod-auth-oauth2.cabal @@ -42,8 +42,6 @@ library , transformers >= 0.2.2 && < 0.4 , hoauth2 >= 0.4.1 && < 0.5 , lifted-base >= 0.2 && < 0.4 - , http-client >= 0.3 && < 0.4 - , http-client-tls >= 0.2 && < 0.3 , uuid >= 1.3 && < 1.4 exposed-modules: Yesod.Auth.OAuth2 From d6fe3090d7230f204efc4d84a6889d14073144d9 Mon Sep 17 00:00:00 2001 From: Freiric Barral Date: Fri, 29 Aug 2014 19:56:12 +0200 Subject: [PATCH 5/9] remove redundant bracket --- Yesod/Auth/OAuth2/Github.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/Yesod/Auth/OAuth2/Github.hs b/Yesod/Auth/OAuth2/Github.hs index f998819..3b9e441 100644 --- a/Yesod/Auth/OAuth2/Github.hs +++ b/Yesod/Auth/OAuth2/Github.hs @@ -56,7 +56,7 @@ oauth2Github clientId clientSecret scopes = basicPlugin {apDispatch = dispatch} oauth = OAuth2 { oauthClientId = encodeUtf8 clientId , oauthClientSecret = encodeUtf8 clientSecret - , oauthOAuthorizeEndpoint = encodeUtf8 $ "https://github.com/login/oauth/authorize?scopes=" `T.append` (T.intercalate "," scopes) + , oauthOAuthorizeEndpoint = encodeUtf8 $ "https://github.com/login/oauth/authorize?scopes=" `T.append` T.intercalate "," scopes , oauthAccessTokenEndpoint = "https://github.com/login/oauth/access_token" , oauthCallback = Nothing } @@ -70,16 +70,16 @@ oauth2Github clientId clientSecret scopes = basicPlugin {apDispatch = dispatch} dispatch "GET" ["forward"] = do state <- liftIO $ fmap (T.pack . toString) nextRandom setSession "githubState" state - (apDispatch (withState state)) "GET" ["forward"] + apDispatch (withState state) "GET" ["forward"] dispatch "GET" ["callback"] = do state <- lift $ runInputGet $ ireq textField "state" savedState <- lookupSession "githubState" case savedState of - Just saved | saved == state -> (apDispatch basicPlugin) "GET" ["callback"] + Just saved | saved == state -> apDispatch basicPlugin "GET" ["callback"] _ -> invalidArgs ["state"] - dispatch method ps = (apDispatch basicPlugin) method ps + dispatch method ps = apDispatch basicPlugin method ps fetchGithubProfile :: Manager -> AccessToken -> IO (Creds m) fetchGithubProfile manager token = do From 4fdd311d4b205755330844f4b86b6749b7a936d3 Mon Sep 17 00:00:00 2001 From: Freiric Barral Date: Sun, 31 Aug 2014 23:11:36 +0200 Subject: [PATCH 6/9] correct typo in the authentication query to github --- Yesod/Auth/OAuth2/Github.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Yesod/Auth/OAuth2/Github.hs b/Yesod/Auth/OAuth2/Github.hs index 3b9e441..e55935c 100644 --- a/Yesod/Auth/OAuth2/Github.hs +++ b/Yesod/Auth/OAuth2/Github.hs @@ -56,7 +56,7 @@ oauth2Github clientId clientSecret scopes = basicPlugin {apDispatch = dispatch} oauth = OAuth2 { oauthClientId = encodeUtf8 clientId , oauthClientSecret = encodeUtf8 clientSecret - , oauthOAuthorizeEndpoint = encodeUtf8 $ "https://github.com/login/oauth/authorize?scopes=" `T.append` T.intercalate "," scopes + , oauthOAuthorizeEndpoint = encodeUtf8 $ "https://github.com/login/oauth/authorize?scope=" `T.append` T.intercalate "," scopes , oauthAccessTokenEndpoint = "https://github.com/login/oauth/access_token" , oauthCallback = Nothing } From e34156dcc3844367a2ad436da12e68bdfc8c4768 Mon Sep 17 00:00:00 2001 From: Freiric Barral Date: Sat, 30 Aug 2014 15:48:23 +0200 Subject: [PATCH 7/9] bump version --- yesod-auth-oauth2.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod-auth-oauth2.cabal b/yesod-auth-oauth2.cabal index 2151ee0..c1934b0 100644 --- a/yesod-auth-oauth2.cabal +++ b/yesod-auth-oauth2.cabal @@ -1,5 +1,5 @@ name: yesod-auth-oauth2 -version: 0.0.5.1 +version: 0.0.5.2 license: BSD3 license-file: LICENSE author: Tom Streller From a992fdb6fa75be9dc9ce41c9e760bd479bd11f74 Mon Sep 17 00:00:00 2001 From: Freiric Barral Date: Sun, 31 Aug 2014 16:30:45 +0200 Subject: [PATCH 8/9] fetch github email in a second query to https://api.github.com/user/emails (the query to https://api.github.com/user return a null in the email field) --- Yesod/Auth/OAuth2/Github.hs | 34 ++++++++++++++++++++++++---------- 1 file changed, 24 insertions(+), 10 deletions(-) diff --git a/Yesod/Auth/OAuth2/Github.hs b/Yesod/Auth/OAuth2/Github.hs index e55935c..c66df14 100644 --- a/Yesod/Auth/OAuth2/Github.hs +++ b/Yesod/Auth/OAuth2/Github.hs @@ -17,6 +17,7 @@ import Control.Exception.Lifted import Control.Monad (mzero) import Data.Aeson import Data.Text (Text) +import Data.Monoid (mappend) import Data.Text.Encoding (encodeUtf8, decodeUtf8) import Yesod.Auth import Yesod.Auth.OAuth2 @@ -31,7 +32,6 @@ import qualified Data.Text as T data GithubUser = GithubUser { githubUserId :: Int , githubUserName :: Text - , githubUserEmail :: Text , githubUserLogin :: Text , githubUserAvatarUrl :: Text } @@ -40,12 +40,21 @@ instance FromJSON GithubUser where parseJSON (Object o) = GithubUser <$> o .: "id" <*> o .: "name" - <*> o .: "email" <*> o .: "login" <*> o .: "avatar_url" parseJSON _ = mzero +data GithubUserEmail = GithubUserEmail + { githubUserEmail :: Text + } + +instance FromJSON GithubUserEmail where + parseJSON (Object o) = + GithubUserEmail <$> o .: "email" + + parseJSON _ = mzero + oauth2Github :: YesodAuth m => Text -- ^ Client ID -> Text -- ^ Client Secret @@ -75,25 +84,30 @@ oauth2Github clientId clientSecret scopes = basicPlugin {apDispatch = dispatch} dispatch "GET" ["callback"] = do state <- lift $ runInputGet $ ireq textField "state" savedState <- lookupSession "githubState" + apDispatch basicPlugin "GET" ["callback"] case savedState of Just saved | saved == state -> apDispatch basicPlugin "GET" ["callback"] - _ -> invalidArgs ["state"] + Just saved -> invalidArgs ["state: " `mappend` state `mappend` ", and not: " `mappend` saved] + _ -> invalidArgs ["state: " `mappend` state] dispatch method ps = apDispatch basicPlugin method ps fetchGithubProfile :: Manager -> AccessToken -> IO (Creds m) fetchGithubProfile manager token = do - result <- authGetJSON manager token "https://api.github.com/user" + userResult <- authGetJSON manager token "https://api.github.com/user" + mailResult <- authGetJSON manager token "https://api.github.com/user/emails" - case result of - Right user -> return $ toCreds user token - Left err -> throwIO $ InvalidProfileResponse "github" err + case (userResult, mailResult) of + (Right user, 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 -> AccessToken -> Creds m -toCreds user token = Creds "github" +toCreds :: GithubUser -> [GithubUserEmail] -> AccessToken -> Creds m +toCreds user userMail token = Creds "github" (T.pack $ show $ githubUserId user) [ ("name", githubUserName user) - , ("email", githubUserEmail user) + , ("email", githubUserEmail $ head userMail) , ("login", githubUserLogin user) , ("avatar_url", githubUserAvatarUrl user) , ("access_token", decodeUtf8 $ accessToken token) From 8046f4d8ccc31f1d198ad2955f9863b07513f044 Mon Sep 17 00:00:00 2001 From: Freiric Barral Date: Sun, 31 Aug 2014 16:40:02 +0200 Subject: [PATCH 9/9] hardcode the scope to user:email (if more info is needed the code will anyway have to be changed to include more queries) --- Yesod/Auth/OAuth2/Github.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/Yesod/Auth/OAuth2/Github.hs b/Yesod/Auth/OAuth2/Github.hs index c66df14..48ccb80 100644 --- a/Yesod/Auth/OAuth2/Github.hs +++ b/Yesod/Auth/OAuth2/Github.hs @@ -56,11 +56,17 @@ instance FromJSON GithubUserEmail where parseJSON _ = mzero oauth2Github :: YesodAuth m + => Text -- ^ Client ID + -> Text -- ^ Client Secret + -> AuthPlugin m +oauth2Github clientId clientSecret = oauth2GithubScoped clientId clientSecret ["user:email"] + +oauth2GithubScoped :: YesodAuth m => Text -- ^ Client ID -> Text -- ^ Client Secret -> [Text] -- ^ List of scopes to request -> AuthPlugin m -oauth2Github clientId clientSecret scopes = basicPlugin {apDispatch = dispatch} +oauth2GithubScoped clientId clientSecret scopes = basicPlugin {apDispatch = dispatch} where oauth = OAuth2 { oauthClientId = encodeUtf8 clientId