Merge branch 'master' of github.com:yesodweb/authenticate

authenticate/OpenId2/Discovery.hs

@@ -22,16 +22,14 @@ module OpenId2.Discovery (
 import OpenId2.Types
 import OpenId2.XRDS
 
-import Debug.Trace
 -- Libraries
 import Data.Char
 import Data.Maybe
 import Network.HTTP.Conduit
-import Data.Conduit (ResourceT, ResourceIO)
 import qualified Data.ByteString.Char8 as S8
 import Control.Arrow (first)
 import Control.Monad.IO.Class (MonadIO (liftIO))
-import Control.Monad (mplus)
+import Control.Monad (mplus, liftM)
 import qualified Data.CaseInsensitive as CI
 import Data.Text (Text, unpack)
 import Data.Text.Lazy (toStrict)
@@ -42,13 +40,15 @@ import Text.HTML.TagSoup (parseTags, Tag (TagOpen))
 import Control.Applicative ((<$>), (<*>))
 import Network.HTTP.Types (status200)
 import Control.Exception (throwIO)
+import Control.Monad.Trans.Resource (MonadResource)
+import Control.Monad.Trans.Control (MonadBaseControl)
 
 data Discovery = Discovery1 Text (Maybe Text)
                | Discovery2 Provider Identifier IdentType
     deriving Show
 
 -- | Attempt to resolve an OpenID endpoint, and user identifier.
-discover :: ResourceIO m => Identifier -> Manager -> ResourceT m Discovery
+discover :: (MonadBaseControl IO m, MonadIO m, MonadResource m) => Identifier -> Manager -> m Discovery
 discover ident@(Identifier i) manager = do
     res1 <- discoverYADIS ident Nothing 10 manager
     case res1 of
@@ -63,12 +63,12 @@ discover ident@(Identifier i) manager = do
 
 -- | Attempt a YADIS based discovery, given a valid identifier.  The result is
 --   an OpenID endpoint, and the actual identifier for the user.
-discoverYADIS :: ResourceIO m
+discoverYADIS :: (MonadResource m, MonadBaseControl IO m)
               => Identifier
               -> Maybe String
               -> Int -- ^ remaining redirects
               -> Manager
-              -> ResourceT m (Maybe (Provider, Identifier, IdentType))
+              -> m (Maybe (Provider, Identifier, IdentType))
 discoverYADIS _ _ 0 _ = liftIO $ throwIO TooManyRedirects
 discoverYADIS ident mb_loc redirects manager = do
     let uri = fromMaybe (unpack $ identifier ident) mb_loc
@@ -79,7 +79,7 @@ discoverYADIS ident mb_loc redirects manager = do
              $ map (first $ map toLower . S8.unpack . CI.original)
              $ responseHeaders res
     let mloc' = if mloc == mb_loc then Nothing else mloc
-    if statusCode res == status200
+    if responseStatus res == status200
         then
           case mloc' of
             Just loc -> discoverYADIS ident (Just loc) (redirects - 1) manager
@@ -116,10 +116,10 @@ parseYADIS ident = listToMaybe . mapMaybe isOpenId . concat
 
 -- | Attempt to discover an OpenID endpoint, from an HTML document.  The result
 -- will be an endpoint on success, and the actual identifier of the user.
-discoverHTML :: ResourceIO m => Identifier -> Manager -> ResourceT m (Maybe Discovery)
+discoverHTML :: (MonadResource m, MonadBaseControl IO m) => Identifier -> Manager -> m (Maybe Discovery)
 discoverHTML ident'@(Identifier ident) manager = do
     req <- liftIO $ parseUrl $ unpack ident
-    Response _ _ lbs <- httpLbs req manager
+    lbs <- liftM responseBody $ httpLbs req manager
     return $ parseHTML ident' . toStrict . decodeUtf8With lenientDecode $ lbs
 
 -- | Parse out an OpenID endpoint and an actual identifier from an HTML
@@ -146,5 +146,5 @@ parseHTML ident = resolve
 
 -- | Filter out link tags from a list of html tags.
 linkTag :: Tag Text -> Maybe (Text, Text)
-linkTag (TagOpen "link" as) = let x = (,) <$> lookup "rel" as <*> lookup "href" as in traceShow x x
+linkTag (TagOpen "link" as) = (,) <$> lookup "rel" as <*> lookup "href" as
 linkTag _x = Nothing

authenticate/Web/Authenticate/BrowserId.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts #-}
 module Web.Authenticate.BrowserId
     ( browserIdJs
     , checkAssertion
@@ -6,22 +7,23 @@ module Web.Authenticate.BrowserId
 
 import Data.Text (Text)
 import Network.HTTP.Conduit (parseUrl, responseBody, httpLbs, Manager, method, urlEncodedBody)
-import Data.Conduit (ResourceT, ResourceIO)
 import Data.Aeson (json, Value (Object, String))
 import Data.Attoparsec.Lazy (parse, maybeResult)
 import qualified Data.HashMap.Lazy as Map
 import Data.Text.Encoding (encodeUtf8)
 import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Trans.Control (MonadBaseControl)
+import Control.Monad.Trans.Resource (MonadResource)
 
 -- | Location of the Javascript file hosted by browserid.org
 browserIdJs :: Text
 browserIdJs = "https://browserid.org/include.js"
 
-checkAssertion :: ResourceIO m
+checkAssertion :: (MonadResource m, MonadBaseControl IO m)
                => Text -- ^ audience
                -> Text -- ^ assertion
                -> Manager
-               -> ResourceT m (Maybe Text)
+               -> m (Maybe Text)
 checkAssertion audience assertion manager = do
     req' <- liftIO $ parseUrl "https://browserid.org/verify"
     let req = urlEncodedBody

authenticate/Web/Authenticate/OpenId.hs

@@ -20,7 +20,6 @@ import Network.HTTP.Conduit
     ( parseUrl, urlEncodedBody, responseBody, httpLbs
     , Manager
     )
-import Data.Conduit (ResourceT, ResourceIO)
 import Control.Arrow ((***), second)
 import Data.List (unfoldr)
 import Data.Maybe (fromMaybe)
@@ -28,17 +27,18 @@ import Data.Text (Text, pack, unpack)
 import Data.Text.Encoding (encodeUtf8, decodeUtf8)
 import Blaze.ByteString.Builder (toByteString)
 import Network.HTTP.Types (renderQueryText)
-import Data.Monoid (mappend)
 import Control.Exception (throwIO)
+import Control.Monad.Trans.Control (MonadBaseControl)
+import Control.Monad.Trans.Resource (MonadResource)
 
 getForwardUrl
-    :: ResourceIO m
+    :: (MonadResource m, MonadBaseControl IO m)
     => 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.
     -> Manager
-    -> ResourceT m Text -- ^ URL to send the user to.
+    -> m Text -- ^ URL to send the user to.
 getForwardUrl openid' complete mrealm params manager = do
     let realm = fromMaybe complete mrealm
     disc <- normalize openid' >>= flip discover manager
@@ -70,10 +70,10 @@ getForwardUrl openid' complete mrealm params manager = do
                 : params
 
 authenticate
-    :: ResourceIO m
+    :: (MonadBaseControl IO m, MonadResource m, MonadIO m)
     => [(Text, Text)]
     -> Manager
-    -> ResourceT m (Identifier, [(Text, Text)])
+    -> m (Identifier, [(Text, Text)])
 authenticate params manager = do
     unless (lookup "openid.mode" params == Just "id_res")
         $ liftIO $ throwIO $ case lookup "openid.mode" params of

authenticate/Web/Authenticate/Rpxnow.hs

@@ -23,7 +23,6 @@ module Web.Authenticate.Rpxnow
 
 import Data.Aeson
 import Network.HTTP.Conduit
-import Data.Conduit (ResourceT, ResourceIO)
 import Control.Monad.IO.Class
 import Data.Maybe
 import Control.Monad
@@ -39,6 +38,8 @@ import qualified Data.Aeson.Types
 import qualified Data.HashMap.Lazy as Map
 import Control.Applicative ((<$>), (<*>))
 import Control.Exception (throwIO)
+import Control.Monad.Trans.Control (MonadBaseControl)
+import Control.Monad.Trans.Resource (MonadResource)
 
 -- | Information received from Rpxnow after a valid login.
 data Identifier = Identifier
@@ -48,11 +49,11 @@ data Identifier = Identifier
     deriving (Eq, Ord, Read, Show, Data, Typeable)
 
 -- | Attempt to log a user in.
-authenticate :: ResourceIO m
+authenticate :: (MonadResource m, MonadBaseControl IO m)
              => String -- ^ API key given by RPXNOW.
              -> String -- ^ Token passed by client.
              -> Manager
-             -> ResourceT m Identifier
+             -> m Identifier
 authenticate apiKey token manager = do
     let body = L.fromChunks
             [ "apiKey="

authenticate/authenticate.cabal

@@ -1,5 +1,5 @@
 name:            authenticate
-version:         1.0.0.1
+version:         1.2.0
 license:         BSD3
 license-file:    LICENSE
 author:          Michael Snoyman, Hiromi Ishii, Arash Rouhani
@@ -15,7 +15,7 @@ homepage:        http://github.com/yesodweb/authenticate
 library
     build-depends:   base                          >= 4        && < 5
                    , aeson                         >= 0.5
-                   , http-conduit                  >= 1.2      && < 1.3
+                   , http-conduit                  >= 1.4      && < 1.5
                    , tagsoup                       >= 0.12     && < 0.13
                    , transformers                  >= 0.1      && < 0.3
                    , bytestring                    >= 0.9
@@ -23,13 +23,15 @@ library
                    , case-insensitive              >= 0.2
                    , text
                    , http-types                    >= 0.6      && < 0.7
-                   , xml-conduit                   >= 0.5.1.2  && < 0.6
+                   , xml-conduit                   >= 0.7      && < 0.8
                    , blaze-builder
                    , attoparsec
                    , containers
                    , unordered-containers
-                   , conduit                       >= 0.2      && < 0.3
+                   , conduit                       >= 0.4      && < 0.5
-                   , blaze-builder-conduit         >= 0.2      && < 0.3
+                   , resourcet                     >= 0.3      && < 0.4
+                   , monad-control                 >= 0.3      && < 0.4
+                   , blaze-builder-conduit         >= 0.4      && < 0.5
     exposed-modules: Web.Authenticate.Rpxnow,
                      Web.Authenticate.OpenId,
                      Web.Authenticate.BrowserId,

authenticate/browserid.hs

@@ -3,7 +3,7 @@ import Yesod
 import Web.Authenticate.BrowserId
 import Data.Object
 import Data.Maybe (fromMaybe)
-import Network.HTTP.Enumerator
+import Network.HTTP.Conduit
 import Data.Text (Text)
 
 data BID = BID