fb 0.14.6 → 0.14.7

raw patch · 14 files changed

+275/−127 lines, 14 filesdep ~hspecPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: hspec

API changes (from Hackage documentation)

Files

• fb.cabal +3/−2
• src/Facebook.hs +4/−0
• src/Facebook/Auth.hs +63/−1
• src/Facebook/Base.hs +11/−3
• src/Facebook/FQL.hs +3/−0
• src/Facebook/Graph.hs +1/−112
• src/Facebook/Object/Checkin.hs +1/−0
• src/Facebook/Object/Page.hs +1/−0
• src/Facebook/Object/User.hs +1/−0
• src/Facebook/Pager.hs +126/−0
• src/Facebook/RealTime.hs +1/−0
• src/Facebook/TestUsers.hs +5/−3
• src/Facebook/Types.hs +13/−5
• tests/Main.hs +42/−1

@@ -1,5 +1,5 @@ name:              fb-version:           0.14.6+version:           0.14.7 license:           BSD3 license-file:      LICENSE author:            Felipe Lessa@@ -51,6 +51,7 @@     Facebook.Monad     Facebook.Base     Facebook.Auth+    Facebook.Pager     Facebook.Graph     Facebook.Object.Action     Facebook.Object.Checkin@@ -116,7 +117,7 @@     , data-default     , HUnit     , QuickCheck-    , hspec >= 1.4 && < 1.6+    , hspec >= 1.4 && < 1.7     , fb   extensions:     TypeFamilies

@@ -30,6 +30,8 @@     , getUserAccessTokenStep2     , getUserLogoutUrl     , extendUserAccessToken+    , debugToken+    , DebugToken(..)       -- ** Signed requests     , parseSignedRequest @@ -66,6 +68,7 @@       -- ** Simple types     , (#=)     , SimpleType(..)+    , FbUTCTime(..)       -- ** Complex types     , Place(..)     , Location(..)@@ -128,6 +131,7 @@ import Facebook.Monad import Facebook.Base import Facebook.Auth+import Facebook.Pager import Facebook.Graph import Facebook.Object.Page import Facebook.Object.User

@@ -11,6 +11,8 @@     , hasExpired     , isValid     , parseSignedRequest+    , debugToken+    , DebugToken(..)     ) where  import Control.Applicative@@ -26,6 +28,7 @@ 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@@ -211,7 +214,7 @@     -- ^ Retrieves the 'Text' back from a 'Permission'.  Most of     -- the time you won't need to use this function, but you may     -- need it if you're a library author.-  }+  } deriving (Eq, Ord)  instance Show Permission where     show = show . unPermission@@ -348,3 +351,62 @@   | drem == 3 = bs `B.append` "="   | otherwise = bs   where drem = B.length bs `mod` 4+++-- | Get detailed information about an access token.+debugToken :: (MonadBaseControl IO m, C.MonadResource m) =>+              AppAccessToken  -- ^ Your app access token.+           -> AccessTokenData -- ^ The access token you want to debug.+           -> FacebookT Auth m DebugToken+debugToken appToken userTokenData  = do+  req <- fbreq "/debug_token" (Just appToken) $+           [ ("input_token", TE.encodeUtf8 userTokenData) ]+  ret <- undata <$> (asJson =<< fbhttp req)+  let muserToken = UserAccessToken <$> dtUserId ret+                                   <*> return userTokenData+                                   <*> dtExpiresAt ret+  return ret { dtAccessToken = muserToken }+++-- | Helper used in 'debugToken'.  Unfortunately, we can't use 'Pager' here.+data Undata a =+  Undata {+    undata :: a+  }++instance AE.FromJSON a => AE.FromJSON (Undata a) where+  parseJSON (AE.Object v) =+    Undata <$> v AE..: "data"+  parseJSON _ = mzero+++-- | Detailed information about an access token (cf. 'debugToken').+data DebugToken =+  DebugToken+    { dtAppId       :: Maybe Text+    , dtAppName     :: Maybe Text+    , dtExpiresAt   :: Maybe UTCTime+    , dtIsValid     :: Maybe Bool+    , dtIssuedAt    :: Maybe UTCTime+    , dtScopes      :: Maybe [Permission]+    , dtUserId      :: Maybe Id+    , dtAccessToken :: Maybe UserAccessToken+    } deriving (Eq, Ord, Show, Typeable)+++-- | Note: this instance always sets 'dtAccessToken' to+-- 'Nothing', but 'debugToken' will update this field before+-- returning the final 'DebugToken'.  This is done because we+-- need the 'AccessTokenData', which is not part of FB's+-- 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+  parseJSON _ = mzero

@@ -13,6 +13,7 @@  import Control.Applicative import Control.Monad (mzero)+import Control.Monad.IO.Class (MonadIO) import Data.ByteString.Char8 (ByteString) import Data.Text (Text) import Data.Typeable (Typeable)@@ -23,6 +24,7 @@ import qualified Data.Aeson as A import qualified Data.Attoparsec.Char8 as AT import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L import qualified Data.Conduit as C import qualified Data.Conduit.Attoparsec as C import qualified Data.Conduit.List as CL@@ -32,7 +34,7 @@ import qualified Network.HTTP.Types as HT  #if DEBUG-import Control.Monad.IO.Class (liftIO)+import Control.Monad.IO.Class (MonadIO, liftIO) import Text.Printf (printf) #endif @@ -83,16 +85,22 @@  -- | Converts a plain 'H.Response' coming from 'H.http' into a -- JSON value.-asJson :: (MonadTrans t, C.MonadThrow m, A.FromJSON a) =>+asJson :: (MonadIO m, MonadTrans t, C.MonadThrow m, A.FromJSON a) =>           H.Response (C.ResumableSource m ByteString)        -> t m a asJson = lift . asJsonHelper -asJsonHelper :: (C.MonadThrow m, A.FromJSON a) =>+asJsonHelper :: (MonadIO m, C.MonadThrow m, A.FromJSON a) =>                 H.Response (C.ResumableSource m ByteString)              -> m a asJsonHelper response = do+#if DEBUG+  bs <- H.responseBody response C.$$+- fmap L.fromChunks CL.consume+  _ <- 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'+#endif   case A.fromJSON val of     A.Success r -> return r     A.Error str ->

@@ -21,6 +21,7 @@ import Facebook.Monad import Facebook.Base import Facebook.Graph+import Facebook.Pager   -- | Query the Facebook Graph using FQL.@@ -44,6 +45,8 @@                    . 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

@@ -4,11 +4,6 @@     , postObject     , deleteObject     , searchObjects-    , Pager(..)-    , fetchNextPage-    , fetchPreviousPage-    , fetchAllNextPages-    , fetchAllPreviousPages     , (#=)     , SimpleType(..)     , Place(..)@@ -20,9 +15,7 @@  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.ByteString.Char8 (ByteString) import Data.Int (Int8, Int16, Int32, Int64) import Data.List (intersperse)@@ -47,6 +40,7 @@ import Facebook.Base import Facebook.Monad import Facebook.Types+import Facebook.Pager   -- | Make a raw @GET@ request to Facebook's Graph API.@@ -101,111 +95,6 @@               -> FacebookT anyAuth m (Pager a) searchObjects objectType keyword query = getObject "/search" query'   where query' = ("q" #= keyword) : ("type" #= objectType) : query------------------------------------------------------------------------------ | Many Graph API results are returned as a JSON object with--- the following structure:------ @--- {---   \"data\": [---     ...item 1...,---          :---     ...item n...---   ],---   \"paging\": {---     \"previous\": \"http://...link to previous page...\",---     \"next\":     \"http://...link to next page...\"---   }--- }--- @------ Only the @\"data\"@ field is required, the others may or may--- not appear.------ 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-  } deriving (Eq, Ord, Show, Read, Typeable)--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"-  parseJSON _ = mzero----- | Tries to fetch the next page of a 'Pager'.  Returns--- 'Nothing' whenever the current @Pager@ does not have a--- 'pagerNext'.-fetchNextPage :: (C.MonadResource m, MonadBaseControl IO m, A.FromJSON a) =>-                 Pager a -> FacebookT anyAuth m (Maybe (Pager a))-fetchNextPage = fetchHelper pagerNext----- | Tries to fetch the previous page of a 'Pager'.  Returns--- 'Nothing' whenever the current @Pager@ does not have a--- 'pagerPrevious'.-fetchPreviousPage :: (C.MonadResource m, MonadBaseControl IO m, A.FromJSON a) =>-                     Pager a -> FacebookT anyAuth m (Maybe (Pager a))-fetchPreviousPage = fetchHelper pagerPrevious----- | (Internal) See 'fetchNextPage' and 'fetchPreviousPage'.-fetchHelper :: (C.MonadResource m, MonadBaseControl IO m, A.FromJSON a) =>-               (Pager a -> Maybe String) -> Pager a -> FacebookT anyAuth m (Maybe (Pager a))-fetchHelper pagerRef pager =-  case pagerRef pager of-    Nothing  -> return Nothing-    Just url -> do-      req <- liftIO (H.parseUrl 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 = 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 = 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 pagerRef pager = do-  manager <- getManager-  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 }-        start =<< lift (C.runResourceT $ asJsonHelper =<< get)-      start p = go (pagerData p) $! pagerRef p-  return (start pager)   ----------------------------------------------------------------------

@@ -21,6 +21,7 @@ import Facebook.Types import Facebook.Monad import Facebook.Graph+import Facebook.Pager   -- | A Facebook check-in (see

@@ -20,6 +20,7 @@ import Facebook.Graph import Facebook.Monad import Facebook.Types+import Facebook.Pager  -- | A Facebook page (see -- <https://developers.facebook.com/docs/reference/api/page/>).

@@ -24,6 +24,7 @@ import Facebook.Types import Facebook.Monad import Facebook.Graph+import Facebook.Pager import Facebook.Object.Checkin  

@@ -0,0 +1,126 @@+{-# LANGUAGE ConstraintKinds, DeriveDataTypeable, FlexibleContexts, OverloadedStrings #-}+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 Data.Aeson as A+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:+--+-- @+-- {+--   \"data\": [+--     ...item 1...,+--          :+--     ...item n...+--   ],+--   \"paging\": {+--     \"previous\": \"http://...link to previous page...\",+--     \"next\":     \"http://...link to next page...\"+--   }+-- }+-- @+--+-- Only the @\"data\"@ field is required, the others may or may+-- not appear.+--+-- 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+  } deriving (Eq, Ord, Show, Read, Typeable)++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"+  parseJSON _ = mzero+++-- | Tries to fetch the next page of a 'Pager'.  Returns+-- 'Nothing' whenever the current @Pager@ does not have a+-- 'pagerNext'.+fetchNextPage :: (C.MonadResource m, MonadBaseControl IO m, A.FromJSON a) =>+                 Pager a -> FacebookT anyAuth m (Maybe (Pager a))+fetchNextPage = fetchHelper pagerNext+++-- | Tries to fetch the previous page of a 'Pager'.  Returns+-- 'Nothing' whenever the current @Pager@ does not have a+-- 'pagerPrevious'.+fetchPreviousPage :: (C.MonadResource m, MonadBaseControl IO m, A.FromJSON a) =>+                     Pager a -> FacebookT anyAuth m (Maybe (Pager a))+fetchPreviousPage = fetchHelper pagerPrevious+++-- | (Internal) See 'fetchNextPage' and 'fetchPreviousPage'.+fetchHelper :: (C.MonadResource m, MonadBaseControl IO m, A.FromJSON a) =>+               (Pager a -> Maybe String) -> Pager a -> FacebookT anyAuth m (Maybe (Pager a))+fetchHelper pagerRef pager =+  case pagerRef pager of+    Nothing  -> return Nothing+    Just url -> do+      req <- liftIO (H.parseUrl 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 = 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 = 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 pagerRef pager = do+  manager <- getManager+  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 }+        start =<< lift (C.runResourceT $ asJsonHelper =<< get)+      start p = go (pagerData p) $! pagerRef p+  return (start pager)

@@ -37,6 +37,7 @@ import Facebook.Monad import Facebook.Base import Facebook.Graph+import Facebook.Pager   -- | The type of objects that a real-time update refers to.

@@ -31,6 +31,7 @@ import Facebook.Graph import Facebook.Monad import Facebook.Types+import Facebook.Pager   -- | A Facebook test user.@@ -120,10 +121,11 @@ -- | Remove an existing test user. removeTestUser :: (C.MonadResource m, MonadBaseControl IO m)                   => TestUser       -- ^ The TestUser to be removed.-                  -> AppAccessToken -- ^ Access token for your app.+                  -> 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")] (Just token)+removeTestUser testUser _token =+  getObjectBool ("/" <> idCode (tuId testUser)) [("method","delete")] token+  where token = incompleteTestUserAccessToken testUser   -- | Make a friend connection between two test users.

@@ -26,6 +26,7 @@ import Data.String (IsString) import Data.Text (Text) import Data.Time (UTCTime, parseTime)+import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Data.Typeable (Typeable, Typeable1) import System.Locale (defaultTimeLocale) @@ -145,15 +146,22 @@ (<>) = mappend  --- | (Internal) @newtype@ for 'UTCTime' that follows Facebook's--- conventions of JSON parsing.  While @aeson@ expects a format--- of @%FT%T%Q@, Facebook gives time values formatted as--- @%FT%T%z@.+-- | @newtype@ for 'UTCTime' that follows Facebook's+-- conventions of JSON parsing.+--+--  * As a string, while @aeson@ expects a format of @%FT%T%Q@,+--    Facebook gives time values formatted as @%FT%T%z@.+--+--  * As a number, 'FbUTCTime' accepts a number of seconds since+--    the Unix epoch. newtype FbUTCTime = FbUTCTime { unFbUTCTime :: UTCTime }+  deriving (Eq, Ord, Show, Read, Typeable)  instance A.FromJSON FbUTCTime where   parseJSON (A.String t) =     case parseTime defaultTimeLocale "%FT%T%z" (T.unpack t) of       Just d -> return (FbUTCTime d)       _      -> fail $ "could not parse FbUTCTime string " ++ show t-  parseJSON _ = fail "could not parse FbUTCTime from something which is not a string"+  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"

@@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings            , Rank2Types            , ScopedTypeVariables+           , GADTs            , FlexibleContexts #-} module Main (main, getCredentials) where @@ -97,11 +98,13 @@   hspec $ do     -- Run the tests twice, once in Facebook's production tier...     facebookTests "Production tier: "+                  creds                   manager                   (C.runResourceT . FB.runFacebookT creds manager)                   (C.runResourceT . FB.runNoAuthFacebookT manager)     -- ...and the other in Facebook's beta tier.     facebookTests "Beta tier: "+                  creds                   manager                   (C.runResourceT . FB.beta_runFacebookT creds manager)                   (C.runResourceT . FB.beta_runNoAuthFacebookT manager)@@ -110,11 +113,12 @@     libraryTests manager  facebookTests :: String+              -> FB.Credentials               -> H.Manager               -> (forall a. FB.FacebookT FB.Auth   (C.ResourceT IO) a -> IO a)               -> (forall a. FB.FacebookT FB.NoAuth (C.ResourceT IO) a -> IO a)               -> Spec-facebookTests pretitle manager runAuth runNoAuth = do+facebookTests pretitle creds manager runAuth runNoAuth = do   let describe' = describe . (pretitle ++)    describe' "getAppAccessToken" $ do@@ -136,6 +140,34 @@     it "returns False on a clearly invalid app access token" $       runNoAuth $ FB.isValid invalidAppAccessToken  #?= False +  describe' "debugToken" $ do+    it "works on a test user access token" $ do+      runAuth $+        withTestUser D.def $ \testUser -> do+          Just testUserAccessTokenData <- return (FB.tuAccessToken testUser)+          appToken <- FB.getAppAccessToken+          ret <- FB.debugToken appToken testUserAccessTokenData+          now <- liftIO TI.getCurrentTime+          FB.dtAppId ret &?= Just (FB.appId creds)+          FB.dtAppName ret &?= Just (FB.appName creds)+          case FB.dtExpiresAt ret of+            Nothing -> fail "dtExpiresAt is Nothing"+            Just t  -> compare t now &?= GT+          FB.dtIsValid ret &?= Just True+          case FB.dtIssuedAt ret of+            Nothing -> return () -- ok since it's a test user+            Just t  -> compare t now &?= LT+          isJust (FB.dtScopes ret) &?= True+          FB.dtUserId ret &?= Just (FB.tuId testUser)+{-+          case FB.dtAccessToken ret of+            Nothing -> fail "dtAccessToken is Nothing"+            Just (FB.UserAccessToken uid dt exps) -> do+              uid &?= FB.tuId testUser+              dt  &?= testUserAccessTokenData+              Just exps &?= FB.dtExpiresAt ret+-}+   describe' "getObject" $ do     it "is able to fetch Facebook's own page" $       runNoAuth $ do@@ -379,6 +411,15 @@     it "seems to work" $ do       let input  = "[1348678357]"           output = FB.FQLTime (read "2012-09-26 16:52:37 UTC")+      A.decode input @?= Just [output]++  describe "FbUTCTime" $ do+    let output = FB.FbUTCTime (read "2012-09-26 16:52:37 UTC")+    it "seems to work (string)" $ do+      let input  = "[\"2012-09-26T16:52:37+0000\"]"+      A.decode input @?= Just [output]+    it "seems to work (unix epoch)" $ do+      let input  = "[1348678357]"       A.decode input @?= Just [output]    describe "FQLList" $ do