module Yesod.Auth.GoogleEmail
( authGoogleEmail
, forwardUrl
) where
import Yesod.Auth
import qualified Web.Authenticate.OpenId as OpenId
import Yesod.Handler
import Yesod.Widget (whamlet)
import Yesod.Request
#if MIN_VERSION_blaze_html(0, 5, 0)
import Text.Blaze.Html (toHtml)
#else
import Text.Blaze (toHtml)
#endif
import Data.Text (Text)
import qualified Yesod.Auth.Message as Msg
import qualified Data.Text as T
import Control.Exception.Lifted (try, SomeException)
pid :: Text
pid = "googleemail"
forwardUrl :: AuthRoute
forwardUrl = PluginR pid ["forward"]
googleIdent :: Text
googleIdent = "https://www.google.com/accounts/o8/id"
authGoogleEmail :: YesodAuth m => AuthPlugin m
authGoogleEmail =
AuthPlugin pid dispatch login
where
complete = PluginR pid ["complete"]
login tm =
[whamlet|
$newline never
<a href=@{tm forwardUrl}>_{Msg.LoginGoogle}
|]
dispatch "GET" ["forward"] = do
render <- getUrlRender
toMaster <- getRouteToMaster
let complete' = render $ toMaster complete
master <- getYesod
eres <- lift $ try $ OpenId.getForwardUrl googleIdent 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
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.authenticateClaimed gets' (authHttpManager master)
toMaster <- getRouteToMaster
let onFailure err = do
setMessage $ toHtml $ show (err :: SomeException)
redirect $ toMaster LoginR
let onSuccess oir = do
let OpenId.Identifier ident = OpenId.oirOpLocal oir
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 pid 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