fb 0.12.6 → 0.12.7

raw patch · 5 files changed

+286/−8 lines, 5 filesdep +data-defaultPVP ok

version bump matches the API change (PVP)

Dependencies added: data-default

API changes (from Hackage documentation)

Files

• fb.cabal +3/−1
• src/Facebook.hs +11/−0
• src/Facebook/Graph.hs +7/−2
• src/Facebook/TestUsers.hs +183/−0
• tests/Main.hs +82/−5

@@ -1,5 +1,5 @@ name:              fb-version:           0.12.6+version:           0.12.7 license:           BSD3 license-file:      LICENSE author:            Felipe Lessa@@ -58,6 +58,7 @@     Facebook.Object.Page     Facebook.RealTime     Facebook.FQL+    Facebook.TestUsers   build-depends:       base               >= 4       && < 5     , lifted-base        >= 0.1     && < 0.2@@ -68,6 +69,7 @@     , monad-control     , resourcet     , conduit            >= 0.5     && < 0.6+    , data-default     , http-types     , http-conduit       >= 1.5     && < 1.7     , attoparsec         >= 0.10    && < 0.11

@@ -88,6 +88,16 @@       -- * FQL     , fqlQuery +      -- * Test User API+    , getTestUsers+    , removeTestUser+    , createTestUser+    , makeFriendConn+    , incompleteTestUserAccessToken+    , TestUser(..)+    , CreateTestUser(..)+    , CreateTestUserInstalled(..)+       -- * Raw access to the Graph API     , getObject     , postObject@@ -113,3 +123,4 @@ import Facebook.Object.Checkin import Facebook.RealTime import Facebook.FQL+import Facebook.TestUsers

@@ -43,9 +43,10 @@ import qualified Network.HTTP.Types as HT  -import Facebook.Types-import Facebook.Monad+import Facebook.Auth import Facebook.Base+import Facebook.Monad+import Facebook.Types   -- | The identification code of an object.@@ -270,6 +271,10 @@ -- | An object's 'Id' code. instance SimpleType Id where     encodeFbParam = idCode++-- | 'Permission' is a @newtype@ of 'Text'+instance SimpleType Permission where+    encodeFbParam = encodeFbParam . unPermission  -- | A comma-separated list of simple types.  This definition -- doesn't work everywhere, just for a few combinations that

@@ -0,0 +1,183 @@+{-# LANGUAGE FlexibleContexts #-}+module Facebook.TestUsers+    ( TestUser(..)+    , CreateTestUser(..)+    , CreateTestUserInstalled(..)+    , getTestUsers+    , removeTestUser+    , createTestUser+    , makeFriendConn+    , incompleteTestUserAccessToken+    ) where+++import Control.Applicative ((<$>), (<*>))+import Control.Monad (unless, mzero)+import Control.Monad.Trans.Control (MonadBaseControl)+import Data.Default+import Data.Text+import Data.Time (UTCTime(..), Day(..))+import Data.Typeable (Typeable)+++import qualified Control.Exception.Lifted as E+import qualified Data.Aeson as A+import qualified Data.ByteString.Char8 as B+import qualified Data.Conduit as C+++import Facebook.Auth+import Facebook.Base+import Facebook.Graph+import Facebook.Monad+import Facebook.Types+++-- | 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)+++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++++-- | 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+   }+++-- | 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.++-- | Default instance for 'CreateTestUser'.+instance Default CreateTestUser where+    def = CreateTestUser def def def++-- | Default instance for 'CreateTestUserInstalled'.+instance Default CreateTestUserInstalled where+    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 ]+++-- | Create a new test user.+createTestUser :: (C.MonadResource m, MonadBaseControl IO m)+                  => CreateTestUser -- ^ How the test user should be+                                    -- created.+                  -> AppAccessToken -- ^ Access token for your app.+                  -> FacebookT Auth m TestUser+createTestUser userInfo token = do+  creds <- getCreds+  let query = ("method","post") : createTestUserQueryArgs userInfo+  getObject ("/" <> appId creds <> "/accounts/test-users") query (Just token)+++-- | Get a list of test users.+getTestUsers :: (C.MonadResource m, MonadBaseControl IO m)+                => AppAccessToken      -- ^ Access token for your app.+                -> FacebookT Auth m (Pager TestUser)+getTestUsers token = do+  creds <- getCreds+  getObject ("/" <> appId creds <> "/accounts/test-users") [] (Just token)+++-- | Remove an existing test user.+removeTestUser :: (C.MonadResource m, MonadBaseControl IO m)+                  => TestUser       -- ^ The TestUser to be removed.+                  -> AppAccessToken -- ^ Access token for your app.+                  -> FacebookT Auth m Bool+removeTestUser testUser token =+  getObjectBool ("/" <> tuId testUser) [("method","delete")] (Just token)+++-- | Make a friend connection between two test users.+--+-- This is how Facebook's API work: two calls must be made. The first+-- call has the format: \"\/userA_id\/friends\/userB_id\" with the+-- access token of user A as query parameter. The second call has the+-- 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 :: (C.MonadResource m, MonadBaseControl IO m)+                  => TestUser+                  -> TestUser+                  -> FacebookT Auth m ()+makeFriendConn (TestUser { tuAccessToken = Nothing }) _ = E.throw $+  FbLibraryException "The test user passed on the first argument doesn't have\+                     \ a token. Both users must have a token."+makeFriendConn _ (TestUser { tuAccessToken = Nothing }) = E.throw $+  FbLibraryException "The test user passed on the second argument doesn't have\+                     \ a token. Both users must have a token."+makeFriendConn (TestUser {tuId = id1, tuAccessToken = (Just token1)}) (TestUser {tuId = id2, tuAccessToken = (Just token2)}) = do+  let friendReq userId1 userId2 token =+          getObjectBool ("/" <> userId1 <> "/friends/" <> userId2)+                        [ "method" #= ("post" :: B.ByteString),+                          "access_token" #= token ]+                        Nothing+  r1 <- friendReq id1 id2 token1+  r2 <- friendReq id2 id1 token2+  unless r1 $ E.throw $ FbLibraryException "Couldn't make friend request."+  unless r2 $ E.throw $ FbLibraryException "Couldn't accept friend request."+  return ()+++-- | Create an 'UserAccessToken' from a 'TestUser'.  It's incomplete+-- because it will not have the right expiration time.+incompleteTestUserAccessToken :: TestUser -> Maybe UserAccessToken+incompleteTestUserAccessToken t = do+  tokenData <- tuAccessToken t+  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 :: (C.MonadResource m, MonadBaseControl IO m)+                 => B.ByteString+                 -- ^ 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")

@@ -1,12 +1,15 @@ {-# LANGUAGE OverloadedStrings            , Rank2Types-           , ScopedTypeVariables #-}+           , ScopedTypeVariables+           , FlexibleContexts #-} module Main (main, getCredentials) where  import Control.Applicative 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) import Data.Maybe (isJust, isNothing) import Data.Text (Text)@@ -16,22 +19,28 @@ import System.Exit (exitFailure) import System.IO.Error (isDoesNotExistError) ++import qualified Control.Exception.Lifted as E import qualified Data.Aeson as A import qualified Data.Aeson.Types as A-import qualified Data.Conduit as C import qualified Data.ByteString.Char8 as B+import qualified Data.Conduit as C+import qualified Data.Conduit.List as CL+import qualified Data.Default as D+import qualified Data.Maybe as M+import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.Time as TI-import qualified Control.Exception.Lifted as E import qualified Facebook as FB import qualified Network.HTTP.Conduit as H+import qualified Test.QuickCheck as QC + import Test.HUnit ((@?=))+import Test.Hspec.HUnit () import Test.Hspec.Monadic import Test.Hspec.QuickCheck-import Test.Hspec.HUnit ()-import qualified Test.QuickCheck as QC   -- | Grab the Facebook credentials from the environment.@@ -106,6 +115,7 @@               -> Spec facebookTests pretitle manager runAuth runNoAuth = do   let describe' = describe . (pretitle ++)+   describe' "getAppAccessToken" $ do     it "works and returns a valid app access token" $       runAuth $ do@@ -226,6 +236,60 @@           then liftIO $ src `hasAtLeast` (firstPageElms * 3) -- items           else fail "This isn't an insightful app =(." +  describe' "createTestUser/removeTestUser/getTestUser" $ do+    it "creates and removes a new test user" $ do+      runAuth $ do+        token <- FB.getAppAccessToken+        -- New test user information+        let installed = FB.CreateTestUserInstalled+                         [ "read_stream"+                         , "read_friendlists"+                         , "publish_stream" ]+            userInfo = FB.CreateTestUser+                       { 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+        FB.removeTestUser newTestUser token+        -- Check user attributes+        FB.userId createdUser     &?= FB.tuId newTestUser+        FB.userName createdUser   &?= Just "Gabriel"+        FB.userLocale createdUser &?= Just "en_US"+        -- Check if the token is valid+        FB.isValid newTestUserToken   #?= False++  describe' "makeFriendConn" $ do+    it "creates two new test users, makes them friends and deletes them" $ do+      runAuth $+        withTestUser D.def $ \testUser1 ->+        withTestUser D.def $ \testUser2 -> do+            let Just tokenUserA = FB.incompleteTestUserAccessToken testUser1+            let Just tokenUserB = FB.incompleteTestUserAccessToken testUser2+            -- Create a friend connection between the new test users+            friendship <- FB.makeFriendConn testUser1 testUser2+            -- Check if the new test users' tokens are valid+            FB.isValid tokenUserA #?= True+            FB.isValid tokenUserB #?= True++  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 $ C.runResourceT $ src C.$$ CL.consume+        withTestUser D.def $ \testUser -> do+          let (%?=) = (&?=) `on` fmap FB.tuId+              (//)  = S.difference `on` S.fromList+          newList <- FB.pagerData <$> FB.getTestUsers token+          S.toList (newList // oldList) %?= [testUser]++ newtype PageName = PageName Text deriving (Eq, Show) instance A.FromJSON PageName where   parseJSON (A.Object v) = PageName <$> (v A..: "name")@@ -313,3 +377,16 @@ instance QC.Arbitrary Text where     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 :: (C.MonadResource m, MonadBaseControl IO m)+                => FB.CreateTestUser+                -> (FB.TestUser -> FB.FacebookT FB.Auth m a)+                -> FB.FacebookT FB.Auth m a+withTestUser ctu action = do+  token <- FB.getAppAccessToken+  E.bracket (FB.createTestUser ctu token)+            (flip FB.removeTestUser token)+            action