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 @@ -23,8 +23,11 @@ -- * Useful functions , serveChannelFile , defaultFbInitOpts - , getUserAccessToken + -- * Access tokens + , extractCredsAccessToken + , getUserAccessTokenFromFbCookie + -- * Advanced , signedRequestCookieName ) where @@ -37,8 +40,8 @@ import Data.Monoid (mappend, mempty) import Data.String (fromString) import Data.Text (Text) +import Network.Wai (queryString) import System.Locale (defaultTimeLocale) -import Text.Hamlet (hamlet) import Text.Julius (JavascriptUrl, julius, rawJS) import Yesod.Auth import Yesod.Content @@ -53,7 +56,6 @@ import qualified Facebook as FB import qualified Yesod.Facebook as YF import qualified Yesod.Auth.Message as Msg --- import qualified Data.Conduit as C -- | Internal function. Construct a route to our plugin. @@ -364,7 +366,7 @@ dispatch "GET" ["login"] = do y <- getYesod when (redirectToReferer y) setUltDestReferer - etoken <- getUserAccessToken + etoken <- getUserAccessTokenFromFbCookie case etoken of Right token -> setCreds True (createCreds token) Left msg -> fail msg @@ -387,22 +389,19 @@ 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. + -- We used to use the client-side flow to finish the + -- authentication. The advantage was simplifying the rest + -- of the code which didn't need to know about the use of + -- the server-side flow above. However, this was very + -- flimsy and sometimes the user landed on a blank page due + -- to race conditions. + ur <- getUrlRender tm <- getRouteToMaster - mr <- getMessageRender - fbjssdkpc <- widgetToPageContent (facebookJSSDK tm) - rephtml <- hamletToRepHtml $ [hamlet|$newline never - $doctype 5 - - - #{mr Msg.LoginTitle} - ^{pageHead fbjssdkpc} - <body> - ^{pageBody fbjssdkpc} - |] - sendResponse rephtml - + query <- queryString <$> waiRequest + let proceedUrl = ur $ tm $ fbcsR ["login", "back"] + query' = [(a,b) | (a, Just b) <- query] + token <- YF.runYesodFbT $ FB.getUserAccessTokenStep2 proceedUrl query' + setCreds True (createCreds token) -- Everything else gives 404 dispatch _ _ = notFound @@ -422,10 +421,40 @@ -- | Create an @yesod-auth@'s 'Creds' for a given -- @'FB.UserAccessToken'@. createCreds :: FB.UserAccessToken -> Creds m -createCreds (FB.UserAccessToken (FB.Id userId) _ _) = Creds "fbcs" id_ [] - where id_ = "http://graph.facebook.com/" `mappend` userId +createCreds at@(FB.UserAccessToken (FB.Id userId) _ _) = + let id_ = "http://graph.facebook.com/" `mappend` userId + in Creds "fbcs" id_ (atToText at) +-- | Get the user access token from a 'Creds' created by this +-- backend. This function should be used on 'getAuthId'. +extractCredsAccessToken :: Creds m -> Maybe FB.UserAccessToken +extractCredsAccessToken (Creds "fbcs" _ extra) = textToAt extra +extractCredsAccessToken _ = Nothing + + +-- | Convert user access token to @[(Text, Text)]@. +-- +-- @ +-- textToAt . atToText === Just +-- @ +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)) ] + + +-- | See 'atToText'. +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 + + -- | Cookie name with the signed request for the given credentials. signedRequestCookieName :: FB.Credentials -> Text signedRequestCookieName = T.append "fbsr_" . FB.appId @@ -438,17 +467,30 @@ -- 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 = +-- This 'getUserAccessTokenFromFbCookie' 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 +-- 'getUserAccessTokenFromFbCookie' 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. +-- +-- Note also that 'getUserAccessTokenFromFbCookie' may return +-- 'Left' even tough the user is properly logged in. When you +-- force authentication via 'facebookForceLoginR' (e.g., via +-- 'requireAuth'/'requireAuthId') we use the server-side flow +-- which will not set the cookie until at least the FB JS SDK +-- runs on the user-agent, sets the cookie and another request is +-- sent to our servers. +-- +-- For the reason stated on the previous paragraph, you should +-- not use this function on 'getAuthId'. Instead, you should use +-- 'extractCredsAccessToken'. +getUserAccessTokenFromFbCookie :: + YesodAuthFbClientSide master => + GHandler sub master (Either String FB.UserAccessToken) +getUserAccessTokenFromFbCookie = runErrorT $ do creds <- lift YF.getFbCredentials unparsed <- toErrorT "cookie not found" $ lookupCookie (signedRequestCookieName creds) @@ -473,7 +515,7 @@ _ -> do -- Get access token from Facebook. let fbErrorMsg :: FB.FacebookException -> String - fbErrorMsg exc = "getUserAccessToken: getUserAccessTokenStep2 " ++ + fbErrorMsg exc = "getUserAccessTokenFromFbCookie: getUserAccessTokenStep2 " ++ "failed with " ++ show exc token <- ErrorT $ fmap (either (Left . fbErrorMsg) Right) $ @@ -491,12 +533,12 @@ Right (_, Just uid, Just oauth_token, Just expires) -> return $ FB.UserAccessToken uid oauth_token (toUTCTime expires) Right (Nothing, _, _, _) -> - throwError "getUserAccessToken: no user_id nor code on signed request" + throwError "getUserAccessTokenFromFbCookie: no user_id nor code on signed request" Left msg -> - throwError ("getUserAccessToken: never here (" ++ show 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 ("getUserAccessToken: " ++ msg)) Right) + toErrorT msg = ErrorT . fmap (maybe (Left ("getUserAccessTokenFromFbCookie: " ++ msg)) Right) toUTCTime :: Integer -> TI.UTCTime toUTCTime = TI.posixSecondsToUTCTime . fromIntegral 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.4 +Version: 1.5 Synopsis: Authentication backend for Yesod using Facebook. Homepage: https://github.com/meteficha/yesod-auth-fb License: BSD3