{-#LANGUAGE RankNTypes#-}
{-#LANGUAGE ScopedTypeVariables#-}
{-#LANGUAGE LambdaCase#-}
module Yesod.Auth.Facebook.ClientSide
(
authFacebookClientSide
, YesodAuthFbClientSide(..)
, facebookJSSDK
, facebookLogin
, facebookForceLoginR
, facebookLogout
, JavaScriptCall
, serveChannelFile
, defaultFbInitOpts
, extractCredsAccessToken
, getUserAccessTokenFromFbCookie
, signedRequestCookieName
) where
import Control.Applicative ((<$>), (<*>))
import Control.Monad (when)
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 Network.Wai (queryString)
import Text.Julius (JavascriptUrl, julius, rawJS)
import Yesod.Auth
import Yesod.Core
import qualified Control.Monad.Trans.Resource as R
import qualified UnliftIO.Exception 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.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 site =>
(Route Auth -> Route site)
-> WidgetT site IO ()
facebookJSSDK toSite = do
(lang, fbInitOptsList, muid, ur) <-
handlerToWidget $
(,,,) <$> getFbLanguage
<*> getFbInitOpts
<*> maybeAuthId
<*> getUrlRender
let loggedIn = maybe False (const True) muid
loginRoute = toSite $ fbcsR ["login"]
logoutRoute = toSite $ LogoutR
fbInitOpts = A.object $ map (uncurry (A..=)) fbInitOptsList
[whamlet|$newline never
<div #fb-root>
|]
toWidgetBody [julius|
// Load the SDK Asynchronously
(function(d){
var js, 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/#{rawJS lang}/all.js";
ref.parentNode.insertBefore(js, ref);
}(document));
// Init the SDK upon load
window.fbAsyncInit = function() {
FB.init(#{A.toJSON 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 = #{A.toJSON 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 side-effect 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}';
}
}
}
});
}
// Logout function
window.$$yfblogout = function () {
FB.getLoginStatus(function(response) {
if (response.status !== 'connected' ||
FB.logout(function () {}) === undefined) {
window.location.href = #{A.toJSON (ur (toSite LogoutR))}
}
});
return (function () {});
};
|]
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 = "window.$$yfblogout()"
type JavaScriptCall = Text
class (YesodAuth site, YF.YesodFacebook site) => YesodAuthFbClientSide site where
getFbChannelFile :: HandlerT site IO (Route site)
getFbLanguage :: HandlerT site IO Text
getFbLanguage = return "en_US"
getFbInitOpts :: HandlerT site IO [(Text, A.Value)]
getFbInitOpts = defaultFbInitOpts
fbAsyncInitJs :: JavascriptUrl (Route site)
fbAsyncInitJs = const mempty
defaultFbInitOpts :: YesodAuthFbClientSide site =>
HandlerT site IO [(Text, A.Value)]
defaultFbInitOpts = do
ur <- getUrlRender
creds <- YF.getFbCredentials
channelFile <- getFbChannelFile
return [ ("appId", A.toJSON $ FB.appId creds)
, ("channelUrl", A.toJSON $ ur channelFile)
, ("status", A.toJSON True)
, ("cookie", A.toJSON True)
]
serveChannelFile :: HandlerT site IO TypedContent
serveChannelFile = do
addHeader "Pragma" "public"
cacheSeconds oneYearSecs
neverExpires
selectRep $ provideRepType "text/html" (return channelFileContent)
where oneYearSecs = 60*60*24*365 :: Int
channelFileContent :: Content
channelFileContent = toContent val
where val :: ByteString
val = "<script src=\"//connect.facebook.net/en_US/all.js\"></script>"
authFacebookClientSide :: YesodAuthFbClientSide site
=> AuthPlugin site
authFacebookClientSide =
AuthPlugin "fbcs" dispatch login
where
dispatch :: YesodAuthFbClientSide site =>
Text -> [Text] -> AuthHandler site TypedContent
dispatch "GET" ["login"] = do
y <- getYesod
when (redirectToReferer y) setUltDestReferer
etoken <- getUserAccessTokenFromFbCookie
case etoken of
Right token -> setCredsRedirect (createCreds token)
Left msg -> liftIO $ fail msg
dispatch "GET" ["login", "go"] = dispatch "GET" ["login", "go", ""]
dispatch "GET" ["login", "go", perms] = do
y <- getYesod
(ur :: Route site -> FB.RedirectUrl) <- getUrlRender
(tm :: Route Auth -> Route site) <- getRouteToParent
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 <- liftSubHandler $ YF.runYesodFbT $
FB.getUserAccessTokenStep1 redirectTo $
map fromString $ uncommas $ T.unpack perms
redirect url
dispatch "GET" ["login", "back"] = do
ur <- getUrlRender
tm <- getRouteToParent
query <- queryString <$> waiRequest
let proceedUrl = ur $ tm $ fbcsR ["login", "back"]
query' = [(a,b) | (a, Just b) <- query]
token <- liftSubHandler $ YF.runYesodFbT $
(FB.getUserAccessTokenStep2 proceedUrl query')
setCredsRedirect (createCreds token)
dispatch _ _ = notFound
login :: YesodAuth site =>
(Route Auth -> Route site)
-> WidgetT site IO ()
login _ = [whamlet|$newline never
<p>
<a href="#" onclick="#{facebookLogin perms}">
_{Msg.Facebook}
|]
where perms = []
createCreds :: FB.UserAccessToken -> Creds m
createCreds at@(FB.UserAccessToken (FB.Id userId) _ _) =
let id_ = "http://graph.facebook.com/" `mappend` userId
in Creds "fbcs" id_ (atToText at)
extractCredsAccessToken :: Creds m -> Maybe FB.UserAccessToken
extractCredsAccessToken (Creds "fbcs" _ extra) = textToAt extra
extractCredsAccessToken _ = Nothing
atToText :: FB.UserAccessToken -> [(Text, Text)]
atToText (FB.UserAccessToken userId data_ expires) =
[ ("at_id", FB.idCode userId)
, ("at_data", data_)
, ("at_expires", T.pack (show expires)) ]
textToAt :: [(Text, Text)] -> Maybe FB.UserAccessToken
textToAt texts = do
at_id <- lookup "at_id" texts
at_data <- lookup "at_data" texts
at_expires <- lookup "at_expires" texts
[(expires, "")] <- return $ readsPrec 0 (T.unpack at_expires)
return $ FB.UserAccessToken (FB.Id at_id) at_data expires
signedRequestCookieName :: FB.Credentials -> Text
signedRequestCookieName = T.append "fbsr_" . FB.appId
getUserAccessTokenFromFbCookie ::
YesodAuthFbClientSide site =>
AuthHandler site (Either String FB.UserAccessToken)
getUserAccessTokenFromFbCookie =
runErrorT $ do
creds <- lift YF.getFbCredentials
unparsed <- toErrorT "cookie not found" $ lookupCookie (signedRequestCookieName creds)
A.Object parsed <- toErrorT "cannot parse signed request" $
liftSubHandler $
YF.runYesodFbT $
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 codeT, _, _, _) -> do
let code = TE.encodeUtf8 codeT
moldCode <- lift $ lookupSessionBS sessionCode
case moldCode of
Just code' | code == code' -> lift $ do
userId <- lookupSessionIO sessionUserId
data_ <- lookupSessionIO sessionToken
exptime <- lookupSessionIO sessionExpires
return $ FB.UserAccessToken (FB.Id userId) data_ (read $ T.unpack exptime)
_ -> do
let fbErrorMsg :: FB.FacebookException -> String
fbErrorMsg exc = "getUserAccessTokenFromFbCookie: getUserAccessTokenStep2 " ++
"failed with " ++ show exc
token <- ErrorT $
fmap (either (Left . fbErrorMsg) Right) $
E.try $
liftSubHandler $
YF.runYesodFbT $
FB.getUserAccessTokenStep2 "" [("code", code)]
case token of
FB.UserAccessToken userId data_ exptime -> lift $ do
setSessionBS sessionCode code
setSession sessionUserId (FB.idCode userId)
setSession 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 "getUserAccessTokenFromFbCookie: no user_id nor code on signed request"
Left msg ->
throwError ("getUserAccessTokenFromFbCookie: never here (" ++ show msg ++ ")")
where
toErrorT :: Functor m => String -> m (Maybe a) -> ErrorT String m a
toErrorT msg = ErrorT . fmap (maybe (Left ("getUserAccessTokenFromFbCookie: " ++ msg)) Right)
toUTCTime :: Integer -> TI.UTCTime
toUTCTime = TI.posixSecondsToUTCTime . fromIntegral
sessionCode = "_FBCSD"
sessionUserId = "_FBCSU"
sessionToken = "_FBCST"
sessionExpires = "_FBCSE"
lookupSessionIO x = lookupSession x >>= \case
Just t -> return t
Nothing -> liftIO $ fail "lookupSession could not find session"