diff --git a/fb.cabal b/fb.cabal --- a/fb.cabal +++ b/fb.cabal @@ -1,5 +1,5 @@ name: fb -version: 0.5 +version: 0.6 license: BSD3 license-file: LICENSE author: Felipe Lessa @@ -45,6 +45,7 @@ Facebook.Base Facebook.Auth Facebook.Graph + Facebook.Object.User Facebook.OpenGraph build-depends: base >= 4 && < 5 diff --git a/src/Facebook.hs b/src/Facebook.hs --- a/src/Facebook.hs +++ b/src/Facebook.hs @@ -11,14 +11,16 @@ , Credentials(..) -- ** Access token , AccessToken(..) + , UserAccessToken + , AppAccessToken , AccessTokenData , hasExpired , isValid -- ** App access token - , App + , AppKind , getAppAccessToken -- ** User access token - , User + , UserKind , RedirectUrl , Permission , getUserAccessTokenStep1 @@ -26,6 +28,12 @@ , getUserLogoutUrl , extendUserAccessToken + -- * Facebook's Graph API Objects + -- ** User + , User(..) + , Gender(..) + , getUser + -- * Facebook's Open Graph API , createAction , Action @@ -47,4 +55,5 @@ import Facebook.Base import Facebook.Auth import Facebook.Graph +import Facebook.Object.User import Facebook.OpenGraph diff --git a/src/Facebook/Auth.hs b/src/Facebook/Auth.hs --- a/src/Facebook/Auth.hs +++ b/src/Facebook/Auth.hs @@ -39,7 +39,7 @@ -- | Get an app access token from Facebook using your -- credentials. getAppAccessToken :: C.ResourceIO m => - FacebookT Auth m (AccessToken App) + FacebookT Auth m AppAccessToken getAppAccessToken = runResourceInFb $ do creds <- getCreds @@ -82,7 +82,7 @@ RedirectUrl -- ^ Should be exactly the same -- as in 'getUserAccessTokenStep1'. -> [Argument] - -> FacebookT Auth m (AccessToken User) + -> FacebookT Auth m UserAccessToken getUserAccessTokenStep2 redirectUrl query = case query of [code@("code", _)] -> runResourceInFb $ do @@ -117,7 +117,7 @@ -- Facebook as a query string. Returns an user access token with -- a broken 'UserId'. userAccessTokenParser :: UTCTime -- ^ 'getCurrentTime' - -> A.Parser (AccessToken User) + -> A.Parser UserAccessToken userAccessTokenParser now = UserAccessToken userId <$ A.string "access_token=" @@ -141,7 +141,7 @@ -- 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. +getUserLogoutUrl :: UserAccessToken -- ^ 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 = @@ -181,7 +181,7 @@ -- | @True@ if the access token has expired, otherwise @False@. -hasExpired :: (Functor m, MonadIO m) => AccessToken kind -> m Bool +hasExpired :: (Functor m, MonadIO m) => AccessToken anyKind -> m Bool hasExpired token = case accessTokenExpires token of Nothing -> return False @@ -194,7 +194,7 @@ -- case of an user access token, they may have changed their -- password, logged out from Facebook or blocked your app. isValid :: C.ResourceIO m => - AccessToken kind + AccessToken anyKind -> FacebookT anyAuth m Bool isValid token = do expired <- hasExpired token @@ -225,8 +225,8 @@ -- extended, only valid tokens. extendUserAccessToken :: C.ResourceIO m => - AccessToken User - -> FacebookT Auth m (Either FacebookException (AccessToken User)) + UserAccessToken + -> FacebookT Auth m (Either FacebookException UserAccessToken) extendUserAccessToken token@(UserAccessToken _ data_ _) = do expired <- hasExpired token if expired then return (Left hasExpiredExc) else tryToExtend diff --git a/src/Facebook/Base.hs b/src/Facebook/Base.hs --- a/src/Facebook/Base.hs +++ b/src/Facebook/Base.hs @@ -29,7 +29,7 @@ -- | A plain 'H.Request' to a Facebook API. Use this instead of -- 'H.def' when creating new 'H.Request'@s@ for Facebook. -fbreq :: HT.Ascii -> Maybe (AccessToken kind) -> HT.SimpleQuery -> H.Request m +fbreq :: HT.Ascii -> Maybe (AccessToken anyKind) -> HT.SimpleQuery -> H.Request m fbreq path mtoken query = H.def { H.secure = True , H.host = "graph.facebook.com" @@ -54,7 +54,7 @@ tsq creds = (:) ("client_id", appId creds) . (:) ("client_secret", appSecret creds) -instance ToSimpleQuery (AccessToken kind) where +instance ToSimpleQuery (AccessToken anyKind) where tsq token = (:) ("access_token", accessTokenData token) diff --git a/src/Facebook/Graph.hs b/src/Facebook/Graph.hs --- a/src/Facebook/Graph.hs +++ b/src/Facebook/Graph.hs @@ -30,7 +30,7 @@ getObject :: (C.ResourceIO m, A.FromJSON a) => Ascii -- ^ Path (should begin with a slash @\/@) -> [Argument] -- ^ Arguments to be passed to Facebook - -> Maybe (AccessToken kind) -- ^ Optional access token + -> Maybe (AccessToken anyKind) -- ^ Optional access token -> FacebookT anyAuth m a getObject path query mtoken = runResourceInFb $ @@ -40,9 +40,9 @@ -- | Make a raw @POST@ request to Facebook's Graph API. Returns -- a raw JSON 'A.Value'. postObject :: (C.ResourceIO m, A.FromJSON a) => - Ascii -- ^ Path (should begin with a slash @\/@) - -> [Argument] -- ^ Arguments to be passed to Facebook - -> AccessToken kind -- ^ Access token + Ascii -- ^ Path (should begin with a slash @\/@) + -> [Argument] -- ^ Arguments to be passed to Facebook + -> AccessToken anyKind -- ^ Access token -> FacebookT Auth m a postObject path query token = runResourceInFb $ diff --git a/src/Facebook/Object/User.hs b/src/Facebook/Object/User.hs new file mode 100644 --- /dev/null +++ b/src/Facebook/Object/User.hs @@ -0,0 +1,86 @@ +module Facebook.Object.User + ( User(..) + , Gender(..) + , getUser + ) where + +import Control.Applicative +import Control.Monad (mzero) +import Data.Aeson ((.:), (.:?)) +-- import Data.ByteString.Char8 (ByteString) +import Data.Text (Text) +import Data.Typeable (Typeable) + +-- import qualified Control.Exception.Lifted as E +import qualified Data.Aeson as A +import qualified Data.Conduit as C +-- import qualified Data.Text as T + + +import Facebook.Types +import Facebook.Monad +import Facebook.Graph + + +-- | A Facebook user profile (see +-- ). +-- +-- /NOTE:/ We still don't support all fields supported by +-- Facebook. Please fill an issue if you need access to any other +-- fields. +data User = + User { userId :: UserId + , userName :: Maybe Text + , userFirstName :: Maybe Text + , userMiddleName :: Maybe Text + , userLastName :: Maybe Text + , userGender :: Maybe Gender + , userLocale :: Maybe Text + , userUsername :: Maybe Text + , userVerified :: Maybe Bool + , userEmail :: Maybe Text + } + deriving (Eq, Ord, Show, Typeable) + +instance A.FromJSON User where + parseJSON (A.Object v) = + User <$> v .: "id" + <*> v .:? "name" + <*> v .:? "first_name" + <*> v .:? "middle_name" + <*> v .:? "last_name" + <*> v .:? "gender" + <*> v .:? "locale" + <*> v .:? "username" + <*> v .:? "verified" + <*> v .:? "email" + parseJSON _ = mzero + + +-- | An user's gender. +data Gender = Male | Female deriving (Eq, Ord, Show, Enum, Typeable) + +instance A.FromJSON Gender where + parseJSON (A.String "male") = return Male + parseJSON (A.String "female") = return Female + parseJSON _ = mzero + +instance A.ToJSON Gender where + toJSON = A.toJSON . toText + where + toText :: Gender -> Text + toText Male = "male" + toText Female = "female" + + +-- | Get an user using his user ID. The user access token is +-- optional, but when provided more information can be returned +-- back by Facebook. The user ID may be @\"me\"@, in which +-- case you must provide an user access token and information +-- about the token's owner is given. +getUser :: C.ResourceIO m => + UserId -- ^ User ID or @\"me\"@. + -> [Argument] -- ^ Arguments to be passed to Facebook. + -> Maybe UserAccessToken -- ^ Optional user access token. + -> FacebookT anyAuth m User +getUser id_ query mtoken = getObject ("/" <> id_) query mtoken diff --git a/src/Facebook/OpenGraph.hs b/src/Facebook/OpenGraph.hs --- a/src/Facebook/OpenGraph.hs +++ b/src/Facebook/OpenGraph.hs @@ -43,12 +43,12 @@ createAction :: C.ResourceIO m => Action -- ^ Action kind to be created. -> [Argument] -- ^ Arguments of the action. - -> Maybe (AccessToken App) + -> Maybe AppAccessToken -- ^ 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. + -> UserAccessToken -- ^ Required user access token. -> FacebookT Auth m Id createAction (Action action) query mapptoken usertoken = do creds <- getCreds diff --git a/src/Facebook/Types.hs b/src/Facebook/Types.hs --- a/src/Facebook/Types.hs +++ b/src/Facebook/Types.hs @@ -1,13 +1,15 @@ module Facebook.Types ( Credentials(..) , AccessToken(..) + , UserAccessToken + , AppAccessToken , AccessTokenData , UserId , accessTokenData , accessTokenExpires , accessTokenUserId - , User - , App + , UserKind + , AppKind , Argument , (<>) ) where @@ -43,12 +45,20 @@ -- [App access token] An access token that allows you to take -- administrative actions for your application. -- --- These access tokens are distinguished by the phantom type on --- 'AccessToken', which can be 'User' or 'App'. +-- These two kinds of access tokens are distinguished by the +-- phantom type on 'AccessToken', which can be 'UserKind' or +-- 'AppKind'. data AccessToken kind where - UserAccessToken :: UserId -> AccessTokenData -> UTCTime -> AccessToken User - AppAccessToken :: AccessTokenData -> AccessToken App + UserAccessToken :: UserId -> AccessTokenData -> UTCTime -> AccessToken UserKind + AppAccessToken :: AccessTokenData -> AccessToken AppKind +-- | Type synonym for @'AccessToken' 'UserKind'@ +type UserAccessToken = AccessToken UserKind + +-- | Type synonym for @'AccessToken' 'AppKind'@ +type AppAccessToken = AccessToken AppKind + + deriving instance Eq (AccessToken kind) deriving instance Ord (AccessToken kind) deriving instance Show (AccessToken kind) @@ -62,27 +72,27 @@ type UserId = Ascii -- | Get the access token data. -accessTokenData :: AccessToken kind -> AccessTokenData +accessTokenData :: AccessToken anyKind -> AccessTokenData 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 :: AccessToken anyKind -> Maybe UTCTime accessTokenExpires (UserAccessToken _ _ expt) = Just expt accessTokenExpires (AppAccessToken _) = Nothing -- | Get the user ID of an user access token. -accessTokenUserId :: AccessToken User -> UserId +accessTokenUserId :: UserAccessToken -> UserId accessTokenUserId (UserAccessToken uid _ _) = uid -- | Phantom type used mark an 'AccessToken' as an user access -- token. -data User deriving (Typeable) +data UserKind deriving (Typeable) -- | Phantom type used mark an 'AccessToken' as an app access -- token. -data App deriving (Typeable) +data AppKind deriving (Typeable) -- | An argument given to an API call. diff --git a/tests/runtests.hs b/tests/runtests.hs --- a/tests/runtests.hs +++ b/tests/runtests.hs @@ -62,7 +62,7 @@ invalidCredentials :: FB.Credentials invalidCredentials = FB.Credentials "this" "isn't" "valid" -invalidUserAccessToken :: FB.AccessToken FB.User +invalidUserAccessToken :: FB.UserAccessToken invalidUserAccessToken = FB.UserAccessToken "invalid" "user" farInTheFuture where Just farInTheFuture = parseTime (error "farInTheFuture") "%Y" "3000" @@ -70,7 +70,7 @@ -- don't want any tests rejecting this invalid user access -- token before even giving it to Facebook. -invalidAppAccessToken :: FB.AccessToken FB.App +invalidAppAccessToken :: FB.AppAccessToken invalidAppAccessToken = FB.AppAccessToken "invalid" @@ -140,6 +140,17 @@ prop "works for Word32" (propShowRead :: Word32 -> Bool) prop "works for Text" (\t -> FB.encodeFbParam t == t) + + describe "getUser" $ do + it "works for Zuckerberg" $ do + runNoAuth $ do + user <- FB.getUser "zuck" [] Nothing + FB.userId user &?= "4" + FB.userName user &?= Just "Mark Zuckerberg" + FB.userFirstName user &?= Just "Mark" + FB.userMiddleName user &?= Nothing + FB.userLastName user &?= Just "Zuckerberg" + FB.userGender user &?= Just FB.Male -- Wrappers for HUnit operators using MonadIO