yesod-auth 1.3.0.5 → 1.3.1
raw patch · 2 files changed
+203/−1 lines, 2 filesdep +attoparsec-conduitdep +blaze-builderdep +conduit
Dependencies added: attoparsec-conduit, blaze-builder, conduit, conduit-extra, http-client
Files
- Yesod/Auth/GoogleEmail2.hs +196/−0
- yesod-auth.cabal +7/−1
+ Yesod/Auth/GoogleEmail2.hs view
@@ -0,0 +1,196 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+-- | Use an email address as an identifier via Google's login system.+--+-- Note that this is a replacement for "Yesod.Auth.GoogleEmail", which depends+-- on Google's now deprecated OpenID system. For more information, see+-- <https://developers.google.com/+/api/auth-migration>.+--+-- By using this plugin, you are trusting Google to validate an email address,+-- and requiring users to have a Google account. On the plus side, you get to+-- use email addresses as the identifier, many users have existing Google+-- accounts, the login system has been long tested (as opposed to BrowserID),+-- and it requires no credential managing or setup (as opposed to Email).+--+-- In order to use this plugin:+--+-- * Create an application on the Google Developer Console <https://console.developers.google.com/>+--+-- * Create OAuth credentials. The redirect URI will be <http://yourdomain/auth/page/googleemail2/complete>. (If you have your authentication subsite at a different root than \/auth\/, please adjust accordingly.)+--+-- * Enable the Google+ API.+--+-- Since 1.3.1+module Yesod.Auth.GoogleEmail2+ ( authGoogleEmail+ , forwardUrl+ ) where++import Blaze.ByteString.Builder (fromByteString, toByteString)+import Control.Applicative ((<$>), (<*>))+import Control.Arrow (second)+import Control.Monad (liftM, unless)+import Data.Aeson.Parser (json')+import Data.Aeson.Types (FromJSON (parseJSON), parseEither,+ withObject)+import Data.Conduit (($$+-))+import Data.Conduit.Attoparsec (sinkParser)+import Data.Monoid (mappend)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import Network.HTTP.Client (parseUrl, requestHeaders,+ responseBody, urlEncodedBody)+import Network.HTTP.Conduit (http)+import Network.HTTP.Types (renderQueryText)+import Network.Mail.Mime (randomString)+import System.Random (newStdGen)+import Yesod.Auth (Auth, AuthPlugin (AuthPlugin),+ AuthRoute, Creds (Creds),+ Route (PluginR), YesodAuth,+ authHttpManager, setCredsRedirect)+import qualified Yesod.Auth.Message as Msg+import Yesod.Core (HandlerSite, MonadHandler,+ getRouteToParent, getUrlRender,+ getYesod, invalidArgs, lift,+ liftBase, lookupGetParam,+ lookupSession, notFound, redirect,+ setSession, whamlet, (.:))++pid :: Text+pid = "googleemail2"++forwardUrl :: AuthRoute+forwardUrl = PluginR pid ["forward"]++csrfKey :: Text+csrfKey = "_GOOGLE_CSRF_TOKEN"++getCsrfToken :: MonadHandler m => m (Maybe Text)+getCsrfToken = lookupSession csrfKey++getCreateCsrfToken :: MonadHandler m => m Text+getCreateCsrfToken = do+ mtoken <- getCsrfToken+ case mtoken of+ Just token -> return token+ Nothing -> do+ stdgen <- liftBase newStdGen+ let token = T.pack $ fst $ randomString 10 stdgen+ setSession csrfKey token+ return token++authGoogleEmail :: YesodAuth m+ => Text -- ^ client ID+ -> Text -- ^ client secret+ -> AuthPlugin m+authGoogleEmail clientID clientSecret =+ AuthPlugin pid dispatch login+ where+ complete = PluginR pid ["complete"]++ getDest :: MonadHandler m+ => (Route Auth -> Route (HandlerSite m))+ -> m Text+ getDest tm = do+ csrf <- getCreateCsrfToken+ render <- getUrlRender+ let qs = map (second Just)+ [ ("scope", "email")+ , ("state", csrf)+ , ("redirect_uri", render $ tm complete)+ , ("response_type", "code")+ , ("client_id", clientID)+ , ("access_type", "offline")+ ]+ return $ decodeUtf8+ $ toByteString+ $ fromByteString "https://accounts.google.com/o/oauth2/auth"+ `mappend` renderQueryText True qs++ login tm = do+ url <- getDest tm+ [whamlet|<a href=#{url}>_{Msg.LoginGoogle}|]+ dispatch "GET" ["forward"] = do+ tm <- getRouteToParent+ lift (getDest tm) >>= redirect++ dispatch "GET" ["complete"] = do+ mstate <- lookupGetParam "state"+ case mstate of+ Nothing -> invalidArgs ["CSRF state from Google is missing"]+ Just state -> do+ mtoken <- getCsrfToken+ unless (Just state == mtoken) $ invalidArgs ["Invalid CSRF token from Google"]+ mcode <- lookupGetParam "code"+ code <-+ case mcode of+ Nothing -> invalidArgs ["Missing code paramter"]+ Just c -> return c++ render <- getUrlRender++ req' <- parseUrl "https://accounts.google.com/o/oauth2/token" -- FIXME don't hardcode, use: https://accounts.google.com/.well-known/openid-configuration+ let req =+ urlEncodedBody+ [ ("code", encodeUtf8 code)+ , ("client_id", encodeUtf8 clientID)+ , ("client_secret", encodeUtf8 clientSecret)+ , ("redirect_uri", encodeUtf8 $ render complete)+ , ("grant_type", "authorization_code")+ ]+ req'+ { requestHeaders = []+ }+ manager <- liftM authHttpManager $ lift getYesod+ res <- http req manager+ value <- responseBody res $$+- sinkParser json'+ Tokens accessToken _idToken tokenType <-+ case parseEither parseJSON value of+ Left e -> error e+ Right t -> return t++ unless (tokenType == "Bearer") $ error $ "Unknown token type: " ++ show tokenType++ req2' <- parseUrl "https://www.googleapis.com/plus/v1/people/me"+ let req2 = req2'+ { requestHeaders =+ [ ("Authorization", encodeUtf8 $ "Bearer " `mappend` accessToken)+ ]+ }+ res2 <- http req2 manager+ value2 <- responseBody res2 $$+- sinkParser json'+ Person emails <-+ case parseEither parseJSON value2 of+ Left e -> error e+ Right x -> return x+ email <-+ case map emailValue $ filter (\e -> emailType e == "account") emails of+ [e] -> return e+ [] -> error "No account email"+ x -> error $ "Too many account emails: " ++ show x+ lift $ setCredsRedirect $ Creds pid email []++ dispatch _ _ = notFound++data Tokens = Tokens Text Text Text+instance FromJSON Tokens where+ parseJSON = withObject "Tokens" $ \o -> Tokens+ <$> o .: "access_token"+ <*> o .: "id_token"+ <*> o .: "token_type"++data Person = Person [Email]+instance FromJSON Person where+ parseJSON = withObject "Person" $ \o -> Person+ <$> o .: "emails"++data Email = Email+ { emailValue :: Text+ , emailType :: Text+ }+ deriving Show+instance FromJSON Email where+ parseJSON = withObject "Email" $ \o -> Email+ <$> o .: "value"+ <*> o .: "type"
yesod-auth.cabal view
@@ -1,5 +1,5 @@ name: yesod-auth-version: 1.3.0.5+version: 1.3.1 license: MIT license-file: LICENSE author: Michael Snoyman, Patrick Brisbin@@ -59,6 +59,11 @@ , base64-bytestring , byteable , binary+ , http-client+ , blaze-builder+ , conduit+ , conduit-extra+ , attoparsec-conduit exposed-modules: Yesod.Auth Yesod.Auth.BrowserId@@ -68,6 +73,7 @@ Yesod.Auth.Rpxnow Yesod.Auth.Message Yesod.Auth.GoogleEmail+ Yesod.Auth.GoogleEmail2 other-modules: Yesod.Auth.Routes Yesod.PasswordStore ghc-options: -Wall