From ba671beb8dddd224618cefddd6fc9eaa59072803 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 5 Oct 2010 09:26:12 +0200 Subject: [PATCH] authenticate 0.6.6 --- Yesod/Helpers/Auth2/OpenId.hs | 76 ++++++++++++----------------------- yesod-auth.cabal | 3 +- 2 files changed, 27 insertions(+), 52 deletions(-) diff --git a/Yesod/Helpers/Auth2/OpenId.hs b/Yesod/Helpers/Auth2/OpenId.hs index 13f57aab..1a2e0a4d 100644 --- a/Yesod/Helpers/Auth2/OpenId.hs +++ b/Yesod/Helpers/Auth2/OpenId.hs @@ -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 diff --git a/yesod-auth.cabal b/yesod-auth.cabal index cc71323b..0634eda5 100644 --- a/yesod-auth.cabal +++ b/yesod-auth.cabal @@ -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