GoogleEmail2
This commit is contained in:
Michael Snoyman
parent
3b53c047e7
commit
96caaf31d8
196
yesod-auth/Yesod/Auth/GoogleEmail2.hs
Normal file
196
yesod-auth/Yesod/Auth/GoogleEmail2.hs
Normal file
@ -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
|
||||
-- <https://developers.google.com/+/api/auth-migration>.
|
||||
--
|
||||
-- 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 <https://console.developers.google.com/>
|
||||
--
|
||||
-- * Create OAuth credentials. The redirect URI will be <http://yourdomain/auth/page/googleemail2/complete>. (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|<a href=#{url}>_{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"
|
||||
@ -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 @@ library
|
||||
, base64-bytestring
|
||||
, byteable
|
||||
, binary
|
||||
, http-client
|
||||
, blaze-builder
|
||||
, conduit
|
||||
, conduit-extra
|
||||
, attoparsec-conduit
|
||||
|
||||
exposed-modules: Yesod.Auth
|
||||
Yesod.Auth.BrowserId
|
||||
@ -68,6 +73,7 @@ library
|
||||
Yesod.Auth.Rpxnow
|
||||
Yesod.Auth.Message
|
||||
Yesod.Auth.GoogleEmail
|
||||
Yesod.Auth.GoogleEmail2
|
||||
other-modules: Yesod.Auth.Routes
|
||||
Yesod.PasswordStore
|
||||
ghc-options: -Wall
|
||||
|
||||
Loading…
Reference in New Issue
Block a user