module Yesod.Auth.OpenId
( authOpenId
, forwardUrl
, claimedKey
, opLocalKey
, credsIdentClaimed
, IdentifierType (..)
) where
import Yesod.Auth
import qualified Web.Authenticate.OpenId as OpenId
import Yesod.Form
import Yesod.Handler
import Yesod.Widget (toWidget, whamlet)
import Yesod.Request
import Text.Cassius (cassius)
#if MIN_VERSION_blaze_html(0, 5, 0)
import Text.Blaze.Html (toHtml)
#else
import Text.Blaze (toHtml)
#endif
import Data.Text (Text, isPrefixOf)
import qualified Yesod.Auth.Message as Msg
import Control.Exception.Lifted (SomeException, try)
import Data.Maybe (fromMaybe)
forwardUrl :: AuthRoute
forwardUrl = PluginR "openid" ["forward"]
data IdentifierType = Claimed | OPLocal
authOpenId :: YesodAuth m
=> IdentifierType
-> [(Text, Text)]
-> AuthPlugin m
authOpenId idType extensionFields =
AuthPlugin "openid" dispatch login
where
complete = PluginR "openid" ["complete"]
name = "openid_identifier"
login tm = do
ident <- lift newIdent
let y :: a -> [(Text, Text)] -> Text
y = undefined
toWidget (\x -> [cassius|##{ident}
background: #fff url(http://www.myopenid.com/static/openidiconsmall.gif) norepeat scroll 0pt 50%;
paddingleft: 18px;
|] $ x `asTypeOf` y)
[whamlet|
$newline never
<form method="get" action="@{tm forwardUrl}">
<input type="hidden" name="openid_identifier" value="https://www.google.com/accounts/o8/id">
<button .openidgoogle>_{Msg.LoginGoogle}
<form method="get" action="@{tm forwardUrl}">
<input type="hidden" name="openid_identifier" value="http://me.yahoo.com">
<button .openidyahoo>_{Msg.LoginYahoo}
<form method="get" action="@{tm forwardUrl}">
<label for="#{ident}">OpenID: #
<input id="#{ident}" type="text" name="#{name}" value="http://">
<input type="submit" value="_{Msg.LoginOpenID}">
|]
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 extensionFields (authHttpManager master)
case eres of
Left err -> do
setMessage $ toHtml $ show (err :: SomeException)
redirect $ toMaster LoginR
Right x -> redirect x
Nothing -> do
toMaster <- getRouteToMaster
setMessageI Msg.NoOpenID
redirect $ toMaster LoginR
dispatch "GET" ["complete", ""] = dispatch "GET" ["complete"]
dispatch "GET" ["complete"] = do
rr <- getRequest
completeHelper idType $ reqGetParams rr
dispatch "POST" ["complete", ""] = dispatch "POST" ["complete"]
dispatch "POST" ["complete"] = do
(posts, _) <- runRequestBody
completeHelper idType posts
dispatch _ _ = notFound
completeHelper :: YesodAuth m => IdentifierType -> [(Text, Text)] -> GHandler Auth m ()
completeHelper idType 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 claimed =
case OpenId.oirClaimed oir of
Nothing -> id
Just (OpenId.Identifier i') -> ((claimedKey, i'):)
oplocal =
case OpenId.oirOpLocal oir of
OpenId.Identifier i' -> ((opLocalKey, i'):)
gets'' = oplocal $ claimed $ filter (\(k, _) -> not $ "__" `isPrefixOf` k) gets'
i = OpenId.identifier $
case idType of
OPLocal -> OpenId.oirOpLocal oir
Claimed -> fromMaybe (OpenId.oirOpLocal oir) $ OpenId.oirClaimed oir
setCreds True $ Creds "openid" i gets''
either onFailure onSuccess eres
claimedKey :: Text
claimedKey = "__CLAIMED"
opLocalKey :: Text
opLocalKey = "__OPLOCAL"
credsIdentClaimed :: Creds m -> Text
credsIdentClaimed c | credsPlugin c /= "openid" = credsIdent c
credsIdentClaimed c = fromMaybe (credsIdent c)
$ lookup claimedKey (credsExtra c)