From 1b3eb2b28234a19bed91a7377d41ff666339e178 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 10 Jan 2012 11:38:59 +0200 Subject: [PATCH] yesod-auth on authenticate 1.0.0 --- authenticate | 2 +- package-list.sh | 1 + yesod-auth/Yesod/Auth.hs | 14 ++++++++++---- yesod-auth/Yesod/Auth/BrowserId.hs | 7 ++++--- yesod-auth/Yesod/Auth/Facebook.hs | 5 +++-- yesod-auth/Yesod/Auth/GoogleEmail.hs | 20 +++++++++++--------- yesod-auth/Yesod/Auth/OAuth.hs | 9 +++++---- yesod-auth/Yesod/Auth/OpenId.hs | 22 +++++++++++----------- yesod-auth/Yesod/Auth/Rpxnow.hs | 3 ++- yesod-auth/yesod-auth.cabal | 4 ++-- 10 files changed, 50 insertions(+), 37 deletions(-) diff --git a/authenticate b/authenticate index 262d06e0..2a903fec 160000 --- a/authenticate +++ b/authenticate @@ -1 +1 @@ -Subproject commit 262d06e045b658e83abfc7a34c5f9878254c7046 +Subproject commit 2a903feca1644fbef9c1c01bd5ae293f312f0b12 diff --git a/package-list.sh b/package-list.sh index c461efb3..41b38a9c 100644 --- a/package-list.sh +++ b/package-list.sh @@ -7,6 +7,7 @@ pkgs=( ./yesod-routes ./yesod-persistent ./yesod-newsfeed ./yesod-form + ./authenticate ./yesod-auth ./yesod-sitemap ./yesod-default diff --git a/yesod-auth/Yesod/Auth.hs b/yesod-auth/Yesod/Auth.hs index d958d86a..37fb7124 100644 --- a/yesod-auth/Yesod/Auth.hs +++ b/yesod-auth/Yesod/Auth.hs @@ -34,11 +34,8 @@ import Data.Text.Encoding (decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) import Data.Text (Text) import qualified Data.Text as T -#if MIN_VERSION_aeson(0, 4, 0) import qualified Data.HashMap.Lazy as Map -#else -import qualified Data.Map as Map -#endif +import Network.HTTP.Conduit (Manager) import Language.Haskell.TH.Syntax hiding (lift) @@ -86,8 +83,10 @@ class (Yesod m, PathPiece (AuthId m), RenderMessage m FormMessage) => YesodAuth -- destination exists. logoutDest :: m -> Route m + -- | Determine the ID associated with the set of credentials. getAuthId :: Creds m -> GHandler s m (Maybe (AuthId m)) + -- | Which authentication backends to use. authPlugins :: [AuthPlugin m] -- | What to show on the login page. @@ -97,6 +96,7 @@ class (Yesod m, PathPiece (AuthId m), RenderMessage m FormMessage) => YesodAuth tm <- lift getRouteToMaster mapM_ (flip apLogin tm) authPlugins + -- | Used for i18n of messages provided by this package. renderAuthMessage :: m -> [Text] -- ^ languages -> AuthMessage -> Text @@ -107,6 +107,12 @@ class (Yesod m, PathPiece (AuthId m), RenderMessage m FormMessage) => YesodAuth redirectToReferer :: m -> Bool redirectToReferer _ = False + -- | Return an HTTP connection manager that is stored in the foundation + -- type. This allows backends to reuse persistent connections. If none of + -- the backends you're using use HTTP connections, you can safely return + -- @error \"authHttpManager"@ here. + authHttpManager :: m -> Manager + mkYesodSub "Auth" [ ClassP ''YesodAuth [VarT $ mkName "master"] ] diff --git a/yesod-auth/Yesod/Auth/BrowserId.hs b/yesod-auth/Yesod/Auth/BrowserId.hs index 378307c3..7715dc65 100644 --- a/yesod-auth/Yesod/Auth/BrowserId.hs +++ b/yesod-auth/Yesod/Auth/BrowserId.hs @@ -12,7 +12,6 @@ import Web.Authenticate.BrowserId import Data.Text (Text) import Yesod.Core import Text.Hamlet (hamlet) -import Control.Monad.IO.Class (liftIO) import qualified Data.Text as T import Data.Maybe (fromMaybe) @@ -32,7 +31,8 @@ authBrowserIdAudience audience = AuthPlugin , apDispatch = \m ps -> case (m, ps) of ("GET", [assertion]) -> do - memail <- liftIO $ checkAssertion audience assertion + master <- getYesod + memail <- lift $ checkAssertion audience assertion (authHttpManager master) case memail of Nothing -> error "Invalid assertion" Just email -> setCreds True Creds @@ -60,7 +60,8 @@ authBrowserId = AuthPlugin tm <- getRouteToMaster r <- getUrlRender let audience = T.takeWhile (/= '/') $ stripScheme $ r $ tm LoginR - memail <- liftIO $ checkAssertion audience assertion + master <- getYesod + memail <- lift $ checkAssertion audience assertion (authHttpManager master) case memail of Nothing -> error "Invalid assertion" Just email -> setCreds True Creds diff --git a/yesod-auth/Yesod/Auth/Facebook.hs b/yesod-auth/Yesod/Auth/Facebook.hs index b76aff70..3e1c6677 100644 --- a/yesod-auth/Yesod/Auth/Facebook.hs +++ b/yesod-auth/Yesod/Auth/Facebook.hs @@ -77,10 +77,11 @@ authFacebook cid secret perms = tm <- getRouteToMaster let fb = Facebook.Facebook cid secret $ render $ tm url code <- runInputGet $ ireq textField "code" - at <- liftIO $ Facebook.getAccessToken fb code + master <- getYesod + at <- lift $ Facebook.getAccessToken fb code (authHttpManager master) let Facebook.AccessToken at' = at setSession facebookAccessTokenKey at' - so <- liftIO $ Facebook.getGraphData at "me" + so <- lift $ Facebook.getGraphData at "me" (authHttpManager master) let c = fromMaybe (error "Invalid response from Facebook") $ parseMaybe (parseCreds at') $ either error id so setCreds True c diff --git a/yesod-auth/Yesod/Auth/GoogleEmail.hs b/yesod-auth/Yesod/Auth/GoogleEmail.hs index 7ac6c16d..5c0eb587 100644 --- a/yesod-auth/Yesod/Auth/GoogleEmail.hs +++ b/yesod-auth/Yesod/Auth/GoogleEmail.hs @@ -17,7 +17,6 @@ module Yesod.Auth.GoogleEmail import Yesod.Auth import qualified Web.Authenticate.OpenId as OpenId -import Control.Monad.Attempt import Yesod.Form import Yesod.Handler @@ -27,6 +26,7 @@ import Text.Blaze (toHtml) import Data.Text (Text) import qualified Yesod.Auth.Message as Msg import qualified Data.Text as T +import Control.Exception.Lifted (try, SomeException) forwardUrl :: AuthRoute forwardUrl = PluginR "googleemail" ["forward"] @@ -50,21 +50,22 @@ authGoogleEmail = render <- getUrlRender toMaster <- getRouteToMaster let complete' = render $ toMaster complete - res <- runAttemptT $ OpenId.getForwardUrl oid complete' Nothing + master <- getYesod + eres <- lift $ try $ OpenId.getForwardUrl oid complete' Nothing [ ("openid.ax.type.email", "http://schema.openid.net/contact/email") , ("openid.ns.ax", "http://openid.net/srv/ax/1.0") , ("openid.ns.ax.required", "email") , ("openid.ax.mode", "fetch_request") , ("openid.ax.required", "email") , ("openid.ui.icon", "true") - ] - attempt + ] (authHttpManager master) + either (\err -> do - setMessage $ toHtml $ show err + setMessage $ toHtml $ show (err :: SomeException) redirect $ toMaster LoginR ) redirect - res + eres Nothing -> do toMaster <- getRouteToMaster setMessageI Msg.NoOpenID @@ -81,10 +82,11 @@ authGoogleEmail = completeHelper :: YesodAuth m => [(Text, Text)] -> GHandler Auth m () completeHelper gets' = do - res <- runAttemptT $ OpenId.authenticate gets' + master <- getYesod + eres <- lift $ try $ OpenId.authenticate gets' (authHttpManager master) toMaster <- getRouteToMaster let onFailure err = do - setMessage $ toHtml $ show err + setMessage $ toHtml $ show (err :: SomeException) redirect $ toMaster LoginR let onSuccess (OpenId.Identifier ident, _) = do memail <- lookupGetParam "openid.ext1.value.email" @@ -96,4 +98,4 @@ completeHelper gets' = do (Nothing, _) -> do setMessage "No email address provided" redirect $ toMaster LoginR - attempt onFailure onSuccess res + either onFailure onSuccess eres diff --git a/yesod-auth/Yesod/Auth/OAuth.hs b/yesod-auth/Yesod/Auth/OAuth.hs index d93d2131..7efd9dfe 100644 --- a/yesod-auth/Yesod/Auth/OAuth.hs +++ b/yesod-auth/Yesod/Auth/OAuth.hs @@ -19,7 +19,6 @@ import Data.Maybe import Data.String import Data.ByteString.Char8 (pack) import Control.Arrow ((***)) -import Control.Monad.IO.Class (liftIO) import Data.Text (Text, unpack) import Data.Text.Encoding (encodeUtf8, decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) @@ -52,15 +51,17 @@ authOAuth name ident reqUrl accUrl authUrl key sec = AuthPlugin name dispatch lo render <- getUrlRender tm <- getRouteToMaster let oauth' = oauth { oauthCallback = Just $ encodeUtf8 $ render $ tm url } - tok <- liftIO $ getTemporaryCredential oauth' + master <- getYesod + tok <- lift $ getTemporaryCredential oauth' (authHttpManager master) redirect $ authorizeUrl oauth' tok dispatch "GET" [] = do (verifier, oaTok) <- runInputGet $ (,) <$> ireq textField "oauth_verifier" <*> ireq textField "oauth_token" let reqTok = Credential [ ("oauth_verifier", encodeUtf8 verifier), ("oauth_token", encodeUtf8 oaTok) - ] - accTok <- liftIO $ getAccessToken oauth reqTok + ] + master <- getYesod + accTok <- lift $ getAccessToken oauth reqTok (authHttpManager master) let crId = decodeUtf8With lenientDecode $ fromJust $ lookup (pack ident) $ unCredential accTok creds = Creds name crId $ map (bsToText *** bsToText ) $ unCredential accTok setCreds True creds diff --git a/yesod-auth/Yesod/Auth/OpenId.hs b/yesod-auth/Yesod/Auth/OpenId.hs index 5eca0a93..86642cdd 100644 --- a/yesod-auth/Yesod/Auth/OpenId.hs +++ b/yesod-auth/Yesod/Auth/OpenId.hs @@ -11,7 +11,6 @@ module Yesod.Auth.OpenId import Yesod.Auth import qualified Web.Authenticate.OpenId as OpenId -import Control.Monad.Attempt import Yesod.Form import Yesod.Handler @@ -21,6 +20,7 @@ import Text.Cassius (cassius) import Text.Blaze (toHtml) import Data.Text (Text) import qualified Yesod.Auth.Message as Msg +import Control.Exception.Lifted (SomeException, try) forwardUrl :: AuthRoute forwardUrl = PluginR "openid" ["forward"] @@ -60,14 +60,13 @@ authOpenIdExtended extensionFields = render <- getUrlRender toMaster <- getRouteToMaster let complete' = render $ toMaster complete - res <- runAttemptT $ OpenId.getForwardUrl oid complete' Nothing extensionFields - attempt - (\err -> do - setMessage $ toHtml $ show err + master <- getYesod + eres <- lift $ try $ OpenId.getForwardUrl oid complete' Nothing extensionFields (authHttpManager master) + case eres of + Left err -> do + setMessage $ toHtml $ show (err :: SomeException) redirect $ toMaster LoginR - ) - redirect - res + Right x -> redirect x Nothing -> do toMaster <- getRouteToMaster setMessageI Msg.NoOpenID @@ -84,11 +83,12 @@ authOpenIdExtended extensionFields = completeHelper :: YesodAuth m => [(Text, Text)] -> GHandler Auth m () completeHelper gets' = do - res <- runAttemptT $ OpenId.authenticate gets' + master <- getYesod + eres <- lift $ try $ OpenId.authenticate gets' (authHttpManager master) toMaster <- getRouteToMaster let onFailure err = do - setMessage $ toHtml $ show err + setMessage $ toHtml $ show (err :: SomeException) redirect $ toMaster LoginR let onSuccess (OpenId.Identifier ident, _) = setCreds True $ Creds "openid" ident gets' - attempt onFailure onSuccess res + either onFailure onSuccess eres diff --git a/yesod-auth/Yesod/Auth/Rpxnow.hs b/yesod-auth/Yesod/Auth/Rpxnow.hs index f57b2dbc..040f6fa7 100644 --- a/yesod-auth/Yesod/Auth/Rpxnow.hs +++ b/yesod-auth/Yesod/Auth/Rpxnow.hs @@ -38,7 +38,8 @@ authRpxnow app apiKey = token <- case token1 ++ token2 of [] -> invalidArgs ["token: Value not supplied"] x:_ -> return $ unpack x - Rpxnow.Identifier ident extra <- liftIO $ Rpxnow.authenticate apiKey token + master <- getYesod + Rpxnow.Identifier ident extra <- lift $ Rpxnow.authenticate apiKey token (authHttpManager master) let creds = Creds "rpxnow" ident $ maybe id (\x -> (:) ("verifiedEmail", x)) diff --git a/yesod-auth/yesod-auth.cabal b/yesod-auth/yesod-auth.cabal index 3b6f34c6..c7467162 100644 --- a/yesod-auth/yesod-auth.cabal +++ b/yesod-auth/yesod-auth.cabal @@ -21,14 +21,13 @@ library cpp-options: -DGHC7 else build-depends: base >= 4 && < 4.3 - build-depends: authenticate >= 0.11.1 && < 0.12 + build-depends: authenticate >= 1.0 && < 1.1 , bytestring >= 0.9.1.4 && < 0.10 , yesod-core >= 0.10 && < 0.11 , wai >= 1.0 && < 1.1 , template-haskell , pureMD5 >= 2.0 && < 2.2 , random >= 1.0.0.2 && < 1.1 - , control-monad-attempt >= 0.3.0 && < 0.4 , text >= 0.7 && < 0.12 , mime-mail >= 0.3 && < 0.5 , blaze-html >= 0.4.1.3 && < 0.5 @@ -46,6 +45,7 @@ library , http-conduit >= 1.1 && < 1.2 , aeson >= 0.5 , pwstore-fast >= 2.2 && < 3 + , lifted-base >= 0.1 && < 0.2 exposed-modules: Yesod.Auth Yesod.Auth.BrowserId