fb 1.0.13 → 2.1.1.2
raw patch · 20 files changed
Files
- CHANGELOG.md +56/−0
- README.md +61/−0
- fb.cabal +106/−108
- src/Facebook.hs +139/−140
- src/Facebook/Auth.hs +283/−242
- src/Facebook/Base.hs +68/−51
- src/Facebook/FQL.hs +46/−37
- src/Facebook/Graph.hs +143/−135
- src/Facebook/Monad.hs +163/−100
- src/Facebook/Object/Action.hs +36/−30
- src/Facebook/Object/Checkin.hs +44/−49
- src/Facebook/Object/FriendList.hs +58/−52
- src/Facebook/Object/Order.hs +55/−58
- src/Facebook/Object/Page.hs +55/−49
- src/Facebook/Object/User.hs +74/−82
- src/Facebook/Pager.hs +56/−50
- src/Facebook/RealTime.hs +103/−109
- src/Facebook/TestUsers.hs +131/−106
- src/Facebook/Types.hs +118/−83
- tests/Main.hs +272/−252
+ CHANGELOG.md view
@@ -0,0 +1,56 @@+# Version 2.1.1.2++* Add support for Aeson v2.2+.++# Version 2.1.1.1++* Add support for Aeson v2+.++# Version 2.1.0++* Same release as 2.0.1 bound follows PVP properly++# Version 2.0.1++* Fix MonadUnliftIO instance for FacebookT+* Have upper bound on unliftio and related packages++# Version 2.0.0++* Remove following dependency:+ - base16-bytestring+ - base64-bytestring+ - cereal+ - crypto-api+ - cryptohash+ - cryptohash-cryptoapi+ - old-locale+* Introduce new dependency:+ - cryptonite+ - memory+* Add new function setApiVersion+* Add Graph API version parameter. Avoid hardcoded `v2.8`.+* Expose setApiVersion and getApiVersion function+* Default API endpoint updated to `v3.2`+* Add appsecret_proof verification.+* Fix appsecret_proof verification encoding.++# Version 1.2.1++* Make it work for ghc-8.4. See [#3](https://github.com/psibi/fb/issues/3)++# Version 1.2.0++* Rewrote fb for conduit-1.3.0+* Fixed various warnings and did general cleanup+* Fixed fetchNextPage/fetchPreviousPage test by adding ("filter", "stream") for comments api.+* Made lower bound of http-conduit to 2.3.0++# Version 1.1.1++* 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://dev.azure.com/psibi2000/Haskell%20Projects/_build/latest?definitionId=16&branchName=master)++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"+ , appSecretProof = False+ }++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,135 +1,133 @@-name: fb-version: 1.0.13-license: BSD3-license-file: LICENSE-author: Felipe Lessa-maintainer: Felipe Lessa <felipe.lessa@gmail.com>-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+cabal-version: 1.12 -description:- This package exports bindings to Facebook's APIs (see- <http://developers.facebook.com/>). Does not have any external- dependencies and tries to use as little resources (such as- memory, sockets and CPU) as possible by using packages such as- @aeson@, @attoparsec@, @bytestring@, @conduit@, @http-conduit@,- @text@ and others.- .- While we would like to have a complete binding to Facebook's- 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>).+-- This file has been generated from package.yaml by hpack version 0.37.0.+--+-- see: https://github.com/sol/hpack +name: fb+version: 2.1.1.2+synopsis: Bindings to Facebook's API.+description: This package exports bindings to Facebook's APIs (see+ <http://developers.facebook.com/>). Does not have any external+ dependencies and tries to use as little resources (such as+ memory, sockets and CPU) as possible by using packages such as+ @aeson@, @attoparsec@, @bytestring@, @conduit@, @http-conduit@,+ @text@ and others.+ .+ While we would like to have a complete binding to Facebook's+ 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/psibi/fb/issues>).+category: Web+stability: Experimental+homepage: https://github.com/psibi/fb+bug-reports: https://github.com/psibi/fb/issues+author: Felipe Lessa, Sibi Prabakaran+maintainer: Sibi <sibi@psibi.in>+copyright: Felipe Lessa and Sibi Prabakaran+license: BSD3+license-file: LICENSE+build-type: Simple extra-source-files:- tests/Main.hs- tests/tryIt.hs- example.hs-+ tests/Main.hs+ tests/tryIt.hs+ example.hs+ README.md+ CHANGELOG.md source-repository head- type: git- location: git://github.com/prowdsponsor/fb.git-+ type: git+ location: git@github.com:psibi/fb.git flag debug- default: False description: Print debugging info.+ manual: False+ default: False -flag conduit11- description: Use conduit >= 1.1.+flag pre-aeson-2-2-compat+ description: Build with aeson < 2.2 where the attoparsec-aeson package didn't exist.+ manual: False+ default: False library- hs-source-dirs: src- ghc-options: -Wall exposed-modules:- Facebook+ Facebook other-modules:- Facebook.Types- Facebook.Monad- Facebook.Base- Facebook.Auth- Facebook.Pager- Facebook.Graph- Facebook.Object.Action- Facebook.Object.FriendList- Facebook.Object.Checkin- Facebook.Object.User- Facebook.Object.Page- Facebook.Object.Order- Facebook.RealTime- Facebook.FQL- Facebook.TestUsers+ Facebook.Auth+ Facebook.Base+ Facebook.FQL+ Facebook.Graph+ Facebook.Monad+ Facebook.Object.Action+ Facebook.Object.Checkin+ Facebook.Object.FriendList+ Facebook.Object.Order+ Facebook.Object.Page+ Facebook.Object.User+ Facebook.Pager+ Facebook.RealTime+ Facebook.TestUsers+ Facebook.Types+ Paths_fb+ hs-source-dirs:+ src+ ghc-options: -Wall build-depends:- base >= 4 && < 5- , lifted-base >= 0.1 && < 0.3- , bytestring >= 0.9 && < 0.11- , text >= 0.11 && < 1.3- , transformers >= 0.2 && < 0.6- , transformers-base- , monad-control- , resourcet+ attoparsec >=0.10.4+ , base ==4.*+ , bytestring >=0.9+ , conduit >=1.3.0+ , conduit-extra+ , cryptonite , data-default+ , http-client >=0.4.30+ , http-conduit >=2.3.0 , http-types- , http-conduit >= 2.0 && < 2.2- , attoparsec >= 0.10.4 && < 0.14+ , memory+ , monad-logger+ , resourcet+ , text >=0.11+ , time >=1.4+ , transformers >=0.2+ , transformers-base+ , unliftio+ , unliftio-core , unordered-containers- , aeson >= 0.5- , base16-bytestring >= 0.1- , base64-bytestring >= 0.1.1- , time >= 1.2 && < 1.7- , 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)+ default-language: Haskell2010+ if flag(debug)+ cpp-options: -DDEBUG+ if flag(pre-aeson-2-2-compat) build-depends:- conduit >= 1.1 && < 1.3- , conduit-extra == 1.1.*+ aeson >=0.8.0.2 else build-depends:- conduit == 1.0.*- , attoparsec-conduit == 1.0.*- extensions:- DeriveDataTypeable- EmptyDataDecls- OverloadedStrings- GADTs- StandaloneDeriving- ScopedTypeVariables- GeneralizedNewtypeDeriving- TypeFamilies- FlexibleInstances- MultiParamTypeClasses- if flag(debug)- cpp-options: -DDEBUG-+ aeson >=2.2.0.0+ , attoparsec-aeson >=2.1.0.0 test-suite runtests type: exitcode-stdio-1.0- ghc-options: -Wall -fno-warn-orphans- hs-source-dirs: tests- main-is: Main.hs+ main-is: Main.hs+ other-modules:+ Paths_fb+ hs-source-dirs:+ tests+ ghc-options: -Wall -fno-warn-orphans build-depends:- -- Library dependencies used on the tests. No need to- -- specify versions since they'll use the same as above.- base, lifted-base, transformers, bytestring, resourcet,- conduit, http-conduit, text, time, aeson, monad-control-- -- Test-only dependencies+ HUnit+ , QuickCheck+ , aeson+ , base+ , bytestring+ , conduit , containers , data-default- , HUnit- , QuickCheck- , hspec >= 1.9 && < 1.12 , fb- extensions:- TypeFamilies- ScopedTypeVariables+ , hspec >=2.5.0+ , http-conduit+ , resourcet+ , text+ , time+ , transformers+ , unliftio+ default-language: Haskell2010
src/Facebook.hs view
@@ -1,149 +1,148 @@ 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@ monad transformer+ FacebookT+ , runFacebookT+ , runNoAuthFacebookT+ , mapFacebookT+ , beta_runFacebookT+ , beta_runNoAuthFacebookT+ , Auth+ , NoAuth+ -- * Authorization and Authentication+ -- ** Credentials+ , Credentials(..)+ -- ** Access token+ , AccessToken(..)+ , UserAccessToken+ , AppAccessToken+ , AccessTokenData+ , ApiVersion+ , hasExpired+ , isValid+ , setApiVersion+ , getApiVersion+ -- ** App access token+ , AppKind+ , getAppAccessToken+ -- ** User access token+ , UserKind+ , RedirectUrl+ , Permission+ , getUserAccessTokenStep1+ , getUserAccessTokenStep2+ , getUserLogoutUrl+ , extendUserAccessToken+ , debugToken+ , DebugToken(..)+ -- ** Signed requests+ , parseSignedRequest+ , addAppSecretProof+ , makeAppSecretProof+ -- * 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 -import Facebook.Types-import Facebook.Monad-import Facebook.Base import Facebook.Auth-import Facebook.Pager+import Facebook.Base+import Facebook.FQL import Facebook.Graph-import Facebook.Object.Page-import Facebook.Object.User+import Facebook.Monad import Facebook.Object.Action import Facebook.Object.Checkin-import Facebook.Object.Order import Facebook.Object.FriendList+import Facebook.Object.Order+import Facebook.Object.Page+import Facebook.Object.User+import Facebook.Pager import Facebook.RealTime-import Facebook.FQL import Facebook.TestUsers+import Facebook.Types
src/Facebook/Auth.hs view
@@ -1,102 +1,116 @@-{-# LANGUAGE FlexibleContexts, GADTs, ScopedTypeVariables, OverloadedStrings #-}-module Facebook.Auth- ( getAppAccessToken- , getUserAccessTokenStep1- , getUserAccessTokenStep2- , getUserLogoutUrl- , extendUserAccessToken- , RedirectUrl- , Permission- , unPermission- , hasExpired- , isValid- , parseSignedRequest- , debugToken- , DebugToken(..)- ) where+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-} +module Facebook.Auth+ ( getAppAccessToken+ , getUserAccessTokenStep1+ , getUserAccessTokenStep2+ , getUserLogoutUrl+ , extendUserAccessToken+ , RedirectUrl+ , Permission+ , unPermission+ , hasExpired+ , isValid+ , parseSignedRequest+ , debugToken+ , DebugToken(..)+ ) where+#if __GLASGOW_HASKELL__ <= 784 import Control.Applicative-import Control.Monad (guard, join, liftM, mzero)-import Control.Monad.IO.Class (MonadIO(liftIO))-import Control.Monad.Trans.Control (MonadBaseControl)+#endif+import Control.Monad (guard, mzero)+import Control.Monad.IO.Class import Control.Monad.Trans.Maybe (MaybeT(..))-import Crypto.Classes (constTimeEq)-import Crypto.Hash.CryptoAPI (SHA256)-import Crypto.HMAC (hmac', MacKey(..))-import Data.Aeson ((.:))-import Data.Aeson.Parser (json')-import Data.Maybe (fromMaybe)-import Data.Text (Text)-import Data.Time (getCurrentTime, addUTCTime, UTCTime)-import Data.Typeable (Typeable)-import Data.String (IsString(..))--import qualified Control.Exception.Lifted as E import qualified Control.Monad.Trans.Resource as R+import Crypto.Hash.Algorithms (SHA256)+import Crypto.MAC.HMAC (HMAC(..), hmac)+import Data.Aeson ((.:)) import qualified Data.Aeson as AE+import Data.Aeson.Parser (json') import qualified Data.Aeson.Types as AE-import qualified Data.Attoparsec.Char8 as AB-import qualified Data.Attoparsec.Text as A+import qualified Data.Attoparsec.ByteString.Char8 as AB+import Data.ByteArray (ScrubbedBytes, convert)+import Data.ByteArray.Encoding (Base(..), convertFromBase) import qualified Data.ByteString as B-import qualified Data.ByteString.Base64.URL as Base64URL import qualified Data.ByteString.Char8 as B8-import qualified Data.Conduit as C-import qualified Data.Conduit.Attoparsec as C-import qualified Data.Conduit.Text as CT import qualified Data.List as L-import qualified Data.Serialize as Cereal+import Data.Maybe (fromMaybe)+import Data.String (IsString(..))+import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.Text.Encoding.Error as TE-import qualified Network.HTTP.Conduit as H+import Data.Time (UTCTime, addUTCTime, getCurrentTime)+import Data.Typeable (Typeable) import qualified Network.HTTP.Types as HT-+import qualified UnliftIO.Exception as E -import Facebook.Types import Facebook.Base import Facebook.Monad-+import Facebook.Types -- | 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, R.MonadUnliftIO m, R.MonadThrow m, MonadIO m)+ => FacebookT Auth m AppAccessToken getAppAccessToken = runResourceInFb $ do creds <- getCreds- req <- fbreq "/oauth/access_token" Nothing $- tsq creds [("grant_type", "client_credentials")]+ 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)-+ (token :: AE.Value) <- asJson response+ case AE.parseMaybe tokenParser token of+ Just appToken -> return $ AppAccessToken appToken+ _ ->+ E.throwIO $+ 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, MonadIO m)+ => RedirectUrl+ -> [Permission]+ -> FacebookT Auth m Text getUserAccessTokenStep1 redirectUrl perms = do creds <- getCreds+ apiVersion <- getApiVersion 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)- )-+ 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 +119,66 @@ -- 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 ::+ (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m, MonadIO 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.throwIO $ 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 value =+ AE.withObject+ "accessToken"+ (\obj -> do+ (token :: Text) <- obj AE..: "access_token"+ (expires_in :: Int) <- obj AE..: "expires_in"+ return (token, toExpire expires_in))+ value -- | The URL an user should be redirected to in order to log them -- out of their Facebook session. Facebook will then redirect@@ -167,27 +192,30 @@ -- 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_)) ]-+ 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 +223,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/>@@ -210,55 +237,54 @@ -- > perms :: [Permission] -- > perms = ["user_about_me", "email", "offline_access"] newtype Permission =- Permission {- unPermission :: Text+ 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)+ }+ 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 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 ::+ (R.MonadResource m, R.MonadUnliftIO 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 +297,87 @@ -- 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+extendUserAccessToken ::+ (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m, MonadIO 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+ 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- return (Right $ case userAccessTokenParser now response of- UserAccessToken _ data' expires' ->- UserAccessToken uid data' expires')+ 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: ":)-+ 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, MonadIO 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+ runMaybeT $+ -- Split, decode and JSON-parse+ do+ let (encodedSignature, encodedUnparsedPayloadWithDot) =+ B8.break (== '.') signedRequest+ ('.', encodedUnparsedPayload) <-+ MaybeT $ return (B8.uncons encodedUnparsedPayloadWithDot)+ signature <-+ eitherToMaybeT $+ convertFromBase Base64 $ addBase64Padding encodedSignature+ unparsedPayload <-+ eitherToMaybeT $+ convertFromBase Base64 $ 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+ creds <- lift getCreds+ let hmacKey = credsToHmacKey creds+ expectedSignature = hmac hmacKey encodedUnparsedPayload :: HMAC SHA256+ guard ((signature :: ScrubbedBytes) == (convert 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 = 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 +393,48 @@ | 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 ::+ (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow 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- }+ Undata+ { undata :: a+ } instance AE.FromJSON a => AE.FromJSON (Undata a) where- parseJSON (AE.Object v) =- Undata <$> v AE..: "data"+ 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+ { 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)-+ }+ deriving (Eq, Ord, Show, Typeable) -- | Note: this instance always sets 'dtAccessToken' to -- 'Nothing', but 'debugToken' will update this field before@@ -402,12 +443,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
@@ -1,4 +1,8 @@-{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, OverloadedStrings, CPP #-}+{-#LANGUAGE DeriveDataTypeable#-}+{-#LANGUAGE FlexibleContexts#-}+{-#LANGUAGE OverloadedStrings#-}+{-#LANGUAGE CPP#-}+ module Facebook.Base ( fbreq , ToSimpleQuery(..)@@ -12,60 +16,72 @@ ) 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) -import qualified Control.Exception.Lifted as E+import qualified UnliftIO.Exception as E import Control.Monad.Trans.Class (MonadTrans)-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+#if MIN_VERSION_aeson(2,2,0)+import qualified Data.Aeson.Parser.Internal as AesonParserInternal+#endif import qualified Data.ByteString as B import qualified Data.Conduit as C+import Data.Conduit ((.|)) 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 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 - -- | 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.+fbreq :: MonadIO m+ => Text -- ^ Path. Should start from "/". -> Maybe (AccessToken anyKind) -- ^ Access token. -> HT.SimpleQuery -- ^ Parameters. -> FacebookT anyAuth m H.Request-fbreq path mtoken query =+fbreq path mtoken query = do++ apiVersion <- getApiVersion+ creds <- getMCreds++ let appSecretProofAdder = case creds of+ Just c@( Credentials _ _ _ True ) -> addAppSecretProof c+ _ -> const id ++ withTier $ \tier -> let host = case tier of Production -> "graph.facebook.com" Beta -> "graph.beta.facebook.com"- in def { H.secure = True+ in H.defaultRequest { H.secure = True , H.host = host , H.port = 443- , H.path = TE.encodeUtf8 path+ , H.path = TE.encodeUtf8 ("/" <> apiVersion <> path) , H.redirectCount = 3 , H.queryString =- HT.renderSimpleQuery False $- maybe id tsq mtoken query+ HT.renderSimpleQuery False+ $ appSecretProofAdder mtoken $ 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 } @@ -88,12 +104,12 @@ -- | Converts a plain 'H.Response' coming from 'H.http' into a -- JSON value. asJson :: (MonadIO m, MonadTrans t, R.MonadThrow m, A.FromJSON a) =>- H.Response (C.ResumableSource m ByteString)+ H.Response (C.ConduitT () ByteString m ()) -> t m a asJson = lift . asJsonHelper asJsonHelper :: (MonadIO m, R.MonadThrow m, A.FromJSON a) =>- H.Response (C.ResumableSource m ByteString)+ H.Response (C.ConduitT () ByteString m ()) -> m a asJsonHelper response = do #if DEBUG@@ -101,12 +117,17 @@ _ <- liftIO $ printf "asJsonHelper: %s\n" (show bs) val <- either (fail . ("asJsonHelper: A.decode returned " ++)) return (A.eitherDecode bs) #else- val <- H.responseBody response C.$$+- C.sinkParser A.json'+ -- aeson-2.2 moved this to new package `attoparsec-aeson`+#if MIN_VERSION_aeson(2,2,0)+ val <- C.runConduit $ (H.responseBody response) .| C.sinkParser AesonParserInternal.json'+#else+ val <- C.runConduit $ (H.responseBody response) .| C.sinkParser A.json' #endif+#endif case A.fromJSON val of A.Success r -> return r A.Error str ->- E.throw $ FbLibraryException $ T.concat+ E.throwIO $ FbLibraryException $ T.concat [ "Facebook.Base.asJson: could not parse " , " Facebook's response as a JSON value (" , T.pack str, ")" ]@@ -114,63 +135,54 @@ -- | Converts a plain 'H.Response' into a string 'ByteString'. asBS :: (Monad m) =>- H.Response (C.ResumableSource m ByteString)+ H.Response (C.ConduitT () ByteString m ()) -> FacebookT anyAuth m ByteString-asBS response = lift $ H.responseBody response C.$$+- fmap B.concat CL.consume----- | An exception that may be thrown by functions on this--- package. Includes any information provided by Facebook.-data FacebookException =- -- | An exception coming from Facebook.- FacebookException { fbeType :: Text- , fbeMessage :: Text- }- -- | An exception coming from the @fb@ package's code.- | FbLibraryException { fbeMessage :: Text }- deriving (Eq, Ord, Show, Read, Typeable)--instance A.FromJSON FacebookException where- parseJSON (A.Object v) =- FacebookException <$> v A..: "type"- <*> v A..: "message"- parseJSON _ = mzero--instance E.Exception FacebookException where+asBS response = lift $ C.runConduit $ H.responseBody response .| fmap B.concat CL.consume -- | Same as 'H.http', but tries to parse errors and throw -- meaningful 'FacebookException'@s@.-fbhttp :: (MonadBaseControl IO m, R.MonadResource m) =>+fbhttp :: (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m) => H.Request- -> FacebookT anyAuth m (H.Response (C.ResumableSource m ByteString))+ -> FacebookT anyAuth m (H.Response (C.ConduitT () ByteString m ())) fbhttp req = do manager <- getManager lift (fbhttpHelper manager req) -fbhttpHelper :: (MonadBaseControl IO m, R.MonadResource m) =>+fbhttpHelper :: (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m) => H.Manager -> H.Request- -> m (H.Response (C.ResumableSource m ByteString))+ -> m (H.Response (C.ConduitT () ByteString m ())) 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 <- C.runConduit $ (H.responseBody response) .| 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+ Right fbexc -> E.throwIO fbexc Left _ -> do case AT.parse wwwAuthenticateParser <$> lookup "WWW-Authenticate" headers of@@ -193,14 +205,19 @@ -- | Send a @HEAD@ request just to see if the resposne status -- code is 2XX (returns @True@) or not (returns @False@).-httpCheck :: (MonadBaseControl IO m, R.MonadResource m) =>+httpCheck :: (R.MonadResource m, R.MonadUnliftIO m) => H.Request -> FacebookT anyAuth m Bool 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/FQL.hs view
@@ -1,13 +1,15 @@-{-# LANGUAGE FlexibleContexts, OverloadedStrings #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+ module Facebook.FQL- ( fqlQuery- , FQLTime(..)- , FQLList(..)- , FQLObject(..)- ) where+ ( fqlQuery+ , FQLTime(..)+ , FQLList(..)+ , FQLObject(..)+ ) where -import Control.Applicative((<$>))-import Control.Monad.Trans.Control (MonadBaseControl)+import Control.Applicative ((<$>)) import Data.Monoid (mempty) import Data.Text (Text) import Data.Time (UTCTime)@@ -15,39 +17,42 @@ import qualified Control.Monad.Trans.Resource as R import qualified Data.Aeson as A-import qualified Data.HashMap.Strict as HMS+#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.KeyMap as Keys+#else+import qualified Data.HashMap.Strict as Keys+#endif + import Facebook.Types import Facebook.Monad import Facebook.Base import Facebook.Graph import Facebook.Pager - -- | Query the Facebook Graph using FQL.-fqlQuery :: (R.MonadResource m, MonadBaseControl IO m, A.FromJSON a) =>- Text -- ^ FQL Query- -> Maybe (AccessToken anyKind) -- ^ Optional access token- -> FacebookT anyAuth m (Pager a)+fqlQuery+ :: (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m, A.FromJSON a)+ => Text -- ^ FQL Query+ -> Maybe (AccessToken anyKind) -- ^ Optional access token+ -> FacebookT anyAuth m (Pager a) fqlQuery fql mtoken =- runResourceInFb $ do- let query = ["q" #= fql]- asJson =<< fbhttp =<< fbreq "/fql" mtoken query-+ runResourceInFb $+ do let query = ["q" #= fql]+ asJson =<< fbhttp =<< fbreq "/fql" mtoken query -- | @newtype@ wrapper around 'UTCTime' that is able to parse -- FQL's time representation as seconds since the Unix epoch.-newtype FQLTime = FQLTime { unFQLTime :: UTCTime }- deriving (Eq, Ord, Show)+newtype FQLTime = FQLTime+ { unFQLTime :: UTCTime+ } deriving (Eq, Ord, Show) instance A.FromJSON FQLTime where- parseJSON = fmap ( FQLTime- . posixSecondsToUTCTime- . fromInteger)- . A.parseJSON--{-# DEPRECATED FQLTime "Deprecated since fb 0.14.7, please use FbUTCTime instead." #-}+ parseJSON = fmap (FQLTime . posixSecondsToUTCTime . fromInteger) . A.parseJSON +{-# DEPRECATED+FQLTime "Deprecated since fb 0.14.7, please use FbUTCTime instead."+ #-} -- | @newtype@ wrapper around lists that works around FQL's -- strange lists.@@ -61,13 +66,14 @@ -- On the other hand, not all FQL arrays are represented in this -- bogus manner. Also, some so-called arrays by FQL's -- documentation are actually objects, see 'FQLObject'.-newtype FQLList a = FQLList { unFQLList :: [a] }- deriving (Eq, Ord, Show)--instance A.FromJSON a => A.FromJSON (FQLList a) where- parseJSON (A.Object o) = FQLList <$> mapM A.parseJSON (HMS.elems o)- parseJSON v = FQLList <$> A.parseJSON v+newtype FQLList a = FQLList+ { unFQLList :: [a]+ } deriving (Eq, Ord, Show) +instance A.FromJSON a =>+ A.FromJSON (FQLList a) where+ parseJSON (A.Object o) = FQLList <$> mapM A.parseJSON (Keys.elems o)+ parseJSON v = FQLList <$> A.parseJSON v -- | @newtype@ wrapper around any object that works around FQL's -- strange objects.@@ -77,9 +83,12 @@ -- empty lists @[]@ instead of a proper empty object @{}@. Also -- note that FQL's documentation says that @app_data@ is an -- array, which it clear is not. See also 'FQLList'.-newtype FQLObject a = FQLObject { unFQLObject :: a }- deriving (Eq, Ord, Show)+newtype FQLObject a = FQLObject+ { unFQLObject :: a+ } deriving (Eq, Ord, Show) -instance A.FromJSON a => A.FromJSON (FQLObject a) where- parseJSON (A.Array a) | a == mempty = FQLObject <$> A.parseJSON (A.Object mempty)- parseJSON v = FQLObject <$> A.parseJSON v+instance A.FromJSON a =>+ A.FromJSON (FQLObject a) where+ parseJSON (A.Array a)+ | a == mempty = FQLObject <$> A.parseJSON (A.Object mempty)+ parseJSON v = FQLObject <$> A.parseJSON v
src/Facebook/Graph.hs view
@@ -1,21 +1,24 @@-{-# LANGUAGE ConstraintKinds, CPP, DeriveDataTypeable, FlexibleContexts, OverloadedStrings #-}-module Facebook.Graph- ( getObject- , postObject- , deleteObject- , searchObjects- , (#=)- , SimpleType(..)- , Place(..)- , Location(..)- , GeoCoordinates(..)- , Tag(..)- ) where-+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE 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) import Data.Int (Int8, Int16, Int32, Int64) import Data.List (intersperse)@@ -27,10 +30,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 +45,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, R.MonadUnliftIO m, R.MonadThrow 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, R.MonadUnliftIO m, R.MonadThrow 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, R.MonadUnliftIO m, R.MonadThrow 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, R.MonadUnliftIO m, R.MonadThrow 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, R.MonadUnliftIO m, R.MonadThrow 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 +213,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/Monad.hs view
@@ -1,150 +1,214 @@-{-# LANGUAGE CPP,- DeriveDataTypeable,- FlexibleContexts,- FlexibleInstances,- GeneralizedNewtypeDeriving,- MultiParamTypeClasses,- StandaloneDeriving,- TypeFamilies,- UndecidableInstances #-}-module Facebook.Monad- ( FacebookT- , Auth- , NoAuth- , FbTier(..)- , runFacebookT- , runNoAuthFacebookT- , beta_runFacebookT- , beta_runNoAuthFacebookT- , getCreds- , getManager- , getTier- , withTier- , runResourceInFb- , mapFacebookT+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-} - -- * Re-export- , lift- ) where+module Facebook.Monad+ ( FacebookT+ , Auth+ , NoAuth+ , FbTier(..)+ , runFacebookT+ , runNoAuthFacebookT+ , beta_runFacebookT+ , beta_runNoAuthFacebookT+ , getApiVersion+ , getCreds+ , getMCreds+ , getManager+ , getTier+ , withTier+ , addAppSecretProof+ , makeAppSecretProof+ , runResourceInFb+ , mapFacebookT+ , setApiVersion+ -- * Re-export+ , lift+ ) where -import Control.Applicative (Applicative, Alternative)+import Control.Applicative (Alternative, Applicative) import Control.Monad (MonadPlus, liftM) import Control.Monad.Base (MonadBase(..))+import Control.Monad.Fail (MonadFail(..)) import Control.Monad.Fix (MonadFix) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Logger (MonadLogger(..)) import Control.Monad.Trans.Class (MonadTrans(lift))-import Control.Monad.Trans.Control ( MonadTransControl(..), MonadBaseControl(..)- , ComposeSt, defaultLiftBaseWith- , defaultRestoreM )-#if MIN_VERSION_monad_control(1,0,0)-import Control.Monad.Trans.Control (defaultLiftWith, defaultRestoreT)-#endif import Control.Monad.Trans.Reader (ReaderT(..), ask, mapReaderT)-import Data.Typeable (Typeable) import qualified Control.Monad.Trans.Resource as R--import qualified Network.HTTP.Conduit as H-+import Crypto.Hash.Algorithms (SHA256)+import Crypto.MAC.HMAC (HMAC(..), hmac)+import Data.ByteArray.Encoding (Base(..), convertToBase)+import qualified Data.Text.Encoding as TE+import Data.Typeable (Typeable) import Facebook.Types-+import qualified Network.HTTP.Conduit as H+import qualified Network.HTTP.Types as HT+import UnliftIO+import qualified UnliftIO.Exception as E -- | @FacebookT auth m a@ is this library's monad transformer. -- Contains information needed to issue commands and queries to -- Facebook. The phantom type @auth@ may be either 'Auth' (you -- have supplied your 'Credentials') or 'NoAuth' (you have not -- supplied any 'Credentials').-newtype FacebookT auth m a = F { unF :: ReaderT FbData m a }- deriving ( Functor, Applicative, Alternative, Monad, MonadFix- , MonadPlus, MonadIO, MonadTrans, R.MonadThrow )--deriving instance (R.MonadResource m, MonadBase IO m) => R.MonadResource (FacebookT auth m)+newtype FacebookT auth m a = F+ { unF :: ReaderT FbData m a -- FbData -> m a+ } deriving ( Functor+ , Applicative+ , Alternative+ , Monad+ , MonadFix+ , MonadPlus+ , MonadIO+ , MonadTrans+ , R.MonadThrow+ , MonadFail+ ) -instance MonadBase b m => MonadBase b (FacebookT auth m) where- liftBase = lift . liftBase+instance (MonadUnliftIO m) => MonadUnliftIO (FacebookT auth m) where+ withRunInIO inner =+ F $+ ReaderT $ \r ->+ withRunInIO $ \run -> inner (\fbT -> run $ (flip runReaderT) r (unF fbT)) -instance MonadTransControl (FacebookT auth) where-#if MIN_VERSION_monad_control(1,0,0)- type StT (FacebookT auth) a = StT (ReaderT FbData) a- liftWith = defaultLiftWith F unF- restoreT = defaultRestoreT F-#else- newtype StT (FacebookT auth) a = FbStT { unFbStT :: StT (ReaderT FbData) a }- liftWith f = F $ liftWith (\run -> f (liftM FbStT . run . unF))- restoreT = F . restoreT . liftM unFbStT-#endif+deriving instance+ (R.MonadResource m, MonadBase IO m) =>+ R.MonadResource (FacebookT auth m) -instance MonadBaseControl b m => MonadBaseControl b (FacebookT auth m) where-#if MIN_VERSION_monad_control(1,0,0)- type StM (FacebookT auth m) a = ComposeSt (FacebookT auth) m a- liftBaseWith = defaultLiftBaseWith- restoreM = defaultRestoreM-#else- newtype StM (FacebookT auth m) a = StMT {unStMT :: ComposeSt (FacebookT auth) m a}- liftBaseWith = defaultLiftBaseWith StMT- restoreM = defaultRestoreM unStMT-#endif+instance MonadBase b m => MonadBase b (FacebookT auth m) where+ liftBase = lift . liftBase -- | Since @fb-0.14.8@. instance MonadLogger m => MonadLogger (FacebookT auth m) where- monadLoggerLog loc src lvl msg = lift (monadLoggerLog loc src lvl msg)-+ monadLoggerLog loc src lvl msg = lift (monadLoggerLog loc src lvl msg) -- | Phantom type stating that you have provided your -- 'Credentials' and thus have access to the whole API.-data Auth deriving (Typeable)+data Auth+ deriving (Typeable) -- | Phantom type stating that you have /not/ provided your -- 'Credentials'. This means that you'll be limited about which -- APIs you'll be able use.-data NoAuth deriving (Typeable)+data NoAuth+ deriving (Typeable) -- | Internal data kept inside 'FacebookT'.-data FbData = FbData { fbdCreds :: Credentials -- ^ Can be 'undefined'!- , fbdManager :: !H.Manager- , fbdTier :: !FbTier- }- deriving (Typeable)+data FbData = FbData+ { fbdCreds :: Maybe Credentials+ , fbdManager :: !H.Manager+ , fbdTier :: !FbTier+ , fbdApiVersion :: IORef ApiVersion+ } deriving (Typeable) -- | Which Facebook tier should be used (see -- <https://developers.facebook.com/support/beta-tier/>).-data FbTier = Production | Beta deriving (Eq, Ord, Show, Read, Enum, Typeable)+data FbTier+ = Production+ | Beta+ deriving (Eq, Ord, Show, Read, Enum, Typeable) +defaultApiVersion :: ApiVersion+defaultApiVersion = "v3.2" +-- | Set the Graph API version.+setApiVersion :: (MonadIO m) => ApiVersion -> FacebookT anyAuth m ()+setApiVersion apiVersion = do+ ref <- fbdApiVersion `liftM` F ask+ atomicModifyIORef' ref (\_ -> (apiVersion, ()))+ return ()+ -- | Run a computation in the 'FacebookT' monad transformer with -- your credentials.-runFacebookT :: Credentials -- ^ Your app's credentials.- -> H.Manager -- ^ Connection manager (see 'H.withManager').- -> FacebookT Auth m a- -> m a-runFacebookT creds manager (F act) =- runReaderT act (FbData creds manager Production)+runFacebookT ::+ (MonadIO m)+ => Credentials -- ^ Your app's credentials.+ -> H.Manager -- ^ Connection manager (see 'H.withManager').+ -> FacebookT Auth m a+ -> m a+runFacebookT creds manager (F act) = do+ apiref <- newIORef defaultApiVersion+ runReaderT act (FbData (Just creds) manager Production apiref) +addAppSecretProof ::+ Credentials+ -> Maybe (AccessToken anykind)+ -> HT.SimpleQuery+ -> HT.SimpleQuery+addAppSecretProof (Credentials _ _ _ False) _ query = query+addAppSecretProof creds mtoken query = makeAppSecretProof creds mtoken <> query++-- | Make an appsecret_proof in case the given credentials access token is a+-- user access token.+-- See: https://developers.facebook.com/docs/graph-api/securing-requests/#appsecret_proof+makeAppSecretProof ::+ Credentials -- ^ App credentials+ -> Maybe (AccessToken anyKind) -- ^+ -> HT.SimpleQuery+makeAppSecretProof creds (Just (UserAccessToken _ accessToken _)) =+ [(TE.encodeUtf8 "appsecret_proof", proof)]+ where+ hmacData :: HMAC SHA256+ hmacData = hmac (appSecretBS creds) (TE.encodeUtf8 accessToken)+ proof = convertToBase Base16 hmacData+makeAppSecretProof _ _ = []+ -- | Run a computation in the 'FacebookT' monad without -- credentials.-runNoAuthFacebookT :: H.Manager -> FacebookT NoAuth m a -> m a-runNoAuthFacebookT manager (F act) =- let creds = error "runNoAuthFacebookT: never here, serious bug"- in runReaderT act (FbData creds manager Production)+runNoAuthFacebookT ::+ (MonadIO m)+ => H.Manager -- ^ Connection manager (see 'H.withManager').+ -> FacebookT NoAuth m a+ -> m a+runNoAuthFacebookT manager (F act) = do+ apiref <- newIORef defaultApiVersion+ runReaderT act (FbData Nothing manager Production apiref) -- | Same as 'runFacebookT', but uses Facebook's beta tier (see -- <https://developers.facebook.com/support/beta-tier/>).-beta_runFacebookT :: Credentials -> H.Manager -> FacebookT Auth m a -> m a-beta_runFacebookT creds manager (F act) =- runReaderT act (FbData creds manager Beta)+beta_runFacebookT ::+ (MonadIO m) => Credentials -> H.Manager -> FacebookT Auth m a -> m a+beta_runFacebookT creds manager (F act) = do+ apiref <- newIORef defaultApiVersion+ runReaderT act (FbData (Just creds) manager Beta apiref) -- | Same as 'runNoAuthFacebookT', but uses Facebook's beta tier -- (see <https://developers.facebook.com/support/beta-tier/>).-beta_runNoAuthFacebookT :: H.Manager -> FacebookT NoAuth m a -> m a-beta_runNoAuthFacebookT manager (F act) =- let creds = error "beta_runNoAuthFacebookT: never here, serious bug"- in runReaderT act (FbData creds manager Beta)+beta_runNoAuthFacebookT ::+ (MonadIO m) => H.Manager -> FacebookT NoAuth m a -> m a+beta_runNoAuthFacebookT manager (F act) = do+ apiref <- newIORef defaultApiVersion+ runReaderT act (FbData Nothing manager Beta apiref) +-- | Get the user's credentials, fail if they are not available.+getCreds :: (Monad m, MonadIO m) => FacebookT Auth m Credentials+getCreds = do+ mCreds <- getMCreds+ case mCreds of+ Nothing -> E.throwIO $ FbLibraryException "Couldn't get credentials."+ Just creds -> return creds -- | Get the user's credentials.-getCreds :: Monad m => FacebookT Auth m Credentials-getCreds = fbdCreds `liftM` F ask+getMCreds :: Monad m => FacebookT anyAuth m (Maybe Credentials)+getMCreds = fbdCreds `liftM` F ask +-- | Get the Graph API version.+getApiVersion :: MonadIO m => FacebookT anyAuth m ApiVersion+getApiVersion = do+ ref <- fbdApiVersion `liftM` F ask+ apiVersion <- readIORef ref+ pure apiVersion+ -- | Get the 'H.Manager'. getManager :: Monad m => FacebookT anyAuth m H.Manager getManager = fbdManager `liftM` F ask@@ -157,13 +221,12 @@ withTier :: Monad m => (FbTier -> a) -> FacebookT anyAuth m a withTier = flip liftM getTier - -- | Run a 'ResourceT' inside a 'FacebookT'.-runResourceInFb :: (R.MonadResource m, MonadBaseControl IO m) =>- FacebookT anyAuth (R.ResourceT m) a- -> FacebookT anyAuth m a+runResourceInFb ::+ (R.MonadResource m, MonadUnliftIO m)+ => FacebookT anyAuth (R.ResourceT m) a+ -> FacebookT anyAuth m a runResourceInFb (F inner) = F $ ask >>= lift . R.runResourceT . runReaderT inner- -- | Transform the computation inside a 'FacebookT'. mapFacebookT :: (m a -> n b) -> FacebookT anyAuth m a -> FacebookT anyAuth n b
src/Facebook/Object/Action.hs view
@@ -1,11 +1,14 @@-{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+ module Facebook.Object.Action- ( createAction- , Action(..)- ) where+ ( createAction+ , Action(..)+ ) where import Control.Arrow (first)-import Control.Monad.Trans.Control (MonadBaseControl)+import Control.Monad.IO.Class import Data.Function (on) import Data.String (IsString(..)) import Data.Text (Text)@@ -16,7 +19,6 @@ import Facebook.Monad import Facebook.Graph - -- | Creates an Open Graph action on the user's timeline. Returns -- the 'Id' of the newly created action. For example: --@@ -25,25 +27,27 @@ -- > [ "recipe" #= "http://example.com/cookie.html" -- > , "when" #= now ] -- > token-createAction :: (R.MonadResource m, MonadBaseControl IO m) =>- Action -- ^ Action kind to be created.- -> [Argument] -- ^ Arguments of the action.- -> Maybe AppAccessToken- -- ^ Optional app access token (optional with- -- respect to this library, since you can't make- -- this mandatory by changing the settings of- -- your action on Facebook).- -> UserAccessToken -- ^ Required user access token.- -> FacebookT Auth m Id+createAction+ :: (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m, MonadIO m)+ => Action -- ^ Action kind to be created.+ -> [Argument] -- ^ Arguments of the action.+ -> Maybe AppAccessToken+ -- ^ Optional app access token (optional with+ -- respect to this library, since you can't make+ -- this mandatory by changing the settings of+ -- your action on Facebook).+ -> UserAccessToken -- ^ Required user access token.+ -> FacebookT Auth m Id createAction (Action action) query mapptoken usertoken = do creds <- getCreds- let post :: (R.MonadResource m, MonadBaseControl IO m) => Text -> AccessToken anyKind -> FacebookT Auth m Id+ let post+ :: (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m)+ => Text -> AccessToken anyKind -> FacebookT Auth m Id post prepath = postObject (prepath <> appName creds <> ":" <> action) query case mapptoken of- Nothing -> post "/me/" usertoken+ Nothing -> post "/me/" usertoken Just apptoken -> post ("/" <> idCode (accessTokenUserId usertoken) <> "/") apptoken - -- | An action of your app. Please refer to Facebook's -- documentation at -- <https://developers.facebook.com/docs/opengraph/keyconcepts/#actions-objects>@@ -58,27 +62,29 @@ -- > foo token = do -- > ... -- > createAction "cook" [...] token-newtype Action = Action { unAction :: Text }+newtype Action = Action+ { unAction :: Text+ } instance Show Action where- show = show . unAction+ show = show . unAction -- | Since 0.7.1 instance Eq Action where- (==) = (==) `on` unAction- (/=) = (/=) `on` unAction+ (==) = (==) `on` unAction+ (/=) = (/=) `on` unAction -- | Since 0.7.1 instance Ord Action where- compare = compare `on` unAction- (<=) = (<=) `on` unAction- (<) = (<) `on` unAction- (>=) = (>=) `on` unAction- (>) = (>) `on` unAction+ compare = compare `on` unAction+ (<=) = (<=) `on` unAction+ (<) = (<) `on` unAction+ (>=) = (>=) `on` unAction+ (>) = (>) `on` unAction -- | Since 0.7.1 instance Read Action where- readsPrec = (fmap (first Action) .) . readsPrec+ readsPrec = (fmap (first Action) .) . readsPrec instance IsString Action where- fromString = Action . fromString+ fromString = Action . fromString
src/Facebook/Object/Checkin.hs view
@@ -1,14 +1,18 @@-{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, OverloadedStrings #-}-module Facebook.Object.Checkin- ( Checkin(..)- , CheckinFrom(..)- , getCheckin- , createCheckin- ) where+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-} +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 ((.:), (.:?)) import Data.Text (Text) import Data.Time (UTCTime)@@ -17,73 +21,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, R.MonadUnliftIO m, R.MonadThrow 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, R.MonadUnliftIO m, R.MonadThrow 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,14 +1,18 @@-{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, OverloadedStrings #-}-module Facebook.Object.FriendList- ( FriendList(..)- , FriendListType(..)- , getUserFriendLists- , getFriendListMembers- ) where+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-} +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 ((.:)) import Data.Text (Text) import Data.Typeable (Typeable)@@ -16,7 +20,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 +27,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, R.MonadUnliftIO m, R.MonadThrow 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, R.MonadUnliftIO m, R.MonadThrow 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,15 +1,16 @@-{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+ module Facebook.Object.Order- ( Order(..)- , OrderId- , OrderStatus(..)- , OrderApplication(..)- , getOrder- ) where+ ( Order(..)+ , OrderId+ , OrderStatus(..)+ , OrderApplication(..)+ , getOrder+ ) where -import Control.Applicative import Control.Monad (mzero)-import Control.Monad.Trans.Control (MonadBaseControl) import Data.Text (Text) import Data.Aeson ((.:), (.:?)) import Data.Typeable (Typeable)@@ -26,66 +27,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, R.MonadUnliftIO m, R.MonadThrow 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,16 +1,15 @@-{-# LANGUAGE DeriveDataTypeable- , FlexibleContexts- , OverloadedStrings- #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+ module Facebook.Object.Page- ( Page(..)- , getPage- , searchPages- ) where+ ( Page(..)+ , getPage+ , getPage_+ , searchPages+ ) where -import Control.Applicative import Control.Monad (mzero)-import Control.Monad.Trans.Control (MonadBaseControl) import Data.Aeson ((.:), (.:?)) import qualified Control.Monad.Trans.Resource as R import qualified Data.Aeson as A@@ -27,52 +26,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, R.MonadUnliftIO m, R.MonadThrow 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, R.MonadUnliftIO m, R.MonadThrow 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, R.MonadUnliftIO m, R.MonadThrow 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,17 +1,18 @@-{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+ module Facebook.Object.User- ( User(..)- , Gender(..)- , getUser- , searchUsers- , getUserCheckins- , Friend(..)- , getUserFriends- ) where+ ( User(..)+ , Gender(..)+ , getUser+ , searchUsers+ , getUserCheckins+ , Friend(..)+ , getUserFriends+ ) where -import Control.Applicative import Control.Monad (mzero)-import Control.Monad.Trans.Control (MonadBaseControl) import Data.Aeson ((.:), (.:?)) import Data.Text (Text) import Data.Typeable (Typeable)@@ -19,119 +20,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, R.MonadUnliftIO m, R.MonadThrow 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, R.MonadUnliftIO m, R.MonadThrow 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, R.MonadUnliftIO m, R.MonadThrow 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, R.MonadUnliftIO m, R.MonadThrow 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,18 +1,17 @@-{-# LANGUAGE ConstraintKinds, DeriveDataTypeable, FlexibleContexts, OverloadedStrings #-}-module Facebook.Pager- ( Pager(..)- , fetchNextPage- , fetchPreviousPage- , fetchAllNextPages- , fetchAllPreviousPages- ) where+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable #-} +module Facebook.Pager+ ( Pager(..)+ , fetchNextPage+ , fetchPreviousPage+ , fetchAllNextPages+ , fetchAllPreviousPages+ ) where -import Control.Applicative import Control.Monad (mzero) import Control.Monad.IO.Class (liftIO)-import Control.Monad.Trans.Control (MonadBaseControl)-import Control.Monad.Trans.Resource (MonadResourceBase) import Data.Typeable (Typeable) import qualified Control.Monad.Trans.Resource as R@@ -20,11 +19,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 +45,89 @@ -- 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, A.FromJSON a, R.MonadThrow m, R.MonadUnliftIO m)+ => 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, A.FromJSON a, R.MonadThrow m, R.MonadUnliftIO m)+ => 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, A.FromJSON a, R.MonadThrow m, R.MonadUnliftIO m)+ => (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- req <- liftIO (H.parseUrl url)- Just <$> (asJson =<< fbhttp req { H.redirectCount = 3 })-+ req <- liftIO (H.parseRequest url)+ 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, A.FromJSON a, R.MonadUnliftIO n, R.MonadThrow n)+ => Pager a -> FacebookT anyAuth m (C.ConduitT () a n ()) 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, A.FromJSON a, R.MonadUnliftIO n, R.MonadThrow n)+ => Pager a -> FacebookT anyAuth m (C.ConduitT () a n ()) 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, A.FromJSON a, R.MonadUnliftIO n, R.MonadThrow n)+ => (Pager a -> Maybe String)+ -> Pager a+ -> FacebookT anyAuth m (C.ConduitT () a n ()) 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- req <- liftIO (H.parseUrl next)- let get = fbhttpHelper manager req { H.redirectCount = 3 }+ req <- liftIO (H.parseRequest next)+ 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/RealTime.hs view
@@ -1,164 +1,159 @@-{-# LANGUAGE FlexibleContexts, OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+ module Facebook.RealTime- ( RealTimeUpdateObject(..)- , RealTimeUpdateField- , RealTimeUpdateUrl- , RealTimeUpdateToken- , modifySubscription- , RealTimeUpdateSubscription(..)- , listSubscriptions- , verifyRealTimeUpdateNotifications- , getRealTimeUpdateNotifications- , RealTimeUpdateNotification(..)- , RealTimeUpdateNotificationUserEntry(..)- ) where+ ( RealTimeUpdateObject(..)+ , RealTimeUpdateField+ , RealTimeUpdateUrl+ , RealTimeUpdateToken+ , modifySubscription+ , RealTimeUpdateSubscription(..)+ , listSubscriptions+ , verifyRealTimeUpdateNotifications+ , getRealTimeUpdateNotifications+ , RealTimeUpdateNotification(..)+ , RealTimeUpdateNotificationUserEntry(..)+ ) where import Control.Applicative ((<$>), (<*>))-import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad (liftM, mzero, void)-import Crypto.Hash.CryptoAPI (SHA1)-import Data.ByteString.Char8 (ByteString)-import Data.Text (Text)-import Data.Text.Encoding (encodeUtf8)-import Data.Typeable (Typeable)-+import Control.Monad.IO.Class import qualified Control.Monad.Trans.Resource as R-import qualified Crypto.Classes as Crypto-import qualified Crypto.HMAC as Crypto+import Crypto.Hash.Algorithms (SHA1)+import Crypto.MAC.HMAC (HMAC(..), hmac) import qualified Data.Aeson as A-import qualified Data.ByteString.Base16 as Base16+import Data.ByteArray (ScrubbedBytes, convert)+import Data.ByteArray.Encoding (Base(..), convertToBase)+import qualified Data.ByteString as B+import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.Conduit as C import qualified Data.Conduit.List as CL+import Data.Text (Text) import qualified Data.Text as T+import Data.Text.Encoding (encodeUtf8) import qualified Data.Text.Encoding as TE+import Data.Typeable (Typeable) import qualified Network.HTTP.Conduit as H import qualified Network.HTTP.Types as HT -import Facebook.Types-import Facebook.Monad import Facebook.Base import Facebook.Graph+import Facebook.Monad import Facebook.Pager-+import Facebook.Types -- | The type of objects that a real-time update refers to.-data RealTimeUpdateObject =- UserRTUO+data RealTimeUpdateObject+ = UserRTUO | PermissionsRTUO | PageRTUO | ErrorsRTUO | OtherRTUO Text- deriving (Eq, Ord, Show, Typeable)+ deriving (Eq, Ord, Show, Typeable) rtuoToBS :: RealTimeUpdateObject -> ByteString-rtuoToBS (UserRTUO) = "user"+rtuoToBS (UserRTUO) = "user" rtuoToBS (PermissionsRTUO) = "permissions"-rtuoToBS (PageRTUO) = "page"-rtuoToBS (ErrorsRTUO) = "errors"+rtuoToBS (PageRTUO) = "page"+rtuoToBS (ErrorsRTUO) = "errors" rtuoToBS (OtherRTUO other) = TE.encodeUtf8 other instance A.FromJSON RealTimeUpdateObject where- parseJSON (A.String "user") = return UserRTUO+ parseJSON (A.String "user") = return UserRTUO parseJSON (A.String "permissions") = return PermissionsRTUO- parseJSON (A.String "page") = return PageRTUO- parseJSON (A.String "errors") = return ErrorsRTUO- parseJSON (A.String other) = return (OtherRTUO other)+ parseJSON (A.String "page") = return PageRTUO+ parseJSON (A.String "errors") = return ErrorsRTUO+ parseJSON (A.String other) = return (OtherRTUO other) parseJSON _ = mzero instance A.ToJSON RealTimeUpdateObject where toJSON = A.String . TE.decodeUtf8 . rtuoToBS - -- | A field of a 'RealTimeUpdateObject' that you would like to -- receive notifications when changed. type RealTimeUpdateField = ByteString - -- | The URL on your server that will receive the real-time -- updates. Please refer to Facebook's documentation in order to -- see what this URL needs to implement. type RealTimeUpdateUrl = Text - -- | A token that is sent back by Facebook's servers to your -- server in order to verify that you really were trying to -- modify your subscription. type RealTimeUpdateToken = ByteString - -- | Add or modify a subscription for real-time updates. If -- there were no previous subscriptions for the given -- 'RealTimeUpdateObject', then a new subscription is created. -- If there was any previous subscription for the given -- 'RealTimeUpdateObject', it's overriden by this one (even if -- the other subscription had a different callback URL).-modifySubscription :: (R.MonadResource m, MonadBaseControl IO m) =>- RealTimeUpdateObject- -- ^ Type of objects whose subscription you- -- and to add or modify.- -> [RealTimeUpdateField]- -- ^ Fields that you are interested in- -- receiving updates.- -> RealTimeUpdateUrl- -- ^ Your callback URL.- -> RealTimeUpdateToken- -- ^ A verification token.- -> AppAccessToken- -- ^ Access token for your app.- -> FacebookT Auth m ()+modifySubscription ::+ (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m)+ => RealTimeUpdateObject+ -- ^ Type of objects whose subscription you+ -- and to add or modify.+ -> [RealTimeUpdateField]+ -- ^ Fields that you are interested in+ -- receiving updates.+ -> RealTimeUpdateUrl+ -- ^ Your callback URL.+ -> RealTimeUpdateToken+ -- ^ A verification token.+ -> AppAccessToken+ -- ^ Access token for your app.+ -> FacebookT Auth m () modifySubscription object fields callbackUrl verifyToken apptoken = do path <- getSubscriptionsPath- let args = [ "object" #= rtuoToBS object- , "fields" #= fields- , "callback_url" #= callbackUrl- , "verify_token" #= verifyToken- ]+ let args =+ [ "object" #= rtuoToBS object+ , "fields" #= fields+ , "callback_url" #= callbackUrl+ , "verify_token" #= verifyToken+ ] runResourceInFb $ do req <- fbreq path (Just apptoken) args- void $ fbhttp req { H.method = HT.methodPost }+ void $ fbhttp req {H.method = HT.methodPost} return () - -- | (Internal) Get the subscription's path.-getSubscriptionsPath :: Monad m => FacebookT Auth m Text+getSubscriptionsPath :: (Monad m, MonadIO m) => FacebookT Auth m Text getSubscriptionsPath = do creds <- getCreds return $ T.concat ["/", appId creds, "/subscriptions"] - -- | Information returned by Facebook about a real-time update -- notification subscription. data RealTimeUpdateSubscription =- RealTimeUpdateSubscription {- rtusObject :: RealTimeUpdateObject- , rtusCallbackUrl :: RealTimeUpdateUrl- , rtusFields :: [RealTimeUpdateField]- , rtusActive :: Bool- } deriving (Eq, Ord, Show, Typeable)+ RealTimeUpdateSubscription+ { rtusObject :: RealTimeUpdateObject+ , rtusCallbackUrl :: RealTimeUpdateUrl+ , rtusFields :: [RealTimeUpdateField]+ , rtusActive :: Bool+ }+ deriving (Eq, Ord, Show, Typeable) instance A.FromJSON RealTimeUpdateSubscription where parseJSON (A.Object v) =- RealTimeUpdateSubscription- <$> v A..: "object"- <*> v A..: "callback_url"- <*> fmap (map encodeUtf8) (v A..: "fields")- <*> v A..: "active"+ RealTimeUpdateSubscription <$> v A..: "object" <*> v A..: "callback_url" <*>+ fmap (map encodeUtf8) (v A..: "fields") <*>+ v A..: "active" parseJSON _ = mzero - -- | List current real-time update subscriptions. listSubscriptions ::- (R.MonadResource m, MonadBaseControl IO m) =>- AppAccessToken -> FacebookT Auth m [RealTimeUpdateSubscription]+ (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m)+ => AppAccessToken+ -> FacebookT Auth m [RealTimeUpdateSubscription] listSubscriptions apptoken = do path <- getSubscriptionsPath pager <- getObject path [] (Just apptoken) src <- fetchAllNextPages pager- lift $ src C.$$ CL.consume-+ lift $ C.runConduit $ src C..| CL.consume --- | Verifies the input's authenticity (i.e. it comes from+-- | Verifi(es the input's authenticity (i.e. it comes from, MonadIO m) -- Facebook) and integrity by calculating its HMAC-SHA1 (using -- your application secret as the key) and verifying that it -- matches the value from the HTTP request's @X-Hub-Signature@@@ -166,20 +161,23 @@ -- otherwise @Just data@ is returned where @data@ is the original -- data. verifyRealTimeUpdateNotifications ::- Monad m =>- ByteString+ (Monad m, MonadIO m)+ => ByteString -- ^ @X-Hub-Signature@ HTTP header's value. -> L.ByteString -- ^ Request body with JSON-encoded notifications. -> FacebookT Auth m (Maybe L.ByteString) verifyRealTimeUpdateNotifications sig body = do creds <- getCreds- let key :: Crypto.MacKey ctx SHA1- key = Crypto.MacKey (appSecretBS creds)- hash = Crypto.hmac key body- expected = "sha1=" <> Base16.encode (Crypto.encode hash)- return $! if sig `Crypto.constTimeEq` expected then Just body else Nothing-+ let hmacData :: HMAC SHA1+ hmacData = hmac (appSecretBS creds) (L.toStrict body)+ hash :: B.ByteString+ hash = convertToBase Base16 hmacData+ expected = "sha1=" <> hash+ return $!+ if ((convert sig :: ScrubbedBytes) == (convert expected))+ then Just body+ else Nothing -- | Same as 'verifyRealTimeUpdateNotifications' but also parses -- the response as JSON. Returns @Nothing@ if either the@@ -187,8 +185,8 @@ -- 'verifyRealTimeUpdateNotifications' if you need to distinguish -- between these two error conditions). getRealTimeUpdateNotifications ::- (Monad m, A.FromJSON a) =>- ByteString+ (Monad m, A.FromJSON a, MonadIO m)+ => ByteString -- ^ @X-Hub-Signature@ HTTP header's value. -> L.ByteString -- ^ Request body with JSON-encoded notifications.@@ -196,7 +194,6 @@ getRealTimeUpdateNotifications = (liftM (>>= A.decode) .) . verifyRealTimeUpdateNotifications - -- | When data changes and there's a valid subscription, Facebook -- will @POST@ to your 'RealTimeUpdateUrl' with a JSON-encoded -- object containing the notifications. A@@ -211,32 +208,29 @@ -- -- We recommend using 'getRealTimeUpdateNotifications'. data RealTimeUpdateNotification a =- RealTimeUpdateNotification {- rtunObject :: RealTimeUpdateObject- , rtunEntries :: [a]- } deriving (Eq, Ord, Show, Typeable)+ RealTimeUpdateNotification+ { rtunObject :: RealTimeUpdateObject+ , rtunEntries :: [a]+ }+ deriving (Eq, Ord, Show, Typeable) instance A.FromJSON a => A.FromJSON (RealTimeUpdateNotification a) where parseJSON (A.Object v) =- RealTimeUpdateNotification- <$> v A..: "object"- <*> v A..: "entry"+ RealTimeUpdateNotification <$> v A..: "object" <*> v A..: "entry" parseJSON _ = mzero - -- | A notification for the 'UserRTUO' object. data RealTimeUpdateNotificationUserEntry =- RealTimeUpdateNotificationUserEntry {- rtuneUserId :: Id- , rtuneChangedFields :: [RealTimeUpdateField]- , rtuneTime :: Integer- } deriving (Eq, Ord, Show, Typeable)+ RealTimeUpdateNotificationUserEntry+ { rtuneUserId :: Id+ , rtuneChangedFields :: [RealTimeUpdateField]+ , rtuneTime :: Integer+ }+ deriving (Eq, Ord, Show, Typeable) instance A.FromJSON RealTimeUpdateNotificationUserEntry where parseJSON (A.Object v) =- RealTimeUpdateNotificationUserEntry- <$> v A..: "uid"- <*> fmap (map encodeUtf8) (v A..: "changed_fields")- <*> v A..: "time"-+ RealTimeUpdateNotificationUserEntry <$> v A..: "uid" <*>+ fmap (map encodeUtf8) (v A..: "changed_fields") <*>+ v A..: "time" parseJSON _ = mzero
src/Facebook/TestUsers.hs view
@@ -1,31 +1,36 @@ {-# LANGUAGE FlexibleContexts #-}-module Facebook.TestUsers- ( TestUser(..)- , CreateTestUser(..)- , CreateTestUserInstalled(..)- , getTestUsers- , removeTestUser- , createTestUser- , makeFriendConn- , incompleteTestUserAccessToken- ) where+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-} +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 Control.Monad.IO.Class+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 UnliftIO.Exception 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 +38,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, R.MonadUnliftIO m, R.MonadThrow m, MonadIO 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, R.MonadUnliftIO m, R.MonadThrow m, MonadIO 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+ :: (R.MonadUnliftIO m, R.MonadThrow m, R.MonadResource m, MonadIO 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, R.MonadUnliftIO m, R.MonadThrow 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 +144,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, R.MonadUnliftIO m, R.MonadThrow m)+ => TestUser -> TestUser -> FacebookT Auth m ()+makeFriendConn (TestUser {tuAccessToken = Nothing}) _ =+ E.throwIO $+ 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.throwIO $+ 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."+ unless r1 $ E.throwIO $ FbLibraryException "Couldn't make friend request."+ unless r2 $ E.throwIO $ 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 +177,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, R.MonadUnliftIO m, R.MonadThrow 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,40 +1,51 @@-{-# LANGUAGE CPP, DeriveDataTypeable, GADTs, StandaloneDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE GeneralizedNewtypeDeriving#-}+{-# LANGUAGE StandaloneDeriving#-}+{-# LANGUAGE GADTs#-}+{-# LANGUAGE DeriveDataTypeable#-}+{-# LANGUAGE CPP#-}+ module Facebook.Types- ( Credentials(..)- , appIdBS- , appSecretBS- , AccessToken(..)- , UserAccessToken- , AppAccessToken- , AccessTokenData- , Id(..)- , UserId- , accessTokenData- , accessTokenExpires- , accessTokenUserId- , UserKind- , AppKind- , Argument- , (<>)- , FbUTCTime(..)- ) where+ ( Credentials(..)+ , ApiVersion+ , appIdBS+ , appSecretBS+ , AccessToken(..)+ , UserAccessToken+ , AppAccessToken+ , AccessTokenData+ , Id(..)+ , UserId+ , accessTokenData+ , accessTokenExpires+ , accessTokenUserId+ , UserKind+ , AppKind+ , Argument+ , (<>)+ , FbUTCTime(..)+ , FacebookException(..)+ ) where import Control.Applicative ((<$>), (<*>), pure) import Control.Monad (mzero)+import qualified UnliftIO.Exception as E import Data.ByteString (ByteString) import Data.Int (Int64)+#if !(MIN_VERSION_base(4,11,0)) import Data.Monoid (Monoid, mappend)+#endif 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 +54,14 @@ 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.+ , appSecretProof :: Bool -- ^ To enable app secret proof verification+ } deriving (Eq, Ord, Show, Read, Typeable) -- | 'appId' for 'ByteString'. appIdBS :: Credentials -> ByteString@@ -62,6 +72,10 @@ appSecretBS = TE.encodeUtf8 . appSecret +-- | Graph API version.+-- See: https://developers.facebook.com/docs/graph-api/changelog+type ApiVersion = Text+ -- | 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 +94,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 +104,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 +152,51 @@ -- | 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+#if !(MIN_VERSION_base(4,11,0))+(<>)+ :: Monoid a+ => a -> a -> a (<>) = mappend-+#endif ------------------------------------------------------------------------ -- | /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 +204,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 +225,41 @@ -- -- * 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"++-- | An exception that may be thrown by functions on this+-- package. Includes any information provided by Facebook.+data FacebookException =+ -- | An exception coming from Facebook.+ FacebookException { fbeType :: Text+ , fbeMessage :: Text+ }+ -- | An exception coming from the @fb@ package's code.+ | FbLibraryException { fbeMessage :: Text }+ deriving (Eq, Ord, Show, Read, Typeable)++instance A.FromJSON FacebookException where+ parseJSON (A.Object v) =+ FacebookException <$> v A..: "type"+ <*> v A..: "message"+ parseJSON _ = mzero++instance E.Exception FacebookException where+
tests/Main.hs view
@@ -1,27 +1,14 @@-{-# LANGUAGE OverloadedStrings- , Rank2Types- , ScopedTypeVariables- , GADTs- , FlexibleContexts #-}-module Main (main, getCredentials) where+{-# LANGUAGE OverloadedStrings, Rank2Types, ScopedTypeVariables,+ GADTs, FlexibleContexts #-} -import Control.Applicative+module Main+ ( main+ , getCredentials+ ) where+ import Control.Monad (mzero) import Control.Monad.IO.Class (MonadIO(liftIO)) import Control.Monad.Trans.Class (lift)-import Control.Monad.Trans.Control (MonadBaseControl)-import Data.Function (on)-import Data.Int (Int8, Int16, Int32, Int64)-import Data.Maybe (isJust, isNothing)-import Data.Text (Text)-import Data.Time (parseTime)-import Data.Word (Word, Word8, Word16, Word32, Word64)-import System.Environment (getEnv)-import System.Exit (exitFailure)-import System.IO.Error (isDoesNotExistError)---import qualified Control.Exception.Lifted as E import qualified Control.Monad.Trans.Resource as R import qualified Data.Aeson as A import qualified Data.Aeson.Types as A@@ -29,34 +16,43 @@ import qualified Data.Conduit as C import qualified Data.Conduit.List as CL import qualified Data.Default as D+import Data.Int (Int16, Int32, Int64, Int8)+import Data.List ((\\)) import qualified Data.Map as Map+import Data.Maybe (isJust, isNothing) import qualified Data.Maybe as M-import qualified Data.Set as S+import Data.Monoid ((<>))+import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.Time as TI+import Data.Word (Word, Word16, Word32, Word64, Word8) import qualified Facebook as FB import qualified Network.HTTP.Conduit as H+import System.Environment (getEnv)+import System.Exit (exitFailure)+import System.IO.Error (isDoesNotExistError) import qualified Test.QuickCheck as QC-+import qualified UnliftIO.Exception as E 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) True+ showHelp exc+ | not (isDoesNotExistError exc) = E.throwIO 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,54 +70,58 @@ , "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"+invalidCredentials = FB.Credentials "this" "isn't" "valid" False 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.+invalidUserAccessToken =+ FB.UserAccessToken (FB.Id "invalid") "user" farInTheFuture+ where+ Just farInTheFuture = TI.parseTimeM True TI.defaultTimeLocale "%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 = do+ manager <- H.newManager H.tlsManagerSettings+ 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@@ -131,16 +131,21 @@ R.runResourceT $ FB.runFacebookT invalidCredentials manager $ do ret <- E.try $ FB.getAppAccessToken- case ret of- Right token -> fail $ show token+ case ret of+ Right token -> fail $ show token Left (_ :: FB.FacebookException) -> lift $ lift (return () :: IO ())-+ describe' "setApiVersion" $ do+ it "Check default apiVersion" $ runNoAuth $ FB.getApiVersion #?= "v3.2"+ it "Change apiVersion" $+ (runNoAuth $ do+ FB.setApiVersion "v100"+ FB.getApiVersion) #?=+ "v100" 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-+ runNoAuth $ FB.isValid invalidAppAccessToken #?= False describe' "debugToken" $ do it "works on a test user access token" $ do runAuth $@@ -153,301 +158,312 @@ FB.dtAppName ret &?= Just (FB.appName creds) case FB.dtExpiresAt ret of Nothing -> fail "dtExpiresAt is Nothing"- Just t -> compare t now &?= GT+ 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+ 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) ()+ let f :: FB.UserAccessToken+ -> FB.FacebookT FB.Auth (R.ResourceT IO) () f (FB.UserAccessToken uid dt exps) = do uid &?= FB.tuId testUser- dt &?= testUserAccessTokenData+ 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-+ 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 "/220746347971798" [] (Just token)+ let Just r =+ flip A.parseMaybe () $+ const $ (,) <$> obj A..:? "id" <*> obj A..:? "name"+ return r+ val `shouldBe`+ (Just "220746347971798" :: Maybe Text, Just "Ruskin Bond" :: Maybe Text) 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+ runAuth $ do+ token <- FB.getAppAccessToken+ page <- FB.getPage_ (FB.Id "220746347971798") [] (Just token)+ FB.pageId page &?= (FB.Id "220746347971798")+ FB.pageName page &?= Just "Ruskin Bond"+ FB.pageCategory page &?= Nothing+ FB.pageIsPublished page &?= Nothing 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"]-+ FB.pageWebsite page &?= Nothing describe' "listSubscriptions" $ do it "returns something" $ do runAuth $ do token <- FB.getAppAccessToken- val <- FB.listSubscriptions token+ val <- FB.listSubscriptions token length val `seq` return ()- describe' "fetchNextPage" $ do- let fetchNextPageWorks :: FB.Pager A.Value -> FB.FacebookT anyAuth (R.ResourceT IO) ()+ 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."+ 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+ 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 "/app/insights" [] (Just token)-+ 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) ()+ 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+ 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- runNoAuth $ do- backAndForthWorks =<< FB.getObject "/135529993185189_397300340341485/comments" [] Nothing+ runAuth $ do+ token <- FB.getAppAccessToken+ backAndForthWorks =<<+ FB.getObject+ "/5281959998_10150628170209999/comments"+ [("filter", "stream")]+ (Just token) it "seems to work on a private list of app insights" $ do runAuth $ do token <- FB.getAppAccessToken- backAndForthWorks =<< FB.getObject "/app/insights" [] (Just token)-+ 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."+ let hasAtLeast :: C.ConduitT () A.Value IO () -> Int -> IO ()+ src `hasAtLeast` n = C.runConduit $ 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+ 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 "/app/insights" [] (Just token)- src <- FB.fetchAllNextPages pager+ 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)+ hasNextPage = isJust (FB.pagerNext pager) if hasNextPage then liftIO $ src `hasAtLeast` (firstPageElms * 3) -- items- else fail "This isn't an insightful app =(."-+ 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+ -- 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-+ 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+ 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.+ -- 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.+ -- Create a friend connection between the new test users. FB.makeFriendConn testUser1 testUser2- -- Verify that one is a friend of the other.+ -- 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))]--+ 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+ token <- FB.getAppAccessToken+ pager <- FB.getTestUsers token+ src <- FB.fetchAllNextPages pager+ oldList <- liftIO $ R.runResourceT $ C.runConduit $ 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]+ 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+ 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 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 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 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 [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 [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-+ in FB.encodeFbParam (toId j) == FB.encodeFbParam j describe "parseSignedRequest" $ do let exampleSig, exampleData :: B.ByteString- exampleSig = "vlXgu64BQGFSQrY0ZcJBZASMvYvTHu9GQ0YM9rjPSso"+ exampleSig = "vlXgu64BQGFSQrY0ZcJBZASMvYvTHu9GQ0YM9rjPSso" exampleData = "eyJhbGdvcml0aG0iOiJITUFDLVNIQTI1NiIsIjAiOiJwYXlsb2FkIn0"- exampleCreds = FB.Credentials "name" "id" "secret"+ exampleCreds = FB.Credentials "name" "id" "secret" False 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)])+ 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 "addAppSecretProof" $ do+ it "appends appsecret_proof to the query when passing an access token" $ do+ now <- liftIO TI.getCurrentTime+ let token = FB.UserAccessToken "id" "token" now+ query = [("test", "whatever")]+ secretProofQ creds = FB.makeAppSecretProof creds (Just token)+ creds <- getCredentials+ FB.addAppSecretProof creds (Just token) query @?= secretProofQ creds <>+ query describe "FQLTime" $ do it "seems to work" $ do- let input = "[1348678357]"+ 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\"]"+ let input = "[\"2012-09-26T16:52:37+0000\"]" A.decode input @?= Just [output] it "seems to work (unix epoch)" $ do- let input = "[1348678357]"+ 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]-+ 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 []" $ 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"]@@ -457,37 +473,41 @@ 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+ A.eitherDecode (A.encode invalidUserAccessToken) @?=+ Right invalidUserAccessToken it "can be round-tripped with ToJSON/FromJSON (AppKind)" $ do- A.eitherDecode (A.encode invalidAppAccessToken) @?= Right invalidAppAccessToken-+ A.eitherDecode (A.encode invalidAppAccessToken) @?=+ Right invalidAppAccessToken+ describe "makeAppSecretProof" $ do+ it "generates correct hmac" $+ let creds = FB.Credentials "name" "id" "secret" True+ uToken = FB.UserAccessToken (FB.Id "user") "accesstoken" undefined+ proof = FB.makeAppSecretProof creds $ Just uToken+ expectedProof =+ "65138b7ea24e641d38c91befa22b6281953980d1bfd0322956bc29959e1a910c"+ in proof @?= [("appsecret_proof", expectedProof)] -- Wrappers for HUnit operators using MonadIO- (&?=) :: (Eq a, Show a, MonadIO m) => a -> a -> m () v &?= e = liftIO (v @?= e) (#?=) :: (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, R.MonadUnliftIO m, R.MonadThrow 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