module Yesod.Helpers.Auth.OpenId
( authOpenId
, forwardUrl
) where
import Yesod
import Yesod.Helpers.Auth
import qualified Web.Authenticate.OpenId as OpenId
import Control.Monad.Attempt
forwardUrl :: AuthRoute
forwardUrl = PluginR "openid" ["forward"]
authOpenId :: YesodAuth m => AuthPlugin m
authOpenId =
AuthPlugin "openid" dispatch login
where
complete = PluginR "openid" ["complete"]
name = "openid_identifier"
login tm = do
ident <- newIdent
addCassius
#if GHC7
[cassius|
#else
[$cassius|
#endif
#$ident$
background: #fff url(http://www.myopenid.com/static/openidiconsmall.gif) norepeat scroll 0pt 50%;
paddingleft: 18px;
|]
addHamlet
#if GHC7
[hamlet|
#else
[$hamlet|
#endif
%form!method=get!action=@tm.forwardUrl@
%label!for=openid OpenID: $
%input#$ident$!type=text!name=$name$!value="http://"
%input!type=submit!value="Login via OpenID"
|]
dispatch "GET" ["forward"] = do
(roid, _, _) <- runFormGet $ stringInput name
case roid of
FormSuccess oid -> do
render <- getUrlRender
toMaster <- getRouteToMaster
let complete' = render $ toMaster complete
res <- runAttemptT $ OpenId.getForwardUrl oid complete'
attempt
(\err -> do
setMessage $ string $ show err
redirect RedirectTemporary $ toMaster LoginR
)
(redirectString RedirectTemporary)
res
_ -> do
toMaster <- getRouteToMaster
setMessage $ string "No OpenID identifier found"
redirect RedirectTemporary $ toMaster LoginR
dispatch "GET" ["complete"] = do
rr <- getRequest
completeHelper $ reqGetParams rr
dispatch "POST" ["complete"] = do
rr <- getRequest
(posts, _) <- liftIO $ reqRequestBody rr
completeHelper posts
dispatch _ _ = notFound
completeHelper :: YesodAuth m => [(String, String)] -> GHandler Auth m ()
completeHelper gets' = do
res <- runAttemptT $ OpenId.authenticate gets'
toMaster <- getRouteToMaster
let onFailure err = do
setMessage $ string $ show err
redirect RedirectTemporary $ toMaster LoginR
let onSuccess (OpenId.Identifier ident) =
setCreds True $ Creds "openid" ident []
attempt onFailure onSuccess res