fb 1.0.13 → 1.1.0
raw patch · 16 files changed
+1662/−1445 lines, 16 filesdep +http-clientdep −attoparsec-conduitdep ~aesondep ~basedep ~conduitnew-uploader
Dependencies added: http-client
Dependencies removed: attoparsec-conduit
Dependency ranges changed: aeson, base, conduit, conduit-extra, hspec, http-conduit, time
Files
- CHANGELOG.md +8/−0
- README.md +61/−0
- fb.cabal +18/−22
- src/Facebook.hs +125/−132
- src/Facebook/Auth.hs +278/−235
- src/Facebook/Base.hs +45/−7
- src/Facebook/Graph.hs +141/−134
- src/Facebook/Object/Checkin.hs +42/−48
- src/Facebook/Object/FriendList.hs +56/−51
- src/Facebook/Object/Order.hs +56/−57
- src/Facebook/Object/Page.hs +56/−48
- src/Facebook/Object/User.hs +75/−81
- src/Facebook/Pager.hs +61/−46
- src/Facebook/TestUsers.hs +125/−102
- src/Facebook/Types.hs +80/−83
- tests/Main.hs +435/−399
+ CHANGELOG.md view
@@ -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
+ README.md view
@@ -0,0 +1,61 @@+fb+--++[](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+```
fb.cabal view
@@ -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 <felipe.lessa@gmail.com>+author: Felipe Lessa, Sibi+maintainer: Sibi <sibi@psibi.in> 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- (<https://github.com/prowdsponsor/fb/issues>).+ (<https://github.com/psibi/fb/issues>). 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
src/Facebook.hs view
@@ -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
src/Facebook/Auth.hs view
@@ -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 -- <https://developers.facebook.com/docs/reference/api/permissions/>@@ -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 <https://developers.facebook.com/blog/post/500/>.- 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 <https://developers.facebook.com/blog/post/500/>.+ 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 -- <https://developers.facebook.com/docs/offline-access-deprecation/>,@@ -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 -- (<https://developers.facebook.com/docs/authentication/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
src/Facebook/Base.hs view
@@ -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
src/Facebook/Graph.hs view
@@ -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 -- <https://developers.facebook.com/docs/opengraph/simpletypes/>).-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
src/Facebook/Object/Checkin.hs view
@@ -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 -- <https://developers.facebook.com/docs/reference/api/checkin/>). -- -- /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
src/Facebook/Object/FriendList.hs view
@@ -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 =
src/Facebook/Object/Order.hs view
@@ -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)
src/Facebook/Object/Page.hs view
@@ -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"
src/Facebook/Object/User.hs view
@@ -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 -- <https://developers.facebook.com/docs/reference/api/user/>). -- -- /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 =
src/Facebook/Pager.hs view
@@ -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)
src/Facebook/TestUsers.hs view
@@ -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
src/Facebook/Types.hs view
@@ -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"
tests/Main.hs view
@@ -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