diff --git a/src/Yesod/Auth/Facebook/ClientSide.hs b/src/Yesod/Auth/Facebook/ClientSide.hs --- a/src/Yesod/Auth/Facebook/ClientSide.hs +++ b/src/Yesod/Auth/Facebook/ClientSide.hs @@ -34,17 +34,14 @@ import Control.Applicative ((<$>), (<*>)) import Control.Monad (when) -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.String (fromString) import Data.Text (Text) import Network.Wai (queryString) -import System.Locale (defaultTimeLocale) 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,18 +77,19 @@ -- 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 +facebookJSSDK :: YesodAuthFbClientSide site => + (Route Auth -> Route site) + -> WidgetT site IO () +facebookJSSDK toSite = do (lang, fbInitOptsList, muid, ur) <- - lift $ (,,,) <$> getFbLanguage - <*> getFbInitOpts - <*> maybeAuthId - <*> getUrlRender + handlerToWidget $ + (,,,) <$> getFbLanguage + <*> getFbInitOpts + <*> maybeAuthId + <*> getUrlRender let loggedIn = maybe False (const True) muid - loginRoute = toMaster $ fbcsR ["login"] - logoutRoute = toMaster $ LogoutR + loginRoute = toSite $ fbcsR ["login"] + logoutRoute = toSite $ LogoutR fbInitOpts = A.object $ map (uncurry (A..=)) fbInitOptsList [whamlet|$newline never
@@ -143,7 +141,7 @@ FB.getLoginStatus(function(response) { if (response.status !== 'connected' || FB.logout(function () {}) === undefined) { - window.location.href = #{A.toJSON (ur (toMaster LogoutR))} + window.location.href = #{A.toJSON (ur (toSite LogoutR))} } }); return (function () {}); @@ -225,7 +223,7 @@ -- -- Minimal complete definition: 'getFbChannelFile'. (We -- recommend implementing 'getFbLanguage' as well.) -class (YesodAuth master, YF.YesodFacebook master) => YesodAuthFbClientSide master where +class (YesodAuth site, YF.YesodFacebook site) => YesodAuthFbClientSide site where -- | A route that serves Facebook's channel file in the /same/ -- /subdomain/ as the current request's subdomain. -- @@ -234,7 +232,7 @@ -- is 'ChannelFileR', then you just need: -- -- @ - -- getChannelFileR :: GHandler sub master ChooseRep + -- getChannelFileR :: HandlerT site IO ChooseRep -- getChannelFileR = serveChannelFile -- @ -- @@ -249,8 +247,8 @@ -- 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) + -- lives inside 'HandlerT'. + getFbChannelFile :: HandlerT site IO (Route site) -- ^ Return channel file in the /same/ -- /subdomain/ as the current route. @@ -283,7 +281,7 @@ -- /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 site IO Text getFbLanguage = return "en_US" -- | /(Optional)/ Options that should be given to @FB.init()@. @@ -300,13 +298,13 @@ -- -- 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 site IO [(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 :: JavascriptUrl (Route site) fbAsyncInitJs = const mempty @@ -320,8 +318,8 @@ -- 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 :: YesodAuthFbClientSide site => + HandlerT site IO [(Text, A.Value)] defaultFbInitOpts = do ur <- getUrlRender creds <- YF.getFbCredentials @@ -339,18 +337,13 @@ -- 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 site 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) + addHeader "Pragma" "public" + cacheSeconds oneYearSecs + neverExpires + selectRep $ provideRepType "text/html" (return 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 @@ -365,37 +358,37 @@ -- authentication flow. -- -- You /MUST/ use 'facebookJSSDK' as its documentation states. -authFacebookClientSide :: YesodAuthFbClientSide master - => AuthPlugin master +authFacebookClientSide :: YesodAuthFbClientSide site + => AuthPlugin site authFacebookClientSide = AuthPlugin "fbcs" dispatch login where - dispatch :: YesodAuthFbClientSide master => - Text -> [Text] -> GHandler Auth master () + dispatch :: YesodAuthFbClientSide site => + Text -> [Text] -> HandlerT Auth (HandlerT site IO) () -- Login route used when successfully logging in. Called via -- AJAX by JavaScript code on 'facebookJSSDK'. dispatch "GET" ["login"] = do - y <- getYesod - when (redirectToReferer y) setUltDestReferer - etoken <- getUserAccessTokenFromFbCookie + y <- lift getYesod + when (redirectToReferer y) (lift setUltDestReferer) + etoken <- lift getUserAccessTokenFromFbCookie 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 - when (redirectToReferer y) setUltDestReferer - let redirectTo = ur $ tm $ fbcsR ["login", "back"] + when (redirectToReferer y) (lift setUltDestReferer) + 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 @@ -407,20 +400,21 @@ -- flimsy and sometimes the user landed on a blank page due -- to race conditions. ur <- getUrlRender - tm <- getRouteToMaster query <- queryString <$> waiRequest - let proceedUrl = ur $ tm $ fbcsR ["login", "back"] + let proceedUrl = ur $ fbcsR ["login", "back"] query' = [(a,b) | (a, Just b) <- query] - token <- YF.runYesodFbT $ FB.getUserAccessTokenStep2 proceedUrl query' - setCreds True (createCreds token) + token <- lift $ + YF.runYesodFbT $ + FB.getUserAccessTokenStep2 proceedUrl query' + lift $ setCreds True (createCreds token) -- Everything else gives 404 dispatch _ _ = notFound -- Small widget for multiple login websites. - login :: YesodAuth master => - (Route Auth -> Route master) - -> GWidget sub master () + login :: YesodAuth site => + (Route Auth -> Route site) + -> WidgetT site IO () login _ = [whamlet|$newline never

@@ -499,8 +493,8 @@ -- not use this function on 'getAuthId'. Instead, you should use -- 'extractCredsAccessToken'. getUserAccessTokenFromFbCookie :: - YesodAuthFbClientSide master => - GHandler sub master (Either String FB.UserAccessToken) + YesodAuthFbClientSide site => + HandlerT site IO (Either String FB.UserAccessToken) getUserAccessTokenFromFbCookie = runErrorT $ do creds <- lift YF.getFbCredentials diff --git a/src/Yesod/Auth/Facebook/ServerSide.hs b/src/Yesod/Auth/Facebook/ServerSide.hs --- a/src/Yesod/Auth/Facebook/ServerSide.hs +++ b/src/Yesod/Auth/Facebook/ServerSide.hs @@ -11,24 +11,21 @@ , 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 Yesod.Core import qualified Data.Text as T import qualified Facebook as FB import qualified Yesod.Auth.Message as Msg -import qualified Data.Conduit as C +import qualified Yesod.Facebook as YF -- | Route for login using this authentication plugin. facebookLogin :: AuthRoute @@ -47,84 +44,51 @@ -- | 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 +authFacebook :: (YesodAuth site, YF.YesodFacebook site) + => [FB.Permission] -- ^ Permissions to be requested. + -> AuthPlugin site +authFacebook 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 + getRedirectUrl :: YF.YesodFacebook site => (Route Auth -> Text) -> HandlerT site IO Text + getRedirectUrl render = + YF.runYesodFbT $ FB.getUserAccessTokenStep1 (render proceedR) perms proceedR = PluginR "fb" ["proceed"] + dispatch :: (YesodAuth site, YF.YesodFacebook site) => + Text -> [Text] -> HandlerT Auth (HandlerT site IO) () -- Redirect the user to Facebook. dispatch "GET" ["login"] = do - m <- getYesod - when (redirectToReferer m) setUltDestReferer - redirect =<< getRedirectUrl =<< getRouteToMaster + ur <- getUrlRender + lift $ do + y <- getYesod + when (redirectToReferer y) setUltDestReferer + redirect =<< getRedirectUrl ur -- Take Facebook's code and finish authentication. dispatch "GET" ["proceed"] = do - tm <- getRouteToMaster 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) + lift $ do + token <- YF.runYesodFbT $ 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 + y <- lift getYesod + mtoken <- lift getUserAccessToken + when (redirectToReferer y) (lift 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 . YF.runYesodFbT . 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 $ YF.runYesodFbT $ FB.getUserLogoutUrl token (render $ PluginR "fb" ["kthxbye"]) redirect dest _ -> dispatch "GET" ["kthxbye"] -- Finish the logout procedure. Unfortunately we have to @@ -132,21 +96,23 @@ -- 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 + dispatch "GET" ["kthxbye"] = + lift $ 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 :: (YesodAuth site, YF.YesodFacebook site) => + (Route Auth -> Route site) + -> WidgetT site IO () login tm = do - redirectUrl <- lift (getRedirectUrl tm) + ur <- getUrlRender + redirectUrl <- handlerToWidget $ getRedirectUrl (ur . tm) [whamlet|$newline never

_{Msg.Facebook} @@ -164,7 +130,7 @@ -- 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 site IO () setUserAccessToken (FB.UserAccessToken (FB.Id userId) data_ exptime) = do setSession "_FBID" userId setSession "_FBAT" data_ @@ -176,7 +142,7 @@ -- 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 site IO (Maybe FB.UserAccessToken) getUserAccessToken = runMaybeT $ do userId <- MaybeT $ lookupSession "_FBID" data_ <- MaybeT $ lookupSession "_FBAT" @@ -186,7 +152,7 @@ -- | 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 site IO () deleteUserAccessToken = do deleteSession "_FBID" deleteSession "_FBAT" diff --git a/yesod-auth-fb.cabal b/yesod-auth-fb.cabal --- a/yesod-auth-fb.cabal +++ b/yesod-auth-fb.cabal @@ -1,5 +1,5 @@ Name: yesod-auth-fb -Version: 1.5.1 +Version: 1.6 Synopsis: Authentication backend for Yesod using Facebook. Homepage: https://github.com/meteficha/yesod-auth-fb License: BSD3 @@ -42,21 +42,20 @@ 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 , aeson == 0.6.* , time >= 1.0 && < 1.5 - , old-locale == 1.0.* Exposed-modules: Yesod.Auth.Facebook , Yesod.Auth.Facebook.ClientSide