yesod-auth-fb 1.0.2 → 1.0.3
raw patch · 6 files changed
+806/−208 lines, 6 filesdep +aesondep +bytestringdep +old-localedep ~basedep ~fbPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: aeson, bytestring, old-locale, shakespeare-js, time
Dependency ranges changed: base, fb
API changes (from Hackage documentation)
- Yesod.Auth.Facebook: authFacebook :: YesodAuth master => Credentials -> [Permission] -> AuthPlugin master
- Yesod.Auth.Facebook: beta_authFacebook :: YesodAuth master => Credentials -> [Permission] -> AuthPlugin master
- Yesod.Auth.Facebook: facebookLogin :: AuthRoute
- Yesod.Auth.Facebook: facebookLogout :: AuthRoute
- Yesod.Auth.Facebook: getUserAccessToken :: GHandler sub master (Maybe UserAccessToken)
- Yesod.Auth.Facebook: setUserAccessToken :: UserAccessToken -> GHandler sub master ()
+ Yesod.Auth.Facebook.ClientSide: authFacebookClientSide :: YesodAuthFbClientSide master => AuthPlugin master
+ Yesod.Auth.Facebook.ClientSide: class YesodAuth master => YesodAuthFbClientSide master where getFbLanguage = return "en_US" getFbInitOpts = defaultFbInitOpts fbAsyncInitJs = const mempty
+ Yesod.Auth.Facebook.ClientSide: defaultFbInitOpts :: YesodAuthFbClientSide master => GHandler sub master [(Text, Value)]
+ Yesod.Auth.Facebook.ClientSide: facebookJSSDK :: YesodAuthFbClientSide master => (Route Auth -> Route master) -> GWidget sub master ()
+ Yesod.Auth.Facebook.ClientSide: facebookLogin :: [Permission] -> JavaScriptCall
+ Yesod.Auth.Facebook.ClientSide: facebookLogout :: JavaScriptCall
+ Yesod.Auth.Facebook.ClientSide: fbAsyncInitJs :: YesodAuthFbClientSide master => JavascriptUrl (Route master)
+ Yesod.Auth.Facebook.ClientSide: fbCredentials :: YesodAuthFbClientSide master => master -> Credentials
+ Yesod.Auth.Facebook.ClientSide: getFbChannelFile :: YesodAuthFbClientSide master => GHandler sub master (Route master)
+ Yesod.Auth.Facebook.ClientSide: getFbCredentials :: YesodAuthFbClientSide master => GHandler sub master Credentials
+ Yesod.Auth.Facebook.ClientSide: getFbInitOpts :: YesodAuthFbClientSide master => GHandler sub master [(Text, Value)]
+ Yesod.Auth.Facebook.ClientSide: getFbLanguage :: YesodAuthFbClientSide master => GHandler sub master Text
+ Yesod.Auth.Facebook.ClientSide: getUserAccessToken :: YesodAuthFbClientSide master => GHandler sub master (Either String UserAccessToken)
+ Yesod.Auth.Facebook.ClientSide: serveChannelFile :: GHandler sub master ChooseRep
+ Yesod.Auth.Facebook.ClientSide: signedRequestCookieName :: Credentials -> Text
+ Yesod.Auth.Facebook.ClientSide: type JavaScriptCall = Text
+ Yesod.Auth.Facebook.ServerSide: authFacebook :: YesodAuth master => Credentials -> [Permission] -> AuthPlugin master
+ Yesod.Auth.Facebook.ServerSide: beta_authFacebook :: YesodAuth master => Credentials -> [Permission] -> AuthPlugin master
+ Yesod.Auth.Facebook.ServerSide: deleteUserAccessToken :: GHandler sub master ()
+ Yesod.Auth.Facebook.ServerSide: facebookLogin :: AuthRoute
+ Yesod.Auth.Facebook.ServerSide: facebookLogout :: AuthRoute
+ Yesod.Auth.Facebook.ServerSide: getUserAccessToken :: GHandler sub master (Maybe UserAccessToken)
+ Yesod.Auth.Facebook.ServerSide: setUserAccessToken :: UserAccessToken -> GHandler sub master ()
Files
- demo/clientside.hs +129/−0
- include/qq.h +0/−11
- src/Yesod/Auth/Facebook.hs +7/−185
- src/Yesod/Auth/Facebook/ClientSide.hs +445/−0
- src/Yesod/Auth/Facebook/ServerSide.hs +196/−0
- yesod-auth-fb.cabal +29/−12
+ demo/clientside.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses,+ TemplateHaskell, OverloadedStrings, StandaloneDeriving #-}++import System.Environment (getEnv)+import System.Exit (exitFailure)+import System.IO.Error (isDoesNotExistError)+import Yesod+import Yesod.Auth+import Yesod.Auth.Facebook.ClientSide+import Yesod.Form.I18n.English+import qualified Control.Exception.Lifted as E+import qualified Data.ByteString.Char8 as B+import qualified Data.Text as T+import qualified Facebook as FB+import qualified Network.HTTP.Conduit as H+++data Test = Test { httpManager :: H.Manager+ , fbCreds :: FB.Credentials }+++mkYesod "Test" [parseRoutes|+ / HomeR GET+ /auth AuthR Auth getAuth+ /fbchannelfile FbChannelFileR GET+|]+++instance Yesod Test where+ approot = ApprootStatic "http://dev.whonodes.org:3000"++instance RenderMessage Test FormMessage where+ renderMessage _ _ = englishFormMessage+++instance YesodAuth Test where+ type AuthId Test = T.Text+ loginDest _ = HomeR+ logoutDest _ = HomeR+ getAuthId creds@(Creds _ id_ _) = do+ setSession "creds" (T.pack $ show creds)+ return (Just id_)+ authPlugins _ = [authFacebookClientSide]+ redirectToReferer _ = True+ authHttpManager = httpManager++deriving instance Show (Creds m)++instance YesodAuthFbClientSide Test where+ fbCredentials = fbCreds+ getFbChannelFile = return FbChannelFileR+++getHomeR :: Handler RepHtml+getHomeR = do+ muid <- maybeAuthId+ mcreds <- lookupSession "creds"+ mtoken <- getUserAccessToken+ let perms = []+ pc <- widgetToPageContent $ [whamlet|+ ^{facebookJSSDK AuthR}+ <p>+ Current uid: #{show muid}+ <br>+ Current credentials: #{show mcreds}+ <br>+ Current access token: #{show mtoken}+ <p>+ <button onclick="#{facebookLogin perms}">+ Login+ <p>+ <button onclick="#{facebookLogout}">+ Logout+ |]+ hamletToRepHtml [hamlet|+ $doctype 5+ <html>+ <head>+ <title>Yesod.Auth.Facebook.ClientSide test+ ^{pageHead pc}+ <body>+ ^{pageBody pc}+ |]+++getFbChannelFileR :: GHandler sub master ChooseRep+getFbChannelFileR = serveChannelFile+++main :: IO ()+main = do+ manager <- H.newManager H.def+ creds <- getCredentials+ warpDebug 3000 (Test manager creds)++++-- Copy & pasted from the "fb" package:++-- | Grab the Facebook credentials from the environment.+getCredentials :: IO FB.Credentials+getCredentials = tryToGet `E.catch` showHelp+ where+ tryToGet = do+ [appName, appId, appSecret] <- mapM getEnv ["APP_NAME", "APP_ID", "APP_SECRET"]+ return $ FB.Credentials (B.pack appName) (B.pack appId) (B.pack appSecret)++ showHelp exc | not (isDoesNotExistError exc) = E.throw exc+ showHelp _ = do+ putStrLn $ unlines+ [ "In order to run the tests from the 'fb' package, you need"+ , "developer access to a Facebook app. The tests are designed"+ , "so that your app isn't going to be hurt, but we may not"+ , "create a Facebook app for this purpose and then distribute"+ , "its secret keys in the open."+ , ""+ , "Please give your app's name, id and secret on the enviroment"+ , "variables APP_NAME, APP_ID and APP_SECRET, respectively. "+ , "For example, before running the test you could run in the shell:"+ , ""+ , " $ export APP_NAME=\"example\""+ , " $ export APP_ID=\"458798571203498\""+ , " $ export APP_SECRET=\"28a9d0fa4272a14a9287f423f90a48f2304\""+ , ""+ , "Of course, these values above aren't valid and you need to"+ , "replace them with your own."+ , ""+ , "(Exiting now with a failure code.)"]+ exitFailure
− include/qq.h
@@ -1,11 +0,0 @@--- Stolen from yesod-auth.------ CPP macro which choses which quasyquotes syntax to use depending--- on GHC version.------ QQ stands for quasiquote.-#if GHC7-# define QQ(x) x-#else-# define QQ(x) $x-#endif
src/Yesod/Auth/Facebook.hs view
@@ -1,187 +1,9 @@+-- | This is a deprecated module that just re-exports+-- "Yesod.Auth.Facebook.ServerSide". module Yesod.Auth.Facebook- ( -- * Authentication plugin- authFacebook- , facebookLogin- , facebookLogout-- -- * Useful functions- , getUserAccessToken- , setUserAccessToken-- -- * Advanced- , beta_authFacebook- ) where--#include "qq.h"-import Control.Applicative ((<$>))-import Control.Monad (when)-import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Monad.Trans.Maybe (MaybeT(..))-import Data.Monoid (mappend)-import Data.Text (Text)-import Network.Wai (queryString)-import Yesod.Auth-import Yesod.Handler-import Yesod.Widget-import qualified Data.Text as T-import qualified Data.Text.Encoding as TE-import qualified Facebook as FB-import qualified Yesod.Auth.Message as Msg-import qualified Data.Conduit as C---- | Route for login using this authentication plugin.-facebookLogin :: AuthRoute-facebookLogin = PluginR "fb" ["login"]----- | Route for logout using this authentication plugin. This--- will log your user out of your site /and/ log him out of--- Facebook since, at the time of writing, Facebook's policies--- (<https://developers.facebook.com/policy/>) specified that the--- user needs to be logged out from Facebook itself as well. If--- you want to always logout from just your site (and not from--- Facebook), use 'LogoutR'.-facebookLogout :: AuthRoute-facebookLogout = PluginR "fb" ["logout"]----- | Yesod authentication plugin using Facebook.-authFacebook :: YesodAuth master- => FB.Credentials -- ^ Your application's credentials.- -> [FB.Permission] -- ^ Permissions to be requested.- -> AuthPlugin master-authFacebook = authFacebookHelper False----- | Same as 'authFacebook', but uses Facebook's beta tier.--- Usually this is /not/ what you want, so use 'authFacebook'--- unless you know what you're doing.------ /Since: 0.10.1/-beta_authFacebook :: YesodAuth master- => FB.Credentials- -> [FB.Permission]- -> AuthPlugin master-beta_authFacebook = authFacebookHelper True----- | Helper function for 'authFacebook' and 'beta_authFacebook'.-authFacebookHelper :: YesodAuth master- => Bool -- ^ @useBeta@- -> FB.Credentials- -> [FB.Permission]- -> AuthPlugin master-authFacebookHelper useBeta creds perms = AuthPlugin "fb" dispatch login- where- -- Run a Facebook action.- runFB :: YesodAuth master =>- FB.FacebookT FB.Auth (C.ResourceT IO) a- -> GHandler sub master a- runFB act = do- manager <- authHttpManager <$> getYesod- liftIO $ C.runResourceT $- (if useBeta then FB.beta_runFacebookT else FB.runFacebookT)- creds manager act-- -- Get the URL in facebook.com where users are redirected to.- getRedirectUrl :: YesodAuth master =>- (Route Auth -> Route master)- -> GHandler sub master Text- getRedirectUrl tm = do- render <- getUrlRender- let proceedUrl = render (tm proceedR)- runFB $ FB.getUserAccessTokenStep1 proceedUrl perms- proceedR = PluginR "fb" ["proceed"]-- -- Redirect the user to Facebook.- dispatch "GET" ["login"] = do- m <- getYesod- when (redirectToReferer m) setUltDestReferer- redirect =<< getRedirectUrl =<< getRouteToMaster- -- Take Facebook's code and finish authentication.- dispatch "GET" ["proceed"] = do- tm <- getRouteToMaster- render <- getUrlRender- query <- queryString <$> waiRequest- let proceedUrl = render (tm proceedR)- query' = [(a,b) | (a, Just b) <- query]- token <- runFB $ FB.getUserAccessTokenStep2 proceedUrl query'- setUserAccessToken token- setCreds True (createCreds token)- -- Logout the user from our site and from Facebook.- dispatch "GET" ["logout"] = do- m <- getYesod- tm <- getRouteToMaster- mtoken <- getUserAccessToken- when (redirectToReferer m) setUltDestReferer-- -- Facebook doesn't redirect back to our chosen address- -- when the user access token is invalid, so we need to- -- check its validity before anything else.- valid <- maybe (return False) (runFB . FB.isValid) mtoken-- case (valid, mtoken) of- (True, Just token) -> do- render <- getUrlRender- dest <- runFB $ FB.getUserLogoutUrl token (render $ tm $ PluginR "fb" ["kthxbye"])- redirect dest- _ -> dispatch "GET" ["kthxbye"]- -- Finish the logout procedure. Unfortunately we have to- -- replicate yesod-auth's postLogoutR code here since it's- -- not accessible for us. We also can't just redirect to- -- LogoutR since it would otherwise call setUltDestReferrer- -- again.- dispatch "GET" ["kthxbye"] = do- m <- getYesod- deleteSession "_ID"- deleteSession "_FBID"- deleteSession "_FBAT"- deleteSession "_FBET"- onLogout- redirectUltDest $ logoutDest m- -- Anything else gives 404- dispatch _ _ = notFound-- -- Small widget for multiple login websites.- login :: YesodAuth master =>- (Route Auth -> Route master)- -> GWidget sub master ()- login tm = do- redirectUrl <- lift (getRedirectUrl tm)- [QQ(whamlet)|-<p>- <a href="#{redirectUrl}">_{Msg.Facebook}-|]----- | Create an @yesod-auth@'s 'Creds' for a given--- @'FB.UserAccessToken'@.-createCreds :: FB.UserAccessToken -> Creds m-createCreds (FB.UserAccessToken userId _ _) = Creds "fb" id_ []- where id_ = "http://graph.facebook.com/" `mappend` TE.decodeUtf8 userId----- | Set the Facebook's user access token on the user's session.--- Usually you don't need to call this function, but it may--- become handy together with 'FB.extendUserAccessToken'.-setUserAccessToken :: FB.UserAccessToken- -> GHandler sub master ()-setUserAccessToken (FB.UserAccessToken userId data_ exptime) = do- setSession "_FBID" (TE.decodeUtf8 userId)- setSession "_FBAT" (TE.decodeUtf8 data_)- setSession "_FBET" (T.pack $ show exptime)-+ {-# DEPRECATED "Use Yesod.Auth.Facebook.ServerSide instead (since yesod-auth-fb 1.0.3)." #-}+ ( -- * Re-export+ module Yesod.Auth.Facebook.ServerSide+ ) where --- | Get the Facebook's user access token from the session.--- Returns @Nothing@ if it's not found (probably because the user--- is not logged in via @yesod-auth-fb@). Note that the returned--- access token may have expired, we recommend using--- 'FB.hasExpired' and 'FB.isValid'.-getUserAccessToken :: GHandler sub master (Maybe FB.UserAccessToken)-getUserAccessToken = runMaybeT $ do- userId <- MaybeT $ lookupSession "_FBID"- data_ <- MaybeT $ lookupSession "_FBAT"- exptime <- MaybeT $ lookupSession "_FBET"- return $ FB.UserAccessToken (TE.encodeUtf8 userId)- (TE.encodeUtf8 data_)- (read $ T.unpack exptime)+import Yesod.Auth.Facebook.ServerSide
+ src/Yesod/Auth/Facebook/ClientSide.hs view
@@ -0,0 +1,445 @@+-- | @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.+module Yesod.Auth.Facebook.ClientSide+ ( -- * Authentication plugin+ authFacebookClientSide+ , YesodAuthFbClientSide(..)++ -- * Widgets+ , facebookJSSDK+ , facebookLogin+ , facebookLogout+ , JavaScriptCall++ -- * Useful functions+ , serveChannelFile+ , getFbCredentials+ , defaultFbInitOpts+ , getUserAccessToken++ -- * Advanced+ , 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+-- import qualified Data.Conduit as C+++-- | 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 :: 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 #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/#{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 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}';+ }+ }+ }+ });+ }+ |]+++-- | 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] -> JavaScriptCall+facebookLogin [] = "FB.login(function () {})"+facebookLogin perms =+ T.concat [ "FB.login(function () {}, {scope: '"+ , T.intercalate "," (map FB.unPermission perms)+ , "'})"+ ]+++-- | 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 :: JavaScriptCall+facebookLogout = "FB.logout(function () {})"+++-- | A JavaScript function call.+type JavaScriptCall = Text+++----------------------------------------------------------------------+++-- | Type class that needs to be implemented in order to use+-- 'authFacebookClientSide'.+--+-- Minimal complete definition: 'fbCredentials' and+-- 'getFbChannelFile'. (We recommend implementing+-- 'getFbLanguage' as well.)+class YesodAuth master => YesodAuthFbClientSide master where+ -- | Facebook 'FB.Credentials' for your app.+ fbCredentials :: master -> FB.Credentials++ -- | 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 :: GHandler sub master (Route master)+ -- ^ 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 :: GHandler sub master Text+ getFbLanguage = 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 :: GHandler sub master [(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 (Route master)+ fbAsyncInitJs = const mempty+++-- | Default implementation for 'getFbInitOpts'. Defines:+--+-- [@appId@] Using '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 :: 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) -- Check login status.+ , ("cookie", A.toJSON True) -- 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 :: 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+++-- | Channel file's content. On the toplevel in order to have+-- its length and memory representation cached.+channelFileContent :: Content+channelFileContent = toContent val+ where val :: ByteString+ val = "<script src=\"//connect.facebook.net/en_US/all.js\"></script>"+++-- | Returns Facebook's 'FB.Credentials' from inside a+-- 'GHandler'. Just a convenience around 'fbCredentials'.+getFbCredentials :: YesodAuthFbClientSide master =>+ GHandler sub master FB.Credentials+getFbCredentials = fbCredentials <$> getYesod+++-- | Yesod authentication plugin using Facebook's client-side+-- authentication flow.+--+-- You /MUST/ use 'facebookJSSDK' as its documentation states.+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+ -- Anything else gives 404+ dispatch _ _ = notFound++ -- Small widget for multiple login websites.+ login :: YesodAuth master =>+ (Route Auth -> Route master)+ -> GWidget sub master ()+ login _ = [whamlet|+ <p>+ <a href="#{facebookLogin perms}">+ _{Msg.Facebook}+ |]+ where perms = []+++-- | Create an @yesod-auth@'s 'Creds' for a given+-- @'FB.UserAccessToken'@.+createCreds :: FB.UserAccessToken -> Creds m+createCreds (FB.UserAccessToken userId _ _) = Creds "fbcs" id_ []+ where id_ = "http://graph.facebook.com/" `mappend` TE.decodeUtf8 userId+++-- | Cookie name with the signed request for the given credentials.+signedRequestCookieName :: FB.Credentials -> Text+signedRequestCookieName = 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 :: 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+ -- We have to exchange the code for the access token.+ moldCode <- lookupSession sessionCode+ case moldCode of+ Just code' | code == TE.encodeUtf8 code' -> do+ -- We have a cached token for this code.+ 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+ -- Get access token from Facebook.+ token <- FB.runFacebookT creds manager $+ FB.getUserAccessTokenStep2 "" [("code", code)]+ case token of+ FB.UserAccessToken userId data_ exptime -> do+ -- Save it for later.+ 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"
+ src/Yesod/Auth/Facebook/ServerSide.hs view
@@ -0,0 +1,196 @@+-- | @yesod-auth@ authentication plugin using Facebook's+-- server-side authentication flow.+module Yesod.Auth.Facebook.ServerSide+ ( -- * Authentication plugin+ authFacebook+ , facebookLogin+ , facebookLogout++ -- * Useful functions+ , getUserAccessToken+ , setUserAccessToken++ -- * Advanced+ , beta_authFacebook+ , deleteUserAccessToken+ ) where++import Control.Applicative ((<$>))+import Control.Monad (when)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Trans.Maybe (MaybeT(..))+import Data.Monoid (mappend)+import Data.Text (Text)+import Network.Wai (queryString)+import Yesod.Auth+import Yesod.Handler+import Yesod.Widget+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Facebook as FB+import qualified Yesod.Auth.Message as Msg+import qualified Data.Conduit as C++-- | Route for login using this authentication plugin.+facebookLogin :: AuthRoute+facebookLogin = PluginR "fb" ["login"]+++-- | Route for logout using this authentication plugin. This+-- will log your user out of your site /and/ log him out of+-- Facebook since, at the time of writing, Facebook's policies+-- (<https://developers.facebook.com/policy/>) specified that the+-- user needs to be logged out from Facebook itself as well. If+-- you want to always logout from just your site (and not from+-- Facebook), use 'LogoutR'.+facebookLogout :: AuthRoute+facebookLogout = PluginR "fb" ["logout"]+++-- | Yesod authentication plugin using Facebook.+authFacebook :: YesodAuth master+ => FB.Credentials -- ^ Your application's credentials.+ -> [FB.Permission] -- ^ Permissions to be requested.+ -> AuthPlugin master+authFacebook = authFacebookHelper False+++-- | Same as 'authFacebook', but uses Facebook's beta tier.+-- Usually this is /not/ what you want, so use 'authFacebook'+-- unless you know what you're doing.+--+-- /Since: 0.10.1/+beta_authFacebook :: YesodAuth master+ => FB.Credentials+ -> [FB.Permission]+ -> AuthPlugin master+beta_authFacebook = authFacebookHelper True+++-- | Helper function for 'authFacebook' and 'beta_authFacebook'.+authFacebookHelper :: YesodAuth master+ => Bool -- ^ @useBeta@+ -> FB.Credentials+ -> [FB.Permission]+ -> AuthPlugin master+authFacebookHelper useBeta creds perms = AuthPlugin "fb" dispatch login+ where+ -- Run a Facebook action.+ runFB :: YesodAuth master =>+ FB.FacebookT FB.Auth (C.ResourceT IO) a+ -> GHandler sub master a+ runFB act = do+ manager <- authHttpManager <$> getYesod+ liftIO $ C.runResourceT $+ (if useBeta then FB.beta_runFacebookT else FB.runFacebookT)+ creds manager act++ -- Get the URL in facebook.com where users are redirected to.+ getRedirectUrl :: YesodAuth master =>+ (Route Auth -> Route master)+ -> GHandler sub master Text+ getRedirectUrl tm = do+ render <- getUrlRender+ let proceedUrl = render (tm proceedR)+ runFB $ FB.getUserAccessTokenStep1 proceedUrl perms+ proceedR = PluginR "fb" ["proceed"]++ -- Redirect the user to Facebook.+ dispatch "GET" ["login"] = do+ m <- getYesod+ when (redirectToReferer m) setUltDestReferer+ redirect =<< getRedirectUrl =<< getRouteToMaster+ -- Take Facebook's code and finish authentication.+ dispatch "GET" ["proceed"] = do+ tm <- getRouteToMaster+ render <- getUrlRender+ query <- queryString <$> waiRequest+ let proceedUrl = render (tm proceedR)+ query' = [(a,b) | (a, Just b) <- query]+ token <- runFB $ FB.getUserAccessTokenStep2 proceedUrl query'+ setUserAccessToken token+ setCreds True (createCreds token)+ -- Logout the user from our site and from Facebook.+ dispatch "GET" ["logout"] = do+ m <- getYesod+ tm <- getRouteToMaster+ mtoken <- getUserAccessToken+ when (redirectToReferer m) setUltDestReferer++ -- Facebook doesn't redirect back to our chosen address+ -- when the user access token is invalid, so we need to+ -- check its validity before anything else.+ valid <- maybe (return False) (runFB . FB.isValid) mtoken++ case (valid, mtoken) of+ (True, Just token) -> do+ render <- getUrlRender+ dest <- runFB $ FB.getUserLogoutUrl token (render $ tm $ PluginR "fb" ["kthxbye"])+ redirect dest+ _ -> dispatch "GET" ["kthxbye"]+ -- Finish the logout procedure. Unfortunately we have to+ -- replicate yesod-auth's postLogoutR code here since it's+ -- not accessible for us. We also can't just redirect to+ -- LogoutR since it would otherwise call setUltDestReferrer+ -- again.+ dispatch "GET" ["kthxbye"] = do+ m <- getYesod+ deleteSession "_ID"+ deleteUserAccessToken+ onLogout+ redirectUltDest $ logoutDest m+ -- Anything else gives 404+ dispatch _ _ = notFound++ -- Small widget for multiple login websites.+ login :: YesodAuth master =>+ (Route Auth -> Route master)+ -> GWidget sub master ()+ login tm = do+ redirectUrl <- lift (getRedirectUrl tm)+ [whamlet|+<p>+ <a href="#{redirectUrl}">_{Msg.Facebook}+|]+++-- | Create an @yesod-auth@'s 'Creds' for a given+-- @'FB.UserAccessToken'@.+createCreds :: FB.UserAccessToken -> Creds m+createCreds (FB.UserAccessToken userId _ _) = Creds "fb" id_ []+ where id_ = "http://graph.facebook.com/" `mappend` TE.decodeUtf8 userId+++-- | Set the Facebook's user access token on the user's session.+-- Usually you don't need to call this function, but it may+-- become handy together with 'FB.extendUserAccessToken'.+setUserAccessToken :: FB.UserAccessToken+ -> GHandler sub master ()+setUserAccessToken (FB.UserAccessToken userId data_ exptime) = do+ setSession "_FBID" (TE.decodeUtf8 userId)+ setSession "_FBAT" (TE.decodeUtf8 data_)+ setSession "_FBET" (T.pack $ show exptime)+++-- | Get the Facebook's user access token from the session.+-- Returns @Nothing@ if it's not found (probably because the user+-- is not logged in via @yesod-auth-fb@). Note that the returned+-- access token may have expired, we recommend using+-- 'FB.hasExpired' and 'FB.isValid'.+getUserAccessToken :: GHandler sub master (Maybe FB.UserAccessToken)+getUserAccessToken = runMaybeT $ do+ userId <- MaybeT $ lookupSession "_FBID"+ data_ <- MaybeT $ lookupSession "_FBAT"+ exptime <- MaybeT $ lookupSession "_FBET"+ return $ FB.UserAccessToken (TE.encodeUtf8 userId)+ (TE.encodeUtf8 data_)+ (read $ T.unpack exptime)+++-- | Delete Facebook's user access token from the session. /Do/+-- /not use/ this function unless you know what you're doing.+deleteUserAccessToken :: GHandler sub master ()+deleteUserAccessToken = do+ deleteSession "_FBID"+ deleteSession "_FBAT"+ deleteSession "_FBET"
yesod-auth-fb.cabal view
@@ -1,5 +1,5 @@ Name: yesod-auth-fb-Version: 1.0.2+Version: 1.0.3 Synopsis: Authentication backend for Yesod using Facebook. Homepage: https://github.com/meteficha/yesod-auth-fb License: BSD3@@ -9,13 +9,29 @@ Category: Web Build-type: Simple Cabal-version: >= 1.6-Extra-source-files: include/qq.h, README+Extra-source-files: README, demo/clientside.hs Description: This package allows you to use Yesod's authentication framework with Facebook as your backend. That is, your site's users will log in to your site through Facebook. Your application need to be registered on Facebook.+ .+ This package works with both the server-side authentication+ flow+ (<https://developers.facebook.com/docs/authentication/server-side/>)+ via the "Yesod.Auth.Facebook.ServerSide" module and the+ client-side authentication+ (<https://developers.facebook.com/docs/authentication/client-side/>)+ via the "Yesod.Auth.Facebook.ClientSide" module. It's up to+ you to decide which one to use. The server-side code is older+ and as such has been through a lot more testing than the+ client-side code. Also, for now only the server-side code is+ able to work with other authentication plugins. The+ client-side code, however, allows you to use some features that+ are available only to the Facebook JS SDK (such as+ automatically logging your users in, see+ <https://developers.facebook.com/blog/post/2012/05/08/how-to--improve-the-experience-for-returning-users/>). Source-repository head type: git@@ -26,22 +42,23 @@ Library hs-source-dirs: src - if flag(ghc7)- Cpp-options: -DGHC7- Build-depends: base >= 4.3 && < 5- else- Build-depends: base >= 4 && < 4.3-- Build-depends: yesod-core >= 1.0 && < 1.1+ Build-depends: base >= 4.3 && < 5+ , yesod-core >= 1.0 && < 1.1 , yesod-auth >= 1.0 && < 1.1+ , shakespeare-js , wai , http-conduit , text >= 0.7 && < 0.12 , transformers >= 0.1.3 && < 0.4- , fb >= 0.8 && < 0.10+ , fb >= 0.9.6 && < 0.10 , conduit == 0.4.*+ , bytestring == 0.9.*+ , aeson == 0.6.*+ , time >= 1.0 && < 1.5+ , old-locale == 1.0.* Exposed-modules: Yesod.Auth.Facebook- Extensions: GADTs QuasiQuotes CPP OverloadedStrings+ , Yesod.Auth.Facebook.ClientSide+ , Yesod.Auth.Facebook.ServerSide+ Extensions: GADTs QuasiQuotes OverloadedStrings GHC-options: -Wall- Include-dirs: include