OpenID 2 support

Yesod/Helpers/Auth2/OpenId.hs

@@ -7,13 +7,15 @@ import Yesod
 import Yesod.Helpers.Auth2
 import qualified Web.Authenticate.OpenId as OpenId
 import Control.Monad.Attempt
+import Network.OpenID
 
 authOpenId :: YesodAuth m => AuthPlugin m
 authOpenId =
     AuthPlugin "openid" dispatch login
   where
     forward = PluginR "openid" ["forward"]
-    complete = PluginR "openid" ["complete"]
+    complete1 = PluginR "openid" ["complete1"]
+    complete2 = PluginR "openid" ["complete2"]
     name = "openid_identifier"
     login = do
         tm <- liftHandler getRouteToMaster
@@ -28,25 +30,47 @@ authOpenId =
     %input#openid!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
         case roid of
             FormSuccess oid -> do
                 render <- getUrlRender
                 toMaster <- getRouteToMaster
-                let complete' = render $ toMaster complete
+                let complete2' = render $ toMaster complete2
+                msg <- forward2 complete2' oid
+                let complete' = render $ toMaster complete1
                 res <- runAttemptT $ OpenId.getForwardUrl oid complete'
                 attempt
                   (\err -> do
-                        setMessage $ string $ show err
-                        redirect RedirectTemporary $ toMaster LoginR)
+                        setMessage $ string $ unlines
+                            [ show err
+                            , msg
+                            ]
+                        redirect RedirectTemporary $ toMaster LoginR
+                        )
                   (redirectString RedirectTemporary)
                   res
             _ -> do
                 toMaster <- getRouteToMaster
                 setMessage $ string "No OpenID identifier found"
                 redirect RedirectTemporary $ toMaster LoginR
-    dispatch "GET" ["complete"] = do
+    dispatch "GET" ["complete1"] = do
         rr <- getRequest
         let gets' = reqGetParams rr
         res <- runAttemptT $ OpenId.authenticate gets'
@@ -57,4 +81,28 @@ 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

@@ -1,5 +1,5 @@
 name:            yesod-auth
-version:         0.0.0
+version:         0.0.1
 license:         BSD3
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -13,7 +13,7 @@ homepage:        http://docs.yesodweb.com/
 
 library
     build-depends:   base                    >= 4         && < 5
-                   , authenticate            >= 0.6.4     && < 0.7
+                   , authenticate            >= 0.6.5     && < 0.7
                    , bytestring              >= 0.9.1.4   && < 0.10
                    , yesod                   >= 0.5.1     && < 0.6
                    , wai                     >= 0.2       && < 0.3
@@ -23,6 +23,7 @@ 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