module Yesod.Auth.FB
( authFacebook
, facebookLogin
, facebookLogout
, getUserAccessToken
, setUserAccessToken
) where
#include "qq.h"
import Control.Applicative ((<$>))
import Control.Monad (when)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe (MaybeT(..))
import Data.Monoid (mappend)
import Data.Text (Text)
import Network.Wai (queryString)
import Yesod.Auth
import Yesod.Handler
import Yesod.Widget
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Facebook as FB
import qualified Network.HTTP.Conduit as H
import qualified Yesod.Auth.Message as Msg
facebookLogin :: AuthRoute
facebookLogin = PluginR "fb" ["login"]
facebookLogout :: AuthRoute
facebookLogout = PluginR "fb" ["logout"]
authFacebook :: YesodAuth master
=> FB.Credentials
-> H.Manager
-> [FB.Permission]
-> AuthPlugin master
authFacebook creds manager perms = AuthPlugin "fb" dispatch login
where
getRedirectUrl :: (YesodAuth master, Monad m) =>
(Route Auth -> Route master)
-> GGHandler sub master m Text
getRedirectUrl tm = do
render <- getUrlRender
let proceedUrl = render (tm proceedR)
return $ FB.getUserAccessTokenStep1 creds proceedUrl perms
proceedR = PluginR "fb" ["proceed"]
dispatch "GET" ["login"] =
redirectText RedirectTemporary =<< getRedirectUrl =<< getRouteToMaster
dispatch "GET" ["proceed"] = do
tm <- getRouteToMaster
render <- getUrlRender
query <- queryString <$> waiRequest
let proceedUrl = render (tm proceedR)
query' = [(a,b) | (a, Just b) <- query]
token <- liftIO $
FB.runFacebookT creds manager $
FB.getUserAccessTokenStep2 proceedUrl query'
setUserAccessToken token
setCreds True (createCreds token)
dispatch "GET" ["logout"] = do
m <- getYesod
tm <- getRouteToMaster
mtoken <- getUserAccessToken
when (redirectToReferer m) setUltDestReferer
let isValid = liftIO .
FB.runNoAuthFacebookT manager .
FB.isValid
valid <- maybe (return False) isValid mtoken
case (valid, mtoken) of
(True, Just token) -> do
render <- getUrlRender
redirectText RedirectTemporary $
FB.getUserLogoutUrl token (render $ tm LogoutR)
_ -> redirect RedirectTemporary (tm LogoutR)
dispatch _ _ = notFound
login :: YesodAuth master =>
(Route Auth -> Route master)
-> GWidget sub master ()
login tm = do
redirectUrl <- lift (getRedirectUrl tm)
[QQ(whamlet)|
<p>
<a href="#{redirectUrl}">_{Msg.Facebook}
|]
createCreds :: FB.UserAccessToken -> Creds m
createCreds (FB.UserAccessToken userId _ _) = Creds "fb" id_ []
where id_ = "http://graph.facebook.com/" `mappend` TE.decodeUtf8 userId
setUserAccessToken :: MonadIO m =>
FB.UserAccessToken
-> GGHandler sub master m ()
setUserAccessToken (FB.UserAccessToken userId data_ exptime) = do
setSession "_FBID" (TE.decodeUtf8 userId)
setSession "_FBAT" (TE.decodeUtf8 data_)
setSession "_FBET" (T.pack $ show exptime)
getUserAccessToken :: MonadIO mo =>
GGHandler sub master mo (Maybe FB.UserAccessToken)
getUserAccessToken = runMaybeT $ do
userId <- MaybeT $ lookupSession "_FBID"
data_ <- MaybeT $ lookupSession "_FBAT"
exptime <- MaybeT $ lookupSession "_FBET"
return $ FB.UserAccessToken (TE.encodeUtf8 userId)
(TE.encodeUtf8 data_)
(read $ T.unpack exptime)