Skip to content

Commit

Permalink
yesod 1.2
Browse files Browse the repository at this point in the history
  • Loading branch information
@snoyberg
snoyberg committed Mar 15, 2013
1 parent 30a79e6 commit 5f121c2
Show file tree
Hide file tree
Showing 3 changed files with 53 additions and 49 deletions.
47 changes: 24 additions & 23 deletions src/Yesod/Auth/Facebook/ClientSide.hs
View file
Expand Up @@ -32,6 +32,7 @@ module Yesod.Auth.Facebook.ClientSide
import Control.Applicative ((<$>), (<*>))
import Control.Monad (when)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Error (ErrorT(..), throwError)
import Data.ByteString (ByteString)
import Data.Monoid (mappend, mempty)
Expand All @@ -41,7 +42,6 @@ import System.Locale (defaultTimeLocale)
import Text.Hamlet (hamlet)
import Text.Julius (JavascriptUrl, julius, rawJS)
import Yesod.Auth
import Yesod.Content
import Yesod.Core
import qualified Control.Exception.Lifted as E
import qualified Data.Aeson as A
Expand Down Expand Up @@ -80,10 +80,11 @@ fbcsR = PluginR "fbcs"
-- @position: absolute@.
facebookJSSDK :: YesodAuthFbClientSide master =>
(Route Auth -> Route master)
-> GWidget sub master ()
-> WidgetT master IO ()
facebookJSSDK toMaster = do
(lang, fbInitOptsList, muid) <-
lift $ (,,) <$> getFbLanguage
handlerToWidget
$ (,,) <$> getFbLanguage
<*> getFbInitOpts
<*> maybeAuthId
let loggedIn = maybe False (const True) muid
Expand Down Expand Up @@ -237,7 +238,7 @@ class (YesodAuth master, YF.YesodFacebook master) => YesodAuthFbClientSide maste
-- 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)
getFbChannelFile :: HandlerT master IO (Route master)
-- ^ Return channel file in the /same/
-- /subdomain/ as the current route.

Expand Down Expand Up @@ -270,7 +271,7 @@ class (YesodAuth master, YF.YesodFacebook master) => YesodAuthFbClientSide maste
-- /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 :: HandlerT master IO Text
getFbLanguage = return "en_US"

-- | /(Optional)/ Options that should be given to @FB.init()@.
Expand All @@ -287,7 +288,7 @@ class (YesodAuth master, YF.YesodFacebook master) => YesodAuthFbClientSide maste
--
-- 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 :: HandlerT master IO [(Text, A.Value)]
getFbInitOpts = defaultFbInitOpts

-- | /(Optional)/ Arbitrary JavaScript that will be called on
Expand All @@ -308,7 +309,7 @@ class (YesodAuth master, YF.YesodFacebook master) => YesodAuthFbClientSide maste
--
-- [@status@] To @True@, since this usually is what you want.
defaultFbInitOpts :: YesodAuthFbClientSide master =>
GHandler sub master [(Text, A.Value)]
HandlerT master IO [(Text, A.Value)]
defaultFbInitOpts = do
ur <- getUrlRender
creds <- YF.getFbCredentials
Expand All @@ -326,13 +327,13 @@ defaultFbInitOpts = do
-- 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 :: HandlerT master IO TypedContent
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)
return $ TypedContent typeHtml channelFileContent
where oneYearSecs = 60*60*24*365 :: Int
oneYearNDF = fromIntegral oneYearSecs :: TI.NominalDiffTime
maxAge = "max-age=" `T.append` T.pack (show oneYearSecs)
Expand All @@ -358,41 +359,41 @@ authFacebookClientSide =
AuthPlugin "fbcs" dispatch login
where
dispatch :: YesodAuthFbClientSide master =>
Text -> [Text] -> GHandler Auth master ()
Text -> [Text] -> HandlerT Auth (HandlerT master IO) ()
-- Login route used when successfully logging in. Called via
-- AJAX by JavaScript code on 'facebookJSSDK'.
dispatch "GET" ["login"] = do
y <- getYesod
y <- lift getYesod
when (redirectToReferer y) setUltDestReferer
etoken <- getUserAccessToken
etoken <- lift getUserAccessToken
case etoken of
Right token -> setCreds True (createCreds token)
Right token -> lift $ setCreds True (createCreds token)
Left msg -> fail msg

-- 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 <- getYesod
y <- lift getYesod
ur <- getUrlRender
tm <- getRouteToMaster
tm <- getRouteToParent
when (redirectToReferer y) setUltDestReferer
let redirectTo = ur $ tm $ fbcsR ["login", "back"]
let redirectTo = ur $ fbcsR ["login", "back"]
uncommas "" = []
uncommas xs = case break (== ',') xs of
(x', ',':xs') -> x' : uncommas xs'
(x', _) -> [x']
url <- YF.runYesodFbT $
url <- lift $ YF.runYesodFbT $
FB.getUserAccessTokenStep1 redirectTo $
map fromString $ uncommas $ T.unpack perms
redirect url
dispatch "GET" ["login", "back"] = do
-- Instead of going on with the server-side flow, use the
-- client-side JS to finish the authentication.
tm <- getRouteToMaster
mr <- getMessageRender
fbjssdkpc <- widgetToPageContent (facebookJSSDK tm)
rephtml <- hamletToRepHtml $ [hamlet|$newline never
tm <- getRouteToParent
mr <- lift getMessageRender
fbjssdkpc <- lift $ widgetToPageContent (facebookJSSDK tm)
rephtml <- lift $ hamletToRepHtml $ [hamlet|$newline never
$doctype 5
<html>
<head>
Expand All @@ -410,7 +411,7 @@ authFacebookClientSide =
-- Small widget for multiple login websites.
login :: YesodAuth master =>
(Route Auth -> Route master)
-> GWidget sub master ()
-> WidgetT master IO ()
login _ = [whamlet|$newline never
<p>
<a href="#" onclick="#{facebookLogin perms}">
Expand Down Expand Up @@ -447,7 +448,7 @@ signedRequestCookieName = T.append "fbsr_" . FB.appId
-- and (c) avoids duplicating the information from the cookie
-- into the session.
getUserAccessToken :: YesodAuthFbClientSide master =>
GHandler sub master (Either String FB.UserAccessToken)
HandlerT master IO (Either String FB.UserAccessToken)
getUserAccessToken =
runErrorT $ do
creds <- lift YF.getFbCredentials
Expand Down
47 changes: 25 additions & 22 deletions src/Yesod/Auth/Facebook/ServerSide.hs
View file
Expand Up @@ -17,14 +17,14 @@ module Yesod.Auth.Facebook.ServerSide

import Control.Applicative ((<$>))
import Control.Monad (when)
import Control.Monad.Trans.Class (lift)
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 Yesod.Core
import qualified Data.Text as T
import qualified Facebook as FB
import qualified Yesod.Auth.Message as Msg
Expand Down Expand Up @@ -77,7 +77,7 @@ authFacebookHelper useBeta creds perms = AuthPlugin "fb" dispatch login
-- Run a Facebook action.
runFB :: YesodAuth master =>
FB.FacebookT FB.Auth (C.ResourceT IO) a
-> GHandler sub master a
-> HandlerT master IO a
runFB act = do
manager <- authHttpManager <$> getYesod
liftIO $ C.runResourceT $
Expand All @@ -87,52 +87,55 @@ authFacebookHelper useBeta creds perms = AuthPlugin "fb" dispatch login
-- Get the URL in facebook.com where users are redirected to.
getRedirectUrl :: YesodAuth master =>
(Route Auth -> Route master)
-> GHandler sub master Text
-> HandlerT master IO 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 :: T.Text
-> [T.Text]
-> AuthHandler master ()
dispatch "GET" ["login"] = do
m <- getYesod
m <- lift getYesod
when (redirectToReferer m) setUltDestReferer
redirect =<< getRedirectUrl =<< getRouteToMaster
redirect =<< lift . getRedirectUrl =<< getRouteToParent
-- Take Facebook's code and finish authentication.
dispatch "GET" ["proceed"] = do
tm <- getRouteToMaster
tm <- getRouteToParent
render <- getUrlRender
query <- queryString <$> waiRequest
let proceedUrl = render (tm proceedR)
let proceedUrl = render proceedR
query' = [(a,b) | (a, Just b) <- query]
token <- runFB $ FB.getUserAccessTokenStep2 proceedUrl query'
setUserAccessToken token
setCreds True (createCreds token)
token <- lift $ runFB $ FB.getUserAccessTokenStep2 proceedUrl query'
lift $ setUserAccessToken token
lift $ setCreds True (createCreds token)
-- Logout the user from our site and from Facebook.
dispatch "GET" ["logout"] = do
m <- getYesod
tm <- getRouteToMaster
mtoken <- getUserAccessToken
m <- lift getYesod
tm <- getRouteToParent
mtoken <- lift 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
valid <- maybe (return False) (lift . runFB . FB.isValid) mtoken

case (valid, mtoken) of
(True, Just token) -> do
render <- getUrlRender
dest <- runFB $ FB.getUserLogoutUrl token (render $ tm $ PluginR "fb" ["kthxbye"])
dest <- lift $ runFB $ FB.getUserLogoutUrl token (render $ 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
dispatch "GET" ["kthxbye"] = lift $ do
m <- getYesod
deleteSession "_ID"
deleteUserAccessToken
Expand All @@ -144,9 +147,9 @@ authFacebookHelper useBeta creds perms = AuthPlugin "fb" dispatch login
-- Small widget for multiple login websites.
login :: YesodAuth master =>
(Route Auth -> Route master)
-> GWidget sub master ()
-> WidgetT master IO ()
login tm = do
redirectUrl <- lift (getRedirectUrl tm)
redirectUrl <- handlerToWidget (getRedirectUrl tm)
[whamlet|$newline never
<p>
<a href="#{redirectUrl}">_{Msg.Facebook}
Expand All @@ -164,7 +167,7 @@ createCreds (FB.UserAccessToken (FB.Id userId) _ _) = Creds "fb" id_ []
-- Usually you don't need to call this function, but it may
-- become handy together with 'FB.extendUserAccessToken'.
setUserAccessToken :: FB.UserAccessToken
-> GHandler sub master ()
-> HandlerT master IO ()
setUserAccessToken (FB.UserAccessToken (FB.Id userId) data_ exptime) = do
setSession "_FBID" userId
setSession "_FBAT" data_
Expand All @@ -176,7 +179,7 @@ setUserAccessToken (FB.UserAccessToken (FB.Id userId) data_ exptime) = do
-- 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 :: HandlerT master IO (Maybe FB.UserAccessToken)
getUserAccessToken = runMaybeT $ do
userId <- MaybeT $ lookupSession "_FBID"
data_ <- MaybeT $ lookupSession "_FBAT"
Expand All @@ -186,7 +189,7 @@ getUserAccessToken = runMaybeT $ do

-- | 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 :: HandlerT master IO ()
deleteUserAccessToken = do
deleteSession "_FBID"
deleteSession "_FBAT"
Expand Down
8 changes: 4 additions & 4 deletions yesod-auth-fb.cabal
View file
@@ -1,5 +1,5 @@
Name: yesod-auth-fb
Version: 1.4
Version: 1.5
Synopsis: Authentication backend for Yesod using Facebook.
Homepage: https://github.com/meteficha/yesod-auth-fb
License: BSD3
Expand Down Expand Up @@ -42,15 +42,15 @@ Library

Build-depends: base >= 4.3 && < 5
, lifted-base >= 0.1 && < 0.3
, yesod-core == 1.1.*
, yesod-auth == 1.1.*
, yesod-core == 1.2.*
, yesod-auth == 1.2.*
, hamlet
, shakespeare-js >= 1.0.2
, wai
, http-conduit >= 1.9
, text >= 0.7 && < 0.12
, transformers >= 0.1.3 && < 0.4
, yesod-fb == 0.2.*
, yesod-fb == 0.3.*
, fb == 0.14.*
, conduit == 1.0.*
, bytestring >= 0.9 && < 0.11
Expand Down

0 comments on commit 5f121c2

Please sign in to comment.