diff --git a/fb.cabal b/fb.cabal --- a/fb.cabal +++ b/fb.cabal @@ -1,5 +1,5 @@ name: fb -version: 0.11.2.1 +version: 0.12 license: BSD3 license-file: LICENSE author: Felipe Lessa @@ -51,10 +51,12 @@ Facebook.Base Facebook.Auth Facebook.Graph + Facebook.Object.Action + Facebook.Object.Checkin Facebook.Object.User Facebook.Object.Page - Facebook.OpenGraph Facebook.RealTime + Facebook.FQL build-depends: base >= 4 && < 5 , lifted-base >= 0.1 && < 0.2 diff --git a/src/Facebook.hs b/src/Facebook.hs --- a/src/Facebook.hs +++ b/src/Facebook.hs @@ -33,31 +33,41 @@ -- ** Signed requests , parseSignedRequest - -- * Facebook's Graph API Objects + -- * Facebook's Graph API -- ** User , User(..) , UserId , Gender(..) - , UserLocation(..) , getUser , searchUsers -- ** Page , Page(..) , getPage , searchPages - - -- * Facebook's Open Graph API -- ** Actions - , createAction , Action + , createAction -- ** Checkins + , Checkin(..) + , CheckinFrom(..) + , getCheckin , createCheckin - -- ** FQL - , fqlQuery - , FQLResult(..) - -- ** Helpers + + -- * Facebook's Graph API basic functionality + -- ** Simple types , (#=) , SimpleType(..) + -- ** Complex types + , Place(..) + , Location(..) + , GeoCoordinates(..) + , Tag(..) + -- ** Pagination + , Pager(..) + , fetchNextPage + , fetchPreviousPage + , fetchAllNextPages + , fetchAllPreviousPages -- * Real-time update notifications -- ** Subscriptions @@ -74,13 +84,15 @@ , RealTimeUpdateNotification(..) , RealTimeUpdateNotificationUserEntry(..) + -- * FQL + , fqlQuery + -- * Raw access to the Graph API , getObject , postObject + , searchObjects , Id(..) , Argument - , searchObjects - , SearchResultPage(..) -- * Exceptions , FacebookException(..) @@ -96,5 +108,7 @@ import Facebook.Graph import Facebook.Object.Page import Facebook.Object.User -import Facebook.OpenGraph +import Facebook.Object.Action +import Facebook.Object.Checkin import Facebook.RealTime +import Facebook.FQL diff --git a/src/Facebook/Base.hs b/src/Facebook/Base.hs --- a/src/Facebook/Base.hs +++ b/src/Facebook/Base.hs @@ -6,6 +6,7 @@ , asBS , FacebookException(..) , fbhttp + , fbhttpHelper , httpCheck ) where @@ -16,6 +17,7 @@ import Data.Typeable (Typeable) import qualified Control.Exception.Lifted as E +import Control.Monad.Trans.Class (MonadTrans) import Control.Monad.Trans.Control (MonadBaseControl) import qualified Data.Aeson as A import qualified Data.Attoparsec.Char8 as AT @@ -78,11 +80,16 @@ -- | Converts a plain 'H.Response' coming from 'H.http' into a -- JSON value. -asJson :: (C.MonadThrow m, A.FromJSON a) => +asJson :: (MonadTrans t, C.MonadThrow m, A.FromJSON a) => H.Response (C.ResumableSource m ByteString) - -> FacebookT anyAuth m a -asJson response = do - val <- lift $ H.responseBody response C.$$+- C.sinkParser A.json' + -> t m a +asJson = lift . asJsonHelper + +asJsonHelper :: (C.MonadThrow m, A.FromJSON a) => + H.Response (C.ResumableSource m ByteString) + -> m a +asJsonHelper response = do + val <- H.responseBody response C.$$+- C.sinkParser A.json' case A.fromJSON val of A.Success r -> return r A.Error str -> @@ -126,11 +133,18 @@ -> FacebookT anyAuth m (H.Response (C.ResumableSource m ByteString)) fbhttp req = do manager <- getManager + lift (fbhttpHelper manager req) + +fbhttpHelper :: (MonadBaseControl IO m, C.MonadResource m) => + H.Manager + -> H.Request m + -> m (H.Response (C.ResumableSource m ByteString)) +fbhttpHelper manager req = do let req' = req { H.checkStatus = \_ _ -> Nothing } #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.Response status _ headers _) <- lift (H.http req' manager) + response@(H.Response status _ headers _) <- H.http req' manager #if DEBUG _ <- liftIO $ printf "fbhttp response status: %s\n" (show status) #endif @@ -138,7 +152,7 @@ then return response else do let statusexc = H.StatusCodeException status headers - val <- E.try $ asJson response + val <- E.try $ asJsonHelper response case val :: Either E.SomeException FacebookException of Right fbexc -> E.throw fbexc Left _ -> do diff --git a/src/Facebook/FQL.hs b/src/Facebook/FQL.hs new file mode 100644 --- /dev/null +++ b/src/Facebook/FQL.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE FlexibleContexts, OverloadedStrings #-} +module Facebook.FQL + ( fqlQuery + ) where + +import Control.Monad.Trans.Control (MonadBaseControl) +import Data.Text (Text) + +import qualified Data.Aeson as A +import qualified Data.Conduit as C + +import Facebook.Types +import Facebook.Monad +import Facebook.Base +import Facebook.Graph + + +-- | Query the Facebook Graph using FQL. +fqlQuery :: (C.MonadResource m, MonadBaseControl IO 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 diff --git a/src/Facebook/Graph.hs b/src/Facebook/Graph.hs --- a/src/Facebook/Graph.hs +++ b/src/Facebook/Graph.hs @@ -1,24 +1,43 @@ {-# LANGUAGE DeriveDataTypeable, FlexibleContexts, OverloadedStrings #-} module Facebook.Graph - ( getObject + ( Id(..) + , getObject , postObject - , Id(..) , searchObjects - , SearchResultPage(..) + , Pager(..) + , fetchNextPage + , fetchPreviousPage + , fetchAllNextPages + , fetchAllPreviousPages + , (#=) + , SimpleType(..) + , Place(..) + , Location(..) + , GeoCoordinates(..) + , Tag(..) ) where import Control.Applicative -import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad (mzero) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Control (MonadBaseControl) import Data.ByteString.Char8 (ByteString) --- import Data.Text (Text) +import Data.Int (Int8, Int16, Int32) +import Data.List (intersperse) +import Data.Text (Text) import Data.Typeable (Typeable) +import Data.Word (Word8, Word16, Word32, Word) +import System.Locale (defaultTimeLocale) --- import qualified Control.Exception.Lifted as E import qualified Data.Aeson as A +import qualified Data.Aeson.Encode as AE (fromValue) +import qualified Data.ByteString.Char8 as B import qualified Data.Conduit as C --- import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TLB +import qualified Data.Time as TI import qualified Network.HTTP.Conduit as H import qualified Network.HTTP.Types as HT @@ -28,6 +47,15 @@ import Facebook.Base +-- | The identification code of an object. +newtype Id = Id { idCode :: ByteString } + deriving (Eq, Ord, Show, Read, Typeable) + +instance A.FromJSON Id where + parseJSON (A.Object v) = Id <$> v A..: "id" + parseJSON other = Id <$> A.parseJSON other + + -- | Make a raw @GET@ request to Facebook's Graph API. getObject :: (C.MonadResource m, MonadBaseControl IO m, A.FromJSON a) => ByteString -- ^ Path (should begin with a slash @\/@) @@ -51,15 +79,6 @@ asJson =<< fbhttp req { H.method = HT.methodPost } --- | The identification code of an object. -newtype Id = Id { idCode :: ByteString } - deriving (Eq, Ord, Show, Read, Typeable) - -instance A.FromJSON Id where - parseJSON (A.Object v) = Id <$> v A..: "id" - parseJSON other = Id <$> A.parseJSON other - - -- | Make a raw @GET@ request to the /search endpoint of Facebook’s -- Graph API. Returns a raw JSON 'A.Value'. searchObjects :: (C.MonadResource m, MonadBaseControl IO m, A.FromJSON a) @@ -67,35 +86,276 @@ -> ByteString -- ^ The keyword to search for -> [Argument] -- ^ Additional arguments to pass -> Maybe UserAccessToken -- ^ Optional access token - -> FacebookT anyAuth m (SearchResultPage a) + -> FacebookT anyAuth m (Pager a) searchObjects objectType keyword query = getObject "/search" query' where query' = ("q", keyword) : ("type", objectType) : query --- | The result object for searchObjects. The type parameter is --- expected to be an instance of A.FromJSON, but nothing has been done --- to assure that Facebook will return the type expected. -data SearchResultPage a = SearchResultPage - { searchResults :: [a] - , searchPage :: Maybe Pager - } deriving (Eq, Ord, Show, Read, Typeable) +---------------------------------------------------------------------- -instance (A.FromJSON a) => A.FromJSON (SearchResultPage a) where - parseJSON (A.Object v) = SearchResultPage - <$> v A..: "data" - <*> v A..:? "paging" + +-- | 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 --- | Simply wraps potential links for previous and next pages within a --- search result set. TODO: Replace with a type that encapsulates the --- paging requests instead of just their URLs? -data Pager = Pager { previousPage :: Maybe ByteString - , nextPage :: Maybe ByteString - } deriving (Eq, Ord, Show, Read, Typeable) +-- | 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 -instance A.FromJSON Pager where - parseJSON (A.Object v) = Pager - <$> v A..:? "previous" - <*> v A..:? "next" + +-- | 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, C.MonadResource n, MonadBaseControl IO 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, C.MonadResource n, MonadBaseControl IO n, A.FromJSON a) => + Pager a -> FacebookT anyAuth m (C.Source n a) +fetchAllPreviousPages = fetchAllHelper pagerPrevious + + +-- | (Internal) See 'fetchAllNextPages' and 'fetchAllPreviousPages'. +fetchAllHelper :: + (Monad m, C.MonadResource n, MonadBaseControl IO 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 =<< asJson =<< lift get + start p = go (pagerData p) $! pagerRef pager + return (start pager) + + +---------------------------------------------------------------------- + + +-- | Create an 'Argument' with a 'SimpleType'. See the docs on +-- 'createAction' for an example. +(#=) :: SimpleType a => ByteString -> a -> Argument +p #= v = (p, encodeFbParam v) + + +-- | Class for data types that may be represented as a Facebook +-- simple type. (see +-- ). +class SimpleType a where + encodeFbParam :: a -> B.ByteString + +-- | Facebook's simple type @Boolean@. +instance SimpleType Bool where + 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" +-- | Facebook's simple type @DateTime@. +instance SimpleType TI.UTCTime where + 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 + +-- @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 +-- | Facebook's simple type @Float@. +instance SimpleType Double where + encodeFbParam = showBS + +-- | Facebook's simple type @Integer@. +instance SimpleType Int where + encodeFbParam = showBS +-- | Facebook's simple type @Integer@. +instance SimpleType Word where + encodeFbParam = showBS +-- | Facebook's simple type @Integer@. +instance SimpleType Int8 where + encodeFbParam = showBS +-- | Facebook's simple type @Integer@. +instance SimpleType Word8 where + encodeFbParam = showBS +-- | Facebook's simple type @Integer@. +instance SimpleType Int16 where + encodeFbParam = showBS +-- | Facebook's simple type @Integer@. +instance SimpleType Word16 where + encodeFbParam = showBS +-- | Facebook's simple type @Integer@. +instance SimpleType Int32 where + encodeFbParam = showBS +-- | Facebook's simple type @Integer@. +instance SimpleType Word32 where + encodeFbParam = showBS + +-- | Facebook's simple type @String@. +instance SimpleType Text where + encodeFbParam = TE.encodeUtf8 +-- | Facebook's simple type @String@. +instance SimpleType ByteString where + encodeFbParam = id + +-- | An object's 'Id' code. +instance SimpleType Id where + encodeFbParam = idCode + +-- | A comma-separated list of simple types. This definition +-- doesn't work everywhere, just for a few combinations that +-- Facebook uses (e.g. @[Int]@). Also, encoding a list of lists +-- 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 + +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) + +instance A.FromJSON Place where + parseJSON (A.Object v) = + 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) + +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 + parseJSON _ = mzero + + +-- | Geographical coordinates. +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" + 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 + 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) + +instance A.FromJSON Tag where + parseJSON (A.Object v) = + Tag <$> v A..: "id" + <*> v A..: "name" parseJSON _ = mzero diff --git a/src/Facebook/Object/Action.hs b/src/Facebook/Object/Action.hs new file mode 100644 --- /dev/null +++ b/src/Facebook/Object/Action.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, OverloadedStrings #-} +module Facebook.Object.Action + ( createAction + , Action(..) + ) where + +import Control.Arrow (first) +import Control.Monad.Trans.Control (MonadBaseControl) +import Data.ByteString.Char8 (ByteString) +import Data.Function (on) +import Data.String (IsString(..)) + +import qualified Data.Conduit as C + +import Facebook.Types +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: +-- +-- > now <- liftIO getCurrentTime +-- > createAction "cook" +-- > [ "recipe" #= "http://example.com/cookie.html" +-- > , "when" #= now ] +-- > token +createAction :: (C.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 (Action action) query mapptoken usertoken = do + creds <- getCreds + let post :: (C.MonadResource m, MonadBaseControl IO m) => ByteString -> AccessToken anyKind -> FacebookT Auth m Id + post prepath = postObject (prepath <> appName creds <> ":" <> action) query + case mapptoken of + Nothing -> post "/me/" usertoken + Just apptoken -> post ("/" <> accessTokenUserId usertoken <> "/") apptoken + + +-- | An action of your app. Please refer to Facebook's +-- documentation at +-- +-- to see how you can create actions. +-- +-- This is a @newtype@ of 'ByteString' that supports only 'IsString'. +-- This means that to create an 'Action' you should use the +-- @OverloadedStrings@ language extension. For example, +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > +-- > foo token = do +-- > ... +-- > createAction "cook" [...] token +newtype Action = Action { unAction :: ByteString } + +instance Show Action where + show = show . unAction + +-- | Since 0.7.1 +instance Eq Action where + (==) = (==) `on` unAction + (/=) = (/=) `on` unAction + +-- | Since 0.7.1 +instance Ord Action where + 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 + +instance IsString Action where + fromString = Action . fromString diff --git a/src/Facebook/Object/Checkin.hs b/src/Facebook/Object/Checkin.hs new file mode 100644 --- /dev/null +++ b/src/Facebook/Object/Checkin.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, OverloadedStrings #-} +module Facebook.Object.Checkin + ( Checkin(..) + , CheckinFrom(..) + , getCheckin + , createCheckin + ) where + +import Control.Applicative +import Control.Monad (mzero) +import Control.Monad.Trans.Control (MonadBaseControl) +import Data.Aeson ((.:), (.:?)) +import Data.Text (Text) +import Data.Time (UTCTime) +import Data.Typeable (Typeable) + +import qualified Data.Aeson as A +import qualified Data.Conduit as C + + +import Facebook.Types +import Facebook.Monad +import Facebook.Graph + + +-- | A Facebook check-in (see +-- ). +-- +-- /NOTE:/ We still don't support all fields supported by +-- Facebook. Please fill an issue if you need access to any other +-- fields. +data Checkin = + Checkin { checkinId :: Id + , checkinFrom :: Maybe CheckinFrom + , checkinPlace :: Maybe Place + , checkinCreatedTime :: Maybe UTCTime + , checkinTags :: Maybe (Pager Tag) + , checkinMessage :: Maybe Text + } + deriving (Eq, Ord, Show, Read, Typeable) + +instance A.FromJSON Checkin where + parseJSON (A.Object v) = + Checkin <$> v .: "id" + <*> v .:? "from" + <*> v .:? "place" + <*> 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) + +instance A.FromJSON CheckinFrom where + 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 :: (C.MonadResource m, MonadBaseControl IO m) => + Id -- ^ Checkin ID. + -> [Argument] -- ^ Arguments to be passed to Facebook. + -> Maybe UserAccessToken -- ^ Optional user access token. + -> FacebookT anyAuth m Checkin +getCheckin (Id id_) query mtoken = getObject ("/" <> id_) query mtoken + + +-- | Creates a 'check-in' and returns its ID. Place and +-- coordinates are both required by Facebook. +createCheckin :: (C.MonadResource m, MonadBaseControl IO m) => + Id -- ^ Place ID. + -> GeoCoordinates -- ^ Coordinates. + -> [Argument] -- ^ Other arguments of the action. + -> UserAccessToken -- ^ Required user access token. + -> FacebookT Auth m Id +createCheckin pid coords args usertoken = do + let body = ("place" #= pid) : ("coordinates" #= coords) : args + postObject "me/checkins" body usertoken diff --git a/src/Facebook/Object/Page.hs b/src/Facebook/Object/Page.hs --- a/src/Facebook/Object/Page.hs +++ b/src/Facebook/Object/Page.hs @@ -20,7 +20,6 @@ import Facebook.Graph import Facebook.Monad -import Facebook.Object.User (UserLocation) import Facebook.Types -- | A Facebook page (see @@ -35,7 +34,7 @@ , pageIsPublished :: Maybe Bool , pageCanPost :: Maybe Bool , pageLikes :: Maybe Integer - , pageLocation :: Maybe UserLocation + , pageLocation :: Maybe Location , pagePhone :: Maybe Text , pageCheckins :: Maybe Integer , pagePicture :: Maybe ByteString @@ -75,5 +74,5 @@ => ByteString -- ^ Keyword to search for -> [Argument] -- ^ Arguments to pass to Facebook -> Maybe UserAccessToken -- ^ Optional user access token - -> FacebookT anyAuth m (SearchResultPage Page) + -> FacebookT anyAuth m (Pager Page) searchPages = searchObjects "page" diff --git a/src/Facebook/Object/User.hs b/src/Facebook/Object/User.hs --- a/src/Facebook/Object/User.hs +++ b/src/Facebook/Object/User.hs @@ -2,7 +2,6 @@ module Facebook.Object.User ( User(..) , Gender(..) - , UserLocation(..) , getUser , searchUsers ) where @@ -43,7 +42,7 @@ , userUsername :: Maybe Text , userVerified :: Maybe Bool , userEmail :: Maybe Text - , userLocation :: Maybe UserLocation + , userLocation :: Maybe Place } deriving (Eq, Ord, Show, Read, Typeable) @@ -79,20 +78,6 @@ toText Female = "female" --- | An user's location. -data UserLocation = - UserLocation { userLocationId :: Id - , userLocationName :: Text - } - deriving (Eq, Ord, Show, Read, Typeable) - -instance A.FromJSON UserLocation where - parseJSON (A.Object v) = - UserLocation <$> v .: "id" - <*> v .: "name" - parseJSON _ = mzero - - -- | 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 @@ -111,5 +96,5 @@ => ByteString -> [Argument] -> Maybe UserAccessToken - -> FacebookT anyAuth m (SearchResultPage User) + -> FacebookT anyAuth m (Pager User) searchUsers = searchObjects "user" diff --git a/src/Facebook/OpenGraph.hs b/src/Facebook/OpenGraph.hs deleted file mode 100644 --- a/src/Facebook/OpenGraph.hs +++ /dev/null @@ -1,240 +0,0 @@ -{-# LANGUAGE FlexibleContexts, OverloadedStrings #-} -module Facebook.OpenGraph - ( createAction - , Action(..) - , createCheckin - , fqlQuery - , FQLResult(..) - , (#=) - , SimpleType(..) - ) where - -import Control.Applicative ((<$>)) -import Control.Arrow (first) -import Control.Monad.Trans.Control (MonadBaseControl) -import Control.Monad (mzero) -import Data.ByteString.Char8 (ByteString) -import Data.Function (on) -import Data.List (intersperse) -import Data.Text (Text) -import qualified Data.Text.Lazy as TL (toStrict) -import Data.Text.Lazy.Builder (toLazyText) --- import Data.Typeable (Typeable, Typeable1) -import Data.Int (Int8, Int16, Int32) -import Data.Word (Word8, Word16, Word32, Word) -import Data.String (IsString(..)) -import System.Locale (defaultTimeLocale) - --- import qualified Control.Exception.Lifted as E -import qualified Data.Aeson as A -import qualified Data.Aeson.Encode as AE (fromValue) -import qualified Data.ByteString.Char8 as B -import qualified Data.Conduit as C --- import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import qualified Data.Time as TI --- import qualified Network.HTTP.Types as HT - - -import Facebook.Types -import Facebook.Monad -import Facebook.Base -import Facebook.Graph - - --- | Creates an Open Graph action on the user's timeline. Returns --- the 'Id' of the newly created action. For example: --- --- > now <- liftIO getCurrentTime --- > createAction "cook" --- > [ "recipe" #= "http://example.com/cookie.html" --- > , "when" #= now ] --- > token -createAction :: (C.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 (Action action) query mapptoken usertoken = do - creds <- getCreds - let post :: (C.MonadResource m, MonadBaseControl IO m) => ByteString -> AccessToken anyKind -> FacebookT Auth m Id - post prepath = postObject (prepath <> appName creds <> ":" <> action) query - case mapptoken of - Nothing -> post "/me/" usertoken - Just apptoken -> post ("/" <> accessTokenUserId usertoken <> "/") apptoken - - --- | An action of your app. Please refer to Facebook's --- documentation at --- --- to see how you can create actions. --- --- This is a @newtype@ of 'ByteString' that supports only 'IsString'. --- This means that to create an 'Action' you should use the --- @OverloadedStrings@ language extension. For example, --- --- > {-# LANGUAGE OverloadedStrings #-} --- > --- > foo token = do --- > ... --- > createAction "cook" [...] token -newtype Action = Action { unAction :: ByteString } - -instance Show Action where - show = show . unAction - --- | Since 0.7.1 -instance Eq Action where - (==) = (==) `on` unAction - (/=) = (/=) `on` unAction - --- | Since 0.7.1 -instance Ord Action where - 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 - -instance IsString Action where - fromString = Action . fromString - - --- | Creates a 'check-in' and returns its id. Place and --- coordinates are both required by Facebook. -createCheckin :: (C.MonadResource m, MonadBaseControl IO m) => - Id -- ^ Place Id - -> (Double, Double) -- ^ (Latitude, Longitude) - -> [Argument] -- ^ Other arguments of the action. - -> UserAccessToken -- ^ Required user access token. - -> FacebookT Auth m Id -createCheckin pid (lat,lon) args usertoken = do - let coords = ("coordinates", toBS $ A.object ["latitude" A..= lat, "longitude" A..= lon]) - body = ("place" #= pid) : coords : args - toBS = TE.encodeUtf8 . TL.toStrict . toLazyText . AE.fromValue - postObject "me/checkins" body usertoken - - --- | Query the Facebook Graph using FQL. You may want to use --- 'FQLResult' when parsing the returned JSON. -fqlQuery :: (C.MonadResource m, MonadBaseControl IO m, A.FromJSON a) => - Text -- ^ FQL Query - -> Maybe (AccessToken anyKind) -- ^ Optional access token - -> FacebookT anyAuth m a -fqlQuery fql mtoken = - runResourceInFb $ do - let query = ["q" #= fql] - asJson =<< fbhttp =<< fbreq "/fql" mtoken query - - --- | Parses an FQL query result. FQL query results are always of the form --- --- @ --- { "data": [ret1, ret2, ...] } --- @ --- --- This @newtype@ unwraps the array from the @"data"@ field --- automatically for you, so you may write something like: --- --- @ --- FQLResult [...] <- fqlQuery ... --- @ -newtype FQLResult a = FQLResult [a] deriving (Eq, Ord, Show, Read) - -instance A.FromJSON a => A.FromJSON (FQLResult a) where - parseJSON (A.Object v) = FQLResult <$> (v A..: "data") - parseJSON _ = mzero - - --- | Create an 'Argument' with a 'SimpleType'. See the docs on --- 'createAction' for an example. -(#=) :: SimpleType a => ByteString -> a -> Argument -p #= v = (p, encodeFbParam v) - - - --- | Class for data types that may be represented as a Facebook --- simple type. (see --- ). -class SimpleType a where - encodeFbParam :: a -> B.ByteString - --- | Facebook's simple type @Boolean@. -instance SimpleType Bool where - 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" --- | Facebook's simple type @DateTime@. -instance SimpleType TI.UTCTime where - 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 - --- @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 --- | Facebook's simple type @Float@. -instance SimpleType Double where - encodeFbParam = showBS - --- | Facebook's simple type @Integer@. -instance SimpleType Int where - encodeFbParam = showBS --- | Facebook's simple type @Integer@. -instance SimpleType Word where - encodeFbParam = showBS --- | Facebook's simple type @Integer@. -instance SimpleType Int8 where - encodeFbParam = showBS --- | Facebook's simple type @Integer@. -instance SimpleType Word8 where - encodeFbParam = showBS --- | Facebook's simple type @Integer@. -instance SimpleType Int16 where - encodeFbParam = showBS --- | Facebook's simple type @Integer@. -instance SimpleType Word16 where - encodeFbParam = showBS --- | Facebook's simple type @Integer@. -instance SimpleType Int32 where - encodeFbParam = showBS --- | Facebook's simple type @Integer@. -instance SimpleType Word32 where - encodeFbParam = showBS - --- | Facebook's simple type @String@. -instance SimpleType Text where - encodeFbParam = TE.encodeUtf8 --- | Facebook's simple type @String@. -instance SimpleType ByteString where - encodeFbParam = id - --- | An object's 'Id' code. -instance SimpleType Id where - encodeFbParam = idCode - --- | A comma-separated list of simple types. This definition --- doesn't work everywhere, just for a few combinations that --- Facebook uses (e.g. @[Int]@). Also, encoding a list of lists --- 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 - -showBS :: Show a => a -> B.ByteString -showBS = B.pack . show diff --git a/src/Facebook/RealTime.hs b/src/Facebook/RealTime.hs --- a/src/Facebook/RealTime.hs +++ b/src/Facebook/RealTime.hs @@ -28,6 +28,7 @@ import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.Conduit as C +import qualified Data.Conduit.List as CL import qualified Data.Text.Encoding as TE import qualified Network.HTTP.Conduit as H import qualified Network.HTTP.Types as HT @@ -36,7 +37,6 @@ import Facebook.Monad import Facebook.Base import Facebook.Graph -import Facebook.OpenGraph -- | The type of objects that a real-time update refers to. @@ -150,8 +150,9 @@ AppAccessToken -> FacebookT Auth m [RealTimeUpdateSubscription] listSubscriptions apptoken = do path <- getSubscriptionsPath - FQLResult ret <- getObject path [] (Just apptoken) - return ret + pager <- getObject path [] (Just apptoken) + src <- fetchAllNextPages pager + lift $ src C.$$ CL.consume -- | Verifies the input's authenticity (i.e. it comes from diff --git a/src/Facebook/Types.hs b/src/Facebook/Types.hs --- a/src/Facebook/Types.hs +++ b/src/Facebook/Types.hs @@ -24,7 +24,7 @@ -- | Credentials that you get for your app when you register on -- Facebook. data Credentials = - Credentials { appName :: ByteString -- ^ Your application name (e.g. for OpenGraph calls). + Credentials { appName :: ByteString -- ^ Your application name (e.g. for Open Graph calls). , appId :: ByteString -- ^ Your application ID. , appSecret :: ByteString -- ^ Your application secret key. } diff --git a/tests/runtests.hs b/tests/runtests.hs --- a/tests/runtests.hs +++ b/tests/runtests.hs @@ -165,7 +165,7 @@ 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 - r &?= FB.FQLResult [PageName "Facebook"] + FB.pagerData r &?= [PageName "Facebook"] describe' "listSubscriptions" $ do it "returns something" $ do