authenticate 0.6.6

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
+    dispatch "GET" ["forward"] = do
-        case normalizeIdentifier $ Identifier oid of
+        (roid, _, _) <- runFormGet $ stringInput name
-          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
         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

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