authenticate 0.8.2.2 → 0.9.0

raw patch · 8 files changed

+208/−135 lines, 8 filesdep +aesondep +attoparsecdep +blaze-builderdep −data-objectdep −data-object-jsondep −waidep ~http-enumeratorPVP ok

version bump matches the API change (PVP)

Dependencies added: aeson, attoparsec, blaze-builder, case-insensitive, enumerator, http-types, text

Dependencies removed: data-object, data-object-json, wai, wai-extra

Dependency ranges changed: http-enumerator

API changes (from Hackage documentation)

Files

• OpenId2/Discovery.hs +10/−9
• OpenId2/Normalization.hs +8/−5
• OpenId2/Types.hs +2/−1
• Web/Authenticate/Facebook.hs +65/−43
• Web/Authenticate/OAuth.hs +52/−27
• Web/Authenticate/OpenId.hs +28/−23
• Web/Authenticate/Rpxnow.hs +34/−21
• authenticate.cabal +9/−6

@@ -29,10 +29,11 @@ import qualified Data.ByteString.Lazy.UTF8 as BSLU import qualified Data.ByteString.Char8 as S8 import Control.Arrow (first, (***))-import Control.Monad.IO.Class (MonadIO)+import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Failure (Failure (failure)) import Control.Monad (mplus, liftM)-import Network.Wai (ciOriginal)+import qualified Data.CaseInsensitive as CI+import Data.Text (Text, pack, unpack)  data Discovery = Discovery1 String (Maybe String)                | Discovery2 Provider Identifier IdentType@@ -53,7 +54,7 @@             res2 <- discoverHTML ident             case res2 of                 Just x -> return x-                Nothing -> failure $ DiscoveryException i+                Nothing -> failure $ DiscoveryException $ unpack i  -- YADIS-Based Discovery ------------------------------------------------------- @@ -68,12 +69,12 @@               -> m (Maybe (Provider, Identifier, IdentType)) discoverYADIS _ _ 0 = failure TooManyRedirects discoverYADIS ident mb_loc redirects = do-    let uri = fromMaybe (identifier ident) mb_loc+    let uri = fromMaybe (unpack $ identifier ident) mb_loc     req <- parseUrl uri-    res <- httpLbs req+    res <- liftIO $ withManager $ httpLbs req     let mloc = fmap S8.unpack              $ lookup "x-xrds-location"-             $ map (first $ map toLower . S8.unpack . ciOriginal)+             $ map (first $ map toLower . S8.unpack . CI.original)              $ responseHeaders res     let mloc' = if mloc == mb_loc then Nothing else mloc     case statusCode res of@@ -95,7 +96,7 @@   where   isOpenId svc = do     let tys = serviceTypes svc-        localId = maybe ident Identifier $ listToMaybe $ serviceLocalIDs svc+        localId = maybe ident (Identifier . pack) $ listToMaybe $ serviceLocalIDs svc         f (x,y) | x `elem` tys = Just y                 | otherwise    = Nothing     (lid, itype) <- listToMaybe $ mapMaybe f@@ -117,7 +118,7 @@              => Identifier              -> m (Maybe Discovery) discoverHTML ident'@(Identifier ident) =-    (parseHTML ident' . BSLU.toString) `liftM` simpleHttp ident+    (parseHTML ident' . BSLU.toString) `liftM` simpleHttp (unpack ident)  -- | Parse out an OpenID endpoint and an actual identifier from an HTML -- document.@@ -135,7 +136,7 @@       return $ Discovery1 server delegate     resolve2 ls = do       prov <- lookup "openid2.provider" ls-      let lid = maybe ident Identifier $ lookup "openid2.local_id" ls+      let lid = maybe ident (Identifier . pack) $ lookup "openid2.local_id" ls       -- Based on OpenID 2.0 spec, section 7.3.3, HTML discovery can only       -- result in a claimed identifier.       return $ Discovery2 (Provider prov) lid ClaimedIdent

@@ -26,12 +26,13 @@     ( uriToString, normalizeCase, normalizeEscape     , normalizePathSegments, parseURI, uriPath, uriScheme, uriFragment     )+import Data.Text (Text, pack, unpack) -normalize :: Failure AuthenticateException m => String -> m Identifier+normalize :: Failure AuthenticateException m => Text -> m Identifier normalize ident =     case normalizeIdentifier $ Identifier ident of         Just i -> return i-        Nothing -> failure $ NormalizationException ident+        Nothing -> failure $ NormalizationException $ unpack ident  -- | Normalize an identifier, discarding XRIs. normalizeIdentifier :: Identifier -> Maybe Identifier@@ -42,12 +43,13 @@ -- normalize an XRI. normalizeIdentifier' :: (String -> Maybe String) -> Identifier                      -> Maybe Identifier-normalizeIdentifier' xri (Identifier str)+normalizeIdentifier' xri (Identifier str')   | null str                  = Nothing-  | "xri://" `isPrefixOf` str = Identifier `fmap` xri str-  | head str `elem` "=@+$!"   = Identifier `fmap` xri str+  | "xri://" `isPrefixOf` str = (Identifier . pack) `fmap` xri str+  | head str `elem` "=@+$!"   = (Identifier . pack) `fmap` xri str   | otherwise = fmt `fmap` (url >>= norm)   where+    str = unpack str'     url = parseURI str <|> parseURI ("http://" ++ str)      norm uri = validScheme >> return u@@ -59,6 +61,7 @@               | otherwise          = uriPath uri      fmt u = Identifier+          $ pack           $ normalizePathSegments           $ normalizeEscape           $ normalizeCase

@@ -21,12 +21,13 @@ import Data.Data (Data) import Data.Typeable (Typeable) import Web.Authenticate.Internal+import Data.Text (Text)  -- | An OpenID provider. newtype Provider = Provider { providerURI :: String } deriving (Eq,Show)  -- | A valid OpenID identifier.-newtype Identifier = Identifier { identifier :: String }+newtype Identifier = Identifier { identifier :: Text }     deriving (Eq, Ord, Show, Read, Data, Typeable)  data IdentType = OPIdent | ClaimedIdent

@@ -1,70 +1,92 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DeriveDataTypeable #-}-module Web.Authenticate.Facebook where+{-# LANGUAGE OverloadedStrings #-}+module Web.Authenticate.Facebook+    ( Facebook (..)+    , AccessToken (..)+    , getForwardUrl+    , getAccessToken+    , getGraphData+    ) where  import Network.HTTP.Enumerator import Data.List (intercalate)-import Data.Object-import Data.Object.Json+import Data.Aeson import qualified Data.ByteString.Lazy.Char8 as L8-import qualified Data.ByteString.Lazy as L-import qualified Data.ByteString as S import Web.Authenticate.Internal (qsEncode) import Data.Data (Data) import Data.Typeable (Typeable)+import Control.Exception (Exception, throwIO)+import Data.Attoparsec.Lazy (parse, eitherResult)+import qualified Data.ByteString.Char8 as S8+import Data.Text (Text, pack)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Blaze.ByteString.Builder (toByteString, copyByteString)+import Blaze.ByteString.Builder.Char.Utf8 (fromText)+import Network.HTTP.Types (renderQueryText)+import Data.Monoid (mappend)+import Data.ByteString (ByteString)  data Facebook = Facebook-    { facebookClientId :: String-    , facebookClientSecret :: String-    , facebookRedirectUri :: String+    { facebookClientId :: Text+    , facebookClientSecret :: Text+    , facebookRedirectUri :: Text     }     deriving (Show, Eq, Read, Ord, Data, Typeable) -newtype AccessToken = AccessToken { unAccessToken :: String }+newtype AccessToken = AccessToken { unAccessToken :: Text }     deriving (Show, Eq, Read, Ord, Data, Typeable) -getForwardUrl :: Facebook -> [String] -> String-getForwardUrl fb perms = concat-    [ "https://graph.facebook.com/oauth/authorize?client_id="-    , qsEncode $ facebookClientId fb-    , "&redirect_uri="-    , qsEncode $ facebookRedirectUri fb-    , if null perms-        then ""-        else "&scope=" ++ qsEncode (intercalate "," perms)-    ]+getForwardUrl :: Facebook -> [Text] -> Text+getForwardUrl fb perms =+    TE.decodeUtf8 $ toByteString $+    copyByteString "https://graph.facebook.com/oauth/authorize"+    `mappend`+    renderQueryText True+        ( ("client_id", Just $ facebookClientId fb)+        : ("redirect_uri", Just $ facebookRedirectUri fb)+        : if null perms+            then []+            else [("scope", Just $ T.intercalate "," perms)]) -accessTokenUrl :: Facebook -> String -> String-accessTokenUrl fb code = concat-    [ "https://graph.facebook.com/oauth/access_token?client_id="-    , qsEncode $ facebookClientId fb-    , "&redirect_uri="-    , qsEncode $ facebookRedirectUri fb-    , "&client_secret="-    , qsEncode $ facebookClientSecret fb-    , "&code="-    , qsEncode code-    ] -getAccessToken :: Facebook -> String -> IO AccessToken+accessTokenUrl :: Facebook -> Text -> ByteString+accessTokenUrl fb code =+    toByteString $+    copyByteString "https://graph.facebook.com/oauth/access_token"+    `mappend`+    renderQueryText True+        [ ("client_id", Just $ facebookClientId fb)+        , ("redirect_uri", Just $ facebookRedirectUri fb)+        , ("code", Just code)+        ]++getAccessToken :: Facebook -> Text -> IO AccessToken getAccessToken fb code = do     let url = accessTokenUrl fb code-    b <- simpleHttp url+    b <- simpleHttp $ S8.unpack url     let (front, back) = splitAt 13 $ L8.unpack b     case front of-        "access_token=" -> return $ AccessToken back+        "access_token=" -> return $ AccessToken $ T.pack back         _ -> error $ "Invalid facebook response: " ++ back -graphUrl :: AccessToken -> String -> String-graphUrl (AccessToken s) func = concat-    [ "https://graph.facebook.com/"-    , func-    , "?access_token="-    , s-    ]+graphUrl :: AccessToken -> Text -> ByteString+graphUrl (AccessToken s) func =+    toByteString $+    copyByteString "https://graph.facebook.com/"+    `mappend` fromText func+    `mappend` renderQueryText True [("access_token", Just s)] -getGraphData :: AccessToken -> String -> IO StringObject+getGraphData :: AccessToken -> Text -> IO (Either String Value) getGraphData at func = do     let url = graphUrl at func-    b <- simpleHttp url-    decode $ S.concat $ L.toChunks b+    b <- simpleHttp $ S8.unpack url+    return $ eitherResult $ parse json b++getGraphData' :: AccessToken -> Text -> IO Value+getGraphData' a b = getGraphData a b >>= either (throwIO . InvalidJsonException) return++data InvalidJsonException = InvalidJsonException String+    deriving (Show, Typeable)+instance Exception InvalidJsonException

@@ -20,7 +20,7 @@ import qualified Data.ByteString.Lazy.Char8 as BSL import Data.Maybe import Control.Applicative-import Network.Wai.Parse+import Network.HTTP.Types (parseSimpleQuery) import Control.Exception import Control.Monad import Data.List (sortBy)@@ -30,9 +30,14 @@ import Data.ByteString.Base64 import Data.Time import Numeric-import Network.Wai (ResponseHeader) import Codec.Crypto.RSA (rsassa_pkcs1_v1_5_sign, ha_SHA1, PrivateKey(..))-+import Network.HTTP.Types (Header)+import Control.Arrow (second)+import Blaze.ByteString.Builder (toByteString)+import Data.Enumerator (($$), run_, Stream (..), continue)+import Data.Monoid (mconcat)+import Control.Monad.IO.Class (MonadIO (liftIO))+import Data.IORef (newIORef, readIORef, atomicModifyIORef)  -- | Data type for OAuth client (consumer). data OAuth = OAuth { oauthServerName      :: String        -- ^ Service name@@ -85,10 +90,10 @@ getTemporaryCredential :: OAuth         -- ^ OAuth Application                        -> IO Credential -- ^ Temporary Credential (Request Token & Secret). getTemporaryCredential oa = do-  let req = fromJust $ parseUrl (oauthRequestUri oa)+  let req = fromJust $ parseUrl $ oauthRequestUri oa   req' <- signOAuth oa emptyCredential (req { method = "POST" }) -  rsp <- httpLbs req'-  let dic = parseQueryString . toStrict . responseBody $ rsp+  rsp <- withManager $ httpLbs req'+  let dic = parseSimpleQuery . toStrict . responseBody $ rsp   return $ Credential dic  -- | URL to obtain OAuth verifier.@@ -104,8 +109,8 @@                -> IO Credential -- ^ Token Credential (Access Token & Secret) getAccessToken oa cr = do   let req = (fromJust $ parseUrl $ oauthAccessTokenUri oa) { method = "POST" }-  rsp <- signOAuth oa cr req >>= httpLbs-  let dic = parseQueryString . toStrict . responseBody $ rsp+  rsp <- signOAuth oa cr req >>= withManager . httpLbs+  let dic = parseSimpleQuery . toStrict . responseBody $ rsp   return $ Credential dic  getTokenCredential = getAccessToken@@ -136,12 +141,12 @@ -- | Add OAuth headers & sign to 'Request'. signOAuth :: OAuth              -- ^ OAuth Application           -> Credential         -- ^ Credential-          -> Request            -- ^ Original Request-          -> IO Request         -- ^ Signed OAuth Request+          -> Request IO         -- ^ Original Request+          -> IO (Request IO)    -- ^ Signed OAuth Request signOAuth oa crd req = do   crd' <- addTimeStamp =<< addNonce crd   let tok = injectOAuthToCred oa crd'-      sign = genSign oa tok req+  sign <- genSign oa tok req   return $ addAuthHeader (insert "oauth_signature" sign tok) req  baseTime :: UTCTime@@ -171,19 +176,19 @@           , ("oauth_version", "1.0")           ] cred -genSign :: OAuth -> Credential -> Request -> BS.ByteString+genSign :: MonadIO m => OAuth -> Credential -> Request m -> m BS.ByteString genSign oa tok req =   case oauthSignatureMethod oa of-    HMACSHA1 ->-      let text = getBaseString tok req-          key  = BS.intercalate "&" $ map paramEncode [oauthConsumerSecret oa, tokenSecret tok]-      in encode $ toStrict $ bytestringDigest $ hmacSha1 (fromStrict key) text+    HMACSHA1 -> do+      text <- getBaseString tok req+      let key  = BS.intercalate "&" $ map paramEncode [oauthConsumerSecret oa, tokenSecret tok]+      return $ encode $ toStrict $ bytestringDigest $ hmacSha1 (fromStrict key) text     PLAINTEXT ->-      BS.intercalate "&" $ map paramEncode [oauthConsumerSecret oa, tokenSecret tok]+      return $ BS.intercalate "&" $ map paramEncode [oauthConsumerSecret oa, tokenSecret tok]     RSASHA1 pr ->-      encode $ toStrict $ rsassa_pkcs1_v1_5_sign ha_SHA1 pr (getBaseString tok req)+      liftM (encode . toStrict . rsassa_pkcs1_v1_5_sign ha_SHA1 pr) (getBaseString tok req) -addAuthHeader :: Credential -> Request -> Request+addAuthHeader :: Credential -> Request a -> Request a addAuthHeader (Credential cred) req =   req { requestHeaders = insertMap "Authorization" (renderAuthHeader cred) $ requestHeaders req } @@ -199,24 +204,44 @@                                oct = '%' : replicate (2 - length num) '0' ++ num                            in BS.pack oct -getBaseString :: Credential -> Request -> BSL.ByteString-getBaseString tok req =+getBaseString :: MonadIO m => Credential -> Request m -> m BSL.ByteString+getBaseString tok req = do   let bsMtd  = BS.map toUpper $ method req       isHttps = secure req       scheme = if isHttps then "https" else "http"       bsPort = if (isHttps && port req /= 443) || (not isHttps && port req /= 80)                  then ':' `BS.cons` BS.pack (show $ port req) else ""       bsURI = BS.concat [scheme, "://", host req, bsPort, path req]-      bsQuery = queryString req-      bsBodyQ = if isBodyFormEncoded $ requestHeaders req-                  then parseQueryString (toStrict $ requestBody req) else []-      bsAuthParams = filter ((`notElem`["oauth_signature","realm", "oauth_token_secret"]).fst) $ unCredential tok+      bsQuery = map (second $ fromMaybe "") $ queryString req+  bsBodyQ <- if isBodyFormEncoded $ requestHeaders req+                  then liftM parseSimpleQuery $ toLBS (requestBody req)+                  else return []+  let bsAuthParams = filter ((`notElem`["oauth_signature","realm", "oauth_token_secret"]).fst) $ unCredential tok       allParams = bsQuery++bsBodyQ++bsAuthParams       bsParams = BS.intercalate "&" $ map (\(a,b)->BS.concat[a,"=",b]) $ sortBy compareTuple                    $ map (\(a,b) -> (paramEncode a,paramEncode b)) allParams-  in BSL.intercalate "&" $ map (fromStrict.paramEncode) [bsMtd, bsURI, bsParams]+  -- FIXME it would be much better to use http-types functions here+  return $ BSL.intercalate "&" $ map (fromStrict.paramEncode) [bsMtd, bsURI, bsParams] -isBodyFormEncoded :: [(ResponseHeader, BS.ByteString)] -> Bool+toLBS :: MonadIO m => RequestBody m -> m BS.ByteString+toLBS (RequestBodyLBS l) = return $ toStrict l+toLBS (RequestBodyBS s) = return s+toLBS (RequestBodyBuilder _ b) = return $ toByteString b+toLBS (RequestBodyEnum _ enum) = do+    i <- liftIO $ newIORef id+    run_ $ enum $$ go i+    liftIO $ liftM (toByteString . mconcat . ($ [])) $ readIORef i+  where+    go i =+        continue go'+      where+        go' (Chunks []) = continue go'+        go' (Chunks x) = do+            liftIO (atomicModifyIORef i $ \y -> (y . (x ++), ()))+            continue go'+        go' EOF = return ()++isBodyFormEncoded :: [Header] -> Bool isBodyFormEncoded = maybe False (=="application/x-www-form-urlencoded") . lookup "Content-Type"  compareTuple :: (Ord a, Ord b) => (a, b) -> (a, b) -> Ordering

@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-} module Web.Authenticate.OpenId     ( getForwardUrl     , authenticate@@ -17,30 +18,33 @@ import qualified Data.ByteString.Lazy.UTF8 as BSLU import Network.HTTP.Enumerator     ( parseUrl, urlEncodedBody, responseBody, httpLbsRedirect-    , HttpException+    , HttpException, withManager     ) import Control.Arrow ((***)) import Data.List (unfoldr) import Data.Maybe (fromMaybe)+import Data.Text (Text, pack, unpack)+import Data.Text.Encoding (encodeUtf8)  getForwardUrl     :: ( MonadIO m        , Failure AuthenticateException m        , Failure HttpException m        )-    => String -- ^ The openid the user provided.-    -> String -- ^ The URL for this application\'s complete page.-    -> Maybe String -- ^ Optional realm-    -> [(String, String)] -- ^ Additional parameters to send to the OpenID provider. These can be useful for using extensions.-    -> m String -- ^ URL to send the user to.+    => Text -- ^ The openid the user provided.+    -> Text -- ^ The URL for this application\'s complete page.+    -> Maybe Text -- ^ Optional realm+    -> [(Text, Text)] -- ^ Additional parameters to send to the OpenID provider. These can be useful for using extensions.+    -> m Text -- ^ URL to send the user to. getForwardUrl openid' complete mrealm params = do     let realm = fromMaybe complete mrealm     disc <- normalize openid' >>= discover     case disc of         Discovery1 server mdelegate ->-            return $ qsUrl server+            return $ pack $ qsUrl server+                $ map (unpack *** unpack) -- FIXME                 $ ("openid.mode", "checkid_setup")-                : ("openid.identity", fromMaybe openid' mdelegate)+                : ("openid.identity", maybe openid' pack mdelegate)                 : ("openid.return_to", complete)                 : ("openid.realm", realm)                 : ("openid.trust_root", complete)@@ -50,22 +54,22 @@                     case itype of                         ClaimedIdent -> i                         OPIdent -> "http://specs.openid.net/auth/2.0/identifier_select"-            return $ qsUrl p+            return $ pack $ qsUrl p                 $ ("openid.ns", "http://specs.openid.net/auth/2.0")                 : ("openid.mode", "checkid_setup")-                : ("openid.claimed_id", i')-                : ("openid.identity", i')-                : ("openid.return_to", complete)-                : ("openid.realm", realm)-                : params+                : ("openid.claimed_id", unpack i')+                : ("openid.identity", unpack i')+                : ("openid.return_to", unpack complete)+                : ("openid.realm", unpack realm)+                : map (unpack *** unpack) params  authenticate     :: ( MonadIO m        , Failure AuthenticateException m        , Failure HttpException m        )-    => [(String, String)]-    -> m (Identifier, [(String, String)])+    => [(Text, Text)]+    -> m (Identifier, [(Text, Text)]) authenticate params = do     unless (lookup "openid.mode" params == Just "id_res")         $ failure $ case lookup "openid.mode" params of@@ -74,8 +78,8 @@                             | m == "error" ->                                 case lookup "openid.error" params of                                   Nothing -> AuthenticationException "An error occurred, but no error message was provided."-                                  (Just e) -> AuthenticationException e-                            | otherwise -> AuthenticationException $ "mode is " ++ m ++ " but we were expecting id_res."+                                  (Just e) -> AuthenticationException $ unpack e+                            | otherwise -> AuthenticationException $ "mode is " ++ unpack m ++ " but we were expecting id_res."     ident <- case lookup "openid.identity" params of                 Just i -> return i                 Nothing ->@@ -84,20 +88,21 @@     let endpoint = case disc of                     Discovery1 p _ -> p                     Discovery2 (Provider p) _ _ -> p-    let params' = map (BSU.fromString *** BSU.fromString)+    let params' = map (encodeUtf8 *** encodeUtf8)                 $ ("openid.mode", "check_authentication")                 : filter (\(k, _) -> k /= "openid.mode") params     req' <- parseUrl endpoint     let req = urlEncodedBody params' req'-    rsp <- httpLbsRedirect req-    let rps = parseDirectResponse $ BSLU.toString $ responseBody rsp+    rsp <- liftIO $ withManager $ httpLbsRedirect req+    let rps = parseDirectResponse $ pack $ BSLU.toString $ responseBody rsp -- FIXME     case lookup "is_valid" rps of         Just "true" -> return (Identifier ident, rps)         _ -> failure $ AuthenticationException "OpenID provider did not validate"  -- | Turn a response body into a list of parameters.-parseDirectResponse :: String -> [(String, String)]-parseDirectResponse  = unfoldr step+parseDirectResponse :: Text -> [(Text, Text)]+parseDirectResponse  =+    map (pack *** pack) . unfoldr step . unpack   where     step []  = Nothing     step str = case split (== '\n') str of

@@ -22,8 +22,7 @@     , AuthenticateException (..)     ) where -import Data.Object-import Data.Object.Json+import Data.Aeson import Network.HTTP.Enumerator import "transformers" Control.Monad.IO.Class import Control.Failure@@ -35,20 +34,22 @@ import Web.Authenticate.Internal import Data.Data (Data) import Data.Typeable (Typeable)+import Data.Attoparsec.Lazy (parse)+import qualified Data.Attoparsec.Lazy as AT+import Data.Text (Text)+import qualified Data.Aeson.Types  -- | Information received from Rpxnow after a valid login. data Identifier = Identifier-    { identifier :: String-    , extraData :: [(String, String)]+    { identifier :: Text+    , extraData :: [(Text, Text)]     }     deriving (Eq, Ord, Read, Show, Data, Typeable)  -- | Attempt to log a user in. authenticate :: (MonadIO m,                  Failure HttpException m,-                 Failure AuthenticateException m,-                 Failure ObjectExtractError m,-                 Failure JsonDecodeError m)+                 Failure AuthenticateException m)              => String -- ^ API key given by RPXNOW.              -> String -- ^ Token passed by client.              -> m Identifier@@ -70,27 +71,39 @@                 , requestHeaders =                     [ ("Content-Type", "application/x-www-form-urlencoded")                     ]-                , requestBody = body+                , requestBody = RequestBodyLBS body+                , checkCerts = const $ return True                 }-    res <- httpLbsRedirect req+    res <- liftIO $ withManager $ httpLbsRedirect req     let b = responseBody res     unless (200 <= statusCode res && statusCode res < 300) $         liftIO $ throwIO $ StatusCodeException (statusCode res) b-    o <- decode $ S.concat $ L.toChunks b-    m <- fromMapping o-    stat <- lookupScalar "stat" m-    unless (stat == "ok") $ failure $ RpxnowException $-        "Rpxnow login not accepted: " ++ stat ++ "\n" ++ L.unpack b-    parseProfile m+    o <- unResult $ parse json b+    --m <- fromMapping o+    let mstat = flip Data.Aeson.Types.parse o $ \v ->+                case v of+                    Object m -> m .: "stat"+                    _ -> mzero+    case mstat of+        Success "ok" -> return ()+        Success stat -> failure $ RpxnowException $+            "Rpxnow login not accepted: " ++ stat ++ "\n" ++ L.unpack b+        _ -> failure $ RpxnowException "Now stat value found on Rpxnow response"+    case Data.Aeson.Types.parse parseProfile o of+        Success x -> return x+        Error e -> failure $ RpxnowException $ "Unable to parse Rpxnow response: " ++ e -parseProfile :: (Monad m, Failure ObjectExtractError m)-             => [(String, StringObject)] -> m Identifier-parseProfile m = do-    profile <- lookupMapping "profile" m-    ident <- lookupScalar "identifier" profile+unResult :: Failure AuthenticateException m => AT.Result a -> m a+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'   where     go ("identifier", _) = Nothing-    go (k, Scalar v) = Just (k, v)+    go (k, String v) = Just (k, v)     go _ = Nothing+parseProfile _ = mzero

@@ -1,5 +1,5 @@ name:            authenticate-version:         0.8.2.2+version:         0.9.0 license:         BSD3 license-file:    LICENSE author:          Michael Snoyman <michael@snoyman.com>@@ -15,9 +15,8 @@  library     build-depends:   base >= 4 && < 5,-                     data-object >= 0.3.1 && < 0.4,-                     data-object-json >= 0.3.1 && < 0.4,-                     http-enumerator >= 0.3.0 && < 0.4,+                     aeson >= 0.3.1.1 && < 0.4,+                     http-enumerator >= 0.6 && < 0.7,                      tagsoup >= 0.6 && < 0.13,                      failure >= 0.0.0 && < 0.2,                      transformers >= 0.1 && < 0.3,@@ -25,13 +24,17 @@                      utf8-string >= 0.3 && < 0.4,                      network >= 2.2.1 && < 2.4,                      xml >= 1.3.7 && < 1.4,-                     wai >= 0.3 && < 0.4,+                     case-insensitive >= 0.2 && < 0.3,                      RSA >= 1.0 && < 1.1,                      time >= 1.1 && < 1.3,                      base64-bytestring >= 0.1 && < 0.2,                      SHA >= 1.4 && < 1.5,                      random >= 1.0 && < 1.1,-                     wai-extra >= 0.3 && < 0.4+                     text >= 0.5 && < 1.0,+                     http-types >= 0.6 && < 0.7,+                     enumerator >= 0.4.7 && < 0.5,+                     blaze-builder >= 0.2 && < 0.4,+                     attoparsec >= 0.8.5 && < 0.9     exposed-modules: Web.Authenticate.Rpxnow,                      Web.Authenticate.OpenId,                      Web.Authenticate.OpenId.Providers,