diff --git a/Yesod/Auth/GoogleEmail2.hs b/Yesod/Auth/GoogleEmail2.hs new file mode 100644 --- /dev/null +++ b/Yesod/Auth/GoogleEmail2.hs @@ -0,0 +1,196 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +-- | Use an email address as an identifier via Google's login system. +-- +-- Note that this is a replacement for "Yesod.Auth.GoogleEmail", which depends +-- on Google's now deprecated OpenID system. For more information, see +-- . +-- +-- By using this plugin, you are trusting Google to validate an email address, +-- and requiring users to have a Google account. On the plus side, you get to +-- use email addresses as the identifier, many users have existing Google +-- accounts, the login system has been long tested (as opposed to BrowserID), +-- and it requires no credential managing or setup (as opposed to Email). +-- +-- In order to use this plugin: +-- +-- * Create an application on the Google Developer Console +-- +-- * Create OAuth credentials. The redirect URI will be . (If you have your authentication subsite at a different root than \/auth\/, please adjust accordingly.) +-- +-- * Enable the Google+ API. +-- +-- Since 1.3.1 +module Yesod.Auth.GoogleEmail2 + ( authGoogleEmail + , forwardUrl + ) where + +import Blaze.ByteString.Builder (fromByteString, toByteString) +import Control.Applicative ((<$>), (<*>)) +import Control.Arrow (second) +import Control.Monad (liftM, unless) +import Data.Aeson.Parser (json') +import Data.Aeson.Types (FromJSON (parseJSON), parseEither, + withObject) +import Data.Conduit (($$+-)) +import Data.Conduit.Attoparsec (sinkParser) +import Data.Monoid (mappend) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Network.HTTP.Client (parseUrl, requestHeaders, + responseBody, urlEncodedBody) +import Network.HTTP.Conduit (http) +import Network.HTTP.Types (renderQueryText) +import Network.Mail.Mime (randomString) +import System.Random (newStdGen) +import Yesod.Auth (Auth, AuthPlugin (AuthPlugin), + AuthRoute, Creds (Creds), + Route (PluginR), YesodAuth, + authHttpManager, setCredsRedirect) +import qualified Yesod.Auth.Message as Msg +import Yesod.Core (HandlerSite, MonadHandler, + getRouteToParent, getUrlRender, + getYesod, invalidArgs, lift, + liftBase, lookupGetParam, + lookupSession, notFound, redirect, + setSession, whamlet, (.:)) + +pid :: Text +pid = "googleemail2" + +forwardUrl :: AuthRoute +forwardUrl = PluginR pid ["forward"] + +csrfKey :: Text +csrfKey = "_GOOGLE_CSRF_TOKEN" + +getCsrfToken :: MonadHandler m => m (Maybe Text) +getCsrfToken = lookupSession csrfKey + +getCreateCsrfToken :: MonadHandler m => m Text +getCreateCsrfToken = do + mtoken <- getCsrfToken + case mtoken of + Just token -> return token + Nothing -> do + stdgen <- liftBase newStdGen + let token = T.pack $ fst $ randomString 10 stdgen + setSession csrfKey token + return token + +authGoogleEmail :: YesodAuth m + => Text -- ^ client ID + -> Text -- ^ client secret + -> AuthPlugin m +authGoogleEmail clientID clientSecret = + AuthPlugin pid dispatch login + where + complete = PluginR pid ["complete"] + + getDest :: MonadHandler m + => (Route Auth -> Route (HandlerSite m)) + -> m Text + getDest tm = do + csrf <- getCreateCsrfToken + render <- getUrlRender + let qs = map (second Just) + [ ("scope", "email") + , ("state", csrf) + , ("redirect_uri", render $ tm complete) + , ("response_type", "code") + , ("client_id", clientID) + , ("access_type", "offline") + ] + return $ decodeUtf8 + $ toByteString + $ fromByteString "https://accounts.google.com/o/oauth2/auth" + `mappend` renderQueryText True qs + + login tm = do + url <- getDest tm + [whamlet|_{Msg.LoginGoogle}|] + dispatch "GET" ["forward"] = do + tm <- getRouteToParent + lift (getDest tm) >>= redirect + + dispatch "GET" ["complete"] = do + mstate <- lookupGetParam "state" + case mstate of + Nothing -> invalidArgs ["CSRF state from Google is missing"] + Just state -> do + mtoken <- getCsrfToken + unless (Just state == mtoken) $ invalidArgs ["Invalid CSRF token from Google"] + mcode <- lookupGetParam "code" + code <- + case mcode of + Nothing -> invalidArgs ["Missing code paramter"] + Just c -> return c + + render <- getUrlRender + + req' <- parseUrl "https://accounts.google.com/o/oauth2/token" -- FIXME don't hardcode, use: https://accounts.google.com/.well-known/openid-configuration + let req = + urlEncodedBody + [ ("code", encodeUtf8 code) + , ("client_id", encodeUtf8 clientID) + , ("client_secret", encodeUtf8 clientSecret) + , ("redirect_uri", encodeUtf8 $ render complete) + , ("grant_type", "authorization_code") + ] + req' + { requestHeaders = [] + } + manager <- liftM authHttpManager $ lift getYesod + res <- http req manager + value <- responseBody res $$+- sinkParser json' + Tokens accessToken _idToken tokenType <- + case parseEither parseJSON value of + Left e -> error e + Right t -> return t + + unless (tokenType == "Bearer") $ error $ "Unknown token type: " ++ show tokenType + + req2' <- parseUrl "https://www.googleapis.com/plus/v1/people/me" + let req2 = req2' + { requestHeaders = + [ ("Authorization", encodeUtf8 $ "Bearer " `mappend` accessToken) + ] + } + res2 <- http req2 manager + value2 <- responseBody res2 $$+- sinkParser json' + Person emails <- + case parseEither parseJSON value2 of + Left e -> error e + Right x -> return x + email <- + case map emailValue $ filter (\e -> emailType e == "account") emails of + [e] -> return e + [] -> error "No account email" + x -> error $ "Too many account emails: " ++ show x + lift $ setCredsRedirect $ Creds pid email [] + + dispatch _ _ = notFound + +data Tokens = Tokens Text Text Text +instance FromJSON Tokens where + parseJSON = withObject "Tokens" $ \o -> Tokens + <$> o .: "access_token" + <*> o .: "id_token" + <*> o .: "token_type" + +data Person = Person [Email] +instance FromJSON Person where + parseJSON = withObject "Person" $ \o -> Person + <$> o .: "emails" + +data Email = Email + { emailValue :: Text + , emailType :: Text + } + deriving Show +instance FromJSON Email where + parseJSON = withObject "Email" $ \o -> Email + <$> o .: "value" + <*> o .: "type" diff --git a/yesod-auth.cabal b/yesod-auth.cabal --- a/yesod-auth.cabal +++ b/yesod-auth.cabal @@ -1,5 +1,5 @@ name: yesod-auth -version: 1.3.0.5 +version: 1.3.1 license: MIT license-file: LICENSE author: Michael Snoyman, Patrick Brisbin @@ -59,6 +59,11 @@ , base64-bytestring , byteable , binary + , http-client + , blaze-builder + , conduit + , conduit-extra + , attoparsec-conduit exposed-modules: Yesod.Auth Yesod.Auth.BrowserId @@ -68,6 +73,7 @@ Yesod.Auth.Rpxnow Yesod.Auth.Message Yesod.Auth.GoogleEmail + Yesod.Auth.GoogleEmail2 other-modules: Yesod.Auth.Routes Yesod.PasswordStore ghc-options: -Wall