Fixed rpxnow JSON code

Web/Authenticate/Rpxnow.hs

@@ -38,6 +38,8 @@ import Data.Attoparsec.Lazy (parse)
 import qualified Data.Attoparsec.Lazy as AT
 import Data.Text (Text)
 import qualified Data.Aeson.Types
+import qualified Data.Map as Map
+import Control.Applicative ((<$>), (<*>))
 
 -- | Information received from Rpxnow after a valid login.
 data Identifier = Identifier
@@ -101,9 +103,9 @@ unResult = either (failure . RpxnowException) return . AT.eitherResult
 parseProfile :: Value -> Data.Aeson.Types.Parser Identifier
 parseProfile (Object m) = do
     profile <- m .: "profile"
-    ident <- m .: "identifier"
-    let profile' = mapMaybe go profile
-    return $ Identifier ident profile'
+    Identifier
+        <$> (profile .: "identifier")
+        <*> return (mapMaybe go (Map.toList profile))
   where
     go ("identifier", _) = Nothing
     go (k, String v) = Just (k, v)

authenticate.cabal

@@ -1,5 +1,5 @@
 name:            authenticate
-version:         0.9.1.2
+version:         0.9.1.3
 license:         BSD3
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -34,7 +34,8 @@ library
                      http-types >= 0.6 && < 0.7,
                      enumerator >= 0.4.7 && < 0.5,
                      blaze-builder >= 0.2 && < 0.4,
-                     attoparsec >= 0.8.5 && < 0.9
+                     attoparsec >= 0.8.5 && < 0.9,
+                     containers
     exposed-modules: Web.Authenticate.Rpxnow,
                      Web.Authenticate.OpenId,
                      Web.Authenticate.OpenId.Providers,

rpxnow.hs

@@ -0,0 +1,38 @@
+{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}
+import Yesod
+import Web.Authenticate.Rpxnow
+import Data.Maybe (fromMaybe)
+import qualified Data.Aeson as A
+import qualified Data.Vector as V
+import qualified Data.Map as M
+import Data.Text (unpack)
+
+appName :: String
+appName = "yesod-test"
+apiKey = "c8043882f14387d7ad8dfc99a1a8dab2e028f690"
+data RP = RP
+type Handler = GHandler RP RP
+
+mkYesod "RP" [parseRoutes|
+/ RootR GET
+/complete CompleteR POST
+|]
+
+instance Yesod RP where approot _ = "http://localhost:3000"
+
+getRootR :: Handler RepHtml
+getRootR = defaultLayout [hamlet|
+<iframe src="http://#{appName}.rpxnow.com/openid/embed?token_url=@{CompleteR}" scrolling="no" frameBorder="no" allowtransparency="true" style="width:400px;height:240px">
+|]
+
+postCompleteR :: Handler RepHtml
+postCompleteR = do
+    Just token <- lookupPostParam "token"
+    Identifier ident extra <- liftIO $ authenticate apiKey $ unpack token
+    defaultLayout [hamlet|
+<h1>Ident: #{ident}
+<h2>Extra: #{show $ extra}
+|]
+
+main :: IO ()
+main = warpDebug 3000 RP