authenticate 0.6.6
This commit is contained in:
Michael Snoyman
parent
3342dd5db9
commit
ba671beb8d
@ -1,19 +1,23 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
module Yesod.Helpers.Auth2.OpenId
|
||||
( authOpenId
|
||||
, forwardUrl
|
||||
) where
|
||||
|
||||
import Yesod
|
||||
import Yesod.Helpers.Auth2
|
||||
import qualified Web.Authenticate.OpenId as OpenId
|
||||
import Control.Monad.Attempt
|
||||
import Network.OpenID
|
||||
import qualified Web.Authenticate.OpenId2 as OpenId2
|
||||
import Control.Exception (toException)
|
||||
|
||||
forwardUrl :: AuthRoute
|
||||
forwardUrl = PluginR "openid" ["forward"]
|
||||
|
||||
authOpenId :: YesodAuth m => AuthPlugin m
|
||||
authOpenId =
|
||||
AuthPlugin "openid" dispatch login
|
||||
where
|
||||
forward = PluginR "openid" ["forward"]
|
||||
complete1 = PluginR "openid" ["complete1"]
|
||||
complete2 = PluginR "openid" ["complete2"]
|
||||
name = "openid_identifier"
|
||||
@ -25,42 +29,30 @@ authOpenId =
|
||||
padding-left: 18px;
|
||||
|]
|
||||
addBody [$hamlet|
|
||||
%form!method=post!action=@tm.forward@
|
||||
%form!method=get!action=@tm.forwardUrl@
|
||||
%label!for=openid OpenID: $
|
||||
%input#$ident$!type=text!name=$name$
|
||||
%input!type=submit!value="Login via OpenID"
|
||||
|]
|
||||
forward2 complete' oid = do
|
||||
case normalizeIdentifier $ Identifier oid of
|
||||
Nothing -> return $ "Unable to normalize identifier: " ++ oid
|
||||
Just ident -> do
|
||||
let resolve = liftIO . makeRequest True
|
||||
rpi <- liftIO $ discover resolve ident
|
||||
case rpi of
|
||||
Left err -> return $ "Error on discovery: " ++ show err
|
||||
Right (p, i) -> do
|
||||
eam <- liftIO $ associate emptyAssociationMap True resolve p
|
||||
case eam of
|
||||
Left err -> return $ "Error on associate: " ++ show err
|
||||
Right am -> do
|
||||
let au = authenticationURI am Setup p i complete' Nothing
|
||||
setSession "OPENID_AM" $ show am
|
||||
redirectString RedirectTemporary $ show au
|
||||
dispatch "POST" ["forward"] = do
|
||||
(roid, _, _) <- runFormPost $ stringInput name
|
||||
dispatch "GET" ["forward"] = do
|
||||
(roid, _, _) <- runFormGet $ stringInput name
|
||||
case roid of
|
||||
FormSuccess oid -> do
|
||||
render <- getUrlRender
|
||||
toMaster <- getRouteToMaster
|
||||
let complete2' = render $ toMaster complete2
|
||||
msg <- forward2 complete2' oid
|
||||
res2 <- runAttemptT $ OpenId2.getForwardUrl oid complete2'
|
||||
msg <-
|
||||
case res2 of
|
||||
Failure e -> return $ toException e
|
||||
Success url -> redirectString RedirectTemporary url
|
||||
let complete' = render $ toMaster complete1
|
||||
res <- runAttemptT $ OpenId.getForwardUrl oid complete'
|
||||
attempt
|
||||
(\err -> do
|
||||
setMessage $ string $ unlines
|
||||
[ show err
|
||||
, msg
|
||||
, show $ toException msg
|
||||
]
|
||||
redirect RedirectTemporary $ toMaster LoginR
|
||||
)
|
||||
@ -70,10 +62,19 @@ authOpenId =
|
||||
toMaster <- getRouteToMaster
|
||||
setMessage $ string "No OpenID identifier found"
|
||||
redirect RedirectTemporary $ toMaster LoginR
|
||||
dispatch "GET" ["complete1"] = do
|
||||
dispatch "GET" ["complete1"] = completeHelper OpenId.authenticate
|
||||
dispatch "GET" ["complete2"] =
|
||||
completeHelper (fmap OpenId.Identifier . OpenId2.authenticate)
|
||||
dispatch _ _ = notFound
|
||||
|
||||
completeHelper
|
||||
:: YesodAuth m
|
||||
=> ([(String, String)] -> AttemptT (GHandler Auth m) OpenId.Identifier)
|
||||
-> GHandler Auth m ()
|
||||
completeHelper auth = do
|
||||
rr <- getRequest
|
||||
let gets' = reqGetParams rr
|
||||
res <- runAttemptT $ OpenId.authenticate gets'
|
||||
res <- runAttemptT $ auth gets'
|
||||
toMaster <- getRouteToMaster
|
||||
let onFailure err = do
|
||||
setMessage $ string $ show err
|
||||
@ -81,28 +82,3 @@ authOpenId =
|
||||
let onSuccess (OpenId.Identifier ident) =
|
||||
setCreds True $ Creds "openid" ident []
|
||||
attempt onFailure onSuccess res
|
||||
dispatch "GET" ["complete2"] = do
|
||||
amString <- lookupSession "OPENID_AM"
|
||||
deleteSession "OPENID_AM"
|
||||
params <- reqGetParams `fmap` getRequest
|
||||
let am = case amString >>= readMay of
|
||||
Nothing -> emptyAssociationMap
|
||||
Just x -> x
|
||||
let resolve = liftIO . makeRequest True
|
||||
render <- getUrlRender
|
||||
toMaster <- getRouteToMaster
|
||||
let complete2' = render $ toMaster complete2
|
||||
res <- liftIO $ verifyAuthentication am params complete2' resolve
|
||||
let mident = lookup "openid.identity" params
|
||||
case (res, mident) of
|
||||
(Right (), Just ident) ->
|
||||
setCreds True $ Creds "openid" ident []
|
||||
_ -> do
|
||||
setMessage $ string "Error logging in via OpenID"
|
||||
redirect RedirectTemporary $ toMaster LoginR
|
||||
dispatch _ _ = notFound
|
||||
|
||||
readMay :: Read a => String -> Maybe a
|
||||
readMay s = case reads s of
|
||||
(x, _):_ -> Just x
|
||||
[] -> Nothing
|
||||
|
||||
@ -13,7 +13,7 @@ homepage: http://docs.yesodweb.com/
|
||||
|
||||
library
|
||||
build-depends: base >= 4 && < 5
|
||||
, authenticate >= 0.6.5 && < 0.7
|
||||
, authenticate >= 0.6.6 && < 0.7
|
||||
, bytestring >= 0.9.1.4 && < 0.10
|
||||
, yesod >= 0.5.1 && < 0.6
|
||||
, wai >= 0.2 && < 0.3
|
||||
@ -23,7 +23,6 @@ library
|
||||
, data-object >= 0.3.1.3 && < 0.4
|
||||
, control-monad-attempt >= 0.3.0 && < 0.4
|
||||
, utf8-string >= 0.3.4 && < 0.4
|
||||
, openid >= 0.1.7 && < 0.2
|
||||
exposed-modules: Yesod.Helpers.Auth2
|
||||
Yesod.Helpers.Auth2.Email
|
||||
Yesod.Helpers.Auth2.Facebook
|
||||
|
||||
Loading…
Reference in New Issue
Block a user