haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Facebook support in auth

Browse Source
This commit is contained in:
Michael Snoyman 2010-06-29 09:35:49 +03:00
parent a8e6485e46
commit f7f42cad1d
2 changed files with 55 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

58
Yesod/Helpers/Auth.hs
View File

@ -38,6 +38,7 @@ module Yesod.Helpers.Auth
import qualified Web.Authenticate.Rpxnow as Rpxnow
import qualified Web.Authenticate.OpenId as OpenId
import qualified Web.Authenticate.Facebook as Facebook
import Yesod
@ -51,6 +52,7 @@ import System.IO
import Control.Monad.Attempt
import Data.Monoid (mempty)
import Data.ByteString.Lazy.UTF8 (fromString)
import Data.Object
class Yesod master => YesodAuth master where
-- | Default destination on successful login or logout, if no other
@ -82,10 +84,12 @@ data Auth = Auth
{ authIsOpenIdEnabled :: Bool
, authRpxnowApiKey :: Maybe String
, authEmailSettings :: Maybe AuthEmailSettings
, authFacebook :: Maybe (String, String) -- ^ client id and secret
, authFacebookPerms :: [String]
}
-- | Which subsystem authenticated the user.
data AuthType = AuthOpenId | AuthRpxnow | AuthEmail
data AuthType = AuthOpenId | AuthRpxnow | AuthEmail | AuthFacebook
deriving (Show, Read, Eq)
type Email = String
@ -117,6 +121,7 @@ data Creds = Creds
, credsEmail :: Maybe String -- ^ Verified e-mail address.
, credsDisplayName :: Maybe String -- ^ Display name.
, credsId :: Maybe Integer -- ^ Numeric ID, if used.
, credsFacebookToken :: Maybe Facebook.AccessToken
}
deriving (Show, Read, Eq)
@ -147,6 +152,9 @@ mkYesodSub "Auth" [("master", [''YesodAuth])] [$parseRoutes|
/openid/complete OpenIdComplete GET
/login/rpxnow RpxnowR
/facebook FacebookR GET
/facebook/start StartFacebookR GET
/register EmailRegisterR GET POST
/verify/#EmailId/#String EmailVerifyR GET
/login EmailLoginR GET POST
@ -206,7 +214,7 @@ getOpenIdComplete = do
redirect RedirectTemporary $ toMaster OpenIdR
let onSuccess (OpenId.Identifier ident) = do
y <- getYesod
setCreds (Creds ident AuthOpenId Nothing Nothing Nothing) []
setCreds (Creds ident AuthOpenId Nothing Nothing Nothing Nothing) []
redirectUltDest RedirectTemporary $ defaultDest y
attempt onFailure onSuccess res
@ -229,6 +237,7 @@ handleRpxnowR = do
(lookup "verifiedEmail" extra)
(getDisplayName extra)
Nothing
Nothing
setCreds creds extra
either (redirect RedirectTemporary) (redirectString RedirectTemporary) $
case pp "dest" of
@ -328,7 +337,8 @@ getEmailVerifyR lid key = do
case (realKey == Just key, memail) of
(True, Just email) -> do
liftIO $ verifyAccount ae lid
setCreds (Creds email AuthEmail (Just email) Nothing (Just lid)) []
setCreds (Creds email AuthEmail (Just email) Nothing (Just lid)
Nothing) []
toMaster <- getRouteToMaster
redirect RedirectTemporary $ toMaster EmailPasswordR
_ -> applyLayout "Invalid verification key" mempty [$hamlet|
@ -376,7 +386,8 @@ postEmailLoginR = do
_ -> Nothing
case mlid of
Just lid -> do
setCreds (Creds email AuthEmail (Just email) Nothing (Just lid)) []
setCreds (Creds email AuthEmail (Just email) Nothing (Just lid)
Nothing) []
redirectUltDest RedirectTemporary $ defaultDest y
Nothing -> do
setMessage $ string "Invalid email/password combination"
@ -389,7 +400,7 @@ getEmailPasswordR = do
toMaster <- getRouteToMaster
mcreds <- maybeCreds
case mcreds of
Just (Creds _ AuthEmail _ _ (Just _)) -> return ()
Just (Creds _ AuthEmail _ _ (Just _) _) -> return ()
_ -> do
setMessage $ string "You must be logged in to set a password"
redirect RedirectTemporary $ toMaster EmailLoginR
@ -425,7 +436,7 @@ postEmailPasswordR = do
redirect RedirectTemporary $ toMaster EmailPasswordR
mcreds <- maybeCreds
lid <- case mcreds of
Just (Creds _ AuthEmail _ _ (Just lid)) -> return lid
Just (Creds _ AuthEmail _ _ (Just lid) _) -> return lid
_ -> do
setMessage $ string "You must be logged in to set a password"
redirect RedirectTemporary $ toMaster EmailLoginR
@ -481,3 +492,38 @@ inMemoryEmailSettings = do
spgo eid pass (email, EmailCreds eid' pass' status key)
| eid == eid' = (email, EmailCreds eid (Just pass) status key)
| otherwise = (email, EmailCreds eid' pass' status key)
getFacebookR :: YesodAuth master => GHandler Auth master ()
getFacebookR = do
y <- getYesod
a <- authFacebook <$> getYesodSub
case a of
Nothing -> notFound
Just (cid, secret) -> do
render <- getUrlRender
tm <- getRouteToMaster
let fb = Facebook.Facebook cid secret $ render $ tm FacebookR
code <- runFormGet $ required $ input "code"
at <- liftIO $ Facebook.getAccessToken fb code
so <- liftIO $ Facebook.getGraphData at "me"
let c = fromMaybe (error "Invalid response from Facebook") $ do
m <- fromMapping so
id' <- lookupScalar "id" m
let name = lookupScalar "name" m
let email = lookupScalar "email" m
let id'' = "http://graph.facebook.com/" ++ id'
return $ Creds id'' AuthFacebook email name Nothing $ Just at
setCreds c []
redirectUltDest RedirectTemporary $ defaultDest y
getStartFacebookR :: GHandler Auth master ()
getStartFacebookR = do
y <- getYesodSub
case authFacebook y of
Nothing -> notFound
Just (cid, secret) -> do
render <- getUrlRender
tm <- getRouteToMaster
let fb = Facebook.Facebook cid secret $ render $ tm FacebookR
let fburl = Facebook.getForwardUrl fb $ authFacebookPerms y
redirectString RedirectTemporary fburl

5
yesod.cabal
View File

@ -24,7 +24,7 @@ library
time >= 1.1.3 && < 1.2,
wai >= 0.1.0 && < 0.2,
wai-extra >= 0.1.3 && < 0.2,
authenticate >= 0.6.2 && < 0.7,
authenticate >= 0.6.3 && < 0.7,
bytestring >= 0.9.1.4 && < 0.10,
directory >= 1 && < 1.1,
text >= 0.5 && < 0.8,
@ -42,7 +42,8 @@ library
old-locale >= 1.0.0.2 && < 1.1,
persistent >= 0.1.0 && < 0.2,
neither >= 0.0.0 && < 0.1,
MonadCatchIO-transformers >= 0.2.2.0 && < 0.3
MonadCatchIO-transformers >= 0.2.2.0 && < 0.3,
data-object >= 0.3.1 && < 0.4
exposed-modules: Yesod
Yesod.Content
Yesod.Dispatch