module Yesod.Auth.Facebook.ClientSide
(
authFacebookClientSide
, YesodAuthFbClientSide(..)
, facebookJSSDK
, facebookLogin
, facebookForceLoginR
, facebookLogout
, JavaScriptCall
, serveChannelFile
, defaultFbInitOpts
, getUserAccessToken
, signedRequestCookieName
) where
import Control.Applicative ((<$>), (<*>))
import Control.Monad (when)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.Error (ErrorT(..), throwError)
import Data.ByteString (ByteString)
import Data.Monoid (mappend, mempty)
import Data.String (fromString)
import Data.Text (Text)
import System.Locale (defaultTimeLocale)
import Text.Hamlet (hamlet)
import Text.Julius (JavascriptUrl, julius)
import Yesod.Auth
import Yesod.Content
import Yesod.Core
import qualified Control.Exception.Lifted as E
import qualified Data.Aeson as A
import qualified Data.Aeson.Types as A
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Lazy.Encoding as TLE
import qualified Data.Time as TI
import qualified Data.Time.Clock.POSIX as TI
import qualified Facebook as FB
import qualified Yesod.Facebook as YF
import qualified Yesod.Auth.Message as Msg
fbcsR :: [Text] -> Route Auth
fbcsR = PluginR "fbcs"
facebookJSSDK :: YesodAuthFbClientSide master =>
(Route Auth -> Route master)
-> GWidget sub master ()
facebookJSSDK toMaster = do
(lang, fbInitOptsList, muid) <-
lift $ (,,) <$> getFbLanguage
<*> getFbInitOpts
<*> maybeAuthId
let loggedIn = maybe ("false" :: Text) (const "true") muid
loginRoute = toMaster $ fbcsR ["login"]
logoutRoute = toMaster $ LogoutR
fbInitOpts = A.object $ map (uncurry (A..=)) fbInitOptsList
[whamlet|$newline never
<div #fbroot>
|]
toWidgetBody [julius|
// Load the SDK Asynchronously
(function(d){
var js, id = 'facebookjssdk', ref = d.getElementsByTagName('script')[0];
if (d.getElementById(id)) {return;}
js = d.createElement('script'); js.id = id; js.async = true;
js.src = "//connect.facebook.net/#{lang}/all.js";
ref.parentNode.insertBefore(js, ref);
}(document));
// Init the SDK upon load
window.fbAsyncInit = function() {
FB.init(#{TLE.decodeUtf8 $ A.encode fbInitOpts});
^{fbAsyncInitJs}
// Subscribe to statusChange event.
FB.Event.subscribe("auth.statusChange", function (response) {
if (response) {
// If the user is logged in on our site or not.
var loggedIn = #{loggedIn};
if (response.status === 'connected') {
// Facebook says the user is logged in.
if (!loggedIn) {
// But he is not logged in on our site.
window.location.href = '@{loginRoute}';
}
} else {
// User is not logged in.
if (loggedIn) {
// But he is logged in on our site, log him out.
// An undesirable sideeffect of this change is
// that we're always going to log the user out of
// the site if he has logged in via another
// Yesod authentication plugin.
window.location.href = '@{logoutRoute}';
}
}
}
});
}
|]
facebookLogin :: [FB.Permission] -> JavaScriptCall
facebookLogin [] = "FB.login(function () {})"
facebookLogin perms =
T.concat [ "FB.login(function () {}, {scope: '"
, joinPermissions perms
, "'})"
]
facebookForceLoginR :: [FB.Permission] -> Route Auth
facebookForceLoginR perms = fbcsR ["login", "go", joinPermissions perms]
joinPermissions :: [FB.Permission] -> Text
joinPermissions = T.intercalate "," . map FB.unPermission
facebookLogout :: JavaScriptCall
facebookLogout = "FB.logout(function () {})"
type JavaScriptCall = Text
class (YesodAuth master, YF.YesodFacebook master) => YesodAuthFbClientSide master where
getFbChannelFile :: GHandler sub master (Route master)
getFbLanguage :: GHandler sub master Text
getFbLanguage = return "en_US"
getFbInitOpts :: GHandler sub master [(Text, A.Value)]
getFbInitOpts = defaultFbInitOpts
fbAsyncInitJs :: JavascriptUrl (Route master)
fbAsyncInitJs = const mempty
defaultFbInitOpts :: YesodAuthFbClientSide master =>
GHandler sub master [(Text, A.Value)]
defaultFbInitOpts = do
ur <- getUrlRender
creds <- YF.getFbCredentials
channelFile <- getFbChannelFile
return [ ("appId", A.toJSON $ TE.decodeUtf8 $ FB.appId creds)
, ("channelUrl", A.toJSON $ ur channelFile)
, ("status", A.toJSON True)
, ("cookie", A.toJSON True)
]
serveChannelFile :: GHandler sub master ChooseRep
serveChannelFile = do
now <- liftIO TI.getCurrentTime
setHeader "Pragma" "public"
setHeader "Cache-Control" maxAge
setHeader "Expires" (T.pack $ expires now)
return $ chooseRep ("text/html" :: ContentType, channelFileContent)
where oneYearSecs = 60*60*24*365 :: Int
oneYearNDF = fromIntegral oneYearSecs :: TI.NominalDiffTime
maxAge = "max-age=" `T.append` T.pack (show oneYearSecs)
expires now = TI.formatTime defaultTimeLocale "%a, %d %b %Y %T GMT" $
TI.addUTCTime oneYearNDF now
channelFileContent :: Content
channelFileContent = toContent val
where val :: ByteString
val = "<script src=\"//connect.facebook.net/en_US/all.js\"></script>"
authFacebookClientSide :: YesodAuthFbClientSide master
=> AuthPlugin master
authFacebookClientSide =
AuthPlugin "fbcs" dispatch login
where
dispatch :: YesodAuthFbClientSide master =>
Text -> [Text] -> GHandler Auth master ()
dispatch "GET" ["login"] = do
y <- getYesod
when (redirectToReferer y) setUltDestReferer
etoken <- getUserAccessToken
case etoken of
Right token -> setCreds True (createCreds token)
Left msg -> fail msg
dispatch "GET" ["login", "go"] = dispatch "GET" ["login", "go", ""]
dispatch "GET" ["login", "go", perms] = do
y <- getYesod
ur <- getUrlRender
tm <- getRouteToMaster
when (redirectToReferer y) setUltDestReferer
let redirectTo = ur $ tm $ fbcsR ["login", "back"]
uncommas "" = []
uncommas xs = case break (== ',') xs of
(x', ',':xs') -> x' : uncommas xs'
(x', _) -> [x']
url <- YF.runFacebookT $
FB.getUserAccessTokenStep1 redirectTo $
map fromString $ uncommas $ T.unpack perms
redirect url
dispatch "GET" ["login", "back"] = do
tm <- getRouteToMaster
mr <- getMessageRender
fbjssdkpc <- widgetToPageContent (facebookJSSDK tm)
rephtml <- hamletToRepHtml $ [hamlet|$newline never
$doctype 5
<html>
<head>
<title>#{mr Msg.LoginTitle}
^{pageHead fbjssdkpc}
<body>
^{pageBody fbjssdkpc}
|]
sendResponse rephtml
dispatch _ _ = notFound
login :: YesodAuth master =>
(Route Auth -> Route master)
-> GWidget sub master ()
login _ = [whamlet|$newline never
<p>
<a href="#" onclick="#{facebookLogin perms}">
_{Msg.Facebook}
|]
where perms = []
createCreds :: FB.UserAccessToken -> Creds m
createCreds (FB.UserAccessToken userId _ _) = Creds "fbcs" id_ []
where id_ = "http://graph.facebook.com/" `mappend` TE.decodeUtf8 userId
signedRequestCookieName :: FB.Credentials -> Text
signedRequestCookieName = T.append "fbsr_" . TE.decodeUtf8 . FB.appId
getUserAccessToken :: YesodAuthFbClientSide master =>
GHandler sub master (Either String FB.UserAccessToken)
getUserAccessToken =
runErrorT $ do
creds <- lift YF.getFbCredentials
unparsed <- toErrorT "cookie not found" $ lookupCookie (signedRequestCookieName creds)
A.Object parsed <- toErrorT "cannot parse signed request" $
YF.runFacebookT $
FB.parseSignedRequest (TE.encodeUtf8 unparsed)
case (flip A.parseEither () $ const $
(,,,) <$> parsed A..:? "code"
<*> parsed A..:? "user_id"
<*> parsed A..:? "oauth_token"
<*> parsed A..:? "expires") of
Right (Just code, _, _, _) -> do
moldCode <- lift $ lookupSessionBS sessionCode
case moldCode of
Just code' | code == code' -> lift $ do
Just userId <- lookupSessionBS sessionUserId
Just data_ <- lookupSessionBS sessionToken
Just exptime <- lookupSession sessionExpires
return $ FB.UserAccessToken userId data_ (read $ T.unpack exptime)
_ -> do
let fbErrorMsg :: FB.FacebookException -> String
fbErrorMsg exc = "getUserAccessToken: getUserAccessTokenStep2 " ++
"failed with " ++ show exc
token <- ErrorT $
fmap (either (Left . fbErrorMsg) Right) $
E.try $
YF.runFacebookT $
FB.getUserAccessTokenStep2 "" [("code", code)]
case token of
FB.UserAccessToken userId data_ exptime -> lift $ do
setSessionBS sessionCode code
setSessionBS sessionUserId userId
setSessionBS sessionToken data_
setSession sessionExpires (T.pack $ show exptime)
return token
Right (_, Just uid, Just oauth_token, Just expires) ->
return $ FB.UserAccessToken uid oauth_token (toUTCTime expires)
Right (Nothing, _, _, _) ->
throwError "getUserAccessToken: no user_id nor code on signed request"
Left msg ->
throwError ("getUserAccessToken: never here (" ++ show msg ++ ")")
where
toErrorT :: Functor m => String -> m (Maybe a) -> ErrorT String m a
toErrorT msg = ErrorT . fmap (maybe (Left ("getUserAccessToken: " ++ msg)) Right)
toUTCTime :: Integer -> TI.UTCTime
toUTCTime = TI.posixSecondsToUTCTime . fromIntegral
sessionCode = "_FBCSD"
sessionUserId = "_FBCSU"
sessionToken = "_FBCST"
sessionExpires = "_FBCSE"