diff --git a/fb.cabal b/fb.cabal --- a/fb.cabal +++ b/fb.cabal @@ -1,5 +1,5 @@ name: fb -version: 0.4.0.2 +version: 0.5 license: BSD3 license-file: LICENSE author: Felipe Lessa diff --git a/src/Facebook.hs b/src/Facebook.hs --- a/src/Facebook.hs +++ b/src/Facebook.hs @@ -23,6 +23,7 @@ , Permission , getUserAccessTokenStep1 , getUserAccessTokenStep2 + , getUserLogoutUrl , extendUserAccessToken -- * Facebook's Open Graph API diff --git a/src/Facebook/Auth.hs b/src/Facebook/Auth.hs --- a/src/Facebook/Auth.hs +++ b/src/Facebook/Auth.hs @@ -2,6 +2,7 @@ ( getAppAccessToken , getUserAccessTokenStep1 , getUserAccessTokenStep2 + , getUserLogoutUrl , extendUserAccessToken , RedirectUrl , Permission @@ -11,6 +12,8 @@ import Control.Applicative import Control.Monad.IO.Class (MonadIO(liftIO)) +import Data.Aeson ((.:)) +import Data.Aeson.Types (parseEither) import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.Time (getCurrentTime, addUTCTime, UTCTime) @@ -25,7 +28,7 @@ import qualified Data.Text.Encoding as TE import qualified Data.Text.Encoding.Error as TE import qualified Network.HTTP.Conduit as H --- import qualified Network.HTTP.Types as HT +import qualified Network.HTTP.Types as HT import Facebook.Types @@ -83,12 +86,25 @@ getUserAccessTokenStep2 redirectUrl query = case query of [code@("code", _)] -> runResourceInFb $ do + -- Get the access token data through Facebook's OAuth. now <- liftIO getCurrentTime creds <- getCreds let req = fbreq "/oauth/access_token" Nothing $ tsq creds [code, ("redirect_uri", TE.encodeUtf8 redirectUrl)] response <- fbhttp req - lift $ H.responseBody response C.$$ C.sinkParser (userAccessTokenParser now) + preToken <- lift $ H.responseBody response C.$$ + C.sinkParser (userAccessTokenParser now) + + -- Get user's ID throught Facebook's graph. + userInfo <- asJson =<< fbhttp (fbreq "/me" (Just preToken) [("fields", "id")]) + case (parseEither (.: "id") userInfo, preToken) of + (Left str, _) -> + E.throw $ FbLibraryException $ T.concat + [ "getUserAccessTokenStep2: failed to get the UserId (" + , T.pack str, ")" ] + (Right (userId :: UserId), UserAccessToken _ d e) -> + return (UserAccessToken userId d e) + _ -> let [error_, errorReason, errorDescr] = map (fromMaybe "" . flip lookup query) ["error", "error_reason", "error_description"] @@ -98,18 +114,43 @@ -- | Attoparsec parser for user access tokens returned by --- Facebook as a query string. -userAccessTokenParser :: UTCTime -- 'getCurrentTime' +-- Facebook as a query string. Returns an user access token with +-- a broken 'UserId'. +userAccessTokenParser :: UTCTime -- ^ 'getCurrentTime' -> A.Parser (AccessToken User) userAccessTokenParser now = - UserAccessToken <$ A.string "access_token=" - <*> A.takeWhile (/= '?') - <* A.string "&expires=" - <*> (toExpire <$> A.decimal) - <* A.endOfInput + UserAccessToken userId + <$ A.string "access_token=" + <*> A.takeWhile (/= '?') + <* A.string "&expires=" + <*> (toExpire <$> A.decimal) + <* A.endOfInput where toExpire i = addUTCTime (fromIntegral (i :: Int)) now + userId = error "userAccessTokenParser: never here" +-- | The URL an user should be redirected to in order to log them +-- out of their Facebook session. Facebook will then redirect +-- the user to the provided URL after logging them out. Note +-- that, at the time of this writing, Facebook's policies require +-- you to log the user out of Facebook when they ask to log out +-- of your site. +-- +-- Note also that Facebook may refuse to redirect the user to the +-- provided URL if their user access token is invalid. In order +-- to prevent this bug, we suggest that you use 'isValid' before +-- redirecting the user to the URL provided by 'getUserLogoutUrl' +-- since this function doesn't do any validity checks. +getUserLogoutUrl :: AccessToken User -- ^ The user's access token. + -> RedirectUrl -- ^ URL the user should be directed to in your site domain. + -> Text -- ^ Logout URL in @https:\/\/www.facebook.com\/@. +getUserLogoutUrl (UserAccessToken _ data_ _) next = + TE.decodeUtf8 $ + "https://www.facebook.com/logout.php?" <> + HT.renderQuery False [ ("next", Just (TE.encodeUtf8 next)) + , ("access_token", Just data_) ] + + -- | URL where the user is redirected to after Facebook -- authenticates the user authorizes your application. This URL -- should be inside the domain registered for your Facebook @@ -161,7 +202,7 @@ then return False else let page = case token of - UserAccessToken _ _ -> "/me" + UserAccessToken _ _ _ -> "/me" -- Documented way of checking if the token is valid, -- see . AppAccessToken _ -> "/19292868552" @@ -186,7 +227,7 @@ C.ResourceIO m => AccessToken User -> FacebookT Auth m (Either FacebookException (AccessToken User)) -extendUserAccessToken token@(UserAccessToken data_ _) +extendUserAccessToken token@(UserAccessToken _ data_ _) = do expired <- hasExpired token if expired then return (Left hasExpiredExc) else tryToExtend where diff --git a/src/Facebook/OpenGraph.hs b/src/Facebook/OpenGraph.hs --- a/src/Facebook/OpenGraph.hs +++ b/src/Facebook/OpenGraph.hs @@ -43,11 +43,21 @@ createAction :: C.ResourceIO m => Action -- ^ Action kind to be created. -> [Argument] -- ^ Arguments of the action. - -> AccessToken User + -> Maybe (AccessToken App) + -- ^ Optional app access token (optional with + -- respect to this library, since you can't make + -- this mandatory by changing the settings of + -- your action on Facebook). + -> AccessToken User -- ^ User access token. -> FacebookT Auth m Id -createAction (Action action) query token = do +createAction (Action action) query mapptoken usertoken = do creds <- getCreds - postObject ("/me/" <> appName creds <> ":" <> action) query token + let post :: C.ResourceIO m => Ascii -> AccessToken anyKind -> FacebookT Auth m Id + post prepath = postObject (prepath <> appName creds <> ":" <> action) query + case mapptoken of + Nothing -> post "/me/" usertoken + Just apptoken -> post ("/" <> accessTokenUserId usertoken <> "/") apptoken + -- | An action of your app. Please refer to Facebook's diff --git a/src/Facebook/Types.hs b/src/Facebook/Types.hs --- a/src/Facebook/Types.hs +++ b/src/Facebook/Types.hs @@ -2,8 +2,10 @@ ( Credentials(..) , AccessToken(..) , AccessTokenData + , UserId , accessTokenData , accessTokenExpires + , accessTokenUserId , User , App , Argument @@ -44,7 +46,7 @@ -- These access tokens are distinguished by the phantom type on -- 'AccessToken', which can be 'User' or 'App'. data AccessToken kind where - UserAccessToken :: AccessTokenData -> UTCTime -> AccessToken User + UserAccessToken :: UserId -> AccessTokenData -> UTCTime -> AccessToken User AppAccessToken :: AccessTokenData -> AccessToken App deriving instance Eq (AccessToken kind) @@ -56,16 +58,23 @@ -- calls. type AccessTokenData = Ascii +-- | A Facebook user id such as @1008905713901@. +type UserId = Ascii + -- | Get the access token data. accessTokenData :: AccessToken kind -> AccessTokenData -accessTokenData (UserAccessToken d _) = d -accessTokenData (AppAccessToken d) = d +accessTokenData (UserAccessToken _ d _) = d +accessTokenData (AppAccessToken d) = d -- | Expire time of an access token. It may never expire, in -- which case it will be @Nothing@. accessTokenExpires :: AccessToken kind -> Maybe UTCTime -accessTokenExpires (UserAccessToken _ expt) = Just expt -accessTokenExpires (AppAccessToken _) = Nothing +accessTokenExpires (UserAccessToken _ _ expt) = Just expt +accessTokenExpires (AppAccessToken _) = Nothing + +-- | Get the user ID of an user access token. +accessTokenUserId :: AccessToken User -> UserId +accessTokenUserId (UserAccessToken uid _ _) = uid -- | Phantom type used mark an 'AccessToken' as an user access -- token. diff --git a/tests/runtests.hs b/tests/runtests.hs --- a/tests/runtests.hs +++ b/tests/runtests.hs @@ -63,7 +63,7 @@ invalidCredentials = FB.Credentials "this" "isn't" "valid" invalidUserAccessToken :: FB.AccessToken FB.User -invalidUserAccessToken = FB.UserAccessToken "invalid" farInTheFuture +invalidUserAccessToken = FB.UserAccessToken "invalid" "user" farInTheFuture where Just farInTheFuture = parseTime (error "farInTheFuture") "%Y" "3000" -- It's actually important to use 'farInTheFuture' since we