module Yesod.Auth.Facebook.ClientSide
(
authFacebookClientSide
, YesodAuthFbClientSide(..)
, facebookJSSDK
, facebookLogin
, facebookLogout
, JavaScriptCall
, serveChannelFile
, getFbCredentials
, defaultFbInitOpts
, getUserAccessToken
, signedRequestCookieName
) where
import Control.Applicative ((<$>), (<*>))
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.Text (Text)
import System.Locale (defaultTimeLocale)
import Text.Julius (JavascriptUrl, julius)
import Yesod.Auth
import Yesod.Content
import Yesod.Handler
import Yesod.Request
import Yesod.Widget
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.Auth.Message as Msg
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 $ PluginR "fbcs" ["login"]
logoutRoute = toMaster $ LogoutR
fbInitOpts = A.object $ map (uncurry (A..=)) fbInitOptsList
[whamlet|
<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: '"
, T.intercalate "," (map FB.unPermission perms)
, "'})"
]
facebookLogout :: JavaScriptCall
facebookLogout = "FB.logout(function () {})"
type JavaScriptCall = Text
class YesodAuth master => YesodAuthFbClientSide master where
fbCredentials :: master -> FB.Credentials
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 <- 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>"
getFbCredentials :: YesodAuthFbClientSide master =>
GHandler sub master FB.Credentials
getFbCredentials = fbCredentials <$> getYesod
authFacebookClientSide :: YesodAuthFbClientSide master
=> AuthPlugin master
authFacebookClientSide =
AuthPlugin "fbcs" dispatch login
where
dispatch "GET" ["login"] = do
etoken <- getUserAccessToken
case etoken of
Right token -> setCreds True (createCreds token)
Left msg -> fail msg
dispatch _ _ = notFound
login :: YesodAuth master =>
(Route Auth -> Route master)
-> GWidget sub master ()
login _ = [whamlet|
<p>
<a href="#{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 getFbCredentials
manager <- authHttpManager <$> lift getYesod
unparsed <- toErrorT "cookie not found" $ lookupCookie (signedRequestCookieName creds)
A.Object parsed <- toErrorT "cannot parse signed request" $
FB.runFacebookT creds manager $
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, _, _, _) -> lift $ do
moldCode <- lookupSession sessionCode
case moldCode of
Just code' | code == TE.encodeUtf8 code' -> do
Just userId <- lookupSession sessionUserId
Just data_ <- lookupSession sessionToken
Just exptime <- lookupSession sessionExpires
return $ FB.UserAccessToken (TE.encodeUtf8 userId)
(TE.encodeUtf8 data_)
(read $ T.unpack exptime)
_ -> do
token <- FB.runFacebookT creds manager $
FB.getUserAccessTokenStep2 "" [("code", code)]
case token of
FB.UserAccessToken userId data_ exptime -> do
setSession sessionCode (TE.decodeUtf8 code)
setSession sessionUserId (TE.decodeUtf8 userId)
setSession sessionToken (TE.decodeUtf8 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 "no user_id nor code on signed request"
Left msg ->
throwError ("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 = "_FBCSC"
sessionUserId = "_FBCSI"
sessionToken = "_FBCSA"
sessionExpires = "_FBCSE"