Permalink
Browse files

yesod 1.2

  • Loading branch information...
1 parent 30a79e6 commit 5f121c23fb8ca4bd041ad55e5e09bb00526fee37 @snoyberg committed Mar 15, 2013
Showing with 53 additions and 49 deletions.
  1. +24 −23 src/Yesod/Auth/Facebook/ClientSide.hs
  2. +25 −22 src/Yesod/Auth/Facebook/ServerSide.hs
  3. +4 −4 yesod-auth-fb.cabal
@@ -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)
@@ -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
@@ -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
@@ -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.
@@ -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()@.
@@ -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
@@ -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
@@ -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)
@@ -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>
@@ -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}">
@@ -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
@@ -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
@@ -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 $
@@ -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
@@ -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}
@@ -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_
@@ -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"
@@ -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"
View
@@ -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
@@ -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

0 comments on commit 5f121c2

Please sign in to comment.