yesod-auth-fb 1.0.3 → 1.0.4
raw patch · 3 files changed
+97/−15 lines, 3 filesdep +hamletdep +lifted-basePVP ok
version bump matches the API change (PVP)
Dependencies added: hamlet, lifted-base
API changes (from Hackage documentation)
+ Yesod.Auth.Facebook.ClientSide: facebookForceLoginR :: [Permission] -> Route Auth
Files
- demo/clientside.hs +3/−0
- src/Yesod/Auth/Facebook/ClientSide.hs +91/−14
- yesod-auth-fb.cabal +3/−1
demo/clientside.hs view
@@ -69,6 +69,9 @@ <button onclick="#{facebookLogin perms}"> Login <p>+ <a href="@{AuthR $ facebookForceLoginR perms}">+ Force login route (avoid this in your code when possible).+ <p> <button onclick="#{facebookLogout}"> Logout |]
src/Yesod/Auth/Facebook/ClientSide.hs view
@@ -16,6 +16,7 @@ -- * Widgets , facebookJSSDK , facebookLogin+ , facebookForceLoginR , facebookLogout , JavaScriptCall @@ -30,18 +31,20 @@ ) where 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 System.Locale (defaultTimeLocale)+import Text.Hamlet (hamlet) import Text.Julius (JavascriptUrl, julius) import Yesod.Auth import Yesod.Content-import Yesod.Handler-import Yesod.Request-import Yesod.Widget+import Yesod.Core+import qualified Control.Exception.Lifted as E import qualified Data.Aeson as A import qualified Data.Aeson.Types as A import qualified Data.Text as T@@ -54,6 +57,11 @@ -- import qualified Data.Conduit as C +-- | Internal function. Construct a route to our plugin.+fbcsR :: [Text] -> Route Auth+fbcsR = PluginR "fbcs"++ -- | Hamlet that should be spliced /right after/ the @<body>@ tag -- in order for Facebook's JS SDK to work. For example: --@@ -80,7 +88,7 @@ <*> getFbInitOpts <*> maybeAuthId let loggedIn = maybe ("false" :: Text) (const "true") muid- loginRoute = toMaster $ PluginR "fbcs" ["login"]+ loginRoute = toMaster $ fbcsR ["login"] logoutRoute = toMaster $ LogoutR fbInitOpts = A.object $ map (uncurry (A..=)) fbInitOptsList [whamlet|@@ -149,11 +157,32 @@ facebookLogin [] = "FB.login(function () {})" facebookLogin perms = T.concat [ "FB.login(function () {}, {scope: '"- , T.intercalate "," (map FB.unPermission perms)+ , joinPermissions perms , "'})" ] +-- | Route that forces the user to log in. You should avoid+-- using this route whenever possible, using 'facebookLogin' is+-- much better (after all, this module is for client-side+-- authentication). However, you may want to use it at least for+-- 'authRoute', e.g.:+--+-- @+-- instance 'Yesod' MyFoundation where+-- ...+-- 'authRoute' _ = Just $ AuthR (facebookForceLoginR [])+-- @+facebookForceLoginR :: [FB.Permission] -> Route Auth+facebookForceLoginR perms = fbcsR ["login", "go", joinPermissions perms]+++-- | Internal function. Joins a list of 'FB.Permission'@s@ into+-- a format that Facebook recognizes.+joinPermissions :: [FB.Permission] -> Text+joinPermissions = T.intercalate "," . map FB.unPermission++ -- | JavaScript function that should be called in order to logout -- the user. You could splice this into a @onclick@ event, for -- example:@@ -340,12 +369,54 @@ authFacebookClientSide = AuthPlugin "fbcs" dispatch login where+ dispatch :: YesodAuthFbClientSide master =>+ Text -> [Text] -> GHandler Auth master ()+ -- Login route used when successfully logging in. Called via+ -- AJAX by JavaScript code on 'facebookJSSDK'. dispatch "GET" ["login"] = do etoken <- getUserAccessToken case etoken of Right token -> setCreds True (createCreds token) Left msg -> fail msg- -- Anything else gives 404++ -- 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+ ur <- getUrlRender+ tm <- getRouteToMaster+ when (redirectToReferer y) setUltDestReferer+ let creds = fbCredentials y+ manager = authHttpManager y+ redirectTo = ur $ tm $ fbcsR ["login", "back"]+ uncommas "" = []+ uncommas xs = case break (== ',') xs of+ (x', ',':xs') -> x' : uncommas xs'+ (x', _) -> [x']+ url <- FB.runFacebookT creds manager $+ 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|+ $doctype 5+ <html>+ <head>+ <title>#{mr Msg.LoginTitle}+ ^{pageHead fbjssdkpc}+ <body>+ ^{pageBody fbjssdkpc}+ |]+ sendResponse rephtml+++ -- Everything else gives 404 dispatch _ _ = notFound -- Small widget for multiple login websites.@@ -354,7 +425,7 @@ -> GWidget sub master () login _ = [whamlet| <p>- <a href="#{facebookLogin perms}">+ <a href="#" onclick="#{facebookLogin perms}"> _{Msg.Facebook} |] where perms = []@@ -402,11 +473,11 @@ <*> parsed A..:? "user_id" <*> parsed A..:? "oauth_token" <*> parsed A..:? "expires") of- Right (Just code, _, _, _) -> lift $ do+ Right (Just code, _, _, _) -> do -- We have to exchange the code for the access token.- moldCode <- lookupSession sessionCode+ moldCode <- lift $ lookupSession sessionCode case moldCode of- Just code' | code == TE.encodeUtf8 code' -> do+ Just code' | code == TE.encodeUtf8 code' -> lift $ do -- We have a cached token for this code. Just userId <- lookupSession sessionUserId Just data_ <- lookupSession sessionToken@@ -416,10 +487,16 @@ (read $ T.unpack exptime) _ -> do -- Get access token from Facebook.- token <- FB.runFacebookT creds manager $+ let fbErrorMsg :: FB.FacebookException -> String+ fbErrorMsg exc = "getUserAccessToken: getUserAccessTokenStep2 " +++ "failed with " ++ show exc+ token <- ErrorT $+ fmap (either (Left . fbErrorMsg) Right) $+ E.try $+ FB.runFacebookT creds manager $ FB.getUserAccessTokenStep2 "" [("code", code)] case token of- FB.UserAccessToken userId data_ exptime -> do+ FB.UserAccessToken userId data_ exptime -> lift $ do -- Save it for later. setSession sessionCode (TE.decodeUtf8 code) setSession sessionUserId (TE.decodeUtf8 userId)@@ -429,9 +506,9 @@ 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"+ throwError "getUserAccessToken: no user_id nor code on signed request" Left msg ->- throwError ("never here (" ++ show msg ++ ")")+ throwError ("getUserAccessToken: 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)
yesod-auth-fb.cabal view
@@ -1,5 +1,5 @@ Name: yesod-auth-fb-Version: 1.0.3+Version: 1.0.4 Synopsis: Authentication backend for Yesod using Facebook. Homepage: https://github.com/meteficha/yesod-auth-fb License: BSD3@@ -43,8 +43,10 @@ hs-source-dirs: src Build-depends: base >= 4.3 && < 5+ , lifted-base == 0.1.* , yesod-core >= 1.0 && < 1.1 , yesod-auth >= 1.0 && < 1.1+ , hamlet , shakespeare-js , wai , http-conduit