From 7ebf584f5272012f80225c5bbd5650ed7cffae8b Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 24 Sep 2010 09:00:37 +0200 Subject: [PATCH] Migrate to http-enumerator --- Web/Authenticate/Facebook.hs | 14 ++++++------ Web/Authenticate/OpenId.hs | 42 +++++++++++++++++++++--------------- Web/Authenticate/Rpxnow.hs | 42 +++++++++++++++++++++++++++--------- authenticate.cabal | 4 ++-- facebook.hs | 7 +++--- 5 files changed, 71 insertions(+), 38 deletions(-) diff --git a/Web/Authenticate/Facebook.hs b/Web/Authenticate/Facebook.hs index 6c440004..eb8acb36 100644 --- 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 @@ accessTokenUrl fb code = concat 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 @@ graphUrl (AccessToken s) func = concat 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 index 548ff0b9..85110087 100644 --- a/Web/Authenticate/OpenId.hs +++ b/Web/Authenticate/OpenId.hs @@ -23,7 +23,7 @@ module Web.Authenticate.OpenId , 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 Data.Data 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 @@ instance Monad Error where 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 @@ getOpenIdVar var content = do 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 @@ alookup :: (Failure AuthenticateException m, Monad m) -> [(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 @@ data AuthenticateException = AuthenticateException String 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 index 676960da..abe4521d 100644 --- 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 @@ module Web.Authenticate.Rpxnow 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 @@ data Identifier = Identifier -- | 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 @@ authenticate :: (MonadIO m, -> 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 index 738f1dad..ca8dcf9d 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.6.3.2 +version: 0.6.4 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -17,7 +17,7 @@ library 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, + http-enumerator >= 0.1.1 && < 0.2, tagsoup >= 0.6 && < 0.12, failure >= 0.0.0 && < 0.2, transformers >= 0.1 && < 0.3, diff --git a/facebook.hs b/facebook.hs index 585f90cb..b88459ca 100644 --- a/facebook.hs +++ b/facebook.hs @@ -3,6 +3,7 @@ import Yesod import Web.Authenticate.Facebook import Data.Object import Data.Maybe (fromMaybe) +import Network.HTTP.Enumerator data FB = FB Facebook fb :: FB @@ -22,9 +23,9 @@ getRootR = do getFacebookR = do FB f <- getYesod - code <- runFormGet $ required $ input "code" + code <- runFormGet' $ stringInput "code" at <- liftIO $ getAccessToken f code - mreq <-runFormGet $ optional $ input "req" + mreq <- runFormGet' $ maybeStringInput "req" let req = fromMaybe "me" mreq so <- liftIO $ getGraphData at req let so' = objToHamlet so @@ -39,7 +40,7 @@ getFacebookR = do ^so'^ |] -main = toWaiApp fb >>= basicHandler 3000 +main = withHttpEnumerator $ basicHandler 3000 fb objToHamlet :: StringObject -> Hamlet url objToHamlet (Scalar s) = [$hamlet|$string.s$|]