diff --git a/Web/Authenticate/Facebook.hs b/Web/Authenticate/Facebook.hs --- a/Web/Authenticate/Facebook.hs +++ b/Web/Authenticate/Facebook.hs @@ -1,11 +1,13 @@ {-# LANGUAGE FlexibleContexts #-} module Web.Authenticate.Facebook where -import Network.HTTP.Wget +import Network.HTTP.Enumerator import Data.List (intercalate) import Data.Object import Data.Object.Json -import Data.ByteString.Char8 (pack) +import qualified Data.ByteString.Lazy.Char8 as L8 +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString as S data Facebook = Facebook { facebookClientId :: String @@ -43,8 +45,8 @@ getAccessToken :: Facebook -> String -> IO AccessToken getAccessToken fb code = do let url = accessTokenUrl fb code - b <- wget url [] [] - let (front, back) = splitAt 13 b + b <- simpleHttp url + let (front, back) = splitAt 13 $ L8.unpack b case front of "access_token=" -> return $ AccessToken back _ -> error $ "Invalid facebook response: " ++ back @@ -60,5 +62,5 @@ getGraphData :: AccessToken -> String -> IO StringObject getGraphData at func = do let url = graphUrl at func - b <- wget url [] [] - decode $ pack b + b <- simpleHttp url + decode $ S.concat $ L.toChunks b diff --git a/Web/Authenticate/OpenId.hs b/Web/Authenticate/OpenId.hs --- a/Web/Authenticate/OpenId.hs +++ b/Web/Authenticate/OpenId.hs @@ -23,7 +23,7 @@ , AuthenticateException (..) ) where -import Network.HTTP.Wget +import Network.HTTP.Enumerator import Text.HTML.TagSoup import Numeric (showHex) import "transformers" Control.Monad.IO.Class @@ -31,6 +31,7 @@ import Control.Failure hiding (Error) import Control.Exception import Control.Monad (liftM) +import qualified Data.ByteString.Lazy.Char8 as L8 -- | An openid identifier (ie, a URL). newtype Identifier = Identifier { identifier :: String } @@ -44,12 +45,16 @@ fail s = Error s -- | Returns a URL to forward the user to in order to login. -getForwardUrl :: (MonadIO m, Failure WgetException m) +getForwardUrl :: (MonadIO m, + Failure InvalidUrlException m, + Failure HttpException m + ) => String -- ^ The openid the user provided. -> String -- ^ The URL for this application\'s complete page. -> m String -- ^ URL to send the user to. getForwardUrl openid complete = do - bodyIdent <- wget openid [] [] + bodyIdent' <- simpleHttp openid + let bodyIdent = L8.unpack bodyIdent' server <- getOpenIdVar "server" bodyIdent let delegate = maybe openid id $ getOpenIdVar "delegate" bodyIdent @@ -70,25 +75,28 @@ mhead [] = fail $ "Variable not found: openid." ++ var -- FIXME mhead (x:_) = return x -constructUrl :: String -> [(String, String)] -> String +constructUrl :: String -> [(String, String)] -> String -- FIXME no longer needed, use Request value directly constructUrl url [] = url -constructUrl url args = url ++ "?" ++ queryString args +constructUrl url args = url ++ "?" ++ queryString' args where - queryString [] = error "queryString with empty args cannot happen" - queryString [first] = onePair first - queryString (first:rest) = onePair first ++ "&" ++ queryString rest + queryString' [] = error "queryString with empty args cannot happen" + queryString' [first] = onePair first + queryString' (first:rest) = onePair first ++ "&" ++ queryString' rest onePair (x, y) = urlEncode x ++ "=" ++ urlEncode y -- | Handle a redirect from an OpenID provider and check that the user -- logged in properly. If it was successfully, 'return's the openid. -- Otherwise, 'failure's an explanation. -authenticate :: (MonadIO m, Failure WgetException m, - Failure AuthenticateException m) +authenticate :: (MonadIO m, + Failure AuthenticateException m, + Failure InvalidUrlException m, + Failure HttpException m) => [(String, String)] -> m Identifier authenticate req = do -- FIXME check openid.mode == id_res (not cancel) authUrl <- getAuthUrl req - content <- wget authUrl [] [] + content' <- simpleHttp authUrl + let content = L8.unpack content' let isValid = contains "is_valid:true" content if isValid then Identifier `liftM` alookup "openid.identity" req @@ -99,7 +107,7 @@ -> [(String, String)] -> m String alookup k x = case lookup k x of - Just k -> return k + Just k' -> return k' Nothing -> failure $ MissingOpenIdParameter k data AuthenticateException = AuthenticateException String @@ -107,14 +115,14 @@ deriving (Show, Typeable) instance Exception AuthenticateException -getAuthUrl :: (MonadIO m, - Failure AuthenticateException m, - Failure WgetException m) +getAuthUrl :: (MonadIO m, Failure AuthenticateException m, + Failure InvalidUrlException m, + Failure HttpException m) => [(String, String)] -> m String getAuthUrl req = do identity <- alookup "openid.identity" req - idContent <- wget identity [] [] - helper idContent + idContent <- simpleHttp identity + helper $ L8.unpack idContent where helper idContent = do server <- getOpenIdVar "server" idContent diff --git a/Web/Authenticate/Rpxnow.hs b/Web/Authenticate/Rpxnow.hs --- a/Web/Authenticate/Rpxnow.hs +++ b/Web/Authenticate/Rpxnow.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} {-# LANGUAGE PackageImports #-} +{-# LANGUAGE OverloadedStrings #-} --------------------------------------------------------- -- -- Module : Web.Authenticate.Rpxnow @@ -21,13 +22,15 @@ import Data.Object import Data.Object.Json -import Network.HTTP.Wget +import Network.HTTP.Enumerator import "transformers" Control.Monad.IO.Class import Control.Failure import Data.Maybe import Web.Authenticate.OpenId (AuthenticateException (..)) import Control.Monad -import Data.ByteString.Char8 (pack) +import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Lazy.Char8 as L +import Control.Exception (throwIO) -- | Information received from Rpxnow after a valid login. data Identifier = Identifier @@ -37,7 +40,8 @@ -- | Attempt to log a user in. authenticate :: (MonadIO m, - Failure WgetException m, + Failure HttpException m, + Failure InvalidUrlException m, Failure AuthenticateException m, Failure ObjectExtractError m, Failure JsonDecodeError m) @@ -45,16 +49,34 @@ -> String -- ^ Token passed by client. -> m Identifier authenticate apiKey token = do - b <- wget "https://rpxnow.com/api/v2/auth_info" - [] - [ ("apiKey", apiKey) - , ("token", token) - ] - o <- decode $ pack b + let body = L.fromChunks + [ "apiKey=" + , S.pack apiKey + , "&token=" + , S.pack token + ] + let req = + Request + { method = "POST" + , secure = True + , host = "rpxnow.com" + , port = 443 + , path = "api/v2/auth_info" + , queryString = [] + , requestHeaders = + [ ("Content-Type", "application/x-www-form-urlencoded") + ] + , requestBody = body + } + res <- httpLbsRedirect req + let b = responseBody res + unless (200 <= statusCode res && statusCode res < 300) $ + liftIO $ throwIO $ HttpException (statusCode res) b + o <- decode $ S.concat $ L.toChunks b m <- fromMapping o stat <- lookupScalar "stat" m unless (stat == "ok") $ failure $ AuthenticateException $ - "Rpxnow login not accepted: " ++ stat ++ "\n" ++ b + "Rpxnow login not accepted: " ++ stat ++ "\n" ++ L.unpack b parseProfile m parseProfile :: (Monad m, Failure ObjectExtractError m) diff --git a/authenticate.cabal b/authenticate.cabal --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.6.3.1 +version: 0.6.4 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -17,8 +17,8 @@ build-depends: base >= 4 && < 5, data-object >= 0.3.1 && < 0.4, data-object-json >= 0.3.1 && < 0.4, - http-wget >= 0.6 && < 0.7, - tagsoup >= 0.6 && < 0.11, + http-enumerator >= 0.1.1 && < 0.2, + tagsoup >= 0.6 && < 0.12, failure >= 0.0.0 && < 0.2, transformers >= 0.1 && < 0.3, bytestring >= 0.9 && < 0.10