diff --git a/authenticate/OpenId2/Discovery.hs b/authenticate/OpenId2/Discovery.hs index 25b64753..861ecdcf 100644 --- a/authenticate/OpenId2/Discovery.hs +++ b/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 diff --git a/authenticate/Web/Authenticate/BrowserId.hs b/authenticate/Web/Authenticate/BrowserId.hs index 3abf5dde..89b79026 100644 --- a/authenticate/Web/Authenticate/BrowserId.hs +++ b/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 diff --git a/authenticate/Web/Authenticate/OpenId.hs b/authenticate/Web/Authenticate/OpenId.hs index 591f8218..c748bb7c 100644 --- a/authenticate/Web/Authenticate/OpenId.hs +++ b/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 diff --git a/authenticate/Web/Authenticate/Rpxnow.hs b/authenticate/Web/Authenticate/Rpxnow.hs index 9aba4978..0407aeb7 100644 --- a/authenticate/Web/Authenticate/Rpxnow.hs +++ b/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=" diff --git a/authenticate/authenticate.cabal b/authenticate/authenticate.cabal index 6ef7d1ce..287c16d1 100644 --- a/authenticate/authenticate.cabal +++ b/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 - , blaze-builder-conduit >= 0.2 && < 0.3 + , conduit >= 0.4 && < 0.5 + , 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, diff --git a/authenticate/browserid.hs b/authenticate/browserid.hs index bf365956..6d3d2ee3 100644 --- a/authenticate/browserid.hs +++ b/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