diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,8 @@ +# Version + +* Make versioned call. By default now it uses `v2.8. +* `disassociateTestuser` function added. +* `getPage_` function added which accepts `AppAccessToken` as opposed + to `getPage` function. +* Fixed a bug in `getObjectBool` +* Travis CI added diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,61 @@ +fb +-- + +[![Build Status](https://travis-ci.org/psibi/fb.svg?branch=master)](https://travis-ci.org/psibi/fb) + +Haskell bindings to Facebook's API + + +## Example code to get User Access token + +```haskell +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +import Facebook +import Network.HTTP.Client +import Network.HTTP.Client.TLS +import Control.Monad.Trans.Control +import Control.Monad.Trans.Resource +import Control.Monad.IO.Class +import Data.Monoid ((<>)) +import Data.ByteString.Char8 (pack) +import Data.Text hiding (pack) +import Data.Aeson +import qualified Data.Text.Encoding as TE + +myCreds :: Credentials +myCreds = + Credentials + { appName = "Your_APP_Name" + , appId = "your_app_id" + , appSecret = "xxxxxxxxxxxxxxxxx" + } + +main :: IO () +main = do + mgr <- newManager tlsManagerSettings + let redirectUrl = "https://www.yourdomain.com/" + runResourceT $ + runFacebookT myCreds mgr $ + do url1 <- getUserAccessTokenStep1 redirectUrl ["public_profile", "email"] + liftIO $ print ("Paste the url in browser and get code: " <> url1) + code <- liftIO $ getLine + token <- getUserAccessTokenStep2 redirectUrl [("code", pack code)] + liftIO $ print token +``` + +## Snippet to get your Profile Picture: + +``` + (picture :: Value) <- + getObject "/me/picture" [("redirect", "0")] (Just token) + liftIO $ print picture +``` + +## Snippet to get your firstname, lastname: + +``` + user <- getUser "me" [("fields", "first_name,last_name")] (Just token) + liftIO $ print user +``` diff --git a/fb.cabal b/fb.cabal --- a/fb.cabal +++ b/fb.cabal @@ -1,16 +1,17 @@ name: fb -version: 1.0.13 +version: 1.1.0 license: BSD3 license-file: LICENSE -author: Felipe Lessa -maintainer: Felipe Lessa +author: Felipe Lessa, Sibi +maintainer: Sibi copyright: (c) Prowdsponsor synopsis: Bindings to Facebook's API. category: Web stability: Experimental cabal-version: >= 1.8 build-type: Simple -homepage: https://github.com/prowdsponsor/fb +homepage: https://github.com/psibi/fb +bug-reports: https://github.com/psibi/fb/issues description: This package exports bindings to Facebook's APIs (see @@ -24,26 +25,25 @@ API, this package is being developed on demand. If you need something that has not been implemented yet, please send a pull request or file an issue on GitHub - (). + (). extra-source-files: tests/Main.hs tests/tryIt.hs example.hs + README.md + CHANGELOG.md source-repository head type: git - location: git://github.com/prowdsponsor/fb.git + location: git@github.com:psibi/fb.git flag debug default: False description: Print debugging info. -flag conduit11 - description: Use conduit >= 1.1. - library hs-source-dirs: src ghc-options: -Wall @@ -76,27 +76,23 @@ , resourcet , data-default , http-types - , http-conduit >= 2.0 && < 2.2 + , http-conduit >= 2.0 + , http-client >= 0.4.18.1 , attoparsec >= 0.10.4 && < 0.14 , unordered-containers - , aeson >= 0.5 + , aeson >= 0.8.0.2 , base16-bytestring >= 0.1 , base64-bytestring >= 0.1.1 - , time >= 1.2 && < 1.7 + , time >= 1.4 , old-locale , cereal >= 0.3 && < 0.6 , crypto-api >= 0.11 && < 0.14 , cryptohash >= 0.7 , cryptohash-cryptoapi == 0.1.* , monad-logger >= 0.3 - if flag(conduit11) - build-depends: - conduit >= 1.1 && < 1.3 - , conduit-extra == 1.1.* - else - build-depends: - conduit == 1.0.* - , attoparsec-conduit == 1.0.* + , conduit + , conduit-extra + extensions: DeriveDataTypeable EmptyDataDecls @@ -108,10 +104,10 @@ TypeFamilies FlexibleInstances MultiParamTypeClasses + CPP if flag(debug) cpp-options: -DDEBUG - test-suite runtests type: exitcode-stdio-1.0 ghc-options: -Wall -fno-warn-orphans @@ -128,7 +124,7 @@ , data-default , HUnit , QuickCheck - , hspec >= 1.9 && < 1.12 + , hspec , fb extensions: TypeFamilies diff --git a/src/Facebook.hs b/src/Facebook.hs --- a/src/Facebook.hs +++ b/src/Facebook.hs @@ -1,137 +1,130 @@ module Facebook - ( -- * @FacebookT@ monad transformer - FacebookT - , runFacebookT - , runNoAuthFacebookT - , mapFacebookT - , beta_runFacebookT - , beta_runNoAuthFacebookT - , Auth - , NoAuth - - -- * Authorization and Authentication - -- ** Credentials - , Credentials(..) - -- ** Access token - , AccessToken(..) - , UserAccessToken - , AppAccessToken - , AccessTokenData - , hasExpired - , isValid - -- ** App access token - , AppKind - , getAppAccessToken - -- ** User access token - , UserKind - , RedirectUrl - , Permission - , getUserAccessTokenStep1 - , getUserAccessTokenStep2 - , getUserLogoutUrl - , extendUserAccessToken - , debugToken - , DebugToken(..) - -- ** Signed requests - , parseSignedRequest - - -- * Facebook's Graph API - -- ** User - , User(..) - , UserId - , Gender(..) - , getUser - , searchUsers - , getUserCheckins - , Friend(..) - , getUserFriends - , getUserFriendLists - -- ** Page - , Page(..) - , getPage - , searchPages - -- ** Actions - , Action - , createAction - -- ** Checkins - , Checkin(..) - , CheckinFrom(..) - , getCheckin - , createCheckin - -- ** Order - , Order(..) - , OrderId - , OrderApplication - , OrderStatus - , getOrder - -- ** Friend list - , FriendList(..) - , FriendListType(..) - , getFriendListMembers - - -- * Facebook's Graph API basic functionality - -- ** Simple types - , (#=) - , SimpleType(..) - , FbUTCTime(..) - -- ** Complex types - , Place(..) - , Location(..) - , GeoCoordinates(..) - , Tag(..) - -- ** Pagination - , Pager(..) - , fetchNextPage - , fetchPreviousPage - , fetchAllNextPages - , fetchAllPreviousPages - - -- * Real-time update notifications - -- ** Subscriptions - , modifySubscription - , listSubscriptions - , RealTimeUpdateObject(..) - , RealTimeUpdateField - , RealTimeUpdateUrl - , RealTimeUpdateToken - , RealTimeUpdateSubscription(..) - -- ** Notifications - , verifyRealTimeUpdateNotifications - , getRealTimeUpdateNotifications - , RealTimeUpdateNotification(..) - , RealTimeUpdateNotificationUserEntry(..) - - -- * FQL - , fqlQuery - , FQLTime(..) - , FQLList(..) - , FQLObject(..) - - -- * Test User API - , getTestUsers - , removeTestUser - , createTestUser - , makeFriendConn - , incompleteTestUserAccessToken - , TestUser(..) - , CreateTestUser(..) - , CreateTestUserInstalled(..) - - -- * Raw access to the Graph API - , getObject - , postObject - , deleteObject - , searchObjects - , Id(..) - , Argument - - -- * Exceptions - , FacebookException(..) - - -- * Internal functions - , unPermission - ) where + ( FacebookT + , runFacebookT + , runNoAuthFacebookT + , mapFacebookT + , beta_runFacebookT + , beta_runNoAuthFacebookT + , Auth + , NoAuth + -- * Authorization and Authentication + -- ** Credentials + , Credentials(..) + -- ** Access token + , AccessToken(..) + , UserAccessToken + , AppAccessToken + , AccessTokenData + , hasExpired + , isValid + -- ** App access token + , AppKind + , getAppAccessToken + -- ** User access token + , UserKind + , RedirectUrl + , Permission + , getUserAccessTokenStep1 + , getUserAccessTokenStep2 + , getUserLogoutUrl + , extendUserAccessToken + , debugToken + , DebugToken(..) + -- ** Signed requests + , parseSignedRequest + -- * Facebook's Graph API + -- ** User + , User(..) + , UserId + , Gender(..) + , getUser + , searchUsers + , getUserCheckins + , Friend(..) + , getUserFriends + , getUserFriendLists + -- ** Page + , Page(..) + , getPage + , getPage_ + , searchPages + -- ** Actions + , Action + , createAction + -- ** Checkins + , Checkin(..) + , CheckinFrom(..) + , getCheckin + , createCheckin + -- ** Order + , Order(..) + , OrderId + , OrderApplication + , OrderStatus + , getOrder + -- ** Friend list + , FriendList(..) + , FriendListType(..) + , getFriendListMembers + -- * Facebook's Graph API basic functionality + -- ** Simple types + , ( #= ) + , SimpleType(..) + , FbUTCTime(..) + -- ** Complex types + , Place(..) + , Location(..) + , GeoCoordinates(..) + , Tag(..) + -- ** Pagination + , Pager(..) + , fetchNextPage + , fetchPreviousPage + , fetchAllNextPages + , fetchAllPreviousPages + -- * Real-time update notifications + -- ** Subscriptions + , modifySubscription + , listSubscriptions + , RealTimeUpdateObject(..) + , RealTimeUpdateField + , RealTimeUpdateUrl + , RealTimeUpdateToken + , RealTimeUpdateSubscription(..) + -- ** Notifications + , verifyRealTimeUpdateNotifications + , getRealTimeUpdateNotifications + , RealTimeUpdateNotification(..) + , RealTimeUpdateNotificationUserEntry(..) + -- * FQL + , fqlQuery + , FQLTime(..) + , FQLList(..) + , FQLObject(..) + -- * Test User API + , getTestUsers + , disassociateTestuser + , removeTestUser + , createTestUser + , makeFriendConn + , incompleteTestUserAccessToken + , TestUser(..) + , CreateTestUser(..) + , CreateTestUserInstalled(..) + -- * Raw access to the Graph API + , getObject + , postObject + , deleteObject + , searchObjects + , Id(..) + , Argument + -- * Exceptions + , FacebookException(..) + -- * Internal functions + , unPermission + ) where +-- * @FacebookT@ monad transformer import Facebook.Types import Facebook.Monad import Facebook.Base diff --git a/src/Facebook/Auth.hs b/src/Facebook/Auth.hs --- a/src/Facebook/Auth.hs +++ b/src/Facebook/Auth.hs @@ -1,21 +1,24 @@ -{-# LANGUAGE FlexibleContexts, GADTs, ScopedTypeVariables, OverloadedStrings #-} -module Facebook.Auth - ( getAppAccessToken - , getUserAccessTokenStep1 - , getUserAccessTokenStep2 - , getUserLogoutUrl - , extendUserAccessToken - , RedirectUrl - , Permission - , unPermission - , hasExpired - , isValid - , parseSignedRequest - , debugToken - , DebugToken(..) - ) where +{-# LANGUAGE FlexibleContexts, GADTs, ScopedTypeVariables, + OverloadedStrings #-} +module Facebook.Auth + ( getAppAccessToken + , getUserAccessTokenStep1 + , getUserAccessTokenStep2 + , getUserLogoutUrl + , extendUserAccessToken + , RedirectUrl + , Permission + , unPermission + , hasExpired + , isValid + , parseSignedRequest + , debugToken + , DebugToken(..) + ) where +#if __GLASGOW_HASKELL__ <= 784 import Control.Applicative +#endif import Control.Monad (guard, join, liftM, mzero) import Control.Monad.IO.Class (MonadIO(liftIO)) import Control.Monad.Trans.Control (MonadBaseControl) @@ -35,9 +38,10 @@ import qualified Control.Monad.Trans.Resource as R import qualified Data.Aeson as AE import qualified Data.Aeson.Types as AE -import qualified Data.Attoparsec.Char8 as AB +import qualified Data.Attoparsec.ByteString.Char8 as AB import qualified Data.Attoparsec.Text as A import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Base64.URL as Base64URL import qualified Data.ByteString.Char8 as B8 import qualified Data.Conduit as C @@ -50,53 +54,68 @@ import qualified Data.Text.Encoding.Error as TE import qualified Network.HTTP.Conduit as H import qualified Network.HTTP.Types as HT - +import Data.Text (Text) import Facebook.Types import Facebook.Base import Facebook.Monad - -- | Get an app access token from Facebook using your -- credentials. -getAppAccessToken :: (R.MonadResource m, MonadBaseControl IO m) => - FacebookT Auth m AppAccessToken +-- Ref: https://developers.facebook.com/docs/facebook-login/manually-build-a-login-flow +getAppAccessToken + :: (R.MonadResource m, MonadBaseControl IO m) + => FacebookT Auth m AppAccessToken getAppAccessToken = - runResourceInFb $ do - creds <- getCreds - req <- fbreq "/oauth/access_token" Nothing $ - tsq creds [("grant_type", "client_credentials")] - response <- fbhttp req - lift $ - H.responseBody response C.$$+- - CT.decode CT.utf8 C.=$ - C.sinkParser (AppAccessToken <$ A.string "access_token=" - <*> A.takeText) - + runResourceInFb $ + do creds <- getCreds + req <- + fbreq "/oauth/access_token" Nothing $ + tsq creds [("grant_type", "client_credentials")] + response <- fbhttp req + (token :: AE.Value) <- asJson response + case AE.parseMaybe tokenParser token of + Just appToken -> return $ AppAccessToken appToken + _ -> + E.throw $ + FbLibraryException ("Unable to parse: " <> (T.pack $ show token)) + where + tokenParser :: AE.Value -> AE.Parser AccessTokenData + tokenParser val = + AE.withObject + "accessToken" + (\obj -> do + (token :: Text) <- obj AE..: "access_token" + return token) + val -- | The first step to get an user access token. Returns the -- Facebook URL you should redirect you user to. Facebook will -- authenticate the user, authorize your app and then redirect -- the user back into the provider 'RedirectUrl'. -getUserAccessTokenStep1 :: Monad m => - RedirectUrl - -> [Permission] - -> FacebookT Auth m Text +getUserAccessTokenStep1 + :: Monad m + => RedirectUrl -> [Permission] -> FacebookT Auth m Text getUserAccessTokenStep1 redirectUrl perms = do creds <- getCreds - withTier $ \tier -> - let urlBase = case tier of - Production -> "https://www.facebook.com/dialog/oauth?client_id=" - Beta -> "https://www.beta.facebook.com/dialog/oauth?client_id=" - in T.concat $ urlBase - : appId creds - : "&redirect_uri=" - : redirectUrl - : (case perms of - [] -> [] - _ -> "&scope=" : L.intersperse "," (map unPermission perms) - ) - + withTier $ + \tier -> + let urlBase = + case tier of + Production -> + "https://www.facebook.com/" <> apiVersion <> + "/dialog/oauth?client_id=" + Beta -> + "https://www.beta.facebook.com/" <> apiVersion <> + "/dialog/oauth?client_id=" + in T.concat $ + urlBase : + appId creds : + "&redirect_uri=" : + redirectUrl : + (case perms of + [] -> [] + _ -> "&scope=" : L.intersperse "," (map unPermission perms)) -- | The second step to get an user access token. If the user is -- successfully authenticate and they authorize your application, @@ -105,55 +124,65 @@ -- request query parameters passed to your 'RedirectUrl' and give -- to this function that will complete the user authentication -- flow and give you an @'UserAccessToken'@. -getUserAccessTokenStep2 :: (MonadBaseControl IO m, R.MonadResource m) => - RedirectUrl -- ^ Should be exactly the same - -- as in 'getUserAccessTokenStep1'. - -> [Argument] -- ^ Query parameters. - -> FacebookT Auth m UserAccessToken +getUserAccessTokenStep2 + :: (MonadBaseControl IO m, R.MonadResource m) + => RedirectUrl -- ^ Should be exactly the same + -- as in 'getUserAccessTokenStep1'. + -> [Argument] -- ^ Query parameters. + -> FacebookT Auth m UserAccessToken getUserAccessTokenStep2 redirectUrl query = case query of - [code@("code", _)] -> runResourceInFb $ do + [code@("code", _)] -> + runResourceInFb $ -- Get the access token data through Facebook's OAuth. - now <- liftIO getCurrentTime - creds <- getCreds - req <- fbreq "/oauth/access_token" Nothing $ - tsq creds [code, ("redirect_uri", TE.encodeUtf8 redirectUrl)] - preToken <- fmap (userAccessTokenParser now) . asBS =<< fbhttp req - - -- Get user's ID throught Facebook's graph. - userInfo <- asJson =<< fbhttp =<< fbreq "/me" (Just preToken) [("fields", "id")] - case (AE.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"] - errorType = T.concat [t error_, " (", t errorReason, ")"] - t = TE.decodeUtf8With TE.lenientDecode - in E.throw $ FacebookException errorType (t errorDescr) - + do now <- liftIO getCurrentTime + creds <- getCreds + req <- + fbreq "/oauth/access_token" Nothing $ + tsq creds [code, ("redirect_uri", TE.encodeUtf8 redirectUrl)] + response <- fbhttp req + (userToken :: AE.Value) <- asJson response + let (token, expire) = userAccessTokenParser now userToken + -- Get user's ID throught Facebook's graph. + userResponse <- + fbhttp =<< + fbreq + "/me" + (Just (UserAccessToken "invalid id" token expire)) + [("fields", "id")] + (userId :: UserId) <- asJson userResponse + return $ UserAccessToken userId token expire + _ -> + let [error_, errorReason, errorDescr] = + map + (fromMaybe "" . flip lookup query) + ["error", "error_reason", "error_description"] + errorType = T.concat [t error_, " (", t errorReason, ")"] + t = TE.decodeUtf8With TE.lenientDecode + in E.throw $ FacebookException errorType (t errorDescr) -- | Attoparsec parser for user access tokens returned by -- Facebook as a query string. Returns an user access token with -- a broken 'UserId'. -userAccessTokenParser :: UTCTime -- ^ 'getCurrentTime' - -> B.ByteString - -> UserAccessToken -userAccessTokenParser now bs = - let q = HT.parseQuery bs; lookup' a = join (lookup a q) - in case (,) <$> lookup' "access_token" <*> lookup' "expires" of - (Just (tok, expt)) -> UserAccessToken userId (dec tok) (toExpire expt) - _ -> error $ "userAccessTokenParser: failed to parse " ++ show bs - where toExpire expt = let i = read (B8.unpack expt) :: Int - in addUTCTime (fromIntegral i) now - userId = error "userAccessTokenParser: never here" - dec = TE.decodeUtf8With TE.lenientDecode - +userAccessTokenParser + :: UTCTime -- ^ 'getCurrentTime' + -> AE.Value + -> (AccessTokenData, UTCTime) +userAccessTokenParser now val = + case AE.parseMaybe tokenParser val of + Just (token, parser) -> (token, parser) + _ -> error $ "userAccessTokenParser: failed to parse " ++ show val + where + toExpire expt = addUTCTime (fromIntegral expt) now + tokenParser :: AE.Value -> AE.Parser (AccessTokenData, UTCTime) + tokenParser val = + AE.withObject + "accessToken" + (\obj -> do + (token :: Text) <- obj AE..: "access_token" + (expires_in :: Int) <- obj AE..: "expires_in" + return (token, toExpire expires_in)) + val -- | The URL an user should be redirected to in order to log them -- out of their Facebook session. Facebook will then redirect @@ -167,27 +196,31 @@ -- 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 :: Monad m => - UserAccessToken - -- ^ The user's access token. - -> RedirectUrl - -- ^ URL the user should be directed to in - -- your site domain. - -> FacebookT Auth m Text - -- ^ Logout URL in - -- @https:\/\/www.facebook.com\/@ (or on - -- @https:\/\/www.beta.facebook.com\/@ when - -- using the beta tier). +getUserLogoutUrl + :: Monad m + => UserAccessToken + -- ^ The user's access token. + -> RedirectUrl + -- ^ URL the user should be directed to in + -- your site domain. + -> FacebookT Auth m Text -- ^ Logout URL in +-- @https:\/\/www.facebook.com\/@ (or on +-- @https:\/\/www.beta.facebook.com\/@ when +-- using the beta tier). getUserLogoutUrl (UserAccessToken _ data_ _) next = do - withTier $ \tier -> - let urlBase = case tier of - Production -> "https://www.facebook.com/logout.php?" - Beta -> "https://www.beta.facebook.com/logout.php?" - in TE.decodeUtf8 $ - urlBase <> - HT.renderQuery False [ ("next", Just (TE.encodeUtf8 next)) - , ("access_token", Just (TE.encodeUtf8 data_)) ] - + withTier $ + \tier -> + let urlBase = + case tier of + Production -> "https://www.facebook.com/logout.php?" + Beta -> "https://www.beta.facebook.com/logout.php?" + in TE.decodeUtf8 $ + urlBase <> + HT.renderQuery + False + [ ("next", Just (TE.encodeUtf8 next)) + , ("access_token", Just (TE.encodeUtf8 data_)) + ] -- | URL where the user is redirected to after Facebook -- authenticates the user authorizes your application. This URL @@ -195,7 +228,6 @@ -- application. type RedirectUrl = Text - -- | A permission that is asked for the user when he authorizes -- your app. Please refer to Facebook's documentation at -- @@ -209,56 +241,54 @@ -- > -- > perms :: [Permission] -- > perms = ["user_about_me", "email", "offline_access"] -newtype Permission = - Permission { - unPermission :: Text +newtype Permission = Permission + { unPermission :: Text -- ^ Retrieves the 'Text' back from a 'Permission'. Most of -- the time you won't need to use this function, but you may -- need it if you're a library author. } deriving (Eq, Ord) instance Show Permission where - show = show . unPermission + show = show . unPermission instance IsString Permission where - fromString = Permission . fromString - + fromString = Permission . fromString -- | @True@ if the access token has expired, otherwise @False@. -hasExpired :: (Functor m, MonadIO m) => AccessToken anyKind -> m Bool +hasExpired + :: (Functor m, MonadIO m) + => AccessToken anyKind -> m Bool hasExpired token = case accessTokenExpires token of - Nothing -> return False + Nothing -> return False Just expTime -> (>= expTime) <$> liftIO getCurrentTime - -- | @True@ if the access token is valid. An expired access -- token is not valid (see 'hasExpired'). However, a non-expired -- access token may not be valid as well. For example, in the -- case of an user access token, they may have changed their -- password, logged out from Facebook or blocked your app. -isValid :: (MonadBaseControl IO m, R.MonadResource m) => - AccessToken anyKind - -> FacebookT anyAuth m Bool +isValid + :: (MonadBaseControl IO m, R.MonadResource m) + => AccessToken anyKind -> FacebookT anyAuth m Bool isValid token = do expired <- hasExpired token if expired then return False - else - let page = case token of - UserAccessToken _ _ _ -> "/me" - -- Documented way of checking if the token is valid, - -- see . - AppAccessToken _ -> "/19292868552" - -- This is Facebook's page on Facebook. While - -- this behaviour is undocumented, it will - -- return a "400 Bad Request" status code - -- whenever the access token is invalid. It - -- will actually work with user access tokens, - -- too, but they have another, better way of - -- being checked. - in httpCheck =<< fbreq page (Just token) [] - + else let page = + case token of + UserAccessToken _ _ _ -> "/me" + -- Documented way of checking if the token is valid, + -- see . + AppAccessToken _ -> "/19292868552" + -- This is Facebook's page on Facebook. While + -- this behaviour is undocumented, it will + -- return a "400 Bad Request" status code + -- whenever the access token is invalid. It + -- will actually work with user access tokens, + -- too, but they have another, better way of + -- being checked. + in httpCheck =<< fbreq page (Just token) [] -- | Extend the expiration time of an user access token (see -- , @@ -271,71 +301,84 @@ -- have the same data and expiration time as before, but you -- can't assume this). Note that expired access tokens can't be -- extended, only valid tokens. -extendUserAccessToken :: (MonadBaseControl IO m, R.MonadResource m) => - UserAccessToken - -> FacebookT Auth m (Either FacebookException UserAccessToken) -extendUserAccessToken token@(UserAccessToken uid data_ _) - = do expired <- hasExpired token - if expired then return (Left hasExpiredExc) else tryToExtend - where - tryToExtend = runResourceInFb $ do - creds <- getCreds - req <- fbreq "/oauth/access_token" Nothing $ - tsq creds [ ("grant_type", "fb_exchange_token") - , ("fb_exchange_token", TE.encodeUtf8 data_) ] - eresponse <- E.try (asBS =<< fbhttp req) - case eresponse of - Right response -> do - now <- liftIO getCurrentTime - return (Right $ case userAccessTokenParser now response of - UserAccessToken _ data' expires' -> - UserAccessToken uid data' expires') - Left exc -> return (Left exc) - - hasExpiredExc = - mkExc [ "the user access token has already expired, " - , "so I'll not try to extend it." ] - mkExc = FbLibraryException . T.concat . ("extendUserAccessToken: ":) - +extendUserAccessToken + :: (MonadBaseControl IO m, R.MonadResource m) + => UserAccessToken + -> FacebookT Auth m (Either FacebookException UserAccessToken) +extendUserAccessToken token@(UserAccessToken uid data_ _) = do + expired <- hasExpired token + if expired + then return (Left hasExpiredExc) + else tryToExtend + where + tryToExtend = + runResourceInFb $ + do creds <- getCreds + req <- + fbreq "/oauth/access_token" Nothing $ + tsq + creds + [ ("grant_type", "fb_exchange_token") + , ("fb_exchange_token", TE.encodeUtf8 data_) + ] + response <- fbhttp req + userToken <- E.try $ asJson response + case userToken of + Right val -> do + now <- liftIO getCurrentTime + let (extendedtoken, expire) = userAccessTokenParser now val + return $ Right $ UserAccessToken uid extendedtoken expire + Left exc -> return (Left exc) + hasExpiredExc = + mkExc + [ "the user access token has already expired, " + , "so I'll not try to extend it." + ] + mkExc = FbLibraryException . T.concat . ("extendUserAccessToken: " :) -- | Parses a Facebook signed request -- (), -- verifies its authencity and integrity using the HMAC and -- decodes its JSON object. -parseSignedRequest :: (AE.FromJSON a, Monad m) => - B8.ByteString -- ^ Encoded Facebook signed request - -> FacebookT Auth m (Maybe a) +parseSignedRequest + :: (AE.FromJSON a, Monad m) + => B8.ByteString -- ^ Encoded Facebook signed request + -> FacebookT Auth m (Maybe a) parseSignedRequest signedRequest = - runMaybeT $ do - -- Split, decode and JSON-parse - let (encodedSignature, encodedUnparsedPayloadWithDot) = B8.break (== '.') signedRequest - ('.', encodedUnparsedPayload) <- MaybeT $ return (B8.uncons encodedUnparsedPayloadWithDot) - signature <- eitherToMaybeT $ Base64URL.decode $ addBase64Padding encodedSignature - unparsedPayload <- eitherToMaybeT $ Base64URL.decode $ addBase64Padding encodedUnparsedPayload - payload <- eitherToMaybeT $ AB.parseOnly json' unparsedPayload - - -- Verify signature - SignedRequestAlgorithm algo <- fromJson payload - guard (algo == "HMAC-SHA256") - hmacKey <- credsToHmacKey `liftM` lift getCreds - let expectedSignature = Cereal.encode $ hmac' hmacKey encodedUnparsedPayload - guard (signature `constTimeEq` expectedSignature) - - -- Parse user data type - fromJson payload + runMaybeT $ + -- Split, decode and JSON-parse + do let (encodedSignature, encodedUnparsedPayloadWithDot) = B8.break (== '.') signedRequest + ('.', encodedUnparsedPayload) <- + MaybeT $ return (B8.uncons encodedUnparsedPayloadWithDot) + signature <- eitherToMaybeT $ Base64URL.decode $ addBase64Padding encodedSignature + unparsedPayload <- eitherToMaybeT $ Base64URL.decode $ addBase64Padding encodedUnparsedPayload + payload <- eitherToMaybeT $ AB.parseOnly json' unparsedPayload + -- Verify signature + SignedRequestAlgorithm algo <- fromJson payload + guard (algo == "HMAC-SHA256") + hmacKey <- credsToHmacKey `liftM` lift getCreds + let expectedSignature = Cereal.encode $ hmac' hmacKey encodedUnparsedPayload + guard (signature `constTimeEq` expectedSignature) + -- Parse user data type + fromJson payload + where + eitherToMaybeT + :: Monad m + => Either a b -> MaybeT m b + eitherToMaybeT = MaybeT . return . either (const Nothing) Just + fromJson + :: (AE.FromJSON a, Monad m) + => AE.Value -> MaybeT m a + fromJson = eitherToMaybeT . AE.parseEither AE.parseJSON + credsToHmacKey :: Credentials -> MacKey ctx SHA256 + credsToHmacKey = MacKey . appSecretBS - where eitherToMaybeT :: Monad m => Either a b -> MaybeT m b - eitherToMaybeT = MaybeT . return . either (const Nothing) Just - fromJson :: (AE.FromJSON a, Monad m) => AE.Value -> MaybeT m a - fromJson = eitherToMaybeT . AE.parseEither AE.parseJSON - credsToHmacKey :: Credentials -> MacKey ctx SHA256 - credsToHmacKey = MacKey . appSecretBS +newtype SignedRequestAlgorithm = + SignedRequestAlgorithm Text -newtype SignedRequestAlgorithm = SignedRequestAlgorithm Text instance AE.FromJSON SignedRequestAlgorithm where parseJSON (AE.Object v) = SignedRequestAlgorithm <$> v .: "algorithm" - parseJSON _ = mzero - + parseJSON _ = mzero -- | The @base64-bytestring@ package provides two different -- decoding functions for @base64url@: 'Base64URL.decode' and @@ -351,49 +394,49 @@ | drem == 2 = bs `B.append` "==" | drem == 3 = bs `B.append` "=" | otherwise = bs - where drem = B.length bs `mod` 4 - + where + drem = B.length bs `mod` 4 -- | Get detailed information about an access token. -debugToken :: (MonadBaseControl IO m, R.MonadResource m) => - AppAccessToken -- ^ Your app access token. - -> AccessTokenData -- ^ The access token you want to debug. - -> FacebookT Auth m DebugToken -debugToken appToken userTokenData = do - req <- fbreq "/debug_token" (Just appToken) $ - [ ("input_token", TE.encodeUtf8 userTokenData) ] +debugToken + :: (MonadBaseControl IO m, R.MonadResource m) + => AppAccessToken -- ^ Your app access token. + -> AccessTokenData -- ^ The access token you want to debug. + -> FacebookT Auth m DebugToken +debugToken appToken userTokenData = do + req <- + fbreq "/debug_token" (Just appToken) $ + [("input_token", TE.encodeUtf8 userTokenData)] ret <- undata <$> (asJson =<< fbhttp req) - let muserToken = UserAccessToken <$> dtUserId ret - <*> return userTokenData - <*> dtExpiresAt ret - return ret { dtAccessToken = muserToken } - + let muserToken = + UserAccessToken <$> dtUserId ret <*> return userTokenData <*> + dtExpiresAt ret + return + ret + { dtAccessToken = muserToken + } -- | Helper used in 'debugToken'. Unfortunately, we can't use 'Pager' here. -data Undata a = - Undata { - undata :: a +data Undata a = Undata + { undata :: a } -instance AE.FromJSON a => AE.FromJSON (Undata a) where - parseJSON (AE.Object v) = - Undata <$> v AE..: "data" +instance AE.FromJSON a => + AE.FromJSON (Undata a) where + parseJSON (AE.Object v) = Undata <$> v AE..: "data" parseJSON _ = mzero - -- | Detailed information about an access token (cf. 'debugToken'). -data DebugToken = - DebugToken - { dtAppId :: Maybe Text - , dtAppName :: Maybe Text - , dtExpiresAt :: Maybe UTCTime - , dtIsValid :: Maybe Bool - , dtIssuedAt :: Maybe UTCTime - , dtScopes :: Maybe [Permission] - , dtUserId :: Maybe Id - , dtAccessToken :: Maybe UserAccessToken - } deriving (Eq, Ord, Show, Typeable) - +data DebugToken = DebugToken + { dtAppId :: Maybe Text + , dtAppName :: Maybe Text + , dtExpiresAt :: Maybe UTCTime + , dtIsValid :: Maybe Bool + , dtIssuedAt :: Maybe UTCTime + , dtScopes :: Maybe [Permission] + , dtUserId :: Maybe Id + , dtAccessToken :: Maybe UserAccessToken + } deriving (Eq, Ord, Show, Typeable) -- | Note: this instance always sets 'dtAccessToken' to -- 'Nothing', but 'debugToken' will update this field before @@ -402,12 +445,12 @@ -- response. instance AE.FromJSON DebugToken where parseJSON (AE.Object v) = - DebugToken <$> (fmap idCode <$> v AE..:? "app_id") - <*> v AE..:? "application" - <*> (fmap unFbUTCTime <$> v AE..:? "expires_at") - <*> v AE..:? "is_valid" - <*> (fmap unFbUTCTime <$> v AE..:? "issued_at") - <*> (fmap (map Permission) <$> v AE..:? "scopes") - <*> v AE..:? "user_id" - <*> pure Nothing + DebugToken <$> (fmap idCode <$> v AE..:? "app_id") <*> + v AE..:? "application" <*> + (fmap unFbUTCTime <$> v AE..:? "expires_at") <*> + v AE..:? "is_valid" <*> + (fmap unFbUTCTime <$> v AE..:? "issued_at") <*> + (fmap (map Permission) <$> v AE..:? "scopes") <*> + v AE..:? "user_id" <*> + pure Nothing parseJSON _ = mzero diff --git a/src/Facebook/Base.hs b/src/Facebook/Base.hs --- a/src/Facebook/Base.hs +++ b/src/Facebook/Base.hs @@ -9,13 +9,13 @@ , fbhttp , fbhttpHelper , httpCheck + , apiVersion ) where import Control.Applicative import Control.Monad (mzero) import Control.Monad.IO.Class (MonadIO) import Data.ByteString.Char8 (ByteString) -import Data.Default (def) import Data.Text (Text) import Data.Typeable (Typeable) @@ -24,31 +24,36 @@ import Control.Monad.Trans.Control (MonadBaseControl) import qualified Control.Monad.Trans.Resource as R import qualified Data.Aeson as A -import qualified Data.Attoparsec.Char8 as AT +import qualified Data.Attoparsec.ByteString.Char8 as AT import qualified Data.ByteString as B import qualified Data.Conduit as C import qualified Data.Conduit.Attoparsec as C import qualified Data.Conduit.List as CL +import qualified Data.Conduit.Binary as CB import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Network.HTTP.Conduit as H import qualified Network.HTTP.Types as HT - +import qualified Data.ByteString.Lazy as L +#if !MIN_VERSION_http_client(0,4,30) +import Data.Default (def) +#endif #if DEBUG import Control.Monad.IO.Class (MonadIO, liftIO) import Text.Printf (printf) -import qualified Data.ByteString.Lazy as L #endif import Facebook.Types import Facebook.Monad +apiVersion :: Text +apiVersion = "v2.8" -- | A plain 'H.Request' to a Facebook API. Use this instead of -- 'def' when creating new 'H.Request'@s@ for Facebook. fbreq :: Monad m => - Text -- ^ Path. + Text -- ^ Path. Should start from "/". -> Maybe (AccessToken anyKind) -- ^ Access token. -> HT.SimpleQuery -- ^ Parameters. -> FacebookT anyAuth m H.Request @@ -57,6 +62,22 @@ let host = case tier of Production -> "graph.facebook.com" Beta -> "graph.beta.facebook.com" +#if MIN_VERSION_http_client(0,4,30) + in H.defaultRequest { H.secure = True + , H.host = host + , H.port = 443 + , H.path = TE.encodeUtf8 ("/" <> apiVersion <> path) + , H.redirectCount = 3 + , H.queryString = + HT.renderSimpleQuery False $ + maybe id tsq mtoken query +#if MIN_VERSION_http_client(0,5,0) + , H.responseTimeout = H.responseTimeoutMicro 120000000 -- 2 minutes +#else + , H.responseTimeout = Just 120000000 -- 2 minutes +#endif + } +#else in def { H.secure = True , H.host = host , H.port = 443 @@ -67,6 +88,7 @@ maybe id tsq mtoken query , H.responseTimeout = Just 120000000 -- 2 minutes } +#endif -- | Internal class for types that may be passed on queries to @@ -153,21 +175,32 @@ -> H.Request -> m (H.Response (C.ResumableSource m ByteString)) fbhttpHelper manager req = do +#if MIN_VERSION_http_client(0,5,0) + let req' = req { H.checkResponse = \_ _ -> return () } +#else let req' = req { H.checkStatus = \_ _ _ -> Nothing } +#endif #if DEBUG _ <- liftIO $ printf "fbhttp doing request\n\tmethod: %s\n\tsecure: %s\n\thost: %s\n\tport: %s\n\tpath: %s\n\tqueryString: %s\n\trequestHeaders: %s\n" (show $ H.method req') (show $ H.secure req') (show $ H.host req') (show $ H.port req') (show $ H.path req') (show $ H.queryString req') (show $ H.requestHeaders req') #endif response <- H.http req' manager let status = H.responseStatus response headers = H.responseHeaders response - cookies = H.responseCookieJar response #if DEBUG _ <- liftIO $ printf "fbhttp response status: %s\n" (show status) #endif if isOkay status then return response else do +#if MIN_VERSION_http_client(0,5,0) + fullResp <- H.responseBody response C.$$+- CB.sinkLbs + let res' = fmap (const ()) response + let statusexc = H.HttpExceptionRequest req $ H.StatusCodeException res' (L.toStrict fullResp) +#else + let cookies = H.responseCookieJar response let statusexc = H.StatusCodeException status headers cookies +#endif + val <- E.try $ asJsonHelper response case val :: Either E.SomeException FacebookException of Right fbexc -> E.throw fbexc @@ -200,7 +233,12 @@ httpCheck req = runResourceInFb $ do manager <- getManager let req' = req { H.method = HT.methodHead - , H.checkStatus = \_ _ _ -> Nothing } +#if MIN_VERSION_http_client(0,5,0) + , H.checkResponse = \_ _ -> return () +#else + , H.checkStatus = \_ _ _ -> Nothing +#endif + } isOkay . H.responseStatus <$> lift (H.httpLbs req' manager) -- Yes, we use httpLbs above so that we don't have to worry -- about consuming the responseBody. Note that the diff --git a/src/Facebook/Graph.hs b/src/Facebook/Graph.hs --- a/src/Facebook/Graph.hs +++ b/src/Facebook/Graph.hs @@ -1,19 +1,21 @@ -{-# LANGUAGE ConstraintKinds, CPP, DeriveDataTypeable, FlexibleContexts, OverloadedStrings #-} -module Facebook.Graph - ( getObject - , postObject - , deleteObject - , searchObjects - , (#=) - , SimpleType(..) - , Place(..) - , Location(..) - , GeoCoordinates(..) - , Tag(..) - ) where - +{-# LANGUAGE ConstraintKinds, CPP, DeriveDataTypeable, + FlexibleContexts, OverloadedStrings #-} +module Facebook.Graph + ( getObject + , postObject + , deleteObject + , searchObjects + , ( #= ) + , SimpleType(..) + , Place(..) + , Location(..) + , GeoCoordinates(..) + , Tag(..) + ) where +#if __GLASGOW_HASKELL__ <= 784 import Control.Applicative +#endif import Control.Monad (mzero) import Control.Monad.Trans.Control (MonadBaseControl) import Data.ByteString.Char8 (ByteString) @@ -27,10 +29,13 @@ #else import System.Locale (defaultTimeLocale) #endif - import qualified Control.Monad.Trans.Resource as R import qualified Data.Aeson as A -import qualified Data.Aeson.Encode as AE (fromValue) +#if MIN_VERSION_aeson(1,0,0) +import Data.Aeson.Text (encodeToTextBuilder) +#else +import Data.Aeson.Encode (encodeToTextBuilder) +#endif import qualified Data.ByteString.Char8 as B import qualified Data.Text.Encoding as TE import qualified Data.Text.Lazy as TL @@ -39,151 +44,167 @@ import qualified Network.HTTP.Conduit as H import qualified Network.HTTP.Types as HT - import Facebook.Auth import Facebook.Base import Facebook.Monad import Facebook.Types import Facebook.Pager - -- | Make a raw @GET@ request to Facebook's Graph API. -getObject :: (R.MonadResource m, MonadBaseControl IO m, A.FromJSON a) => - Text -- ^ Path (should begin with a slash @\/@) - -> [Argument] -- ^ Arguments to be passed to Facebook - -> Maybe (AccessToken anyKind) -- ^ Optional access token - -> FacebookT anyAuth m a +getObject + :: (R.MonadResource m, MonadBaseControl IO m, A.FromJSON a) + => Text -- ^ Path (should begin with a slash @\/@) + -> [Argument] -- ^ Arguments to be passed to Facebook + -> Maybe (AccessToken anyKind) -- ^ Optional access token + -> FacebookT anyAuth m a getObject path query mtoken = - runResourceInFb $ - asJson =<< fbhttp =<< fbreq path mtoken query - + runResourceInFb $ asJson =<< fbhttp =<< fbreq path mtoken query -- | Make a raw @POST@ request to Facebook's Graph API. -postObject :: (R.MonadResource m, MonadBaseControl IO m, A.FromJSON a) => - Text -- ^ Path (should begin with a slash @\/@) - -> [Argument] -- ^ Arguments to be passed to Facebook - -> AccessToken anyKind -- ^ Access token - -> FacebookT Auth m a +postObject + :: (R.MonadResource m, MonadBaseControl IO m, A.FromJSON a) + => Text -- ^ Path (should begin with a slash @\/@) + -> [Argument] -- ^ Arguments to be passed to Facebook + -> AccessToken anyKind -- ^ Access token + -> FacebookT Auth m a postObject = methodObject HT.methodPost - -- | Make a raw @DELETE@ request to Facebook's Graph API. -deleteObject :: (R.MonadResource m, MonadBaseControl IO m, A.FromJSON a) => - Text -- ^ Path (should begin with a slash @\/@) - -> [Argument] -- ^ Arguments to be passed to Facebook - -> AccessToken anyKind -- ^ Access token - -> FacebookT Auth m a +deleteObject + :: (R.MonadResource m, MonadBaseControl IO m, A.FromJSON a) + => Text -- ^ Path (should begin with a slash @\/@) + -> [Argument] -- ^ Arguments to be passed to Facebook + -> AccessToken anyKind -- ^ Access token + -> FacebookT Auth m a deleteObject = methodObject HT.methodDelete - -- | Helper function used by 'postObject' and 'deleteObject'. -methodObject :: (R.MonadResource m, MonadBaseControl IO m, A.FromJSON a) => - HT.Method - -> Text -- ^ Path (should begin with a slash @\/@) - -> [Argument] -- ^ Arguments to be passed to Facebook - -> AccessToken anyKind -- ^ Access token - -> FacebookT Auth m a +methodObject + :: (R.MonadResource m, MonadBaseControl IO m, A.FromJSON a) + => HT.Method + -> Text -- ^ Path (should begin with a slash @\/@) + -> [Argument] -- ^ Arguments to be passed to Facebook + -> AccessToken anyKind -- ^ Access token + -> FacebookT Auth m a methodObject method path query token = - runResourceInFb $ do - req <- fbreq path (Just token) query - asJson =<< fbhttp req { H.method = method } - + runResourceInFb $ + do req <- fbreq path (Just token) query + asJson =<< + fbhttp + req + { H.method = method + } -- | Make a raw @GET@ request to the /search endpoint of Facebook’s -- Graph API. Returns a raw JSON 'A.Value'. -searchObjects :: (R.MonadResource m, MonadBaseControl IO m, A.FromJSON a) - => Text -- ^ A Facebook object type to search for - -> Text -- ^ The keyword to search for - -> [Argument] -- ^ Additional arguments to pass - -> Maybe UserAccessToken -- ^ Optional access token - -> FacebookT anyAuth m (Pager a) +searchObjects + :: (R.MonadResource m, MonadBaseControl IO m, A.FromJSON a) + => Text -- ^ A Facebook object type to search for + -> Text -- ^ The keyword to search for + -> [Argument] -- ^ Additional arguments to pass + -> Maybe UserAccessToken -- ^ Optional access token + -> FacebookT anyAuth m (Pager a) searchObjects objectType keyword query = getObject "/search" query' - where query' = ("q" #= keyword) : ("type" #= objectType) : query - + where + query' = ("q" #= keyword) : ("type" #= objectType) : query ---------------------------------------------------------------------- - - -- | Create an 'Argument' with a 'SimpleType'. See the docs on -- 'createAction' for an example. -(#=) :: SimpleType a => ByteString -> a -> Argument +( #= ) + :: SimpleType a + => ByteString -> a -> Argument p #= v = (p, encodeFbParam v) - -- | Class for data types that may be represented as a Facebook -- simple type. (see -- ). -class SimpleType a where - encodeFbParam :: a -> B.ByteString +class SimpleType a where + encodeFbParam :: a -> B.ByteString -- | Facebook's simple type @Boolean@. instance SimpleType Bool where - encodeFbParam b = if b then "1" else "0" + encodeFbParam b = + if b + then "1" + else "0" -- | Facebook's simple type @DateTime@ with only the date. instance SimpleType TI.Day where - encodeFbParam = B.pack . TI.formatTime defaultTimeLocale "%Y-%m-%d" + encodeFbParam = B.pack . TI.formatTime defaultTimeLocale "%Y-%m-%d" + -- | Facebook's simple type @DateTime@. instance SimpleType TI.UTCTime where - encodeFbParam = B.pack . TI.formatTime defaultTimeLocale "%Y%m%dT%H%MZ" + encodeFbParam = B.pack . TI.formatTime defaultTimeLocale "%Y%m%dT%H%MZ" + -- | Facebook's simple type @DateTime@. instance SimpleType TI.ZonedTime where - encodeFbParam = encodeFbParam . TI.zonedTimeToUTC + encodeFbParam = encodeFbParam . TI.zonedTimeToUTC -- @Enum@ doesn't make sense to support as a Haskell data type. - -- | Facebook's simple type @Float@ with less precision than supported. instance SimpleType Float where - encodeFbParam = showBS + encodeFbParam = showBS + -- | Facebook's simple type @Float@. instance SimpleType Double where - encodeFbParam = showBS + encodeFbParam = showBS -- | Facebook's simple type @Integer@. instance SimpleType Int where - encodeFbParam = showBS + encodeFbParam = showBS + -- | Facebook's simple type @Integer@. instance SimpleType Word where - encodeFbParam = showBS + encodeFbParam = showBS + -- | Facebook's simple type @Integer@. instance SimpleType Int8 where - encodeFbParam = showBS + encodeFbParam = showBS + -- | Facebook's simple type @Integer@. instance SimpleType Word8 where - encodeFbParam = showBS + encodeFbParam = showBS + -- | Facebook's simple type @Integer@. instance SimpleType Int16 where - encodeFbParam = showBS + encodeFbParam = showBS + -- | Facebook's simple type @Integer@. instance SimpleType Word16 where - encodeFbParam = showBS + encodeFbParam = showBS + -- | Facebook's simple type @Integer@. instance SimpleType Int32 where - encodeFbParam = showBS + encodeFbParam = showBS + -- | Facebook's simple type @Integer@. instance SimpleType Word32 where - encodeFbParam = showBS + encodeFbParam = showBS + -- | Facebook's simple type @Integer@. instance SimpleType Int64 where - encodeFbParam = showBS + encodeFbParam = showBS + -- | Facebook's simple type @Integer@. instance SimpleType Word64 where - encodeFbParam = showBS + encodeFbParam = showBS -- | Facebook's simple type @String@. instance SimpleType Text where - encodeFbParam = TE.encodeUtf8 + encodeFbParam = TE.encodeUtf8 + -- | Facebook's simple type @String@. instance SimpleType ByteString where - encodeFbParam = id + encodeFbParam = id -- | An object's 'Id' code. instance SimpleType Id where - encodeFbParam = TE.encodeUtf8 . idCode + encodeFbParam = TE.encodeUtf8 . idCode -- | 'Permission' is a @newtype@ of 'Text' instance SimpleType Permission where - encodeFbParam = encodeFbParam . unPermission + encodeFbParam = encodeFbParam . unPermission -- | A comma-separated list of simple types. This definition -- doesn't work everywhere, just for a few combinations that @@ -191,86 +212,72 @@ -- is the same as encoding the concatenation of all lists. In -- other words, this instance is here more for your convenience -- than to make sure your code is correct. -instance SimpleType a => SimpleType [a] where - encodeFbParam = B.concat . intersperse "," . map encodeFbParam +instance SimpleType a => + SimpleType [a] where + encodeFbParam = B.concat . intersperse "," . map encodeFbParam -showBS :: Show a => a -> B.ByteString +showBS + :: Show a + => a -> B.ByteString showBS = B.pack . show - ---------------------------------------------------------------------- - - -- | Information about a place. This is not a Graph Object, -- instead it's just a field of a Object. (Not to be confused -- with the @Page@ object.) -data Place = - Place { placeId :: Id -- ^ @Page@ ID. - , placeName :: Maybe Text -- ^ @Page@ name. - , placeLocation :: Maybe Location - } - deriving (Eq, Ord, Show, Read, Typeable) +data Place = Place + { placeId :: Id -- ^ @Page@ ID. + , placeName :: Maybe Text -- ^ @Page@ name. + , placeLocation :: Maybe Location + } deriving (Eq, Ord, Show, Read, Typeable) instance A.FromJSON Place where parseJSON (A.Object v) = - Place <$> v A..: "id" - <*> v A..:? "name" - <*> v A..:? "location" + Place <$> v A..: "id" <*> v A..:? "name" <*> v A..:? "location" parseJSON _ = mzero - -- | A geographical location. -data Location = - Location { locationStreet :: Maybe Text - , locationCity :: Maybe Text - , locationState :: Maybe Text - , locationCountry :: Maybe Text - , locationZip :: Maybe Text - , locationCoords :: Maybe GeoCoordinates - } - deriving (Eq, Ord, Show, Read, Typeable) +data Location = Location + { locationStreet :: Maybe Text + , locationCity :: Maybe Text + , locationState :: Maybe Text + , locationCountry :: Maybe Text + , locationZip :: Maybe Text + , locationCoords :: Maybe GeoCoordinates + } deriving (Eq, Ord, Show, Read, Typeable) instance A.FromJSON Location where parseJSON obj@(A.Object v) = - Location <$> v A..:? "street" - <*> v A..:? "city" - <*> v A..:? "state" - <*> v A..:? "country" - <*> v A..:? "zip" - <*> A.parseJSON obj + Location <$> v A..:? "street" <*> v A..:? "city" <*> v A..:? "state" <*> + v A..:? "country" <*> + v A..:? "zip" <*> + A.parseJSON obj parseJSON _ = mzero - -- | Geographical coordinates. -data GeoCoordinates = - GeoCoordinates { latitude :: !Double - , longitude :: !Double - } - deriving (Eq, Ord, Show, Read, Typeable) +data GeoCoordinates = GeoCoordinates + { latitude :: !Double + , longitude :: !Double + } deriving (Eq, Ord, Show, Read, Typeable) instance A.FromJSON GeoCoordinates where parseJSON (A.Object v) = - GeoCoordinates <$> v A..: "latitude" - <*> v A..: "longitude" + GeoCoordinates <$> v A..: "latitude" <*> v A..: "longitude" parseJSON _ = mzero instance SimpleType GeoCoordinates where encodeFbParam c = - let obj = A.object [ "latitude" A..= latitude c - , "longitude" A..= longitude c] - toBS = TE.encodeUtf8 . TL.toStrict . TLB.toLazyText . AE.fromValue + let obj = + A.object ["latitude" A..= latitude c, "longitude" A..= longitude c] + toBS = TE.encodeUtf8 . TL.toStrict . TLB.toLazyText . encodeToTextBuilder in toBS obj - -- | A tag (i.e. \"I'll /tag/ you on my post\"). -data Tag = - Tag { tagId :: Id -- ^ Who is tagged. - , tagName :: Text -- ^ Name of the tagged person. - } - deriving (Eq, Ord, Show, Read, Typeable) +data Tag = Tag + { tagId :: Id -- ^ Who is tagged. + , tagName :: Text -- ^ Name of the tagged person. + } deriving (Eq, Ord, Show, Read, Typeable) instance A.FromJSON Tag where - parseJSON (A.Object v) = - Tag <$> v A..: "id" - <*> v A..: "name" + parseJSON (A.Object v) = Tag <$> v A..: "id" <*> v A..: "name" parseJSON _ = mzero diff --git a/src/Facebook/Object/Checkin.hs b/src/Facebook/Object/Checkin.hs --- a/src/Facebook/Object/Checkin.hs +++ b/src/Facebook/Object/Checkin.hs @@ -1,12 +1,15 @@ -{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, OverloadedStrings #-} -module Facebook.Object.Checkin - ( Checkin(..) - , CheckinFrom(..) - , getCheckin - , createCheckin - ) where +{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, + OverloadedStrings #-} +module Facebook.Object.Checkin + ( Checkin(..) + , CheckinFrom(..) + , getCheckin + , createCheckin + ) where +#if __GLASGOW_HASKELL__ <= 784 import Control.Applicative +#endif import Control.Monad (mzero) import Control.Monad.Trans.Control (MonadBaseControl) import Data.Aeson ((.:), (.:?)) @@ -17,73 +20,64 @@ import qualified Control.Monad.Trans.Resource as R import qualified Data.Aeson as A - import Facebook.Types import Facebook.Monad import Facebook.Graph import Facebook.Pager - -- | A Facebook check-in (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 Checkin = - Checkin { checkinId :: Id - , checkinFrom :: Maybe CheckinFrom - , checkinPlace :: Maybe Place - , checkinCreatedTime :: Maybe UTCTime - , checkinTags :: Maybe (Pager Tag) - , checkinMessage :: Maybe Text - } - deriving (Eq, Ord, Show, Read, Typeable) +data Checkin = Checkin + { checkinId :: Id + , checkinFrom :: Maybe CheckinFrom + , checkinPlace :: Maybe Place + , checkinCreatedTime :: Maybe UTCTime + , checkinTags :: Maybe (Pager Tag) + , checkinMessage :: Maybe Text + } deriving (Eq, Ord, Show, Read, Typeable) instance A.FromJSON Checkin where - parseJSON (A.Object v) = - Checkin <$> v .: "id" - <*> v .:? "from" - <*> v .:? "place" - <*> ((unFbUTCTime <$>) <$> v .:? "created_time") - <*> v .:? "tags" - <*> v .:? "message" - parseJSON _ = mzero - + parseJSON (A.Object v) = + Checkin <$> v .: "id" <*> v .:? "from" <*> v .:? "place" <*> + ((unFbUTCTime <$>) <$> v .:? "created_time") <*> + v .:? "tags" <*> + v .:? "message" + parseJSON _ = mzero -- | Information about the user who made the check-in. -data CheckinFrom = - CheckinFrom { checkinFromId :: UserId - , checkinFromName :: Text - } - deriving (Eq, Ord, Show, Read, Typeable) +data CheckinFrom = CheckinFrom + { checkinFromId :: UserId + , checkinFromName :: Text + } deriving (Eq, Ord, Show, Read, Typeable) instance A.FromJSON CheckinFrom where - parseJSON (A.Object v) = - CheckinFrom <$> v .: "id" - <*> v .: "name" + parseJSON (A.Object v) = CheckinFrom <$> v .: "id" <*> v .: "name" parseJSON _ = mzero - -- | Get a checkin from its ID. The user access token is -- optional, but when provided more information can be returned -- back by Facebook. -getCheckin :: (R.MonadResource m, MonadBaseControl IO m) => - Id -- ^ Checkin ID. - -> [Argument] -- ^ Arguments to be passed to Facebook. - -> Maybe UserAccessToken -- ^ Optional user access token. - -> FacebookT anyAuth m Checkin +getCheckin + :: (R.MonadResource m, MonadBaseControl IO m) + => Id -- ^ Checkin ID. + -> [Argument] -- ^ Arguments to be passed to Facebook. + -> Maybe UserAccessToken -- ^ Optional user access token. + -> FacebookT anyAuth m Checkin getCheckin id_ query mtoken = getObject ("/" <> idCode id_) query mtoken - -- | Creates a 'check-in' and returns its ID. Place and -- coordinates are both required by Facebook. -createCheckin :: (R.MonadResource m, MonadBaseControl IO m) => - Id -- ^ Place ID. - -> GeoCoordinates -- ^ Coordinates. - -> [Argument] -- ^ Other arguments of the action. - -> UserAccessToken -- ^ Required user access token. - -> FacebookT Auth m Id +createCheckin + :: (R.MonadResource m, MonadBaseControl IO m) + => Id -- ^ Place ID. + -> GeoCoordinates -- ^ Coordinates. + -> [Argument] -- ^ Other arguments of the action. + -> UserAccessToken -- ^ Required user access token. + -> FacebookT Auth m Id createCheckin pid coords args usertoken = do let body = ("place" #= pid) : ("coordinates" #= coords) : args postObject "me/checkins" body usertoken diff --git a/src/Facebook/Object/FriendList.hs b/src/Facebook/Object/FriendList.hs --- a/src/Facebook/Object/FriendList.hs +++ b/src/Facebook/Object/FriendList.hs @@ -1,12 +1,15 @@ -{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, OverloadedStrings #-} -module Facebook.Object.FriendList - ( FriendList(..) - , FriendListType(..) - , getUserFriendLists - , getFriendListMembers - ) where +{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, + OverloadedStrings #-} +module Facebook.Object.FriendList + ( FriendList(..) + , FriendListType(..) + , getUserFriendLists + , getFriendListMembers + ) where +#if __GLASGOW_HASKELL__ <= 784 import Control.Applicative +#endif import Control.Monad (mzero) import Control.Monad.Trans.Control (MonadBaseControl) import Data.Aeson ((.:)) @@ -16,7 +19,6 @@ import qualified Control.Monad.Trans.Resource as R import qualified Data.Aeson as A - import Facebook.Types import Facebook.Monad import Facebook.Graph @@ -24,65 +26,68 @@ import Facebook.Object.User -- | A friend list for a 'User'. -data FriendList = - FriendList { friendListId :: Id - , friendListName :: Text - , friendListType :: FriendListType - } - deriving (Eq, Ord, Show, Read, Typeable) +data FriendList = FriendList + { friendListId :: Id + , friendListName :: Text + , friendListType :: FriendListType + } deriving (Eq, Ord, Show, Read, Typeable) instance A.FromJSON FriendList where - parseJSON (A.Object v) = - FriendList <$> v .: "id" - <*> v .: "name" - <*> v .: "list_type" - parseJSON _ = mzero + parseJSON (A.Object v) = + FriendList <$> v .: "id" <*> v .: "name" <*> v .: "list_type" + parseJSON _ = mzero -data FriendListType = CloseFriendsList | AcquaintancesList | RestrictedList - | UserCreatedList | EducationList | WorkList | CurrentCityList | FamilyList - deriving (Eq, Ord, Show, Read, Enum, Typeable) +data FriendListType + = CloseFriendsList + | AcquaintancesList + | RestrictedList + | UserCreatedList + | EducationList + | WorkList + | CurrentCityList + | FamilyList + deriving (Eq, Ord, Show, Read, Enum, Typeable) instance A.FromJSON FriendListType where - parseJSON (A.String "close_friends") = return CloseFriendsList - parseJSON (A.String "acquaintances") = return AcquaintancesList - parseJSON (A.String "restricted") = return RestrictedList - parseJSON (A.String "user_created") = return UserCreatedList - parseJSON (A.String "education") = return EducationList - parseJSON (A.String "work") = return WorkList - parseJSON (A.String "current_city") = return CurrentCityList - parseJSON (A.String "family") = return FamilyList - parseJSON _ = mzero + parseJSON (A.String "close_friends") = return CloseFriendsList + parseJSON (A.String "acquaintances") = return AcquaintancesList + parseJSON (A.String "restricted") = return RestrictedList + parseJSON (A.String "user_created") = return UserCreatedList + parseJSON (A.String "education") = return EducationList + parseJSON (A.String "work") = return WorkList + parseJSON (A.String "current_city") = return CurrentCityList + parseJSON (A.String "family") = return FamilyList + parseJSON _ = mzero instance A.ToJSON FriendListType where - toJSON = A.toJSON . toText - where - toText :: FriendListType -> Text - toText CloseFriendsList = "close_friends" - toText AcquaintancesList = "aquaintances" - toText RestrictedList = "restricted" - toText UserCreatedList = "user_created" - toText EducationList = "education" - toText WorkList = "work" - toText CurrentCityList = "current_city" - toText FamilyList = "family" + toJSON = A.toJSON . toText + where + toText :: FriendListType -> Text + toText CloseFriendsList = "close_friends" + toText AcquaintancesList = "aquaintances" + toText RestrictedList = "restricted" + toText UserCreatedList = "user_created" + toText EducationList = "education" + toText WorkList = "work" + toText CurrentCityList = "current_city" + toText FamilyList = "family" -- close_friends, acquaintances, restricted, user_created, education, work, current_city, family - -- | Get the friend lists of the given user. -getUserFriendLists :: - (R.MonadResource m, MonadBaseControl IO m) => - UserId -- ^ User ID or @\"me\"@. - -> [Argument] -- ^ Arguments to be passed to Facebook. +getUserFriendLists + :: (R.MonadResource m, MonadBaseControl IO m) + => UserId -- ^ User ID or @\"me\"@. + -> [Argument] -- ^ Arguments to be passed to Facebook. -> UserAccessToken -- ^ User access token. -> FacebookT anyAuth m (Pager FriendList) getUserFriendLists id_ query token = getObject ("/" <> idCode id_ <> "/friendlists") query (Just token) -- | Get the members of a friend list. -getFriendListMembers :: - (R.MonadResource m, MonadBaseControl IO m) => - Id -- ^ List ID. - -> [Argument] -- ^ Arguments to be passed to Facebook. +getFriendListMembers + :: (R.MonadResource m, MonadBaseControl IO m) + => Id -- ^ List ID. + -> [Argument] -- ^ Arguments to be passed to Facebook. -> UserAccessToken -- ^ User access token. -> FacebookT anyAuth m (Pager Friend) getFriendListMembers id_ query token = diff --git a/src/Facebook/Object/Order.hs b/src/Facebook/Object/Order.hs --- a/src/Facebook/Object/Order.hs +++ b/src/Facebook/Object/Order.hs @@ -1,13 +1,16 @@ -{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, OverloadedStrings #-} -module Facebook.Object.Order - ( Order(..) - , OrderId - , OrderStatus(..) - , OrderApplication(..) - , getOrder - ) where +{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, + OverloadedStrings #-} +module Facebook.Object.Order + ( Order(..) + , OrderId + , OrderStatus(..) + , OrderApplication(..) + , getOrder + ) where +#if __GLASGOW_HASKELL__ <= 784 import Control.Applicative +#endif import Control.Monad (mzero) import Control.Monad.Trans.Control (MonadBaseControl) import Data.Text (Text) @@ -26,66 +29,62 @@ type OrderId = Id -- | A Facebook @Order@ oject. -data Order = Order { - orderId :: OrderId, - orderFrom :: UserId, - orderTo :: UserId, - orderAmount :: Integer, - orderStatus :: OrderStatus, - orderApplication :: OrderApplication, - orderCountry :: Text, - orderRefundCode :: Maybe Text, - orderCreatedTime :: ZonedTime, - orderUpdatedTime :: ZonedTime -} deriving (Show, Typeable) +data Order = Order + { orderId :: OrderId + , orderFrom :: UserId + , orderTo :: UserId + , orderAmount :: Integer + , orderStatus :: OrderStatus + , orderApplication :: OrderApplication + , orderCountry :: Text + , orderRefundCode :: Maybe Text + , orderCreatedTime :: ZonedTime + , orderUpdatedTime :: ZonedTime + } deriving (Show, Typeable) -- | A Facebook 'Order' status type. -data OrderStatus = - OrderPlaced - | OrderSettled - | OrderRefunded - | OrderDisputed - | OrderCancelled - deriving (Show, Enum, Eq, Typeable) +data OrderStatus + = OrderPlaced + | OrderSettled + | OrderRefunded + | OrderDisputed + | OrderCancelled + deriving (Show, Enum, Eq, Typeable) -- | A trimmed down version of Facebook Application as it is used in 'Order'. -data OrderApplication = OrderApplication { - appId :: Text, - appName :: Text -} deriving (Show, Typeable) +data OrderApplication = OrderApplication + { appId :: Text + , appName :: Text + } deriving (Show, Typeable) instance A.FromJSON OrderApplication where - parseJSON (A.Object v) = - OrderApplication <$> v .: "id" - <*> v .: "name" - parseJSON _ = mzero + parseJSON (A.Object v) = OrderApplication <$> v .: "id" <*> v .: "name" + parseJSON _ = mzero instance A.FromJSON Order where - parseJSON (A.Object v) = - Order <$> v .: "id" - <*> v .: "from" - <*> v .: "to" - <*> v .: "amount" - <*> v .: "status" - <*> v .: "application" - <*> v .: "country" - <*> v .:? "refund_reason_code" - <*> v .: "created_time" - <*> v .: "updated_time" - parseJSON _ = mzero + parseJSON (A.Object v) = + Order <$> v .: "id" <*> v .: "from" <*> v .: "to" <*> v .: "amount" <*> + v .: "status" <*> + v .: "application" <*> + v .: "country" <*> + v .:? "refund_reason_code" <*> + v .: "created_time" <*> + v .: "updated_time" + parseJSON _ = mzero instance A.FromJSON OrderStatus where - parseJSON (A.String "placed") = return OrderPlaced - parseJSON (A.String "settled") = return OrderSettled - parseJSON (A.String "refunded") = return OrderRefunded - parseJSON (A.String "disputed") = return OrderDisputed - parseJSON (A.String "cancelled") = return OrderCancelled - parseJSON _ = mzero + parseJSON (A.String "placed") = return OrderPlaced + parseJSON (A.String "settled") = return OrderSettled + parseJSON (A.String "refunded") = return OrderRefunded + parseJSON (A.String "disputed") = return OrderDisputed + parseJSON (A.String "cancelled") = return OrderCancelled + parseJSON _ = mzero -- | Get an 'Order' using its 'OrderId'. The user access token -- is mandatory. -getOrder :: (R.MonadResource m, MonadBaseControl IO m) => - OrderId -- ^ Order ID. - -> UserAccessToken -- ^ User access token. - -> FacebookT anyAuth m Order +getOrder + :: (R.MonadResource m, MonadBaseControl IO m) + => OrderId -- ^ Order ID. + -> UserAccessToken -- ^ User access token. + -> FacebookT anyAuth m Order getOrder id_ mtoken = getObject ("/" <> idCode id_) [] (Just mtoken) diff --git a/src/Facebook/Object/Page.hs b/src/Facebook/Object/Page.hs --- a/src/Facebook/Object/Page.hs +++ b/src/Facebook/Object/Page.hs @@ -1,14 +1,15 @@ -{-# LANGUAGE DeriveDataTypeable - , FlexibleContexts - , OverloadedStrings - #-} -module Facebook.Object.Page - ( Page(..) - , getPage - , searchPages - ) where +{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, + OverloadedStrings #-} +module Facebook.Object.Page + ( Page(..) + , getPage + , getPage_ + , searchPages + ) where +#if __GLASGOW_HASKELL__ <= 784 import Control.Applicative +#endif import Control.Monad (mzero) import Control.Monad.Trans.Control (MonadBaseControl) import Data.Aeson ((.:), (.:?)) @@ -27,52 +28,59 @@ -- -- /NOTE:/ Does not yet support all fields. Please file an issue if -- you need any other fields. -data Page = Page { pageId :: Id - , pageName :: Maybe Text - , pageLink :: Maybe Text - , pageCategory :: Maybe Text - , pageIsPublished :: Maybe Bool - , pageCanPost :: Maybe Bool - , pageLikes :: Maybe Integer - , pageLocation :: Maybe Location - , pagePhone :: Maybe Text - , pageCheckins :: Maybe Integer - , pagePicture :: Maybe Text - , pageWebsite :: Maybe Text - , pageTalkingAboutCount :: Maybe Integer - } deriving (Eq, Ord, Show, Read, Typeable) +data Page = Page + { pageId :: Id + , pageName :: Maybe Text + , pageLink :: Maybe Text + , pageCategory :: Maybe Text + , pageIsPublished :: Maybe Bool + , pageCanPost :: Maybe Bool + , pageLikes :: Maybe Integer + , pageLocation :: Maybe Location + , pagePhone :: Maybe Text + , pageCheckins :: Maybe Integer + , pagePicture :: Maybe Text + , pageWebsite :: Maybe Text + , pageTalkingAboutCount :: Maybe Integer + } deriving (Eq, Ord, Show, Read, Typeable) instance A.FromJSON Page where parseJSON (A.Object v) = - Page <$> v .: "id" - <*> v .:? "name" - <*> v .:? "link" - <*> v .:? "category" - <*> v .:? "is_published" - <*> v .:? "can_post" - <*> v .:? "likes" - <*> v .:? "location" - <*> v .:? "phone" - <*> v .:? "checkin" - <*> v .:? "picture" - <*> v .:? "website" - <*> v .:? "talking_about_count" + Page <$> v .: "id" <*> v .:? "name" <*> v .:? "link" <*> v .:? "category" <*> + v .:? "is_published" <*> + v .:? "can_post" <*> + v .:? "likes" <*> + v .:? "location" <*> + v .:? "phone" <*> + v .:? "checkin" <*> + v .:? "picture" <*> + v .:? "website" <*> + v .:? "talking_about_count" parseJSON _ = mzero - -- | Get a page using its ID. The user access token is optional. -getPage :: (R.MonadResource m, MonadBaseControl IO m) - => Id -- ^ Page ID - -> [Argument] -- ^ Arguments to be passed to Facebook - -> Maybe UserAccessToken -- ^ Optional user access token - -> FacebookT anyAuth m Page -getPage id_ = getObject $ "/" <> idCode id_ +getPage + :: (R.MonadResource m, MonadBaseControl IO m) + => Id -- ^ Page ID + -> [Argument] -- ^ Arguments to be passed to Facebook + -> Maybe UserAccessToken -- ^ Optional user access token + -> FacebookT anyAuth m Page +getPage id_ = getObject $ ("/" <> idCode id_) +-- | Get a page using its ID. The user access token is optional. +getPage_ + :: (R.MonadResource m, MonadBaseControl IO m) + => Id -- ^ Page ID + -> [Argument] -- ^ Arguments to be passed to Facebook + -> Maybe AppAccessToken -- ^ Optional user access token + -> FacebookT anyAuth m Page +getPage_ id_ = getObject $ ("/" <> idCode id_) -- | Search pages by keyword. The user access token is optional. -searchPages :: (R.MonadResource m, MonadBaseControl IO m) - => Text -- ^ Keyword to search for - -> [Argument] -- ^ Arguments to pass to Facebook - -> Maybe UserAccessToken -- ^ Optional user access token - -> FacebookT anyAuth m (Pager Page) +searchPages + :: (R.MonadResource m, MonadBaseControl IO m) + => Text -- ^ Keyword to search for + -> [Argument] -- ^ Arguments to pass to Facebook + -> Maybe UserAccessToken -- ^ Optional user access token + -> FacebookT anyAuth m (Pager Page) searchPages = searchObjects "page" diff --git a/src/Facebook/Object/User.hs b/src/Facebook/Object/User.hs --- a/src/Facebook/Object/User.hs +++ b/src/Facebook/Object/User.hs @@ -1,15 +1,18 @@ -{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, OverloadedStrings #-} -module Facebook.Object.User - ( User(..) - , Gender(..) - , getUser - , searchUsers - , getUserCheckins - , Friend(..) - , getUserFriends - ) where +{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, + OverloadedStrings #-} +module Facebook.Object.User + ( User(..) + , Gender(..) + , getUser + , searchUsers + , getUserCheckins + , Friend(..) + , getUserFriends + ) where +#if __GLASGOW_HASKELL__ <= 784 import Control.Applicative +#endif import Control.Monad (mzero) import Control.Monad.Trans.Control (MonadBaseControl) import Data.Aeson ((.:), (.:?)) @@ -19,119 +22,110 @@ import qualified Control.Monad.Trans.Resource as R import qualified Data.Aeson as A - import Facebook.Types import Facebook.Monad import Facebook.Graph import Facebook.Pager import Facebook.Object.Checkin - -- | 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 - , userLocation :: Maybe Place - } - deriving (Eq, Ord, Show, Read, Typeable) +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 + , userLocation :: Maybe Place + } deriving (Eq, Ord, Show, Read, 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" - <*> v .:? "location" - parseJSON _ = mzero - + 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" <*> + v .:? "location" + parseJSON _ = mzero -- | An user's gender. -data Gender = Male | Female deriving (Eq, Ord, Show, Read, Enum, Typeable) +data Gender + = Male + | Female + deriving (Eq, Ord, Show, Read, Enum, Typeable) instance A.FromJSON Gender where - parseJSON (A.String "male") = return Male - parseJSON (A.String "female") = return Female - parseJSON _ = mzero + 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" - + 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 :: (R.MonadResource m, MonadBaseControl IO m) => - UserId -- ^ User ID or @\"me\"@. - -> [Argument] -- ^ Arguments to be passed to Facebook. - -> Maybe UserAccessToken -- ^ Optional user access token. - -> FacebookT anyAuth m User +getUser + :: (R.MonadResource m, MonadBaseControl IO 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 ("/" <> idCode id_) query mtoken - -- | Search users by keyword. -searchUsers :: (R.MonadResource m, MonadBaseControl IO m) - => Text - -> [Argument] - -> Maybe UserAccessToken - -> FacebookT anyAuth m (Pager User) +searchUsers + :: (R.MonadResource m, MonadBaseControl IO m) + => Text + -> [Argument] + -> Maybe UserAccessToken + -> FacebookT anyAuth m (Pager User) searchUsers = searchObjects "user" - -- | Get a list of check-ins made by a given user. -getUserCheckins :: - (R.MonadResource m, MonadBaseControl IO m) => - UserId -- ^ User ID or @\"me\"@. - -> [Argument] -- ^ Arguments to be passed to Facebook. +getUserCheckins + :: (R.MonadResource m, MonadBaseControl IO m) + => UserId -- ^ User ID or @\"me\"@. + -> [Argument] -- ^ Arguments to be passed to Facebook. -> UserAccessToken -- ^ User access token. -> FacebookT anyAuth m (Pager Checkin) getUserCheckins id_ query token = getObject ("/" <> idCode id_ <> "/checkins") query (Just token) - -- | A friend connection of a 'User'. -data Friend = - Friend { friendId :: UserId - , friendName :: Text - } - deriving (Eq, Ord, Show, Read, Typeable) +data Friend = Friend + { friendId :: UserId + , friendName :: Text + } deriving (Eq, Ord, Show, Read, Typeable) instance A.FromJSON Friend where - parseJSON (A.Object v) = - Friend <$> v .: "id" - <*> v .: "name" - parseJSON _ = mzero - + parseJSON (A.Object v) = Friend <$> v .: "id" <*> v .: "name" + parseJSON _ = mzero -- | Get the list of friends of the given user. -getUserFriends :: - (R.MonadResource m, MonadBaseControl IO m) => - UserId -- ^ User ID or @\"me\"@. - -> [Argument] -- ^ Arguments to be passed to Facebook. +getUserFriends + :: (R.MonadResource m, MonadBaseControl IO m) + => UserId -- ^ User ID or @\"me\"@. + -> [Argument] -- ^ Arguments to be passed to Facebook. -> UserAccessToken -- ^ User access token. -> FacebookT anyAuth m (Pager Friend) getUserFriends id_ query token = diff --git a/src/Facebook/Pager.hs b/src/Facebook/Pager.hs --- a/src/Facebook/Pager.hs +++ b/src/Facebook/Pager.hs @@ -1,14 +1,16 @@ -{-# LANGUAGE ConstraintKinds, DeriveDataTypeable, FlexibleContexts, OverloadedStrings #-} -module Facebook.Pager - ( Pager(..) - , fetchNextPage - , fetchPreviousPage - , fetchAllNextPages - , fetchAllPreviousPages - ) where - +{-# LANGUAGE ConstraintKinds, DeriveDataTypeable, FlexibleContexts, + OverloadedStrings#-} +module Facebook.Pager + ( Pager(..) + , fetchNextPage + , fetchPreviousPage + , fetchAllNextPages + , fetchAllPreviousPages + ) where +#if __GLASGOW_HASKELL__ <= 784 import Control.Applicative +#endif import Control.Monad (mzero) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Control (MonadBaseControl) @@ -20,11 +22,9 @@ import qualified Data.Conduit as C import qualified Network.HTTP.Conduit as H - import Facebook.Base import Facebook.Monad - -- | Many Graph API results are returned as a JSON object with -- the following structure: -- @@ -48,80 +48,95 @@ -- A @Pager a@ datatype encodes such result where each item has -- type @a@. You may use functions 'fetchNextPage' and -- 'fetchPreviousPage' to navigate through the results. -data Pager a = - Pager { - pagerData :: [a] - , pagerPrevious :: Maybe String - , pagerNext :: Maybe String +data Pager a = Pager + { pagerData :: [a] + , pagerPrevious :: Maybe String + , pagerNext :: Maybe String } deriving (Eq, Ord, Show, Read, Typeable) -instance A.FromJSON a => A.FromJSON (Pager a) where +instance A.FromJSON a => + A.FromJSON (Pager a) where parseJSON (A.Object v) = let paging f = v A..:? "paging" >>= maybe (return Nothing) (A..:? f) - in Pager <$> v A..: "data" - <*> paging "previous" - <*> paging "next" + in Pager <$> v A..: "data" <*> paging "previous" <*> paging "next" parseJSON _ = mzero - -- | Tries to fetch the next page of a 'Pager'. Returns -- 'Nothing' whenever the current @Pager@ does not have a -- 'pagerNext'. -fetchNextPage :: (R.MonadResource m, MonadBaseControl IO m, A.FromJSON a) => - Pager a -> FacebookT anyAuth m (Maybe (Pager a)) +fetchNextPage + :: (R.MonadResource m, MonadBaseControl IO m, A.FromJSON a) + => Pager a -> FacebookT anyAuth m (Maybe (Pager a)) fetchNextPage = fetchHelper pagerNext - -- | Tries to fetch the previous page of a 'Pager'. Returns -- 'Nothing' whenever the current @Pager@ does not have a -- 'pagerPrevious'. -fetchPreviousPage :: (R.MonadResource m, MonadBaseControl IO m, A.FromJSON a) => - Pager a -> FacebookT anyAuth m (Maybe (Pager a)) +fetchPreviousPage + :: (R.MonadResource m, MonadBaseControl IO m, A.FromJSON a) + => Pager a -> FacebookT anyAuth m (Maybe (Pager a)) fetchPreviousPage = fetchHelper pagerPrevious - -- | (Internal) See 'fetchNextPage' and 'fetchPreviousPage'. -fetchHelper :: (R.MonadResource m, MonadBaseControl IO m, A.FromJSON a) => - (Pager a -> Maybe String) -> Pager a -> FacebookT anyAuth m (Maybe (Pager a)) +fetchHelper + :: (R.MonadResource m, MonadBaseControl IO m, A.FromJSON a) + => (Pager a -> Maybe String) + -> Pager a + -> FacebookT anyAuth m (Maybe (Pager a)) fetchHelper pagerRef pager = case pagerRef pager of - Nothing -> return Nothing + Nothing -> return Nothing Just url -> do +#if MIN_VERSION_http_client(0,4,30) + req <- liftIO (H.parseRequest url) +#else req <- liftIO (H.parseUrl url) - Just <$> (asJson =<< fbhttp req { H.redirectCount = 3 }) - +#endif + Just <$> + (asJson =<< + fbhttp + req + { H.redirectCount = 3 + }) -- | Tries to fetch all next pages and returns a 'C.Source' with -- all results. The 'C.Source' will include the results from -- this page as well. Previous pages will not be considered. -- Next pages will be fetched on-demand. -fetchAllNextPages :: - (Monad m, MonadResourceBase n, A.FromJSON a) => - Pager a -> FacebookT anyAuth m (C.Source n a) +fetchAllNextPages + :: (Monad m, MonadResourceBase n, A.FromJSON a) + => Pager a -> FacebookT anyAuth m (C.Source n a) fetchAllNextPages = fetchAllHelper pagerNext - -- | Tries to fetch all previous pages and returns a 'C.Source' -- with all results. The 'C.Source' will include the results -- from this page as well. Next pages will not be -- considered. Previous pages will be fetched on-demand. -fetchAllPreviousPages :: - (Monad m, MonadResourceBase n, A.FromJSON a) => - Pager a -> FacebookT anyAuth m (C.Source n a) +fetchAllPreviousPages + :: (Monad m, MonadResourceBase n, A.FromJSON a) + => Pager a -> FacebookT anyAuth m (C.Source n a) fetchAllPreviousPages = fetchAllHelper pagerPrevious - -- | (Internal) See 'fetchAllNextPages' and 'fetchAllPreviousPages'. -fetchAllHelper :: - (Monad m, MonadResourceBase n, A.FromJSON a) => - (Pager a -> Maybe String) -> Pager a -> FacebookT anyAuth m (C.Source n a) +fetchAllHelper + :: (Monad m, MonadResourceBase n, A.FromJSON a) + => (Pager a -> Maybe String) -> Pager a -> FacebookT anyAuth m (C.Source n a) fetchAllHelper pagerRef pager = do manager <- getManager - let go (x:xs) mnext = C.yield x >> go xs mnext - go [] Nothing = return () + let go (x:xs) mnext = C.yield x >> go xs mnext + go [] Nothing = return () go [] (Just next) = do +#if MIN_VERSION_http_client(0,4,30) + req <- liftIO (H.parseRequest next) +#else req <- liftIO (H.parseUrl next) - let get = fbhttpHelper manager req { H.redirectCount = 3 } +#endif + let get = + fbhttpHelper + manager + req + { H.redirectCount = 3 + } start =<< lift (R.runResourceT $ asJsonHelper =<< get) start p = go (pagerData p) $! pagerRef p return (start pager) diff --git a/src/Facebook/TestUsers.hs b/src/Facebook/TestUsers.hs --- a/src/Facebook/TestUsers.hs +++ b/src/Facebook/TestUsers.hs @@ -1,31 +1,34 @@ {-# LANGUAGE FlexibleContexts #-} -module Facebook.TestUsers - ( TestUser(..) - , CreateTestUser(..) - , CreateTestUserInstalled(..) - , getTestUsers - , removeTestUser - , createTestUser - , makeFriendConn - , incompleteTestUserAccessToken - ) where +module Facebook.TestUsers + ( TestUser(..) + , CreateTestUser(..) + , CreateTestUserInstalled(..) + , getTestUsers + , disassociateTestuser + , removeTestUser + , createTestUser + , makeFriendConn + , incompleteTestUserAccessToken + ) where import Control.Applicative ((<$>), (<*>)) import Control.Monad (unless, mzero) import Control.Monad.Trans.Control (MonadBaseControl) +import Data.ByteString.Lazy (fromStrict) import Data.Default import Data.Text +import Data.Text.Encoding (encodeUtf8) import Data.Time (UTCTime(..), Day(..)) import Data.Typeable (Typeable) - +import Data.Aeson +import Data.Aeson.Types import qualified Control.Exception.Lifted as E import qualified Control.Monad.Trans.Resource as R import qualified Data.Aeson as A import qualified Data.ByteString.Char8 as B - import Facebook.Auth import Facebook.Base import Facebook.Graph @@ -33,100 +36,103 @@ import Facebook.Types import Facebook.Pager - -- | A Facebook test user. -data TestUser = - TestUser { tuId :: UserId - , tuAccessToken :: Maybe AccessTokenData - , tuLoginUrl :: Maybe Text - , tuEmail :: Maybe Text - , tuPassword :: Maybe Text - } - deriving (Eq, Ord, Show, Read, Typeable) - +-- Ref: https://developers.facebook.com/docs/graph-api/reference/v2.8/app/accounts/test-users +data TestUser = TestUser + { tuId :: UserId + , tuAccessToken :: Maybe AccessTokenData + , tuLoginUrl :: Maybe Text + , tuEmail :: Maybe Text + , tuPassword :: Maybe Text + } deriving (Eq, Ord, Show, Read, Typeable) instance A.FromJSON TestUser where - parseJSON (A.Object v) = - TestUser <$> v A..: "id" - <*> v A..:? "access_token" - <*> v A..:? "login_url" - <*> v A..:? "email" - <*> v A..:? "password" - parseJSON _ = mzero - - + parseJSON (A.Object v) = + TestUser <$> v A..: "id" <*> v A..:? "access_token" <*> v A..:? "login_url" <*> + v A..:? "email" <*> + v A..:? "password" + parseJSON _ = mzero -- | Data type used to hold information of a new test user. This type -- also accepts a Data.Default value. -data CreateTestUser = - CreateTestUser - { ctuInstalled :: CreateTestUserInstalled - , ctuName :: Maybe Text - , ctuLocale :: Maybe Text - } - +data CreateTestUser = CreateTestUser + { ctuInstalled :: CreateTestUserInstalled + , ctuName :: Maybe Text + , ctuLocale :: Maybe Text + } -- | Specify if the app is to be installed on the new test user. If -- it is, then you must tell what permissions should be given. -data CreateTestUserInstalled = - CreateTestUserNotInstalled - | CreateTestUserInstalled { ctuiPermissions :: [Permission] } - | CreateTestUserFbDefault - -- ^ Uses Facebook's default. It seems that this is equivalent to - -- @CreateTestUserInstalled []@, but Facebook's documentation is - -- not clear about it. +data CreateTestUserInstalled + = CreateTestUserNotInstalled + | CreateTestUserInstalled { ctuiPermissions :: [Permission]} + | CreateTestUserFbDefault -- ^ Uses Facebook's default. It seems that this is equivalent to +-- @CreateTestUserInstalled []@, but Facebook's documentation is +-- not clear about it. -- | Default instance for 'CreateTestUser'. instance Default CreateTestUser where - def = CreateTestUser def def def + def = CreateTestUser def def def -- | Default instance for 'CreateTestUserInstalled'. instance Default CreateTestUserInstalled where - def = CreateTestUserFbDefault - + def = CreateTestUserFbDefault -- | Construct a query from a 'CreateTestUser'. createTestUserQueryArgs :: CreateTestUser -> [Argument] createTestUserQueryArgs (CreateTestUser installed name locale) = - forInst installed ++ forField "name" name ++ forField "locale" locale - where - forInst (CreateTestUserInstalled p) = [ "installed" #= True, "permissions" #= p ] - forInst CreateTestUserNotInstalled = [ "installed" #= False ] - forInst CreateTestUserFbDefault = [] - forField _ Nothing = [] - forField fieldName (Just f) = [ fieldName #= f ] - + forInst installed ++ forField "name" name ++ forField "locale" locale + where + forInst (CreateTestUserInstalled p) = + ["installed" #= True, "permissions" #= p] + forInst CreateTestUserNotInstalled = ["installed" #= False] + forInst CreateTestUserFbDefault = [] + forField _ Nothing = [] + forField fieldName (Just f) = [fieldName #= f] -- | Create a new test user. -createTestUser :: (R.MonadResource m, MonadBaseControl IO m) - => CreateTestUser -- ^ How the test user should be - -- created. - -> AppAccessToken -- ^ Access token for your app. - -> FacebookT Auth m TestUser +-- Ref: https://developers.facebook.com/docs/graph-api/reference/v2.8/app/accounts/test-users#publish +createTestUser + :: (R.MonadResource m, MonadBaseControl IO m) + => CreateTestUser -- ^ How the test user should be + -- created. + -> AppAccessToken -- ^ Access token for your app. + -> FacebookT Auth m TestUser createTestUser userInfo token = do creds <- getCreds - let query = ("method","post") : createTestUserQueryArgs userInfo + let query = ("method", "post") : createTestUserQueryArgs userInfo getObject ("/" <> appId creds <> "/accounts/test-users") query (Just token) - -- | Get a list of test users. -getTestUsers :: (R.MonadResource m, MonadBaseControl IO m) - => AppAccessToken -- ^ Access token for your app. - -> FacebookT Auth m (Pager TestUser) +getTestUsers + :: (R.MonadResource m, MonadBaseControl IO m) + => AppAccessToken -- ^ Access token for your app. + -> FacebookT Auth m (Pager TestUser) getTestUsers token = do creds <- getCreds getObject ("/" <> appId creds <> "/accounts/test-users") [] (Just token) +disassociateTestuser + :: (MonadBaseControl IO m, R.MonadResource m) + => TestUser -> AppAccessToken -> FacebookT Auth m Bool +disassociateTestuser testUser _token = do + creds <- getCreds + getObjectBool + ("/" <> (appId creds) <> "/accounts/test-users") + [("uid", encodeUtf8 $ idCode $ tuId testUser), ("method", "delete")] + (Just _token) -- | Remove an existing test user. -removeTestUser :: (R.MonadResource m, MonadBaseControl IO m) - => TestUser -- ^ The TestUser to be removed. - -> AppAccessToken -- ^ Access token for your app (ignored since fb 0.14.7). - -> FacebookT Auth m Bool -removeTestUser testUser _token = - getObjectBool ("/" <> idCode (tuId testUser)) [("method","delete")] token - where token = incompleteTestUserAccessToken testUser - +removeTestUser + :: (R.MonadResource m, MonadBaseControl IO m) + => TestUser -- ^ The TestUser to be removed. + -> AppAccessToken -- ^ Access token for your app (ignored since fb 0.14.7). + -> FacebookT Auth m Bool +removeTestUser testUser _token = do + getObjectBool + ("/" <> (idCode $ tuId testUser)) + [("method", "delete")] + (Just _token) -- | Make a friend connection between two test users. -- @@ -136,29 +142,31 @@ -- format: \"\/userB_id\/friends\/userA_id\" with the access token of -- user B as query parameter. The first call creates a friend request -- and the second call accepts the friend request. -makeFriendConn :: (R.MonadResource m, MonadBaseControl IO m) - => TestUser - -> TestUser - -> FacebookT Auth m () -makeFriendConn (TestUser { tuAccessToken = Nothing }) _ = E.throw $ - FbLibraryException "The test user passed on the first argument doesn't have\ - \ a token. Both users must have a token." -makeFriendConn _ (TestUser { tuAccessToken = Nothing }) = E.throw $ - FbLibraryException "The test user passed on the second argument doesn't have\ - \ a token. Both users must have a token." -makeFriendConn (TestUser {tuId = id1, tuAccessToken = (Just token1)}) (TestUser {tuId = id2, tuAccessToken = (Just token2)}) = do +makeFriendConn + :: (R.MonadResource m, MonadBaseControl IO m) + => TestUser -> TestUser -> FacebookT Auth m () +makeFriendConn (TestUser {tuAccessToken = Nothing}) _ = + E.throw $ + FbLibraryException + "The test user passed on the first argument doesn't have a token. Both users must have a token." +makeFriendConn _ (TestUser {tuAccessToken = Nothing}) = + E.throw $ + FbLibraryException + "The test user passed on the second argument doesn't have a token. Both users must have a token." +makeFriendConn (TestUser {tuId = id1 + ,tuAccessToken = (Just token1)}) (TestUser {tuId = id2 + ,tuAccessToken = (Just token2)}) = do let friendReq userId1 userId2 token = - getObjectBool ("/" <> idCode userId1 <> "/friends/" <> idCode userId2) - [ "method" #= ("post" :: B.ByteString), - "access_token" #= token ] - Nothing + getObjectBool + ("/" <> idCode userId1 <> "/friends/" <> idCode userId2) + ["method" #= ("post" :: B.ByteString), "access_token" #= token] + Nothing r1 <- friendReq id1 id2 token1 r2 <- friendReq id2 id1 token2 unless r1 $ E.throw $ FbLibraryException "Couldn't make friend request." unless r2 $ E.throw $ FbLibraryException "Couldn't accept friend request." return () - -- | Create an 'UserAccessToken' from a 'TestUser'. It's incomplete -- because it will not have the right expiration time. incompleteTestUserAccessToken :: TestUser -> Maybe UserAccessToken @@ -167,19 +175,34 @@ let farFuture = UTCTime (ModifiedJulianDay 100000) 0 return (UserAccessToken (tuId t) tokenData farFuture) - -- | Same as 'getObject', but instead of parsing the result -- as a JSON, it tries to parse either as "true" or "false". -- Used only by the Test User API bindings. -getObjectBool :: (R.MonadResource m, MonadBaseControl IO m) - => Text - -- ^ Path (should begin with a slash @\/@). - -> [Argument] - -- ^ Arguments to be passed to Facebook. - -> Maybe (AccessToken anyKind) - -- ^ Optional access token. - -> FacebookT anyAuth m Bool +getObjectBool + :: (R.MonadResource m, MonadBaseControl IO m) + => Text + -- ^ Path (should begin with a slash @\/@). + -> [Argument] + -- ^ Arguments to be passed to Facebook. + -> Maybe (AccessToken anyKind) + -- ^ Optional access token. + -> FacebookT anyAuth m Bool getObjectBool path query mtoken = - runResourceInFb $ do - bs <- asBS =<< fbhttp =<< fbreq path mtoken query - return (bs == "true") + runResourceInFb $ + do req <- fbreq path mtoken query + response <- fbhttp req + bs <- asBS response + let respJson :: Maybe Value = decode (fromStrict bs) + maybe + (return False) + (\val -> maybe (return False) return (parseMaybe isTrue val)) + respJson + where + isTrue :: Value -> Parser Bool + isTrue val = + withObject + "success" + (\obj -> do + (status :: Bool) <- obj .: "success" + return status) + val diff --git a/src/Facebook/Types.hs b/src/Facebook/Types.hs --- a/src/Facebook/Types.hs +++ b/src/Facebook/Types.hs @@ -1,23 +1,24 @@ {-# LANGUAGE CPP, DeriveDataTypeable, GADTs, StandaloneDeriving #-} + module Facebook.Types - ( Credentials(..) - , appIdBS - , appSecretBS - , AccessToken(..) - , UserAccessToken - , AppAccessToken - , AccessTokenData - , Id(..) - , UserId - , accessTokenData - , accessTokenExpires - , accessTokenUserId - , UserKind - , AppKind - , Argument - , (<>) - , FbUTCTime(..) - ) where + ( Credentials(..) + , appIdBS + , appSecretBS + , AccessToken(..) + , UserAccessToken + , AppAccessToken + , AccessTokenData + , Id(..) + , UserId + , accessTokenData + , accessTokenExpires + , accessTokenUserId + , UserKind + , AppKind + , Argument + , (<>) + , FbUTCTime(..) + ) where import Control.Applicative ((<$>), (<*>), pure) import Control.Monad (mzero) @@ -26,15 +27,15 @@ import Data.Monoid (Monoid, mappend) import Data.String (IsString) import Data.Text (Text) -import Data.Time (UTCTime, parseTime) +import Data.Time (UTCTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) -import Data.Typeable (Typeable, Typeable1) +import Data.Typeable (Typeable) #if MIN_VERSION_time(1,5,0) -import Data.Time (defaultTimeLocale) +import Data.Time (defaultTimeLocale, parseTimeM) #else import System.Locale (defaultTimeLocale) +import Data.Time (parseTime) #endif - import qualified Data.Aeson as A import qualified Data.Aeson.Types as A import qualified Data.Text as T @@ -43,15 +44,13 @@ import qualified Data.Text.Lazy.Builder as TLB import qualified Data.Text.Lazy.Builder.Int as TLBI - -- | Credentials that you get for your app when you register on -- Facebook. -data Credentials = - Credentials { appName :: Text -- ^ Your application name (e.g. for Open Graph calls). - , appId :: Text -- ^ Your application ID. - , appSecret :: Text -- ^ Your application secret key. - } - deriving (Eq, Ord, Show, Read, Typeable) +data Credentials = Credentials + { appName :: Text -- ^ Your application name (e.g. for Open Graph calls). + , appId :: Text -- ^ Your application ID. + , appSecret :: Text -- ^ Your application secret key. + } deriving (Eq, Ord, Show, Read, Typeable) -- | 'appId' for 'ByteString'. appIdBS :: Credentials -> ByteString @@ -61,7 +60,6 @@ appSecretBS :: Credentials -> ByteString appSecretBS = TE.encodeUtf8 . appSecret - -- | An access token. While you can make some API calls without -- an access token, many require an access token and some will -- give you more information with an appropriate access token. @@ -80,8 +78,9 @@ -- phantom type on 'AccessToken', which can be 'UserKind' or -- 'AppKind'. data AccessToken kind where - UserAccessToken :: UserId -> AccessTokenData -> UTCTime -> AccessToken UserKind - AppAccessToken :: AccessTokenData -> AccessToken AppKind + UserAccessToken :: + UserId -> AccessTokenData -> UTCTime -> AccessToken UserKind + AppAccessToken :: AccessTokenData -> AccessToken AppKind -- | Type synonym for @'AccessToken' 'UserKind'@. type UserAccessToken = AccessToken UserKind @@ -89,46 +88,47 @@ -- | Type synonym for @'AccessToken' 'AppKind'@. type AppAccessToken = AccessToken AppKind +deriving instance Eq (AccessToken kind) -deriving instance Eq (AccessToken kind) -deriving instance Ord (AccessToken kind) +deriving instance Ord (AccessToken kind) + deriving instance Show (AccessToken kind) -deriving instance Typeable1 AccessToken +deriving instance Typeable AccessToken -- | The access token data that is passed to Facebook's API -- calls. type AccessTokenData = Text -- | The identification code of an object. -newtype Id = Id { idCode :: Text } - deriving (Eq, Ord, Show, Read, Typeable, IsString) +newtype Id = Id + { idCode :: Text + } deriving (Eq, Ord, Show, Read, Typeable, IsString) instance A.FromJSON Id where - parseJSON (A.Object v) = v A..: "id" - parseJSON (A.String s) = pure $ Id s - parseJSON (A.Number d) = pure $ Id $ from $ floor d - where from i = TL.toStrict $ TLB.toLazyText $ TLBI.decimal (i :: Int64) - parseJSON o = fail $ "Can't parse Facebook.Id from " ++ show o + parseJSON (A.Object v) = v A..: "id" + parseJSON (A.String s) = pure $ Id s + parseJSON (A.Number d) = pure $ Id $ from $ floor d + where + from i = TL.toStrict $ TLB.toLazyText $ TLBI.decimal (i :: Int64) + parseJSON o = fail $ "Can't parse Facebook.Id from " ++ show o instance A.ToJSON Id where - toJSON (Id t) = A.String t - + toJSON (Id t) = A.String t -- | A Facebook user ID such as @1008905713901@. type UserId = Id - -- | Get the access token data. accessTokenData :: AccessToken anyKind -> AccessTokenData accessTokenData (UserAccessToken _ d _) = d -accessTokenData (AppAccessToken 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 anyKind -> Maybe UTCTime accessTokenExpires (UserAccessToken _ _ expt) = Just expt -accessTokenExpires (AppAccessToken _) = Nothing +accessTokenExpires (AppAccessToken _) = Nothing -- | Get the user ID of an user access token. accessTokenUserId :: UserAccessToken -> UserId @@ -136,58 +136,49 @@ -- | Phantom type used mark an 'AccessToken' as an user access -- token. -data UserKind deriving (Typeable) +data UserKind + deriving (Typeable) -- | Phantom type used mark an 'AccessToken' as an app access -- token. -data AppKind deriving (Typeable) - +data AppKind + deriving (Typeable) -- | An argument given to an API call. type Argument = (ByteString, ByteString) - -- | Synonym for 'mappend'. -(<>) :: Monoid a => a -> a -> a +(<>) + :: Monoid a + => a -> a -> a (<>) = mappend - ---------------------------------------------------------------------- - - -- | /Since 0.14.9./ Not a Facebook JSON format, but a custom @fb@ -- format for convenience if you need to serialize access tokens. instance A.ToJSON (AccessToken kind) where toJSON (UserAccessToken uid data_ expires) = A.object - [ "kind" A..= ("user" :: Text) - , "id" A..= uid - , "token" A..= data_ - , "expires" A..= expires ] + [ "kind" A..= ("user" :: Text) + , "id" A..= uid + , "token" A..= data_ + , "expires" A..= expires + ] toJSON (AppAccessToken data_) = - A.object - [ "kind" A..= ("app" :: Text) - , "token" A..= data_ ] - + A.object ["kind" A..= ("app" :: Text), "token" A..= data_] -- | (Internal) Since the user of 'parseJSON' is going to choose -- via its @kind@ whether a 'UserAccessToken' or an -- 'AppAccessToken' is wanted, we need this type class to -- implement 'FromJSON'. -class ParseAccessToken kind where +class ParseAccessToken kind where parseTokenJSON :: A.Object -> A.Parser (AccessToken kind) instance ParseAccessToken UserKind where - parseTokenJSON v = - checkKind v "user" $ - UserAccessToken <$> v A..: "id" - <*> v A..: "token" - <*> v A..: "expires" + parseTokenJSON v = checkKind v "user" $ UserAccessToken <$> v A..: "id" <*> v A..: "token" <*> v A..: "expires" instance ParseAccessToken AppKind where - parseTokenJSON v = - checkKind v "app" $ - AppAccessToken <$> v A..: "token" + parseTokenJSON v = checkKind v "app" $ AppAccessToken <$> v A..: "token" -- | (Internal) Used to implement 'parseTokenJSON'. checkKind :: A.Object -> Text -> A.Parser a -> A.Parser a @@ -195,20 +186,19 @@ kind' <- v A..: "kind" if kind == kind' then ok - else fail $ "Expected access token kind " <> show kind <> - " but found " <> show kind' <> "." + else fail $ + "Expected access token kind " <> show kind <> " but found " <> show kind' <> + "." -- | /Since 0.14.9./ Parses the format that 'ToJSON' produces. -- Note that you need to statically decide whether you want to -- parse a user access token or an app access token. -instance ParseAccessToken kind => A.FromJSON (AccessToken kind) where +instance ParseAccessToken kind => + A.FromJSON (AccessToken kind) where parseJSON (A.Object v) = parseTokenJSON v - parseJSON _ = mzero - + parseJSON _ = mzero ---------------------------------------------------------------------- - - -- | @newtype@ for 'UTCTime' that follows Facebook's -- conventions of JSON parsing. -- @@ -217,14 +207,21 @@ -- -- * As a number, 'FbUTCTime' accepts a number of seconds since -- the Unix epoch. -newtype FbUTCTime = FbUTCTime { unFbUTCTime :: UTCTime } - deriving (Eq, Ord, Show, Read, Typeable) +newtype FbUTCTime = FbUTCTime + { unFbUTCTime :: UTCTime + } deriving (Eq, Ord, Show, Read, Typeable) instance A.FromJSON FbUTCTime where parseJSON (A.String t) = +#if MIN_VERSION_time(1,5,0) + case parseTimeM True defaultTimeLocale "%FT%T%z" (T.unpack t) of +#else case parseTime defaultTimeLocale "%FT%T%z" (T.unpack t) of +#endif Just d -> return (FbUTCTime d) - _ -> fail $ "could not parse FbUTCTime string " ++ show t + _ -> fail $ "could not parse FbUTCTime string " ++ show t parseJSON (A.Number n) = return $ FbUTCTime $ posixSecondsToUTCTime $ fromInteger $ floor n - parseJSON _ = fail "could not parse FbUTCTime from something which is not a string or number" + parseJSON _ = + fail + "could not parse FbUTCTime from something which is not a string or number" diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,10 +1,11 @@ -{-# LANGUAGE OverloadedStrings - , Rank2Types - , ScopedTypeVariables - , GADTs - , FlexibleContexts #-} -module Main (main, getCredentials) where +{-# LANGUAGE OverloadedStrings, Rank2Types, ScopedTypeVariables, + GADTs, FlexibleContexts #-} +module Main + ( main + , getCredentials + ) where + import Control.Applicative import Control.Monad (mzero) import Control.Monad.IO.Class (MonadIO(liftIO)) @@ -19,8 +20,8 @@ import System.Environment (getEnv) import System.Exit (exitFailure) import System.IO.Error (isDoesNotExistError) - - +import Data.List ((\\)) +import Data.Monoid ((<>)) import qualified Control.Exception.Lifted as E import qualified Control.Monad.Trans.Resource as R import qualified Data.Aeson as A @@ -39,24 +40,24 @@ import qualified Network.HTTP.Conduit as H import qualified Test.QuickCheck as QC - import Test.HUnit ((@?=)) import Test.Hspec import Test.Hspec.HUnit () import Test.Hspec.QuickCheck - -- | Grab the Facebook credentials from the environment. getCredentials :: IO FB.Credentials getCredentials = tryToGet `E.catch` showHelp - where - tryToGet = do - [appName, appId, appSecret] <- mapM getEnv ["APP_NAME", "APP_ID", "APP_SECRET"] - return $ FB.Credentials (T.pack appName) (T.pack appId) (T.pack appSecret) - - showHelp exc | not (isDoesNotExistError exc) = E.throw exc - showHelp _ = do - putStrLn $ unlines + where + tryToGet = do + [appName, appId, appSecret] <- + mapM getEnv ["APP_NAME", "APP_ID", "APP_SECRET"] + return $ FB.Credentials (T.pack appName) (T.pack appId) (T.pack appSecret) + showHelp exc + | not (isDoesNotExistError exc) = E.throw exc + showHelp _ = do + putStrLn $ + unlines [ "In order to run the tests from the 'fb' package, you need" , "developer access to a Facebook app. The tests are designed" , "so that your app isn't going to be hurt, but we may not" @@ -74,420 +75,455 @@ , "Of course, these values above aren't valid and you need to" , "replace them with your own." , "" - , "(Exiting now with a failure code.)"] - exitFailure - + , "(Exiting now with a failure code.)" + ] + exitFailure invalidCredentials :: FB.Credentials invalidCredentials = FB.Credentials "this" "isn't" "valid" invalidUserAccessToken :: FB.UserAccessToken invalidUserAccessToken = FB.UserAccessToken (FB.Id "invalid") "user" farInTheFuture - where - Just farInTheFuture = parseTime (error "farInTheFuture") "%Y" "3000" - -- It's actually important to use 'farInTheFuture' since we - -- don't want any tests rejecting this invalid user access - -- token before even giving it to Facebook. + where + Just farInTheFuture = parseTime (error "farInTheFuture") "%Y" "3000" +-- It's actually important to use 'farInTheFuture' since we +-- don't want any tests rejecting this invalid user access +-- token before even giving it to Facebook. invalidAppAccessToken :: FB.AppAccessToken invalidAppAccessToken = FB.AppAccessToken "invalid" - main :: IO () -main = H.withManager $ \manager -> liftIO $ do - creds <- getCredentials - hspec $ do - -- Run the tests twice, once in Facebook's production tier... - facebookTests "Production tier: " - creds - manager - (R.runResourceT . FB.runFacebookT creds manager) - (R.runResourceT . FB.runNoAuthFacebookT manager) - -- ...and the other in Facebook's beta tier. - facebookTests "Beta tier: " - creds - manager - (R.runResourceT . FB.beta_runFacebookT creds manager) - (R.runResourceT . FB.beta_runNoAuthFacebookT manager) - - -- Tests that don't depend on which tier is chosen. - libraryTests manager +main = + H.withManager $ + \manager -> + liftIO $ + do creds <- getCredentials + hspec $ + -- Run the tests twice, once in Facebook's production tier... + do facebookTests + "Production tier: " + creds + manager + (R.runResourceT . FB.runFacebookT creds manager) + (R.runResourceT . FB.runNoAuthFacebookT manager) + -- ...and the other in Facebook's beta tier. + facebookTests + "Beta tier: " + creds + manager + (R.runResourceT . FB.beta_runFacebookT creds manager) + (R.runResourceT . FB.beta_runNoAuthFacebookT manager) + -- Tests that don't depend on which tier is chosen. + libraryTests manager -facebookTests :: String - -> FB.Credentials - -> H.Manager - -> (forall a. FB.FacebookT FB.Auth (R.ResourceT IO) a -> IO a) - -> (forall a. FB.FacebookT FB.NoAuth (R.ResourceT IO) a -> IO a) - -> Spec +facebookTests + :: String + -> FB.Credentials + -> H.Manager + -> (forall a. FB.FacebookT FB.Auth (R.ResourceT IO) a -> IO a) + -> (forall a. FB.FacebookT FB.NoAuth (R.ResourceT IO) a -> IO a) + -> Spec facebookTests pretitle creds manager runAuth runNoAuth = do let describe' = describe . (pretitle ++) - - describe' "getAppAccessToken" $ do - it "works and returns a valid app access token" $ - runAuth $ do - token <- FB.getAppAccessToken - FB.isValid token #?= True - it "throws a FacebookException on invalid credentials" $ - R.runResourceT $ - FB.runFacebookT invalidCredentials manager $ do - ret <- E.try $ FB.getAppAccessToken - case ret of - Right token -> fail $ show token - Left (_ :: FB.FacebookException) -> lift $ lift (return () :: IO ()) - - describe' "isValid" $ do - it "returns False on a clearly invalid user access token" $ - runNoAuth $ FB.isValid invalidUserAccessToken #?= False - it "returns False on a clearly invalid app access token" $ - runNoAuth $ FB.isValid invalidAppAccessToken #?= False - - describe' "debugToken" $ do - it "works on a test user access token" $ do - runAuth $ - withTestUser D.def $ \testUser -> do - Just testUserAccessTokenData <- return (FB.tuAccessToken testUser) - appToken <- FB.getAppAccessToken - ret <- FB.debugToken appToken testUserAccessTokenData - now <- liftIO TI.getCurrentTime - FB.dtAppId ret &?= Just (FB.appId creds) - FB.dtAppName ret &?= Just (FB.appName creds) - case FB.dtExpiresAt ret of - Nothing -> fail "dtExpiresAt is Nothing" - Just t -> compare t now &?= GT - FB.dtIsValid ret &?= Just True - case FB.dtIssuedAt ret of - Nothing -> return () -- ok since it's a test user - Just t -> compare t now &?= LT - isJust (FB.dtScopes ret) &?= True - FB.dtUserId ret &?= Just (FB.tuId testUser) - case FB.dtAccessToken ret of - Nothing -> fail "dtAccessToken is Nothing" - Just t -> do - let f :: FB.UserAccessToken -> FB.FacebookT FB.Auth (R.ResourceT IO) () - f (FB.UserAccessToken uid dt exps) = do - uid &?= FB.tuId testUser - dt &?= testUserAccessTokenData - Just exps &?= FB.dtExpiresAt ret - f t - - describe' "getObject" $ do - it "is able to fetch Facebook's own page" $ - runNoAuth $ do - A.Object obj <- FB.getObject "/19292868552" [] Nothing - let Just r = flip A.parseMaybe () $ const $ - (,,) <$> obj A..:? "id" - <*> obj A..:? "website" - <*> obj A..:? "name" - just x = Just (x :: Text) - r &?= ( just "19292868552" - , just "http://developers.facebook.com" - , just "Facebook Developers" ) - - describe' "getUser" $ do - it "works for Zuckerberg" $ do - runNoAuth $ do - user <- FB.getUser (FB.Id "zuck") [] Nothing - FB.userId user &?= FB.Id "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 - - describe' "getPage" $ do - it "works for FB Developers" $ do - runNoAuth $ do - page <- FB.getPage (FB.Id "19292868552") [] Nothing - FB.pageId page &?= (FB.Id "19292868552") - FB.pageName page &?= Just "Facebook Developers" - FB.pageCategory page &?= Just "Product/service" - FB.pageIsPublished page &?= Just True - FB.pageCanPost page &?= Nothing - FB.pagePhone page &?= Nothing - FB.pageCheckins page &?= Nothing - FB.pageWebsite page &?= Just "http://developers.facebook.com" - - describe' "fqlQuery" $ do - it "is able to query Facebook's page name from its page id" $ - runNoAuth $ do - r <- FB.fqlQuery "SELECT name FROM page WHERE page_id = 20531316728" Nothing - FB.pagerData r &?= [PageName "Facebook"] - - describe' "listSubscriptions" $ do - it "returns something" $ do - runAuth $ do - token <- FB.getAppAccessToken - val <- FB.listSubscriptions token - length val `seq` return () - - describe' "fetchNextPage" $ do - let fetchNextPageWorks :: FB.Pager A.Value -> FB.FacebookT anyAuth (R.ResourceT IO) () - fetchNextPageWorks pager - | isNothing (FB.pagerNext pager) = return () - | otherwise = FB.fetchNextPage pager >>= maybe not_ (\_ -> return ()) - where not_ = fail "Pager had a next page but fetchNextPage didn't work." - it "seems to work on a public list of comments" $ do - runNoAuth $ do - fetchNextPageWorks =<< FB.getObject "/135529993185189_397300340341485/comments" [] Nothing - it "seems to work on a private list of app insights" $ do - runAuth $ do - token <- FB.getAppAccessToken - fetchNextPageWorks =<< FB.getObject "/app/insights" [] (Just token) - - describe' "fetchNextPage/fetchPreviousPage" $ do - let backAndForthWorks :: FB.Pager A.Value -> FB.FacebookT anyAuth (R.ResourceT IO) () - backAndForthWorks pager = do - Just pager2 <- FB.fetchNextPage pager - Just pager3 <- FB.fetchPreviousPage pager2 - pager3 &?= pager - it "seems to work on a public list of comments" $ do - runNoAuth $ do - backAndForthWorks =<< FB.getObject "/135529993185189_397300340341485/comments" [] Nothing - it "seems to work on a private list of app insights" $ do - runAuth $ do - token <- FB.getAppAccessToken - backAndForthWorks =<< FB.getObject "/app/insights" [] (Just token) - - describe' "fetchAllNextPages" $ do - let hasAtLeast :: C.Source IO A.Value -> Int -> IO () - src `hasAtLeast` n = src C.$$ go n - where go 0 = return () - go m = C.await >>= maybe not_ (\_ -> go (m-1)) - not_ = fail $ "Source does not have at least " ++ show n ++ " elements." - it "seems to work on a public list of comments" $ do - runNoAuth $ do - pager <- FB.getObject "/135529993185189_397300340341485/comments" [] Nothing - src <- FB.fetchAllNextPages pager - liftIO $ src `hasAtLeast` 200 -- items - it "seems to work on a private list of app insights" $ do - runAuth $ do - token <- FB.getAppAccessToken - pager <- FB.getObject "/app/insights" [] (Just token) - src <- FB.fetchAllNextPages pager - let firstPageElms = length (FB.pagerData pager) - hasNextPage = isJust (FB.pagerNext pager) - if hasNextPage - then liftIO $ src `hasAtLeast` (firstPageElms * 3) -- items - else fail "This isn't an insightful app =(." - - describe' "createTestUser/removeTestUser/getTestUser" $ do - it "creates and removes a new test user" $ do - runAuth $ do - token <- FB.getAppAccessToken - -- New test user information - let installed = FB.CreateTestUserInstalled - [ "read_stream" - , "read_friendlists" - , "publish_stream" ] - userInfo = FB.CreateTestUser + describe' "getAppAccessToken" $ + do it "works and returns a valid app access token" $ + runAuth $ + do token <- FB.getAppAccessToken + FB.isValid token #?= True + it "throws a FacebookException on invalid credentials" $ + R.runResourceT $ + FB.runFacebookT invalidCredentials manager $ + do ret <- E.try $ FB.getAppAccessToken + case ret of + Right token -> fail $ show token + Left (_ :: FB.FacebookException) -> + lift $ lift (return () :: IO ()) + describe' "isValid" $ + do it "returns False on a clearly invalid user access token" $ + runNoAuth $ FB.isValid invalidUserAccessToken #?= False + it "returns False on a clearly invalid app access token" $ + runNoAuth $ FB.isValid invalidAppAccessToken #?= False + describe' "debugToken" $ + do it "works on a test user access token" $ + do runAuth $ + withTestUser D.def $ + \testUser -> do + Just testUserAccessTokenData <- + return (FB.tuAccessToken testUser) + appToken <- FB.getAppAccessToken + ret <- FB.debugToken appToken testUserAccessTokenData + now <- liftIO TI.getCurrentTime + FB.dtAppId ret &?= Just (FB.appId creds) + FB.dtAppName ret &?= Just (FB.appName creds) + case FB.dtExpiresAt ret of + Nothing -> fail "dtExpiresAt is Nothing" + Just t -> compare t now &?= GT + FB.dtIsValid ret &?= Just True + case FB.dtIssuedAt ret of + Nothing -> return () -- ok since it's a test user + Just t -> compare t now &?= LT + isJust (FB.dtScopes ret) &?= True + FB.dtUserId ret &?= Just (FB.tuId testUser) + case FB.dtAccessToken ret of + Nothing -> fail "dtAccessToken is Nothing" + Just t -> do + let f + :: FB.UserAccessToken + -> FB.FacebookT FB.Auth (R.ResourceT IO) () + f (FB.UserAccessToken uid dt exps) = do + uid &?= FB.tuId testUser + dt &?= testUserAccessTokenData + Just exps &?= FB.dtExpiresAt ret + f t + describe' "getObject" $ + do it "is able to fetch Facebook's own page" $ + do val <- + runAuth $ -- Needs permission now: https://developers.facebook.com/docs/graph-api/reference/page#Reading + do token <- FB.getAppAccessToken + A.Object obj <- FB.getObject "/19292868552" [] (Just token) + let Just r = + flip A.parseMaybe () $ + const $ (,) <$> obj A..:? "id" <*> obj A..:? "name" + return r + val `shouldBe` + ( Just "19292868552" :: Maybe Text + , Just "Facebook for Developers" :: Maybe Text) + describe' "getPage" $ + do it "works for FB Developers" $ + do runAuth $ + do token <- FB.getAppAccessToken + page <- FB.getPage_ (FB.Id "19292868552") [] (Just token) + FB.pageId page &?= (FB.Id "19292868552") + FB.pageName page &?= Just "Facebook for Developers" + FB.pageCategory page &?= Nothing + FB.pageIsPublished page &?= Nothing + FB.pageCanPost page &?= Nothing + FB.pagePhone page &?= Nothing + FB.pageCheckins page &?= Nothing + FB.pageWebsite page &?= Nothing + describe' "listSubscriptions" $ + do it "returns something" $ + do runAuth $ + do token <- FB.getAppAccessToken + val <- FB.listSubscriptions token + length val `seq` return () + describe' "fetchNextPage" $ + do let fetchNextPageWorks :: FB.Pager A.Value + -> FB.FacebookT anyAuth (R.ResourceT IO) () + fetchNextPageWorks pager + | isNothing (FB.pagerNext pager) = return () + | otherwise = + FB.fetchNextPage pager >>= maybe not_ (\_ -> return ()) + where + not_ = + fail "Pager had a next page but fetchNextPage didn't work." + it "seems to work on a public list of comments" $ + do runAuth $ + -- Postid: https://www.facebook.com/nytimes/posts/10150628170209999 + -- Page id found using this technique: https://www.facebook.com/help/community/question/?id=529591157094317 + do token <- FB.getAppAccessToken + fetchNextPageWorks =<< + FB.getObject + "/5281959998_10150628170209999/comments" + [] + (Just token) + it "seems to work on a private list of app insights" $ + do runAuth $ + do token <- FB.getAppAccessToken + fetchNextPageWorks =<< + FB.getObject + ("/" <> FB.appId creds <> "/app_insights/api_calls") + [] + (Just token) + describe' "fetchNextPage/fetchPreviousPage" $ + do let backAndForthWorks :: FB.Pager A.Value + -> FB.FacebookT anyAuth (R.ResourceT IO) () + backAndForthWorks pager = do + pager2 <- FB.fetchNextPage pager + case pager2 of + Nothing -> True &?= True + Just pager2' -> do + Just pager3 <- FB.fetchPreviousPage pager2' + pager3 &?= pager + it "seems to work on a public list of comments" $ + do runAuth $ + do token <- FB.getAppAccessToken + backAndForthWorks =<< + FB.getObject + "/5281959998_10150628170209999/comments" + [] + (Just token) + it "seems to work on a private list of app insights" $ + do runAuth $ + do token <- FB.getAppAccessToken + backAndForthWorks =<< + FB.getObject + ("/" <> FB.appId creds <> "/app_insights/api_calls") + [] + (Just token) + describe' "fetchAllNextPages" $ + do let hasAtLeast :: C.Source IO A.Value -> Int -> IO () + src `hasAtLeast` n = src C.$$ go n + where + go 0 = return () + go m = C.await >>= maybe not_ (\_ -> go (m - 1)) + not_ = + fail $ + "Source does not have at least " ++ show n ++ " elements." + it "seems to work on a public list of comments" $ + do runAuth $ + do token <- FB.getAppAccessToken + pager <- + FB.getObject + "/63441126719_10154249531391720/comments" + [] + (Just token) + src <- FB.fetchAllNextPages pager + liftIO $ src `hasAtLeast` 200 -- items + it "seems to work on a private list of app insights" $ + do runAuth $ + do token <- FB.getAppAccessToken + pager <- + FB.getObject + ("/" <> FB.appId creds <> "/app_insights/api_calls") + [] + (Just token) + src <- FB.fetchAllNextPages pager + let firstPageElms = length (FB.pagerData pager) + hasNextPage = isJust (FB.pagerNext pager) + if hasNextPage + then liftIO $ src `hasAtLeast` (firstPageElms * 3) -- items + else return () -- fail "This isn't an insightful app =(." + describe' "createTestUser/removeTestUser/getTestUser" $ + do it "creates and removes a new test user" $ + do runAuth $ + do token <- FB.getAppAccessToken + -- New test user information + let installed = + FB.CreateTestUserInstalled + ["read_stream", "read_friendlists", "publish_stream"] + userInfo = + FB.CreateTestUser { FB.ctuInstalled = installed - , FB.ctuName = Just "Gabriel" - , FB.ctuLocale = Just "en_US" } - -- Create the test user - newTestUser <- FB.createTestUser userInfo token - let newTestUserToken = (M.fromJust $ FB.incompleteTestUserAccessToken newTestUser) - -- Get the created user - createdUser <- FB.getUser (FB.tuId newTestUser) [] (Just newTestUserToken) - -- Remove the test user - True <- FB.removeTestUser newTestUser token - -- Check user attributes - FB.userId createdUser &?= FB.tuId newTestUser - FB.userName createdUser &?= Just "Gabriel" - FB.userLocale createdUser &?= Just "en_US" - -- Check if the token is valid - FB.isValid newTestUserToken #?= False - - describe' "makeFriendConn" $ do - it "creates two new test users, makes them friends and deletes them" $ do - runAuth $ - withTestUser D.def $ \testUser1 -> - withTestUser D.def $ \testUser2 -> do - let Just tokenUser1 = FB.incompleteTestUserAccessToken testUser1 - let Just tokenUser2 = FB.incompleteTestUserAccessToken testUser2 - -- Check if the new test users' tokens are valid. - FB.isValid tokenUser1 #?= True - FB.isValid tokenUser2 #?= True - -- Create a friend connection between the new test users. - FB.makeFriendConn testUser1 testUser2 - -- Verify that one is a friend of the other. - user1 <- FB.getUser (FB.tuId testUser1) [] (Just tokenUser1) - user2 <- FB.getUser (FB.tuId testUser2) [] (Just tokenUser2) - friends1 <- FB.getUserFriends (FB.tuId testUser1) [] tokenUser1 - friends2 <- FB.getUserFriends (FB.tuId testUser2) [] tokenUser2 - FB.pagerData friends1 &?= [FB.Friend (FB.tuId testUser2) (M.fromJust (FB.userName user2))] - FB.pagerData friends2 &?= [FB.Friend (FB.tuId testUser1) (M.fromJust (FB.userName user1))] - - - describe' "getTestUsers" $ do - it "gets a list of test users" $ do - runAuth $ do - token <- FB.getAppAccessToken - pager <- FB.getTestUsers token - src <- FB.fetchAllNextPages pager - oldList <- liftIO $ R.runResourceT $ src C.$$ CL.consume - withTestUser D.def $ \testUser -> do - let (%?=) = (&?=) `on` fmap FB.tuId - (//) = S.difference `on` S.fromList - newList <- FB.pagerData <$> FB.getTestUsers token - S.toList (newList // oldList) %?= [testUser] + , FB.ctuName = Just "Gabriel" + , FB.ctuLocale = Just "en_US" + } + -- Create the test user + newTestUser <- FB.createTestUser userInfo token + let newTestUserToken = + (M.fromJust $ FB.incompleteTestUserAccessToken newTestUser) + -- Get the created user + createdUser <- + FB.getUser (FB.tuId newTestUser) [] (Just newTestUserToken) + -- Remove the test user + removed <- FB.removeTestUser newTestUser token + -- Check user attributes + FB.userId createdUser &?= FB.tuId newTestUser + FB.userName createdUser &?= Just "Gabriel" + -- FB.userLocale createdUser &?= Just "en_US" -- fix this test later + -- Check if the token is valid + FB.isValid newTestUserToken #?= False + removed &?= True + describe' "makeFriendConn" $ + do it "creates two new test users, makes them friends and deletes them" $ + do runAuth $ + withTestUser D.def $ + \testUser1 -> + withTestUser D.def $ + \testUser2 -> do + let Just tokenUser1 = FB.incompleteTestUserAccessToken testUser1 + let Just tokenUser2 = FB.incompleteTestUserAccessToken testUser2 + -- Check if the new test users' tokens are valid. + FB.isValid tokenUser1 #?= True + FB.isValid tokenUser2 #?= True + -- Create a friend connection between the new test users. + FB.makeFriendConn testUser1 testUser2 + -- Verify that one is a friend of the other. + user1 <- FB.getUser (FB.tuId testUser1) [] (Just tokenUser1) + user2 <- FB.getUser (FB.tuId testUser2) [] (Just tokenUser2) + friends1 <- FB.getUserFriends (FB.tuId testUser1) [] tokenUser1 + friends2 <- FB.getUserFriends (FB.tuId testUser2) [] tokenUser2 + FB.pagerData friends1 &?= + [ FB.Friend + (FB.tuId testUser2) + (M.fromJust (FB.userName user2)) + ] + FB.pagerData friends2 &?= + [ FB.Friend + (FB.tuId testUser1) + (M.fromJust (FB.userName user1)) + ] + describe' "getTestUsers" $ + do it "gets a list of test users" $ + do runAuth $ + do token <- FB.getAppAccessToken + pager <- FB.getTestUsers token + src <- FB.fetchAllNextPages pager + oldList <- liftIO $ R.runResourceT $ src C.$$ CL.consume + withTestUser D.def $ + \testUser -> do + newList <- FB.pagerData <$> FB.getTestUsers token + let newList' = map FB.tuId newList + oldList' = map FB.tuId oldList + ((FB.tuId testUser) `elem` (newList' \\ oldList')) &?= True +newtype PageName = + PageName Text + deriving (Eq, Show) -newtype PageName = PageName Text deriving (Eq, Show) instance A.FromJSON PageName where parseJSON (A.Object v) = PageName <$> (v A..: "name") parseJSON _ = mzero - libraryTests :: H.Manager -> Spec libraryTests manager = do - describe "SimpleType" $ do - it "works for Bool" $ (map FB.encodeFbParam [True, False]) @?= ["1", "0"] - - let day = TI.fromGregorian 2012 12 21 - time = TI.TimeOfDay 11 37 22 - diffTime = TI.secondsToDiffTime (11*3600 + 37*60) - utcTime = TI.UTCTime day diffTime - localTime = TI.LocalTime day time - zonedTime = TI.ZonedTime localTime (TI.minutesToTimeZone 30) - it "works for Day" $ FB.encodeFbParam day @?= "2012-12-21" - it "works for UTCTime" $ FB.encodeFbParam utcTime @?= "20121221T1137Z" - it "works for ZonedTime" $ FB.encodeFbParam zonedTime @?= "20121221T1107Z" - - let propShowRead :: (Show a, Read a, Eq a, FB.SimpleType a) => a -> Bool - propShowRead x = read (B.unpack $ FB.encodeFbParam x) == x - prop "works for Float" (propShowRead :: Float -> Bool) - prop "works for Double" (propShowRead :: Double -> Bool) - prop "works for Int" (propShowRead :: Int -> Bool) - prop "works for Int8" (propShowRead :: Int8 -> Bool) - prop "works for Int16" (propShowRead :: Int16 -> Bool) - prop "works for Int32" (propShowRead :: Int32 -> Bool) - prop "works for Int64" (propShowRead :: Int64 -> Bool) - prop "works for Word" (propShowRead :: Word -> Bool) - prop "works for Word8" (propShowRead :: Word8 -> Bool) - prop "works for Word16" (propShowRead :: Word16 -> Bool) - prop "works for Word32" (propShowRead :: Word32 -> Bool) - prop "works for Word64" (propShowRead :: Word64 -> Bool) - - let propShowReadL :: (Show a, Read a, Eq a, FB.SimpleType a) => [a] -> Bool - propShowReadL x = read ('[' : B.unpack (FB.encodeFbParam x) ++ "]") == x - prop "works for [Float]" (propShowReadL :: [Float] -> Bool) - prop "works for [Double]" (propShowReadL :: [Double] -> Bool) - prop "works for [Int]" (propShowReadL :: [Int] -> Bool) - prop "works for [Int8]" (propShowReadL :: [Int8] -> Bool) - prop "works for [Int16]" (propShowReadL :: [Int16] -> Bool) - prop "works for [Int32]" (propShowReadL :: [Int32] -> Bool) - prop "works for [Int64]" (propShowReadL :: [Int64] -> Bool) - prop "works for [Word]" (propShowReadL :: [Word] -> Bool) - prop "works for [Word8]" (propShowReadL :: [Word8] -> Bool) - prop "works for [Word16]" (propShowReadL :: [Word16] -> Bool) - prop "works for [Word32]" (propShowReadL :: [Word32] -> Bool) - prop "works for [Word64]" (propShowReadL :: [Word64] -> Bool) - - prop "works for Text" (\t -> FB.encodeFbParam t == TE.encodeUtf8 t) - - prop "works for Id" $ \i -> - let toId :: Int -> FB.Id - toId = FB.Id . T.pack . show - j = abs i - in FB.encodeFbParam (toId j) == FB.encodeFbParam j - - describe "parseSignedRequest" $ do - let exampleSig, exampleData :: B.ByteString - exampleSig = "vlXgu64BQGFSQrY0ZcJBZASMvYvTHu9GQ0YM9rjPSso" - exampleData = "eyJhbGdvcml0aG0iOiJITUFDLVNIQTI1NiIsIjAiOiJwYXlsb2FkIn0" - exampleCreds = FB.Credentials "name" "id" "secret" - runExampleAuth :: FB.FacebookT FB.Auth (R.ResourceT IO) a -> IO a - runExampleAuth = R.runResourceT . FB.runFacebookT exampleCreds manager - it "works for Facebook example" $ do - runExampleAuth $ do - ret <- FB.parseSignedRequest (B.concat [exampleSig, ".", exampleData]) - ret &?= Just (A.object [ "algorithm" A..= ("HMAC-SHA256" :: Text) - , "0" A..= ("payload" :: Text)]) - it "fails to parse the Facebook example when signature is corrupted" $ do - let corruptedSig = B.cons 'a' (B.tail exampleSig) - runExampleAuth $ do - ret <- FB.parseSignedRequest (B.concat [corruptedSig, ".", exampleData]) - ret &?= (Nothing :: Maybe A.Value) - - describe "FQLTime" $ do - it "seems to work" $ do - let input = "[1348678357]" - output = FB.FQLTime (read "2012-09-26 16:52:37 UTC") - A.decode input @?= Just [output] - - describe "FbUTCTime" $ do - let output = FB.FbUTCTime (read "2012-09-26 16:52:37 UTC") - it "seems to work (string)" $ do - let input = "[\"2012-09-26T16:52:37+0000\"]" - A.decode input @?= Just [output] - it "seems to work (unix epoch)" $ do - let input = "[1348678357]" - A.decode input @?= Just [output] - - describe "FQLList" $ do - let j :: [Int] -> Maybe (FB.FQLList Int) - j = Just . FB.FQLList - it "parses []" $ do - A.decode "[]" @?= j [] - it "parses {}" $ do - A.decode "{}" @?= j [] - it "parses [1234]" $ do - A.decode "[1234]" @?= j [1234] - it "parses {\"1234\": 1234}" $ do - A.decode "{\"1234\": 1234}" @?= j [1234] - - describe "FQLObject" $ do - let j :: [(Text, Int)] -> Maybe (FB.FQLObject (Map.Map Text Int)) - j = Just . FB.FQLObject . Map.fromList - it "parses []" $ do - A.decode "[]" @?= j [] - it "parses {}" $ do - A.decode "{}" @?= j [] - it "parses {\"abc\": 1234}" $ do - A.decode "{\"abc\": 1234}" @?= j [("abc", 1234)] - it "does not parse [1234]" $ do - A.decode "[1234]" @?= (Nothing `asTypeOf` j []) - - describe "Id" $ do - it "can be parsed from a string" $ do - A.decode "[\"1234\"]" @?= Just [FB.Id "1234"] - it "can be parsed from an integer" $ do - A.decode "[1234]" @?= Just [FB.Id "1234"] - it "can be parsed from an object with a string" $ do - A.decode "{\"id\": \"1234\"}" @?= Just (FB.Id "1234") - it "can be parsed from an object with an integer" $ do - A.decode "{\"id\": 1234}" @?= Just (FB.Id "1234") - - describe "AccessToken" $ do - it "can be round-tripped with ToJSON/FromJSON (UserKind)" $ do - A.eitherDecode (A.encode invalidUserAccessToken) @?= Right invalidUserAccessToken - it "can be round-tripped with ToJSON/FromJSON (AppKind)" $ do - A.eitherDecode (A.encode invalidAppAccessToken) @?= Right invalidAppAccessToken - + describe "SimpleType" $ + do it "works for Bool" $ (map FB.encodeFbParam [True, False]) @?= ["1", "0"] + let day = TI.fromGregorian 2012 12 21 + time = TI.TimeOfDay 11 37 22 + diffTime = TI.secondsToDiffTime (11 * 3600 + 37 * 60) + utcTime = TI.UTCTime day diffTime + localTime = TI.LocalTime day time + zonedTime = TI.ZonedTime localTime (TI.minutesToTimeZone 30) + it "works for Day" $ FB.encodeFbParam day @?= "2012-12-21" + it "works for UTCTime" $ FB.encodeFbParam utcTime @?= "20121221T1137Z" + it "works for ZonedTime" $ + FB.encodeFbParam zonedTime @?= "20121221T1107Z" + let propShowRead + :: (Show a, Read a, Eq a, FB.SimpleType a) + => a -> Bool + propShowRead x = read (B.unpack $ FB.encodeFbParam x) == x + prop "works for Float" (propShowRead :: Float -> Bool) + prop "works for Double" (propShowRead :: Double -> Bool) + prop "works for Int" (propShowRead :: Int -> Bool) + prop "works for Int8" (propShowRead :: Int8 -> Bool) + prop "works for Int16" (propShowRead :: Int16 -> Bool) + prop "works for Int32" (propShowRead :: Int32 -> Bool) + prop "works for Int64" (propShowRead :: Int64 -> Bool) + prop "works for Word" (propShowRead :: Word -> Bool) + prop "works for Word8" (propShowRead :: Word8 -> Bool) + prop "works for Word16" (propShowRead :: Word16 -> Bool) + prop "works for Word32" (propShowRead :: Word32 -> Bool) + prop "works for Word64" (propShowRead :: Word64 -> Bool) + let propShowReadL + :: (Show a, Read a, Eq a, FB.SimpleType a) + => [a] -> Bool + propShowReadL x = + read ('[' : B.unpack (FB.encodeFbParam x) ++ "]") == x + prop "works for [Float]" (propShowReadL :: [Float] -> Bool) + prop "works for [Double]" (propShowReadL :: [Double] -> Bool) + prop "works for [Int]" (propShowReadL :: [Int] -> Bool) + prop "works for [Int8]" (propShowReadL :: [Int8] -> Bool) + prop "works for [Int16]" (propShowReadL :: [Int16] -> Bool) + prop "works for [Int32]" (propShowReadL :: [Int32] -> Bool) + prop "works for [Int64]" (propShowReadL :: [Int64] -> Bool) + prop "works for [Word]" (propShowReadL :: [Word] -> Bool) + prop "works for [Word8]" (propShowReadL :: [Word8] -> Bool) + prop "works for [Word16]" (propShowReadL :: [Word16] -> Bool) + prop "works for [Word32]" (propShowReadL :: [Word32] -> Bool) + prop "works for [Word64]" (propShowReadL :: [Word64] -> Bool) + prop "works for Text" (\t -> FB.encodeFbParam t == TE.encodeUtf8 t) + prop "works for Id" $ + \i -> + let toId :: Int -> FB.Id + toId = FB.Id . T.pack . show + j = abs i + in FB.encodeFbParam (toId j) == FB.encodeFbParam j + describe "parseSignedRequest" $ + do let exampleSig, exampleData :: B.ByteString + exampleSig = "vlXgu64BQGFSQrY0ZcJBZASMvYvTHu9GQ0YM9rjPSso" + exampleData = + "eyJhbGdvcml0aG0iOiJITUFDLVNIQTI1NiIsIjAiOiJwYXlsb2FkIn0" + exampleCreds = FB.Credentials "name" "id" "secret" + runExampleAuth :: FB.FacebookT FB.Auth (R.ResourceT IO) a -> IO a + runExampleAuth = R.runResourceT . FB.runFacebookT exampleCreds manager + it "works for Facebook example" $ + do runExampleAuth $ + do ret <- + FB.parseSignedRequest + (B.concat [exampleSig, ".", exampleData]) + ret &?= + Just + (A.object + [ "algorithm" A..= ("HMAC-SHA256" :: Text) + , "0" A..= ("payload" :: Text) + ]) + it "fails to parse the Facebook example when signature is corrupted" $ + do let corruptedSig = B.cons 'a' (B.tail exampleSig) + runExampleAuth $ + do ret <- + FB.parseSignedRequest + (B.concat [corruptedSig, ".", exampleData]) + ret &?= (Nothing :: Maybe A.Value) + describe "FQLTime" $ + do it "seems to work" $ + do let input = "[1348678357]" + output = FB.FQLTime (read "2012-09-26 16:52:37 UTC") + A.decode input @?= Just [output] + describe "FbUTCTime" $ + do let output = FB.FbUTCTime (read "2012-09-26 16:52:37 UTC") + it "seems to work (string)" $ + do let input = "[\"2012-09-26T16:52:37+0000\"]" + A.decode input @?= Just [output] + it "seems to work (unix epoch)" $ + do let input = "[1348678357]" + A.decode input @?= Just [output] + describe "FQLList" $ + do let j :: [Int] -> Maybe (FB.FQLList Int) + j = Just . FB.FQLList + it "parses []" $ do A.decode "[]" @?= j [] + it "parses {}" $ do A.decode "{}" @?= j [] + it "parses [1234]" $ do A.decode "[1234]" @?= j [1234] + it "parses {\"1234\": 1234}" $ + do A.decode "{\"1234\": 1234}" @?= j [1234] + describe "FQLObject" $ + do let j :: [(Text, Int)] -> Maybe (FB.FQLObject (Map.Map Text Int)) + j = Just . FB.FQLObject . Map.fromList + it "parses []" $ do A.decode "[]" @?= j [] + it "parses {}" $ do A.decode "{}" @?= j [] + it "parses {\"abc\": 1234}" $ + do A.decode "{\"abc\": 1234}" @?= j [("abc", 1234)] + it "does not parse [1234]" $ + do A.decode "[1234]" @?= (Nothing `asTypeOf` j []) + describe "Id" $ + do it "can be parsed from a string" $ + do A.decode "[\"1234\"]" @?= Just [FB.Id "1234"] + it "can be parsed from an integer" $ + do A.decode "[1234]" @?= Just [FB.Id "1234"] + it "can be parsed from an object with a string" $ + do A.decode "{\"id\": \"1234\"}" @?= Just (FB.Id "1234") + it "can be parsed from an object with an integer" $ + do A.decode "{\"id\": 1234}" @?= Just (FB.Id "1234") + describe "AccessToken" $ + do it "can be round-tripped with ToJSON/FromJSON (UserKind)" $ + do A.eitherDecode (A.encode invalidUserAccessToken) @?= Right invalidUserAccessToken + it "can be round-tripped with ToJSON/FromJSON (AppKind)" $ + do A.eitherDecode (A.encode invalidAppAccessToken) @?= Right invalidAppAccessToken -- Wrappers for HUnit operators using MonadIO - -(&?=) :: (Eq a, Show a, MonadIO m) => a -> a -> m () +(&?=) + :: (Eq a, Show a, MonadIO m) + => a -> a -> m () v &?= e = liftIO (v @?= e) -(#?=) :: (Eq a, Show a, MonadIO m) => m a -> a -> m () +( #?= ) + :: (Eq a, Show a, MonadIO m) + => m a -> a -> m () m #?= e = m >>= (&?= e) - -- | Sad, orphan instance. instance QC.Arbitrary Text where - arbitrary = T.pack <$> QC.arbitrary - shrink = map T.pack . QC.shrink . T.unpack - + arbitrary = T.pack <$> QC.arbitrary + shrink = map T.pack . QC.shrink . T.unpack -- | Perform an action with a new test user. Remove the new test user -- after the action is performed. -withTestUser :: (R.MonadResource m, MonadBaseControl IO m) - => FB.CreateTestUser - -> (FB.TestUser -> FB.FacebookT FB.Auth m a) - -> FB.FacebookT FB.Auth m a +withTestUser + :: (R.MonadResource m, MonadBaseControl IO m) + => FB.CreateTestUser + -> (FB.TestUser -> FB.FacebookT FB.Auth m a) + -> FB.FacebookT FB.Auth m a withTestUser ctu action = do token <- FB.getAppAccessToken - E.bracket (FB.createTestUser ctu token) - (flip FB.removeTestUser token) - action + E.bracket (FB.createTestUser ctu token) (flip FB.removeTestUser token) action