Migrate to http-enumerator

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

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

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)

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 <michael@snoyman.com>
@@ -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,

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$|]