authenticate 0.6.3.1 → 0.6.4

raw patch · 4 files changed

+68/−36 lines, 4 filesdep +http-enumeratordep −http-wgetdep ~tagsoupPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: http-enumerator

Dependencies removed: http-wget

Dependency ranges changed: tagsoup

API changes (from Hackage documentation)

Files

• Web/Authenticate/Facebook.hs +8/−6
• Web/Authenticate/OpenId.hs +25/−17
• Web/Authenticate/Rpxnow.hs +32/−10
• authenticate.cabal +3/−3

@@ -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

@@ -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

@@ -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)

@@ -1,5 +1,5 @@ name:            authenticate-version:         0.6.3.1+version:         0.6.4 license:         BSD3 license-file:    LICENSE author:          Michael Snoyman <michael@snoyman.com>@@ -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