module Yesod.Auth.Facebook.ServerSide
(
authFacebook
, facebookLogin
, facebookLogout
, getUserAccessToken
, setUserAccessToken
, beta_authFacebook
, deleteUserAccessToken
) where
import Control.Applicative ((<$>))
import Control.Monad (when)
import Control.Monad.IO.Class (MonadIO, liftIO)
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 Yesod.Auth.Message as Msg
import qualified Data.Conduit as C
facebookLogin :: AuthRoute
facebookLogin = PluginR "fb" ["login"]
facebookLogout :: AuthRoute
facebookLogout = PluginR "fb" ["logout"]
authFacebook :: YesodAuth master
=> FB.Credentials
-> [FB.Permission]
-> AuthPlugin master
authFacebook = authFacebookHelper False
beta_authFacebook :: YesodAuth master
=> FB.Credentials
-> [FB.Permission]
-> AuthPlugin master
beta_authFacebook = authFacebookHelper True
authFacebookHelper :: YesodAuth master
=> Bool
-> FB.Credentials
-> [FB.Permission]
-> AuthPlugin master
authFacebookHelper useBeta creds perms = AuthPlugin "fb" dispatch login
where
runFB :: YesodAuth master =>
FB.FacebookT FB.Auth (C.ResourceT IO) a
-> GHandler sub master a
runFB act = do
manager <- authHttpManager <$> getYesod
liftIO $ C.runResourceT $
(if useBeta then FB.beta_runFacebookT else FB.runFacebookT)
creds manager act
getRedirectUrl :: YesodAuth master =>
(Route Auth -> Route master)
-> GHandler sub master Text
getRedirectUrl tm = do
render <- getUrlRender
let proceedUrl = render (tm proceedR)
runFB $ FB.getUserAccessTokenStep1 proceedUrl perms
proceedR = PluginR "fb" ["proceed"]
dispatch "GET" ["login"] = do
m <- getYesod
when (redirectToReferer m) setUltDestReferer
redirect =<< 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 <- runFB $ FB.getUserAccessTokenStep2 proceedUrl query'
setUserAccessToken token
setCreds True (createCreds token)
dispatch "GET" ["logout"] = do
m <- getYesod
tm <- getRouteToMaster
mtoken <- getUserAccessToken
when (redirectToReferer m) setUltDestReferer
valid <- maybe (return False) (runFB . FB.isValid) mtoken
case (valid, mtoken) of
(True, Just token) -> do
render <- getUrlRender
dest <- runFB $ FB.getUserLogoutUrl token (render $ tm $ PluginR "fb" ["kthxbye"])
redirect dest
_ -> dispatch "GET" ["kthxbye"]
dispatch "GET" ["kthxbye"] = do
m <- getYesod
deleteSession "_ID"
deleteUserAccessToken
onLogout
redirectUltDest $ logoutDest m
dispatch _ _ = notFound
login :: YesodAuth master =>
(Route Auth -> Route master)
-> GWidget sub master ()
login tm = do
redirectUrl <- lift (getRedirectUrl tm)
[whamlet|$newline never
<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 :: FB.UserAccessToken
-> GHandler sub master ()
setUserAccessToken (FB.UserAccessToken userId data_ exptime) = do
setSession "_FBID" (TE.decodeUtf8 userId)
setSession "_FBAT" (TE.decodeUtf8 data_)
setSession "_FBET" (T.pack $ show exptime)
getUserAccessToken :: GHandler sub master (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)
deleteUserAccessToken :: GHandler sub master ()
deleteUserAccessToken = do
deleteSession "_FBID"
deleteSession "_FBAT"
deleteSession "_FBET"