diff --git a/OpenId2/Discovery.hs b/OpenId2/Discovery.hs --- a/OpenId2/Discovery.hs +++ b/OpenId2/Discovery.hs @@ -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 diff --git a/OpenId2/Normalization.hs b/OpenId2/Normalization.hs --- a/OpenId2/Normalization.hs +++ b/OpenId2/Normalization.hs @@ -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 diff --git a/OpenId2/Types.hs b/OpenId2/Types.hs --- a/OpenId2/Types.hs +++ b/OpenId2/Types.hs @@ -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 diff --git a/Web/Authenticate/Facebook.hs b/Web/Authenticate/Facebook.hs --- a/Web/Authenticate/Facebook.hs +++ b/Web/Authenticate/Facebook.hs @@ -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 diff --git a/Web/Authenticate/OAuth.hs b/Web/Authenticate/OAuth.hs --- a/Web/Authenticate/OAuth.hs +++ b/Web/Authenticate/OAuth.hs @@ -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 diff --git a/Web/Authenticate/OpenId.hs b/Web/Authenticate/OpenId.hs --- a/Web/Authenticate/OpenId.hs +++ b/Web/Authenticate/OpenId.hs @@ -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 diff --git a/Web/Authenticate/Rpxnow.hs b/Web/Authenticate/Rpxnow.hs --- a/Web/Authenticate/Rpxnow.hs +++ b/Web/Authenticate/Rpxnow.hs @@ -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 diff --git a/authenticate.cabal b/authenticate.cabal --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.8.2.2 +version: 0.9.0 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -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,