diff --git a/Yesod/Auth/OAuth2.hs b/Yesod/Auth/OAuth2.hs index bde70d2..b3476bb 100644 --- a/Yesod/Auth/OAuth2.hs +++ b/Yesod/Auth/OAuth2.hs @@ -22,6 +22,8 @@ import Data.Text.Encoding (decodeUtf8With, encodeUtf8) import Data.Text.Encoding.Error (lenientDecode) import Data.Typeable import Network.OAuth.OAuth2 +import Network.HTTP.Client (newManager) +import Network.HTTP.Client.TLS (tlsManagerSettings) import Yesod.Auth import Yesod.Core import Yesod.Form @@ -62,14 +64,15 @@ authOAuth2 name oauth getCreds = AuthPlugin name dispatch login lift $ redirect authUrl dispatch "GET" ["callback"] = do + manager <- liftIO $ newManager tlsManagerSettings code <- lift $ runInputGet $ ireq textField "code" oauth' <- withCallback - result <- liftIO $ fetchAccessToken oauth' (encodeUtf8 code) + result <- liftIO $ fetchAccessToken manager oauth' (encodeUtf8 code) case result of Left _ -> permissionDenied "Unable to retreive OAuth2 token" Right token -> do creds <- liftIO $ getCreds token - lift $ setCreds True creds + lift $ setCredsRedirect creds dispatch _ _ = notFound 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/Learn.hs b/Yesod/Auth/OAuth2/Learn.hs index a26f0f7..c3c6d27 100644 --- a/Yesod/Auth/OAuth2/Learn.hs +++ b/Yesod/Auth/OAuth2/Learn.hs @@ -20,6 +20,8 @@ import Data.Text (Text) import Data.Text.Encoding (encodeUtf8) import Yesod.Auth import Yesod.Auth.OAuth2 +import Network.HTTP.Client (newManager) +import Network.HTTP.Client.TLS (tlsManagerSettings) import qualified Data.Text as T data LearnUser = LearnUser @@ -62,7 +64,8 @@ oauth2Learn clientId clientSecret = authOAuth2 "learn" fetchLearnProfile :: AccessToken -> IO (Creds m) fetchLearnProfile token = do - result <- authGetJSON token "http://learn.thoughtbot.com/api/v1/me.json" + manager <- newManager tlsManagerSettings + result <- authGetJSON manager token "http://learn.thoughtbot.com/api/v1/me.json" case result of Right (LearnResponse user) -> return $ toCreds user diff --git a/yesod-auth-oauth2.cabal b/yesod-auth-oauth2.cabal index 55bfd9d..83a1bd3 100644 --- a/yesod-auth-oauth2.cabal +++ b/yesod-auth-oauth2.cabal @@ -24,18 +24,21 @@ library build-depends: bytestring >= 0.9.1.4 , http-conduit >= 2.0 && < 3.0 , http-types >= 0.8 && < 0.9 - , aeson >= 0.6 && < 0.8 + , aeson >= 0.6 && < 0.9 , yesod-core >= 1.2 && < 1.3 - , yesod-auth >= 1.2 && < 1.3 + , yesod-auth >= 1.3 && < 1.4 , text >= 0.7 && < 2.0 , yesod-form >= 1.3 && < 1.4 - , transformers >= 0.2.2 && < 0.4 - , hoauth2 >= 0.3.6 && < 0.4 + , transformers >= 0.3 && < 0.5 + , hoauth2 >= 0.4 && < 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 Yesod.Auth.OAuth2.Google Yesod.Auth.OAuth2.Learn + Yesod.Auth.OAuth2.Github ghc-options: -Wall