module Yesod.Auth.Facebook
( authFacebook
, facebookLogin
, facebookUrl
, facebookLogout
, getFacebookAccessToken
) where
#include "qq.h"
import Yesod.Auth
import qualified Web.Authenticate.Facebook as Facebook
import Data.Aeson
import Data.Aeson.Types (parseMaybe)
import Data.Maybe (fromMaybe)
import Yesod.Form
import Yesod.Handler
import Yesod.Widget
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.Class (lift)
import Data.Text (Text)
import Control.Monad (liftM, mzero, when)
import Data.Monoid (mappend)
import qualified Data.Aeson.Types
import qualified Yesod.Auth.Message as Msg
facebookLogin :: AuthRoute
facebookLogin = PluginR "facebook" ["forward"]
facebookUrl :: AuthRoute
facebookUrl = facebookLogin
facebookLogout :: AuthRoute
facebookLogout = PluginR "facebook" ["logout"]
getFacebookAccessToken :: MonadIO mo => GGHandler sub master mo (Maybe Facebook.AccessToken)
getFacebookAccessToken =
liftM (fmap Facebook.AccessToken) (lookupSession facebookAccessTokenKey)
facebookAccessTokenKey :: Text
facebookAccessTokenKey = "_FB"
authFacebook :: YesodAuth m
=> Text
-> Text
-> [Text]
-> AuthPlugin m
authFacebook cid secret perms =
AuthPlugin "facebook" dispatch login
where
url = PluginR "facebook" []
dispatch "GET" ["forward"] = do
tm <- getRouteToMaster
render <- getUrlRender
let fb = Facebook.Facebook cid secret $ render $ tm url
redirectText RedirectTemporary $ Facebook.getForwardUrl fb perms
dispatch "GET" [] = do
render <- getUrlRender
tm <- getRouteToMaster
let fb = Facebook.Facebook cid secret $ render $ tm url
code <- runInputGet $ ireq textField "code"
at <- liftIO $ Facebook.getAccessToken fb code
let Facebook.AccessToken at' = at
setSession facebookAccessTokenKey at'
so <- liftIO $ Facebook.getGraphData at "me"
let c = fromMaybe (error "Invalid response from Facebook")
$ parseMaybe (parseCreds at') $ either error id so
setCreds True c
dispatch "GET" ["logout"] = do
m <- getYesod
tm <- getRouteToMaster
mtoken <- getFacebookAccessToken
when (redirectToReferer m) setUltDestReferer
case mtoken of
Nothing -> do
redirect RedirectTemporary (tm LogoutR)
Just at -> do
render <- getUrlRender
let logout = Facebook.getLogoutUrl at (render $ tm LogoutR)
redirectText RedirectTemporary logout
dispatch _ _ = notFound
login tm = do
render <- lift getUrlRender
let fb = Facebook.Facebook cid secret $ render $ tm url
let furl = Facebook.getForwardUrl fb $ perms
[QQ(whamlet)|
<p>
<a href="#{furl}">_{Msg.Facebook}
|]
parseCreds :: Text -> Value -> Data.Aeson.Types.Parser (Creds m)
parseCreds at' (Object m) = do
id' <- m .: "id"
let id'' = "http://graph.facebook.com/" `mappend` id'
name <- m .:? "name"
email <- m .:? "email"
return
$ Creds "facebook" id''
$ maybe id (\x -> (:) ("verifiedEmail", x)) email
$ maybe id (\x -> (:) ("displayName ", x)) name
[ ("accessToken", at')
]
parseCreds _ _ = mzero