-- | @yesod-auth@ authentication plugin using Facebook's-- client-side authentication flow. You may see a demo at-- <https://github.com/meteficha/yesod-auth-fb/blob/master/demo/clientside.hs>.---- /WARNING:/ Currently this authentication plugin /does not/-- work with other authentication plugins. If you need many-- different authentication plugins, please try the server-side-- authentication flow (module "Yesod.Auth.Facebook.ServerSide").---- TODO: Explain how the whole thing fits together.moduleYesod.Auth.Facebook.ClientSide(-- * Authentication pluginauthFacebookClientSide,YesodAuthFbClientSide(..)-- * Widgets,facebookJSSDK,facebookLogin,facebookForceLoginR,facebookLogout,JavaScriptCall-- * Useful functions,serveChannelFile,defaultFbInitOpts,getUserAccessToken-- * Advanced,signedRequestCookieName)whereimportControl.Applicative((<$>),(<*>))importControl.Monad(when)importControl.Monad.IO.Class(MonadIO,liftIO)importControl.Monad.Trans.Error(ErrorT(..),throwError)importData.ByteString(ByteString)importData.Monoid(mappend,mempty)importData.String(fromString)importData.Text(Text)importSystem.Locale(defaultTimeLocale)importText.Hamlet(hamlet)importText.Julius(JavascriptUrl,julius)importYesod.AuthimportYesod.ContentimportYesod.CoreimportqualifiedControl.Exception.LiftedasEimportqualifiedData.AesonasAimportqualifiedData.Aeson.TypesasAimportqualifiedData.TextasTimportqualifiedData.Text.EncodingasTEimportqualifiedData.Text.Lazy.EncodingasTLEimportqualifiedData.TimeasTIimportqualifiedData.Time.Clock.POSIXasTIimportqualifiedFacebookasFBimportqualifiedYesod.FacebookasYFimportqualifiedYesod.Auth.MessageasMsg-- import qualified Data.Conduit as C-- | Internal function. Construct a route to our plugin.fbcsR::[Text]->RouteAuthfbcsR=PluginR"fbcs"-- | Hamlet that should be spliced /right after/ the @<body>@ tag-- in order for Facebook's JS SDK to work. For example:---- @-- $doctype 5-- \<html\>-- \<head\>-- ...-- \<body\>-- ^{facebookJSSDK AuthR}-- ...-- @---- Facebook's JS SDK may not work correctly if you place it-- anywhere else on the body. If you absolutely need to do so,-- avoid any elements placed with @position: relative@ or-- @position: absolute@.facebookJSSDK::YesodAuthFbClientSidemaster=>(RouteAuth->Routemaster)->GWidgetsubmaster()facebookJSSDKtoMaster=do(lang,fbInitOptsList,muid)<-lift$(,,)<$>getFbLanguage<*>getFbInitOpts<*>maybeAuthIdletloggedIn=maybe("false"::Text)(const"true")muidloginRoute=toMaster$fbcsR["login"]logoutRoute=toMaster$LogoutRfbInitOpts=A.object$map(uncurry(A..=))fbInitOptsList[whamlet|$newlinenever<div#fb-root>|]toWidgetBody[julius|//LoadtheSDKAsynchronously(function(d){varjs,id='facebook-jssdk',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));//InittheSDKuponloadwindow.fbAsyncInit=function(){FB.init(#{TLE.decodeUtf8$A.encodefbInitOpts});^{fbAsyncInitJs}//SubscribetostatusChangeevent.FB.Event.subscribe("auth.statusChange",function(response){if(response){//Iftheuserisloggedinonoursiteornot.varloggedIn=#{loggedIn};if(response.status==='connected'){//Facebooksaystheuserisloggedin.if(!loggedIn){//Butheisnotloggedinonoursite.window.location.href='@{loginRoute}';}}else{//Userisnotloggedin.if(loggedIn){//Butheisloggedinonoursite,loghimout.//Anundesirableside-effectofthischangeis//thatwe'realwaysgoingtologtheuseroutof//thesiteifhehasloggedinviaanother//Yesodauthenticationplugin.window.location.href='@{logoutRoute}';}}}});}|]-- | JavaScript function that should be called in order to login-- the user. You could splice this into a @onclick@ event, for-- example:---- @-- \<a href=\"\#\" onclick=\"\#{facebookLogin perms}\"\>-- Login via Facebook-- @---- You should not call this function if the user is already-- logged in.------ This is only a helper around Facebook JS SDK's @FB.login()@,-- you may call that function directly if you prefer.facebookLogin::[FB.Permission]->JavaScriptCallfacebookLogin[]="FB.login(function () {})"facebookLoginperms=T.concat["FB.login(function () {}, {scope: '",joinPermissionsperms,"'})"]-- | Route that forces the user to log in. You should avoid-- using this route whenever possible, using 'facebookLogin' is-- much better (after all, this module is for client-side-- authentication). However, you may want to use it at least for-- 'authRoute', e.g.:---- @-- instance 'Yesod' MyFoundation where-- ...-- 'authRoute' _ = Just $ AuthR (facebookForceLoginR [])-- @facebookForceLoginR::[FB.Permission]->RouteAuthfacebookForceLoginRperms=fbcsR["login","go",joinPermissionsperms]-- | Internal function. Joins a list of 'FB.Permission'@s@ into-- a format that Facebook recognizes.joinPermissions::[FB.Permission]->TextjoinPermissions=T.intercalate",".mapFB.unPermission-- | JavaScript function that should be called in order to logout-- the user. You could splice this into a @onclick@ event, for-- example:---- @-- \<a href=\"\#\" onclick=\"\#{facebookLogout}\"\>-- Logout-- @---- You should not call this function if the user is not logged-- in.---- This is only a helper around Facebook JS SDK's @FB.logout()@,-- you may call that function directly if you prefer.facebookLogout::JavaScriptCallfacebookLogout="FB.logout(function () {})"-- | A JavaScript function call.typeJavaScriptCall=Text------------------------------------------------------------------------ | Type class that needs to be implemented in order to use-- 'authFacebookClientSide'.---- Minimal complete definition: 'getFbChannelFile'. (We-- recommend implementing 'getFbLanguage' as well.)class(YesodAuthmaster,YF.YesodFacebookmaster)=>YesodAuthFbClientSidemasterwhere-- | A route that serves Facebook's channel file in the /same/-- /subdomain/ as the current request's subdomain.---- First of all, we recomment using 'serveChannelFile' to-- implement the route's handler. For example, if your route-- is 'ChannelFileR', then you just need:---- @-- getChannelFileR :: GHandler sub master ChooseRep-- getChannelFileR = serveChannelFile-- @---- On most simple cases you may just implement 'fbChannelFile'-- as---- @-- getFbChannelFile = return ChannelFileR-- @---- However, if your routes span many subdomains, then you must-- have a channel file for each subdomain, otherwise your site-- won't work on old Internet Explorer versions (and maybe even-- on other browsers as well). That's why 'getFbChannelFile'-- lives inside 'GHandler'.getFbChannelFile::GHandlersubmaster(Routemaster)-- ^ Return channel file in the /same/-- /subdomain/ as the current route.-- | /(Optional)/ Returns which language we should ask for-- Facebook's JS SDK. You may use information about the-- current request to decide upon a language. Defaults to-- @"en_US"@.---- If you already use Yesod's I18n capabilities, then there's-- an easy way of implementing this function. Just create a-- @FbLanguage@ message, for example on your @en.msg@ file:---- @-- FbLanguage: en_US-- @---- and on your @pt.msg@ file:---- @-- FbLanguage: pt_BR-- @---- Then implement 'getFbLanguage' as:---- @-- getFbLanguage = ($ MsgFbLanguage) \<$\> getMessageRender-- @---- Although somewhat hacky, this trick works perfectly fine and-- /guarantees/ that all Facebook messages will be in the same-- language as the rest of your site (even if Facebook support-- a language that you don't).getFbLanguage::GHandlersubmasterTextgetFbLanguage=return"en_US"-- | /(Optional)/ Options that should be given to @FB.init()@.-- The default implementation is 'defaultFbInitOpts'. If you-- intend to override this function, we advise you to also call-- 'defaultFbInitOpts', e.g.:---- @-- getFbInitOpts = do-- defOpts <- defaultFbInitOpts-- ...-- return (defOpts ++ myOpts)-- @---- However, if you know what you're doing you're free to-- override any or all values returned by 'defaultFbInitOpts'.getFbInitOpts::GHandlersubmaster[(Text,A.Value)]getFbInitOpts=defaultFbInitOpts-- | /(Optional)/ Arbitrary JavaScript that will be called on-- Facebook's JS SDK's @fbAsyncInit@ (i.e. as soon as their SDK-- is loaded).fbAsyncInitJs::JavascriptUrl(Routemaster)fbAsyncInitJs=constmempty-- | Default implementation for 'getFbInitOpts'. Defines:---- [@appId@] Using 'YF.getFbCredentials'.---- [@channelUrl@] Using 'getFbChannelFile'.---- [@cookie@] To @True@. This one is extremely important and-- this module won't work /at all/ without it.---- [@status@] To @True@, since this usually is what you want.defaultFbInitOpts::YesodAuthFbClientSidemaster=>GHandlersubmaster[(Text,A.Value)]defaultFbInitOpts=dour<-getUrlRendercreds<-YF.getFbCredentialschannelFile<-getFbChannelFilereturn[("appId",A.toJSON$TE.decodeUtf8$FB.appIdcreds),("channelUrl",A.toJSON$urchannelFile),("status",A.toJSONTrue)-- Check login status.,("cookie",A.toJSONTrue)-- Enable cookie, extremely important.]-- | Facebook's channel file implementation (see-- <https://developers.facebook.com/docs/reference/javascript/>).---- Note that we set an expire time in the far future, so you-- won't be able to re-use this route again. No common users-- will see this route, so you may use anything.serveChannelFile::GHandlersubmasterChooseRepserveChannelFile=donow<-liftIOTI.getCurrentTimesetHeader"Pragma""public"setHeader"Cache-Control"maxAgesetHeader"Expires"(T.pack$expiresnow)return$chooseRep("text/html"::ContentType,channelFileContent)whereoneYearSecs=60*60*24*365::IntoneYearNDF=fromIntegraloneYearSecs::TI.NominalDiffTimemaxAge="max-age="`T.append`T.pack(showoneYearSecs)expiresnow=TI.formatTimedefaultTimeLocale"%a, %d %b %Y %T GMT"$TI.addUTCTimeoneYearNDFnow-- | Channel file's content. On the toplevel in order to have-- its length and memory representation cached.channelFileContent::ContentchannelFileContent=toContentvalwhereval::ByteStringval="<script src=\"//connect.facebook.net/en_US/all.js\"></script>"-- | Yesod authentication plugin using Facebook's client-side-- authentication flow.---- You /MUST/ use 'facebookJSSDK' as its documentation states.authFacebookClientSide::YesodAuthFbClientSidemaster=>AuthPluginmasterauthFacebookClientSide=AuthPlugin"fbcs"dispatchloginwheredispatch::YesodAuthFbClientSidemaster=>Text->[Text]->GHandlerAuthmaster()-- Login route used when successfully logging in. Called via-- AJAX by JavaScript code on 'facebookJSSDK'.dispatch"GET"["login"]=doy<-getYesodwhen(redirectToReferery)setUltDestRefereretoken<-getUserAccessTokencaseetokenofRighttoken->setCredsTrue(createCredstoken)Leftmsg->failmsg-- Login routes used to forcefully require the user to login.dispatch"GET"["login","go"]=dispatch"GET"["login","go",""]dispatch"GET"["login","go",perms]=do-- Redirect the user to the server-side flow login url.y<-getYesodur<-getUrlRendertm<-getRouteToMasterwhen(redirectToReferery)setUltDestRefererletredirectTo=ur$tm$fbcsR["login","back"]uncommas""=[]uncommasxs=casebreak(==',')xsof(x',',':xs')->x':uncommasxs'(x',_)->[x']url<-YF.runFacebookT$FB.getUserAccessTokenStep1redirectTo$mapfromString$uncommas$T.unpackpermsredirecturldispatch"GET"["login","back"]=do-- Instead of going on with the server-side flow, use the-- client-side JS to finish the authentication.tm<-getRouteToMastermr<-getMessageRenderfbjssdkpc<-widgetToPageContent(facebookJSSDKtm)rephtml<-hamletToRepHtml$[hamlet|$newlinenever$doctype5<html><head><title>#{mrMsg.LoginTitle}^{pageHeadfbjssdkpc}<body>^{pageBodyfbjssdkpc}|]sendResponserephtml-- Everything else gives 404dispatch__=notFound-- Small widget for multiple login websites.login::YesodAuthmaster=>(RouteAuth->Routemaster)->GWidgetsubmaster()login_=[whamlet|$newlinenever<p><ahref="#"onclick="#{facebookLogin perms}">_{Msg.Facebook}|]whereperms=[]-- | Create an @yesod-auth@'s 'Creds' for a given-- @'FB.UserAccessToken'@.createCreds::FB.UserAccessToken->CredsmcreateCreds(FB.UserAccessTokenuserId__)=Creds"fbcs"id_[]whereid_="http://graph.facebook.com/"`mappend`TE.decodeUtf8userId-- | Cookie name with the signed request for the given credentials.signedRequestCookieName::FB.Credentials->TextsignedRequestCookieName=T.append"fbsr_".TE.decodeUtf8.FB.appId-- | Get the Facebook's user access token from Facebook's cookie.-- Returns 'Left' if the cookie is not found, is not-- authentic, is for another app, is corrupted /or/ does not-- contains the information needed (maybe the user is not logged-- in). Note that the returned access token may have expired, we-- recommend using 'FB.hasExpired' and 'FB.isValid'.---- This 'getUserAccessToken' is completely different from the one-- from the "Yesod.Auth.Facebook.ServerSide" module. This one-- does not use only the session, which means that (a) it's somewhat-- slower because everytime you call this 'getUserAccessToken' it-- needs to reverify the cookie, but (b) it is always up-to-date-- with the latest cookie that the Facebook JS SDK has given us-- and (c) avoids duplicating the information from the cookie-- into the session.getUserAccessToken::YesodAuthFbClientSidemaster=>GHandlersubmaster(EitherStringFB.UserAccessToken)getUserAccessToken=runErrorT$docreds<-liftYF.getFbCredentialsunparsed<-toErrorT"cookie not found"$lookupCookie(signedRequestCookieNamecreds)A.Objectparsed<-toErrorT"cannot parse signed request"$YF.runFacebookT$FB.parseSignedRequest(TE.encodeUtf8unparsed)case(flipA.parseEither()$const$(,,,)<$>parsedA..:?"code"<*>parsedA..:?"user_id"<*>parsedA..:?"oauth_token"<*>parsedA..:?"expires")ofRight(Justcode,_,_,_)->do-- We have to exchange the code for the access token.moldCode<-lift$lookupSessionBSsessionCodecasemoldCodeofJustcode'|code==code'->lift$do-- We have a cached token for this code.JustuserId<-lookupSessionBSsessionUserIdJustdata_<-lookupSessionBSsessionTokenJustexptime<-lookupSessionsessionExpiresreturn$FB.UserAccessTokenuserIddata_(read$T.unpackexptime)_->do-- Get access token from Facebook.letfbErrorMsg::FB.FacebookException->StringfbErrorMsgexc="getUserAccessToken: getUserAccessTokenStep2 "++"failed with "++showexctoken<-ErrorT$fmap(either(Left.fbErrorMsg)Right)$E.try$YF.runFacebookT$FB.getUserAccessTokenStep2""[("code",code)]casetokenofFB.UserAccessTokenuserIddata_exptime->lift$do-- Save it for later.setSessionBSsessionCodecodesetSessionBSsessionUserIduserIdsetSessionBSsessionTokendata_setSessionsessionExpires(T.pack$showexptime)returntokenRight(_,Justuid,Justoauth_token,Justexpires)->return$FB.UserAccessTokenuidoauth_token(toUTCTimeexpires)Right(Nothing,_,_,_)->throwError"getUserAccessToken: no user_id nor code on signed request"Leftmsg->throwError("getUserAccessToken: never here ("++showmsg++")")wheretoErrorT::Functorm=>String->m(Maybea)->ErrorTStringmatoErrorTmsg=ErrorT.fmap(maybe(Left("getUserAccessToken: "++msg))Right)toUTCTime::Integer->TI.UTCTimetoUTCTime=TI.posixSecondsToUTCTime.fromIntegralsessionCode="_FBCSD"sessionUserId="_FBCSU"sessionToken="_FBCST"sessionExpires="_FBCSE"