123 lines
4.1 KiB
Haskell
123 lines
4.1 KiB
Haskell
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
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 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
|
|
|
|
-- | Route for login using this authentication plugin.
|
|
facebookLogin :: AuthRoute
|
|
facebookLogin = PluginR "facebook" ["forward"]
|
|
|
|
-- | This is just a synonym of 'facebookLogin'. Deprecated since
|
|
-- @yesod-auth 0.7.8@, please use 'facebookLogin' instead.
|
|
facebookUrl :: AuthRoute
|
|
facebookUrl = facebookLogin
|
|
{-# DEPRECATED facebookUrl "Please use facebookLogin instead." #-}
|
|
|
|
-- | Route for logout using this authentication plugin. Per
|
|
-- Facebook's policies
|
|
-- (<https://developers.facebook.com/policy/>), the user needs to
|
|
-- logout from Facebook itself as well.
|
|
facebookLogout :: AuthRoute
|
|
facebookLogout = PluginR "facebook" ["logout"]
|
|
|
|
-- | Get Facebook's access token from the session. Returns
|
|
-- @Nothing@ if it's not found (probably because the user is not
|
|
-- logged in via Facebook). Note that the returned access token
|
|
-- may have expired.
|
|
getFacebookAccessToken :: GHandler sub master (Maybe Facebook.AccessToken)
|
|
getFacebookAccessToken =
|
|
liftM (fmap Facebook.AccessToken) (lookupSession facebookAccessTokenKey)
|
|
|
|
-- | Key used to store Facebook's access token in the client
|
|
-- session.
|
|
facebookAccessTokenKey :: Text
|
|
facebookAccessTokenKey = "_FB"
|
|
|
|
-- | Authentication plugin using Facebook.
|
|
authFacebook :: YesodAuth m
|
|
=> Text -- ^ Application ID
|
|
-> Text -- ^ Application secret
|
|
-> [Text] -- ^ Requested permissions
|
|
-> 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
|
|
-- Well... then just logout from our app.
|
|
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
|