module Yesod.Auth.GoogleEmail
( authGoogleEmail
, forwardUrl
) where
import Yesod.Auth
import qualified Web.Authenticate.OpenId as OpenId
import Yesod.Form
import Yesod.Handler
import Yesod.Widget
import Yesod.Request
import Text.Blaze (toHtml)
import Data.Text (Text)
import qualified Yesod.Auth.Message as Msg
import qualified Data.Text as T
import Control.Exception.Lifted (try, SomeException)
forwardUrl :: AuthRoute
forwardUrl = PluginR "googleemail" ["forward"]
authGoogleEmail :: YesodAuth m => AuthPlugin m
authGoogleEmail =
AuthPlugin "googleemail" dispatch login
where
complete = PluginR "googleemail" ["complete"]
name = "openid_identifier"
login tm = do
[whamlet|
<form method=get action=@{tm forwardUrl}>
<input type=hidden name=openid_identifier value=https://www.google.com/accounts/o8/id>
<input type=submit value=_{Msg.LoginGoogle}>
|]
dispatch "GET" ["forward"] = do
roid <- runInputGet $ iopt textField name
case roid of
Just oid -> do
render <- getUrlRender
toMaster <- getRouteToMaster
let complete' = render $ toMaster complete
master <- getYesod
eres <- lift $ try $ OpenId.getForwardUrl oid complete' Nothing
[ ("openid.ax.type.email", "http://schema.openid.net/contact/email")
, ("openid.ns.ax", "http://openid.net/srv/ax/1.0")
, ("openid.ns.ax.required", "email")
, ("openid.ax.mode", "fetch_request")
, ("openid.ax.required", "email")
, ("openid.ui.icon", "true")
] (authHttpManager master)
either
(\err -> do
setMessage $ toHtml $ show (err :: SomeException)
redirect $ toMaster LoginR
)
redirect
eres
Nothing -> do
toMaster <- getRouteToMaster
setMessageI Msg.NoOpenID
redirect $ toMaster LoginR
dispatch "GET" ["complete", ""] = dispatch "GET" ["complete"]
dispatch "GET" ["complete"] = do
rr <- getRequest
completeHelper $ reqGetParams rr
dispatch "POST" ["complete", ""] = dispatch "POST" ["complete"]
dispatch "POST" ["complete"] = do
(posts, _) <- runRequestBody
completeHelper posts
dispatch _ _ = notFound
completeHelper :: YesodAuth m => [(Text, Text)] -> GHandler Auth m ()
completeHelper gets' = do
master <- getYesod
eres <- lift $ try $ OpenId.authenticate gets' (authHttpManager master)
toMaster <- getRouteToMaster
let onFailure err = do
setMessage $ toHtml $ show (err :: SomeException)
redirect $ toMaster LoginR
let onSuccess (OpenId.Identifier ident, _) = do
memail <- lookupGetParam "openid.ext1.value.email"
case (memail, "https://www.google.com/accounts/o8/id" `T.isPrefixOf` ident) of
(Just email, True) -> setCreds True $ Creds "openid" email []
(_, False) -> do
setMessage "Only Google login is supported"
redirect $ toMaster LoginR
(Nothing, _) -> do
setMessage "No email address provided"
redirect $ toMaster LoginR
either onFailure onSuccess eres