fb-1.0.13/src/ 0000755 0000000 0000000 00000000000 12641032441 011135 5 ustar 00 0000000 0000000 fb-1.0.13/src/Facebook/ 0000755 0000000 0000000 00000000000 12641032441 012646 5 ustar 00 0000000 0000000 fb-1.0.13/src/Facebook/Object/ 0000755 0000000 0000000 00000000000 12641032441 014054 5 ustar 00 0000000 0000000 fb-1.0.13/tests/ 0000755 0000000 0000000 00000000000 12641032441 011510 5 ustar 00 0000000 0000000 fb-1.0.13/src/Facebook.hs 0000644 0000000 0000000 00000006155 12641032441 013211 0 ustar 00 0000000 0000000 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
import Facebook.Types
import Facebook.Monad
import Facebook.Base
import Facebook.Auth
import Facebook.Pager
import Facebook.Graph
import Facebook.Object.Page
import Facebook.Object.User
import Facebook.Object.Action
import Facebook.Object.Checkin
import Facebook.Object.Order
import Facebook.Object.FriendList
import Facebook.RealTime
import Facebook.FQL
import Facebook.TestUsers
fb-1.0.13/src/Facebook/Types.hs 0000644 0000000 0000000 00000016341 12641032441 014313 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP, DeriveDataTypeable, GADTs, StandaloneDeriving #-}
module Facebook.Types
( Credentials(..)
, appIdBS
, appSecretBS
, AccessToken(..)
, UserAccessToken
, AppAccessToken
, AccessTokenData
, Id(..)
, UserId
, accessTokenData
, accessTokenExpires
, accessTokenUserId
, UserKind
, AppKind
, Argument
, (<>)
, FbUTCTime(..)
) where
import Control.Applicative ((<$>), (<*>), pure)
import Control.Monad (mzero)
import Data.ByteString (ByteString)
import Data.Int (Int64)
import Data.Monoid (Monoid, mappend)
import Data.String (IsString)
import Data.Text (Text)
import Data.Time (UTCTime, parseTime)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Data.Typeable (Typeable, Typeable1)
#if MIN_VERSION_time(1,5,0)
import Data.Time (defaultTimeLocale)
#else
import System.Locale (defaultTimeLocale)
#endif
import qualified Data.Aeson as A
import qualified Data.Aeson.Types as A
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.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)
-- | 'appId' for 'ByteString'.
appIdBS :: Credentials -> ByteString
appIdBS = TE.encodeUtf8 . appId
-- | 'appSecret' for 'ByteString'.
appSecretBS :: Credentials -> ByteString
appSecretBS = TE.encodeUtf8 . appSecret
-- | An access token. While you can make some API calls without
-- an access token, many require an access token and some will
-- give you more information with an appropriate access token.
--
-- There are two kinds of access tokens:
--
-- [User access token] An access token obtained after an user
-- accepts your application. Let's you access more information
-- about that user and act on their behalf (depending on which
-- permissions you've asked for).
--
-- [App access token] An access token that allows you to take
-- administrative actions for your application.
--
-- These two kinds of access tokens are distinguished by the
-- phantom type on 'AccessToken', which can be 'UserKind' or
-- 'AppKind'.
data AccessToken kind where
UserAccessToken :: UserId -> AccessTokenData -> UTCTime -> AccessToken UserKind
AppAccessToken :: AccessTokenData -> AccessToken AppKind
-- | Type synonym for @'AccessToken' 'UserKind'@.
type UserAccessToken = AccessToken UserKind
-- | Type synonym for @'AccessToken' 'AppKind'@.
type AppAccessToken = AccessToken AppKind
deriving instance Eq (AccessToken kind)
deriving instance Ord (AccessToken kind)
deriving instance Show (AccessToken kind)
deriving instance Typeable1 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)
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
instance A.ToJSON Id where
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
-- | 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
-- | Get the user ID of an user access token.
accessTokenUserId :: UserAccessToken -> UserId
accessTokenUserId (UserAccessToken uid _ _) = uid
-- | Phantom type used mark an 'AccessToken' as an user access
-- token.
data UserKind deriving (Typeable)
-- | Phantom type used mark an 'AccessToken' as an app access
-- token.
data AppKind deriving (Typeable)
-- | An argument given to an API call.
type Argument = (ByteString, ByteString)
-- | Synonym for 'mappend'.
(<>) :: Monoid a => a -> a -> a
(<>) = mappend
----------------------------------------------------------------------
-- | /Since 0.14.9./ Not a Facebook JSON format, but a custom @fb@
-- format for convenience if you need to serialize access tokens.
instance A.ToJSON (AccessToken kind) where
toJSON (UserAccessToken uid data_ expires) =
A.object
[ "kind" A..= ("user" :: Text)
, "id" A..= uid
, "token" A..= data_
, "expires" A..= expires ]
toJSON (AppAccessToken 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
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"
instance ParseAccessToken AppKind where
parseTokenJSON v =
checkKind v "app" $
AppAccessToken <$> v A..: "token"
-- | (Internal) Used to implement 'parseTokenJSON'.
checkKind :: A.Object -> Text -> A.Parser a -> A.Parser a
checkKind v kind ok = do
kind' <- v A..: "kind"
if kind == kind'
then ok
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
parseJSON (A.Object v) = parseTokenJSON v
parseJSON _ = mzero
----------------------------------------------------------------------
-- | @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 (A.Number n) =
return $ FbUTCTime $ posixSecondsToUTCTime $ fromInteger $ floor n
parseJSON _ = fail "could not parse FbUTCTime from something which is not a string or number"
fb-1.0.13/src/Facebook/Monad.hs 0000644 0000000 0000000 00000014123 12641032441 014241 0 ustar 00 0000000 0000000 {-# 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
-- * Re-export
, lift
) where
import Control.Applicative (Applicative, Alternative)
import Control.Monad (MonadPlus, liftM)
import Control.Monad.Base (MonadBase(..))
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 Facebook.Types
-- | @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)
instance MonadBase b m => MonadBase b (FacebookT auth m) where
liftBase = lift . liftBase
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
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
-- | Since @fb-0.14.8@.
instance MonadLogger m => MonadLogger (FacebookT auth m) where
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)
-- | 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)
-- | Internal data kept inside 'FacebookT'.
data FbData = FbData { fbdCreds :: Credentials -- ^ Can be 'undefined'!
, fbdManager :: !H.Manager
, fbdTier :: !FbTier
}
deriving (Typeable)
-- | Which Facebook tier should be used (see
-- ).
data FbTier = Production | Beta deriving (Eq, Ord, Show, Read, Enum, Typeable)
-- | 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)
-- | 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)
-- | Same as 'runFacebookT', but uses Facebook's beta tier (see
-- ).
beta_runFacebookT :: Credentials -> H.Manager -> FacebookT Auth m a -> m a
beta_runFacebookT creds manager (F act) =
runReaderT act (FbData creds manager Beta)
-- | Same as 'runNoAuthFacebookT', but uses Facebook's beta tier
-- (see ).
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)
-- | Get the user's credentials.
getCreds :: Monad m => FacebookT Auth m Credentials
getCreds = fbdCreds `liftM` F ask
-- | Get the 'H.Manager'.
getManager :: Monad m => FacebookT anyAuth m H.Manager
getManager = fbdManager `liftM` F ask
-- | Get the 'FbTier'.
getTier :: Monad m => FacebookT anyAuth m FbTier
getTier = fbdTier `liftM` F ask
-- | Run a pure function that depends on the 'FbTier' being used.
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 (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
mapFacebookT f = F . mapReaderT f . unF
fb-1.0.13/src/Facebook/Base.hs 0000644 0000000 0000000 00000016762 12641032441 014070 0 ustar 00 0000000 0000000 {-# LANGUAGE DeriveDataTypeable, FlexibleContexts, OverloadedStrings, CPP #-}
module Facebook.Base
( fbreq
, ToSimpleQuery(..)
, asJson
, asJsonHelper
, asBS
, FacebookException(..)
, fbhttp
, fbhttpHelper
, httpCheck
) 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 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.ByteString as B
import qualified Data.Conduit as C
import qualified Data.Conduit.Attoparsec as C
import qualified Data.Conduit.List as CL
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Network.HTTP.Conduit as H
import qualified Network.HTTP.Types as HT
#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.
-> Maybe (AccessToken anyKind) -- ^ Access token.
-> HT.SimpleQuery -- ^ Parameters.
-> FacebookT anyAuth m H.Request
fbreq path mtoken query =
withTier $ \tier ->
let host = case tier of
Production -> "graph.facebook.com"
Beta -> "graph.beta.facebook.com"
in def { H.secure = True
, H.host = host
, H.port = 443
, H.path = TE.encodeUtf8 path
, H.redirectCount = 3
, H.queryString =
HT.renderSimpleQuery False $
maybe id tsq mtoken query
, H.responseTimeout = Just 120000000 -- 2 minutes
}
-- | Internal class for types that may be passed on queries to
-- Facebook's API.
class ToSimpleQuery a where
-- | Prepend to the given query the parameters necessary to
-- pass this data type to Facebook.
tsq :: a -> HT.SimpleQuery -> HT.SimpleQuery
tsq _ = id
instance ToSimpleQuery Credentials where
tsq creds = (:) ("client_id", appIdBS creds) .
(:) ("client_secret", appSecretBS creds)
instance ToSimpleQuery (AccessToken anyKind) where
tsq token = (:) ("access_token", TE.encodeUtf8 $ accessTokenData token)
-- | 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)
-> t m a
asJson = lift . asJsonHelper
asJsonHelper :: (MonadIO m, R.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 ->
E.throw $ FbLibraryException $ T.concat
[ "Facebook.Base.asJson: could not parse "
, " Facebook's response as a JSON value ("
, T.pack str, ")" ]
-- | Converts a plain 'H.Response' into a string 'ByteString'.
asBS :: (Monad m) =>
H.Response (C.ResumableSource m ByteString)
-> 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
-- | Same as 'H.http', but tries to parse errors and throw
-- meaningful 'FacebookException'@s@.
fbhttp :: (MonadBaseControl IO m, R.MonadResource m) =>
H.Request
-> FacebookT anyAuth m (H.Response (C.ResumableSource m ByteString))
fbhttp req = do
manager <- getManager
lift (fbhttpHelper manager req)
fbhttpHelper :: (MonadBaseControl IO m, R.MonadResource m) =>
H.Manager
-> H.Request
-> 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.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
let statusexc = H.StatusCodeException status headers cookies
val <- E.try $ asJsonHelper response
case val :: Either E.SomeException FacebookException of
Right fbexc -> E.throw fbexc
Left _ -> do
case AT.parse wwwAuthenticateParser <$>
lookup "WWW-Authenticate" headers of
Just (AT.Done _ fbexc) -> E.throwIO fbexc
_ -> E.throwIO statusexc
-- | Try to parse the @WWW-Authenticate@ header of a Facebook
-- response.
wwwAuthenticateParser :: AT.Parser FacebookException
wwwAuthenticateParser =
FacebookException <$ AT.string "OAuth \"Facebook Platform\" "
<*> text
<* AT.char ' '
<*> text
where
text = T.pack <$ AT.char '"' <*> many tchar <* AT.char '"'
tchar = (AT.char '\\' *> AT.anyChar) <|> AT.notChar '"'
-- | 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) =>
H.Request
-> FacebookT anyAuth m Bool
httpCheck req = runResourceInFb $ do
manager <- getManager
let req' = req { H.method = HT.methodHead
, H.checkStatus = \_ _ _ -> Nothing }
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
-- responseBody should be empty since we're using HEAD, but
-- I don't know if this is guaranteed.
-- | @True@ if the the 'Status' is ok (i.e. @2XX@).
isOkay :: HT.Status -> Bool
isOkay status =
let sc = HT.statusCode status
in 200 <= sc && sc < 300
fb-1.0.13/src/Facebook/Auth.hs 0000644 0000000 0000000 00000041467 12641032441 014117 0 ustar 00 0000000 0000000 {-# LANGUAGE FlexibleContexts, GADTs, ScopedTypeVariables, OverloadedStrings #-}
module Facebook.Auth
( getAppAccessToken
, getUserAccessTokenStep1
, getUserAccessTokenStep2
, getUserLogoutUrl
, extendUserAccessToken
, RedirectUrl
, Permission
, unPermission
, hasExpired
, isValid
, parseSignedRequest
, debugToken
, DebugToken(..)
) where
import Control.Applicative
import Control.Monad (guard, join, liftM, mzero)
import Control.Monad.IO.Class (MonadIO(liftIO))
import Control.Monad.Trans.Control (MonadBaseControl)
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 qualified Data.Aeson as AE
import qualified Data.Aeson.Types as AE
import qualified Data.Attoparsec.Char8 as AB
import qualified Data.Attoparsec.Text as A
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 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 qualified Network.HTTP.Types as HT
import Facebook.Types
import Facebook.Base
import Facebook.Monad
-- | Get an app access token from Facebook using your
-- credentials.
getAppAccessToken :: (R.MonadResource m, MonadBaseControl IO m) =>
FacebookT Auth m AppAccessToken
getAppAccessToken =
runResourceInFb $ do
creds <- getCreds
req <- fbreq "/oauth/access_token" Nothing $
tsq creds [("grant_type", "client_credentials")]
response <- fbhttp req
lift $
H.responseBody response C.$$+-
CT.decode CT.utf8 C.=$
C.sinkParser (AppAccessToken <$ A.string "access_token="
<*> A.takeText)
-- | 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 redirectUrl perms = do
creds <- getCreds
withTier $ \tier ->
let urlBase = case tier of
Production -> "https://www.facebook.com/dialog/oauth?client_id="
Beta -> "https://www.beta.facebook.com/dialog/oauth?client_id="
in T.concat $ urlBase
: appId creds
: "&redirect_uri="
: redirectUrl
: (case perms of
[] -> []
_ -> "&scope=" : L.intersperse "," (map unPermission perms)
)
-- | The second step to get an user access token. If the user is
-- successfully authenticate and they authorize your application,
-- then they'll be redirected back to the 'RedirectUrl' you've
-- passed to 'getUserAccessTokenStep1'. You should take the
-- 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 redirectUrl query =
case query of
[code@("code", _)] -> runResourceInFb $ do
-- 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)
-- | 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
-- | The URL an user should be redirected to in order to log them
-- out of their Facebook session. Facebook will then redirect
-- the user to the provided URL after logging them out. Note
-- that, at the time of this writing, Facebook's policies require
-- you to log the user out of Facebook when they ask to log out
-- of your site.
--
-- Note also that Facebook may refuse to redirect the user to the
-- provided URL if their user access token is invalid. In order
-- 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 (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_)) ]
-- | URL where the user is redirected to after Facebook
-- authenticates the user authorizes your application. This URL
-- should be inside the domain registered for your Facebook
-- application.
type RedirectUrl = Text
-- | A permission that is asked for the user when he authorizes
-- your app. Please refer to Facebook's documentation at
--
-- to see which permissions are available.
--
-- This is a @newtype@ of 'Text' that supports only 'IsString'.
-- This means that to create a 'Permission' you should use the
-- @OverloadedStrings@ language extension. For example,
--
-- > {-# LANGUAGE OverloadedStrings #-}
-- >
-- > perms :: [Permission]
-- > perms = ["user_about_me", "email", "offline_access"]
newtype Permission =
Permission {
unPermission :: Text
-- ^ Retrieves the 'Text' back from a 'Permission'. Most of
-- the time you won't need to use this function, but you may
-- need it if you're a library author.
} deriving (Eq, Ord)
instance Show Permission where
show = show . unPermission
instance IsString Permission where
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
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 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 .
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
-- ,
-- ).
-- Only short-lived user access tokens may extended into
-- long-lived user access tokens, you must get a new short-lived
-- user access token if you need to extend a long-lived
-- one. Returns @Left exc@ if there is an error while extending,
-- or @Right token@ with the new user access token (which could
-- have the same data and expiration time as before, but you
-- can't assume this). Note that expired access tokens can't be
-- extended, only valid tokens.
extendUserAccessToken :: (MonadBaseControl IO m, R.MonadResource m) =>
UserAccessToken
-> FacebookT Auth m (Either FacebookException UserAccessToken)
extendUserAccessToken token@(UserAccessToken uid data_ _)
= do expired <- hasExpired token
if expired then return (Left hasExpiredExc) else tryToExtend
where
tryToExtend = runResourceInFb $ do
creds <- getCreds
req <- fbreq "/oauth/access_token" Nothing $
tsq creds [ ("grant_type", "fb_exchange_token")
, ("fb_exchange_token", TE.encodeUtf8 data_) ]
eresponse <- E.try (asBS =<< fbhttp req)
case eresponse of
Right response -> do
now <- liftIO getCurrentTime
return (Right $ case userAccessTokenParser now response of
UserAccessToken _ data' expires' ->
UserAccessToken uid data' expires')
Left exc -> return (Left exc)
hasExpiredExc =
mkExc [ "the user access token has already expired, "
, "so I'll not try to extend it." ]
mkExc = FbLibraryException . T.concat . ("extendUserAccessToken: ":)
-- | Parses a Facebook 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 signedRequest =
runMaybeT $ do
-- Split, decode and JSON-parse
let (encodedSignature, encodedUnparsedPayloadWithDot) = B8.break (== '.') signedRequest
('.', encodedUnparsedPayload) <- MaybeT $ return (B8.uncons encodedUnparsedPayloadWithDot)
signature <- eitherToMaybeT $ Base64URL.decode $ addBase64Padding encodedSignature
unparsedPayload <- eitherToMaybeT $ Base64URL.decode $ addBase64Padding encodedUnparsedPayload
payload <- eitherToMaybeT $ AB.parseOnly json' unparsedPayload
-- Verify signature
SignedRequestAlgorithm algo <- fromJson payload
guard (algo == "HMAC-SHA256")
hmacKey <- credsToHmacKey `liftM` lift getCreds
let expectedSignature = Cereal.encode $ hmac' hmacKey encodedUnparsedPayload
guard (signature `constTimeEq` expectedSignature)
-- Parse user data type
fromJson payload
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
instance AE.FromJSON SignedRequestAlgorithm where
parseJSON (AE.Object v) = SignedRequestAlgorithm <$> v .: "algorithm"
parseJSON _ = mzero
-- | The @base64-bytestring@ package provides two different
-- decoding functions for @base64url@: 'Base64URL.decode' and
-- 'Base64URL.decodeLenient'. The former is too strict for us
-- since Facebook does add padding to its signed requests, but
-- the latter is too lenient and will accept *anything*.
--
-- Instead of being too lenient, we just use this function add
-- the padding base to the encoded string, thus allowing
-- 'Base64URL.decode' to chew it.
addBase64Padding :: B.ByteString -> B.ByteString
addBase64Padding bs
| drem == 2 = bs `B.append` "=="
| 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, R.MonadResource m) =>
AppAccessToken -- ^ Your app access token.
-> AccessTokenData -- ^ The access token you want to debug.
-> FacebookT Auth m DebugToken
debugToken appToken userTokenData = do
req <- fbreq "/debug_token" (Just appToken) $
[ ("input_token", TE.encodeUtf8 userTokenData) ]
ret <- undata <$> (asJson =<< fbhttp req)
let muserToken = UserAccessToken <$> dtUserId ret
<*> return userTokenData
<*> dtExpiresAt ret
return ret { dtAccessToken = muserToken }
-- | 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
fb-1.0.13/src/Facebook/Pager.hs 0000644 0000000 0000000 00000010233 12641032441 014237 0 ustar 00 0000000 0000000 {-# 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 Control.Monad.Trans.Resource as R
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 :: (R.MonadResource m, MonadBaseControl IO m, A.FromJSON a) =>
Pager a -> FacebookT anyAuth m (Maybe (Pager a))
fetchNextPage = fetchHelper pagerNext
-- | Tries to fetch the previous page of a 'Pager'. Returns
-- 'Nothing' whenever the current @Pager@ does not have a
-- 'pagerPrevious'.
fetchPreviousPage :: (R.MonadResource m, MonadBaseControl IO m, A.FromJSON a) =>
Pager a -> FacebookT anyAuth m (Maybe (Pager a))
fetchPreviousPage = 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 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 (R.runResourceT $ asJsonHelper =<< get)
start p = go (pagerData p) $! pagerRef p
return (start pager)
fb-1.0.13/src/Facebook/Graph.hs 0000644 0000000 0000000 00000022225 12641032441 014246 0 ustar 00 0000000 0000000 {-# LANGUAGE ConstraintKinds, CPP, DeriveDataTypeable, FlexibleContexts, OverloadedStrings #-}
module Facebook.Graph
( getObject
, postObject
, deleteObject
, searchObjects
, (#=)
, SimpleType(..)
, Place(..)
, Location(..)
, GeoCoordinates(..)
, Tag(..)
) where
import Control.Applicative
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)
import Data.Text (Text)
import Data.Typeable (Typeable)
import Data.Word (Word, Word8, Word16, Word32, Word64)
#if MIN_VERSION_time(1,5,0)
import Data.Time (defaultTimeLocale)
#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)
import qualified Data.ByteString.Char8 as B
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
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 path query mtoken =
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 = 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 = 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 method path query token =
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 objectType keyword query = getObject "/search" 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
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 @Integer@.
instance SimpleType Int64 where
encodeFbParam = showBS
-- | Facebook's simple type @Integer@.
instance SimpleType Word64 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 = TE.encodeUtf8 . 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
-- 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
fb-1.0.13/src/Facebook/Object/Action.hs 0000644 0000000 0000000 00000005347 12641032441 015636 0 ustar 00 0000000 0000000 {-# LANGUAGE DeriveDataTypeable, FlexibleContexts, OverloadedStrings #-}
module Facebook.Object.Action
( createAction
, Action(..)
) where
import Control.Arrow (first)
import Control.Monad.Trans.Control (MonadBaseControl)
import Data.Function (on)
import Data.String (IsString(..))
import Data.Text (Text)
import qualified Control.Monad.Trans.Resource as R
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 :: (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 (Action action) query mapptoken usertoken = do
creds <- getCreds
let post :: (R.MonadResource m, MonadBaseControl IO m) => Text -> AccessToken anyKind -> FacebookT Auth m Id
post prepath = postObject (prepath <> appName creds <> ":" <> action) query
case mapptoken of
Nothing -> post "/me/" usertoken
Just apptoken -> post ("/" <> idCode (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 'Text' 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 :: Text }
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
fb-1.0.13/src/Facebook/Object/FriendList.hs 0000644 0000000 0000000 00000006361 12641032441 016461 0 ustar 00 0000000 0000000 {-# LANGUAGE DeriveDataTypeable, FlexibleContexts, OverloadedStrings #-}
module Facebook.Object.FriendList
( FriendList(..)
, FriendListType(..)
, getUserFriendLists
, getFriendListMembers
) 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)
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.User
-- | A friend list for a 'User'.
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
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
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"
-- 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.
-> 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.
-> UserAccessToken -- ^ User access token.
-> FacebookT anyAuth m (Pager Friend)
getFriendListMembers id_ query token =
getObject ("/" <> idCode id_ <> "/members") query (Just token)
fb-1.0.13/src/Facebook/Object/Checkin.hs 0000644 0000000 0000000 00000005655 12641032441 015767 0 ustar 00 0000000 0000000 {-# 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 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
-- ).
--
-- /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"
<*> ((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)
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 :: (R.MonadResource m, MonadBaseControl IO m) =>
Id -- ^ Checkin ID.
-> [Argument] -- ^ Arguments to be passed to Facebook.
-> Maybe UserAccessToken -- ^ Optional user access token.
-> FacebookT anyAuth m Checkin
getCheckin id_ query mtoken = getObject ("/" <> idCode id_) query mtoken
-- | Creates a 'check-in' and returns its ID. Place and
-- coordinates are both required by Facebook.
createCheckin :: (R.MonadResource m, MonadBaseControl IO m) =>
Id -- ^ Place ID.
-> GeoCoordinates -- ^ Coordinates.
-> [Argument] -- ^ Other arguments of the action.
-> UserAccessToken -- ^ Required user access token.
-> FacebookT Auth m Id
createCheckin pid coords args usertoken = do
let body = ("place" #= pid) : ("coordinates" #= coords) : args
postObject "me/checkins" body usertoken
fb-1.0.13/src/Facebook/Object/User.hs 0000644 0000000 0000000 00000010324 12641032441 015326 0 ustar 00 0000000 0000000 {-# LANGUAGE DeriveDataTypeable, FlexibleContexts, OverloadedStrings #-}
module Facebook.Object.User
( 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)
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
-- ).
--
-- /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)
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
-- | An user's gender.
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
instance A.ToJSON Gender where
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 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 = 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.
-> 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)
instance A.FromJSON Friend where
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.
-> UserAccessToken -- ^ User access token.
-> FacebookT anyAuth m (Pager Friend)
getUserFriends id_ query token =
getObject ("/" <> idCode id_ <> "/friends") query (Just token)
fb-1.0.13/src/Facebook/Object/Page.hs 0000644 0000000 0000000 00000005373 12641032441 015274 0 ustar 00 0000000 0000000 {-# LANGUAGE DeriveDataTypeable
, FlexibleContexts
, OverloadedStrings
#-}
module Facebook.Object.Page
( Page(..)
, 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
import Data.Text (Text)
import Data.Typeable (Typeable)
import Facebook.Graph
import Facebook.Monad
import Facebook.Types
import Facebook.Pager
-- | A Facebook page (see
-- ).
--
-- /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)
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"
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_
-- | 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 = searchObjects "page"
fb-1.0.13/src/Facebook/Object/Order.hs 0000644 0000000 0000000 00000005454 12641032441 015473 0 ustar 00 0000000 0000000 {-# LANGUAGE DeriveDataTypeable, FlexibleContexts, OverloadedStrings #-}
module Facebook.Object.Order
( 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)
import Data.Time.LocalTime (ZonedTime)
import qualified Control.Monad.Trans.Resource as R
import qualified Data.Aeson as A
import Facebook.Types
import Facebook.Monad
import Facebook.Graph
-- | 'Order' Id type.
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)
-- | A Facebook 'Order' status type.
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)
instance A.FromJSON OrderApplication where
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
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
-- | 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 id_ mtoken = getObject ("/" <> idCode id_) [] (Just mtoken)
fb-1.0.13/src/Facebook/RealTime.hs 0000644 0000000 0000000 00000020601 12641032441 014703 0 ustar 00 0000000 0000000 {-# LANGUAGE FlexibleContexts, OverloadedStrings #-}
module Facebook.RealTime
( 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 qualified Control.Monad.Trans.Resource as R
import qualified Crypto.Classes as Crypto
import qualified Crypto.HMAC as Crypto
import qualified Data.Aeson as A
import qualified Data.ByteString.Base16 as Base16
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 as T
import qualified Data.Text.Encoding as TE
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.Pager
-- | The type of objects that a real-time update refers to.
data RealTimeUpdateObject =
UserRTUO
| PermissionsRTUO
| PageRTUO
| ErrorsRTUO
| OtherRTUO Text
deriving (Eq, Ord, Show, Typeable)
rtuoToBS :: RealTimeUpdateObject -> ByteString
rtuoToBS (UserRTUO) = "user"
rtuoToBS (PermissionsRTUO) = "permissions"
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 "permissions") = return PermissionsRTUO
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 object fields callbackUrl verifyToken apptoken = do
path <- getSubscriptionsPath
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 }
return ()
-- | (Internal) Get the subscription's path.
getSubscriptionsPath :: Monad 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)
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"
parseJSON _ = mzero
-- | List current real-time update subscriptions.
listSubscriptions ::
(R.MonadResource m, MonadBaseControl IO m) =>
AppAccessToken -> FacebookT Auth m [RealTimeUpdateSubscription]
listSubscriptions apptoken = do
path <- getSubscriptionsPath
pager <- getObject path [] (Just apptoken)
src <- fetchAllNextPages pager
lift $ src C.$$ CL.consume
-- | Verifies the input's authenticity (i.e. it comes from
-- 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@
-- header's value. If it's not valid, @Nothing@ is returned,
-- otherwise @Just data@ is returned where @data@ is the original
-- data.
verifyRealTimeUpdateNotifications ::
Monad 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
-- | Same as 'verifyRealTimeUpdateNotifications' but also parses
-- the response as JSON. Returns @Nothing@ if either the
-- signature is invalid or the data can't be parsed (use
-- 'verifyRealTimeUpdateNotifications' if you need to distinguish
-- between these two error conditions).
getRealTimeUpdateNotifications ::
(Monad m, A.FromJSON a) =>
ByteString
-- ^ @X-Hub-Signature@ HTTP header's value.
-> L.ByteString
-- ^ Request body with JSON-encoded notifications.
-> FacebookT Auth m (Maybe (RealTimeUpdateNotification a))
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
-- 'RealTimeUpdateNotification a' represents such object where
-- 'a' is type of the entries (e.g.,
-- 'RealTimeUpdateNotificationUserEntry').
--
-- If you have a single 'RealTimeUpdateUrl' for different kinds
-- of notifications, you may parse a @RealTimeUpdateNotification
-- 'A.Value'@ and then manually parse the 'A.Value' depending on
-- the value of 'rtunObject'.
--
-- We recommend using 'getRealTimeUpdateNotifications'.
data RealTimeUpdateNotification a =
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"
parseJSON _ = mzero
-- | A notification for the 'UserRTUO' object.
data RealTimeUpdateNotificationUserEntry =
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"
parseJSON _ = mzero
fb-1.0.13/src/Facebook/FQL.hs 0000644 0000000 0000000 00000005647 12641032441 013640 0 ustar 00 0000000 0000000 {-# LANGUAGE FlexibleContexts, OverloadedStrings #-}
module Facebook.FQL
( fqlQuery
, FQLTime(..)
, FQLList(..)
, FQLObject(..)
) where
import Control.Applicative((<$>))
import Control.Monad.Trans.Control (MonadBaseControl)
import Data.Monoid (mempty)
import Data.Text (Text)
import Data.Time (UTCTime)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import qualified Control.Monad.Trans.Resource as R
import qualified Data.Aeson as A
import qualified Data.HashMap.Strict as HMS
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 fql mtoken =
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)
instance A.FromJSON FQLTime where
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.
--
-- For example, if you fetch the @tagged_uids@ field from
-- @location_post@, you'll find that Facebook's FQL represents an
-- empty list of tagged UIDs as plain JSON array (@[]@).
-- However, it represents a singleton list as an object
-- @{\"1234\": 1234}@ instead of the much more correct @[1234]@.
--
-- 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@ wrapper around any object that works around FQL's
-- strange objects.
--
-- For example, if you fetch the @app_data@ field from @stream@,
-- you'll find that empty objects are actually represented as
-- 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)
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
fb-1.0.13/src/Facebook/TestUsers.hs 0000644 0000000 0000000 00000015522 12641032441 015150 0 ustar 00 0000000 0000000 {-# 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 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
import Facebook.Monad
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)
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 :: (R.MonadResource m, MonadBaseControl IO m)
=> CreateTestUser -- ^ How the test user should be
-- created.
-> AppAccessToken -- ^ Access token for your app.
-> FacebookT Auth m TestUser
createTestUser userInfo token = do
creds <- getCreds
let query = ("method","post") : createTestUserQueryArgs userInfo
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 token = do
creds <- getCreds
getObject ("/" <> appId creds <> "/accounts/test-users") [] (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
-- | 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 :: (R.MonadResource m, MonadBaseControl IO m)
=> TestUser
-> TestUser
-> FacebookT Auth m ()
makeFriendConn (TestUser { tuAccessToken = Nothing }) _ = E.throw $
FbLibraryException "The test user passed on the first argument doesn't have\
\ a token. Both users must have a token."
makeFriendConn _ (TestUser { tuAccessToken = Nothing }) = E.throw $
FbLibraryException "The test user passed on the second argument doesn't have\
\ a token. Both users must have a token."
makeFriendConn (TestUser {tuId = id1, tuAccessToken = (Just token1)}) (TestUser {tuId = id2, tuAccessToken = (Just token2)}) = do
let friendReq userId1 userId2 token =
getObjectBool ("/" <> idCode userId1 <> "/friends/" <> idCode userId2)
[ "method" #= ("post" :: B.ByteString),
"access_token" #= token ]
Nothing
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 :: (R.MonadResource m, MonadBaseControl IO m)
=> Text
-- ^ Path (should begin with a slash @\/@).
-> [Argument]
-- ^ Arguments to be passed to Facebook.
-> Maybe (AccessToken anyKind)
-- ^ Optional access token.
-> FacebookT anyAuth m Bool
getObjectBool path query mtoken =
runResourceInFb $ do
bs <- asBS =<< fbhttp =<< fbreq path mtoken query
return (bs == "true")
fb-1.0.13/tests/Main.hs 0000644 0000000 0000000 00000051137 12641032441 012737 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings
, Rank2Types
, ScopedTypeVariables
, GADTs
, FlexibleContexts #-}
module Main (main, getCredentials) where
import Control.Applicative
import Control.Monad (mzero)
import Control.Monad.IO.Class (MonadIO(liftIO))
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
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.Map as Map
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 Facebook as FB
import qualified Network.HTTP.Conduit as H
import qualified Test.QuickCheck as QC
import Test.HUnit ((@?=))
import Test.Hspec
import Test.Hspec.HUnit ()
import Test.Hspec.QuickCheck
-- | Grab the Facebook credentials from the environment.
getCredentials :: IO FB.Credentials
getCredentials = tryToGet `E.catch` showHelp
where
tryToGet = do
[appName, appId, appSecret] <- mapM getEnv ["APP_NAME", "APP_ID", "APP_SECRET"]
return $ FB.Credentials (T.pack appName) (T.pack appId) (T.pack appSecret)
showHelp exc | not (isDoesNotExistError exc) = E.throw exc
showHelp _ = do
putStrLn $ unlines
[ "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"
, "create a Facebook app for this purpose and then distribute"
, "its secret keys in the open."
, ""
, "Please give your app's name, id and secret on the enviroment"
, "variables APP_NAME, APP_ID and APP_SECRET, respectively. "
, "For example, before running the test you could run in the shell:"
, ""
, " $ export APP_NAME=\"example\""
, " $ export APP_ID=\"458798571203498\""
, " $ export APP_SECRET=\"28a9d0fa4272a14a9287f423f90a48f2304\""
, ""
, "Of course, these values above aren't valid and you need to"
, "replace them with your own."
, ""
, "(Exiting now with a failure code.)"]
exitFailure
invalidCredentials :: FB.Credentials
invalidCredentials = FB.Credentials "this" "isn't" "valid"
invalidUserAccessToken :: FB.UserAccessToken
invalidUserAccessToken = FB.UserAccessToken (FB.Id "invalid") "user" farInTheFuture
where
Just farInTheFuture = parseTime (error "farInTheFuture") "%Y" "3000"
-- It's actually important to use 'farInTheFuture' since we
-- don't want any tests rejecting this invalid user access
-- token before even giving it to Facebook.
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
facebookTests :: String
-> FB.Credentials
-> H.Manager
-> (forall a. FB.FacebookT FB.Auth (R.ResourceT IO) a -> IO a)
-> (forall a. FB.FacebookT FB.NoAuth (R.ResourceT IO) a -> IO a)
-> Spec
facebookTests pretitle creds manager runAuth runNoAuth = do
let describe' = describe . (pretitle ++)
describe' "getAppAccessToken" $ do
it "works and returns a valid app access token" $
runAuth $ do
token <- FB.getAppAccessToken
FB.isValid token #?= True
it "throws a FacebookException on invalid credentials" $
R.runResourceT $
FB.runFacebookT invalidCredentials manager $ do
ret <- E.try $ FB.getAppAccessToken
case ret of
Right token -> fail $ show token
Left (_ :: FB.FacebookException) -> lift $ lift (return () :: IO ())
describe' "isValid" $ do
it "returns False on a clearly invalid user access token" $
runNoAuth $ FB.isValid invalidUserAccessToken #?= False
it "returns False on a clearly invalid app access token" $
runNoAuth $ FB.isValid invalidAppAccessToken #?= False
describe' "debugToken" $ do
it "works on a test user access token" $ do
runAuth $
withTestUser D.def $ \testUser -> do
Just testUserAccessTokenData <- return (FB.tuAccessToken testUser)
appToken <- FB.getAppAccessToken
ret <- FB.debugToken appToken testUserAccessTokenData
now <- liftIO TI.getCurrentTime
FB.dtAppId ret &?= Just (FB.appId creds)
FB.dtAppName ret &?= Just (FB.appName creds)
case FB.dtExpiresAt ret of
Nothing -> fail "dtExpiresAt is Nothing"
Just t -> compare t now &?= GT
FB.dtIsValid ret &?= Just True
case FB.dtIssuedAt ret of
Nothing -> return () -- ok since it's a test user
Just t -> compare t now &?= LT
isJust (FB.dtScopes ret) &?= True
FB.dtUserId ret &?= Just (FB.tuId testUser)
case FB.dtAccessToken ret of
Nothing -> fail "dtAccessToken is Nothing"
Just t -> do
let f :: FB.UserAccessToken -> FB.FacebookT FB.Auth (R.ResourceT IO) ()
f (FB.UserAccessToken uid dt exps) = do
uid &?= FB.tuId testUser
dt &?= testUserAccessTokenData
Just exps &?= FB.dtExpiresAt ret
f t
describe' "getObject" $ do
it "is able to fetch Facebook's own page" $
runNoAuth $ do
A.Object obj <- FB.getObject "/19292868552" [] Nothing
let Just r = flip A.parseMaybe () $ const $
(,,) <$> obj A..:? "id"
<*> obj A..:? "website"
<*> obj A..:? "name"
just x = Just (x :: Text)
r &?= ( just "19292868552"
, just "http://developers.facebook.com"
, just "Facebook Developers" )
describe' "getUser" $ do
it "works for Zuckerberg" $ do
runNoAuth $ do
user <- FB.getUser (FB.Id "zuck") [] Nothing
FB.userId user &?= FB.Id "4"
FB.userName user &?= Just "Mark Zuckerberg"
FB.userFirstName user &?= Just "Mark"
FB.userMiddleName user &?= Nothing
FB.userLastName user &?= Just "Zuckerberg"
FB.userGender user &?= Just FB.Male
describe' "getPage" $ do
it "works for FB Developers" $ do
runNoAuth $ do
page <- FB.getPage (FB.Id "19292868552") [] Nothing
FB.pageId page &?= (FB.Id "19292868552")
FB.pageName page &?= Just "Facebook Developers"
FB.pageCategory page &?= Just "Product/service"
FB.pageIsPublished page &?= Just True
FB.pageCanPost page &?= Nothing
FB.pagePhone page &?= Nothing
FB.pageCheckins page &?= Nothing
FB.pageWebsite page &?= Just "http://developers.facebook.com"
describe' "fqlQuery" $ do
it "is able to query Facebook's page name from its page id" $
runNoAuth $ do
r <- FB.fqlQuery "SELECT name FROM page WHERE page_id = 20531316728" Nothing
FB.pagerData r &?= [PageName "Facebook"]
describe' "listSubscriptions" $ do
it "returns something" $ do
runAuth $ do
token <- FB.getAppAccessToken
val <- FB.listSubscriptions token
length val `seq` return ()
describe' "fetchNextPage" $ do
let fetchNextPageWorks :: FB.Pager A.Value -> FB.FacebookT anyAuth (R.ResourceT IO) ()
fetchNextPageWorks pager
| isNothing (FB.pagerNext pager) = return ()
| otherwise = FB.fetchNextPage pager >>= maybe not_ (\_ -> return ())
where not_ = fail "Pager had a next page but fetchNextPage didn't work."
it "seems to work on a public list of comments" $ do
runNoAuth $ do
fetchNextPageWorks =<< FB.getObject "/135529993185189_397300340341485/comments" [] Nothing
it "seems to work on a private list of app insights" $ do
runAuth $ do
token <- FB.getAppAccessToken
fetchNextPageWorks =<< FB.getObject "/app/insights" [] (Just token)
describe' "fetchNextPage/fetchPreviousPage" $ do
let backAndForthWorks :: FB.Pager A.Value -> FB.FacebookT anyAuth (R.ResourceT IO) ()
backAndForthWorks pager = do
Just pager2 <- FB.fetchNextPage pager
Just pager3 <- FB.fetchPreviousPage pager2
pager3 &?= pager
it "seems to work on a public list of comments" $ do
runNoAuth $ do
backAndForthWorks =<< FB.getObject "/135529993185189_397300340341485/comments" [] Nothing
it "seems to work on a private list of app insights" $ do
runAuth $ do
token <- FB.getAppAccessToken
backAndForthWorks =<< FB.getObject "/app/insights" [] (Just token)
describe' "fetchAllNextPages" $ do
let hasAtLeast :: C.Source IO A.Value -> Int -> IO ()
src `hasAtLeast` n = src C.$$ go n
where go 0 = return ()
go m = C.await >>= maybe not_ (\_ -> go (m-1))
not_ = fail $ "Source does not have at least " ++ show n ++ " elements."
it "seems to work on a public list of comments" $ do
runNoAuth $ do
pager <- FB.getObject "/135529993185189_397300340341485/comments" [] Nothing
src <- FB.fetchAllNextPages pager
liftIO $ src `hasAtLeast` 200 -- items
it "seems to work on a private list of app insights" $ do
runAuth $ do
token <- FB.getAppAccessToken
pager <- FB.getObject "/app/insights" [] (Just token)
src <- FB.fetchAllNextPages pager
let firstPageElms = length (FB.pagerData pager)
hasNextPage = isJust (FB.pagerNext pager)
if hasNextPage
then liftIO $ src `hasAtLeast` (firstPageElms * 3) -- items
else fail "This isn't an insightful app =(."
describe' "createTestUser/removeTestUser/getTestUser" $ do
it "creates and removes a new test user" $ do
runAuth $ do
token <- FB.getAppAccessToken
-- New test user information
let installed = FB.CreateTestUserInstalled
[ "read_stream"
, "read_friendlists"
, "publish_stream" ]
userInfo = FB.CreateTestUser
{ FB.ctuInstalled = installed
, FB.ctuName = Just "Gabriel"
, FB.ctuLocale = Just "en_US" }
-- Create the test user
newTestUser <- FB.createTestUser userInfo token
let newTestUserToken = (M.fromJust $ FB.incompleteTestUserAccessToken newTestUser)
-- Get the created user
createdUser <- FB.getUser (FB.tuId newTestUser) [] (Just newTestUserToken)
-- Remove the test user
True <- FB.removeTestUser newTestUser token
-- Check user attributes
FB.userId createdUser &?= FB.tuId newTestUser
FB.userName createdUser &?= Just "Gabriel"
FB.userLocale createdUser &?= Just "en_US"
-- Check if the token is valid
FB.isValid newTestUserToken #?= False
describe' "makeFriendConn" $ do
it "creates two new test users, makes them friends and deletes them" $ do
runAuth $
withTestUser D.def $ \testUser1 ->
withTestUser D.def $ \testUser2 -> do
let Just tokenUser1 = FB.incompleteTestUserAccessToken testUser1
let Just tokenUser2 = FB.incompleteTestUserAccessToken testUser2
-- Check if the new test users' tokens are valid.
FB.isValid tokenUser1 #?= True
FB.isValid tokenUser2 #?= True
-- Create a friend connection between the new test users.
FB.makeFriendConn testUser1 testUser2
-- Verify that one is a friend of the other.
user1 <- FB.getUser (FB.tuId testUser1) [] (Just tokenUser1)
user2 <- FB.getUser (FB.tuId testUser2) [] (Just tokenUser2)
friends1 <- FB.getUserFriends (FB.tuId testUser1) [] tokenUser1
friends2 <- FB.getUserFriends (FB.tuId testUser2) [] tokenUser2
FB.pagerData friends1 &?= [FB.Friend (FB.tuId testUser2) (M.fromJust (FB.userName user2))]
FB.pagerData friends2 &?= [FB.Friend (FB.tuId testUser1) (M.fromJust (FB.userName user1))]
describe' "getTestUsers" $ do
it "gets a list of test users" $ do
runAuth $ do
token <- FB.getAppAccessToken
pager <- FB.getTestUsers token
src <- FB.fetchAllNextPages pager
oldList <- liftIO $ R.runResourceT $ src C.$$ CL.consume
withTestUser D.def $ \testUser -> do
let (%?=) = (&?=) `on` fmap FB.tuId
(//) = S.difference `on` S.fromList
newList <- FB.pagerData <$> FB.getTestUsers token
S.toList (newList // oldList) %?= [testUser]
newtype PageName = PageName Text deriving (Eq, Show)
instance A.FromJSON PageName where
parseJSON (A.Object v) = PageName <$> (v A..: "name")
parseJSON _ = mzero
libraryTests :: H.Manager -> Spec
libraryTests manager = do
describe "SimpleType" $ do
it "works for Bool" $ (map FB.encodeFbParam [True, False]) @?= ["1", "0"]
let day = TI.fromGregorian 2012 12 21
time = TI.TimeOfDay 11 37 22
diffTime = TI.secondsToDiffTime (11*3600 + 37*60)
utcTime = TI.UTCTime day diffTime
localTime = TI.LocalTime day time
zonedTime = TI.ZonedTime localTime (TI.minutesToTimeZone 30)
it "works for Day" $ FB.encodeFbParam day @?= "2012-12-21"
it "works for UTCTime" $ FB.encodeFbParam utcTime @?= "20121221T1137Z"
it "works for ZonedTime" $ FB.encodeFbParam zonedTime @?= "20121221T1107Z"
let propShowRead :: (Show a, Read a, Eq a, FB.SimpleType a) => a -> Bool
propShowRead x = read (B.unpack $ FB.encodeFbParam x) == x
prop "works for Float" (propShowRead :: Float -> Bool)
prop "works for Double" (propShowRead :: Double -> Bool)
prop "works for Int" (propShowRead :: Int -> Bool)
prop "works for Int8" (propShowRead :: Int8 -> Bool)
prop "works for Int16" (propShowRead :: Int16 -> Bool)
prop "works for Int32" (propShowRead :: Int32 -> Bool)
prop "works for Int64" (propShowRead :: Int64 -> Bool)
prop "works for Word" (propShowRead :: Word -> Bool)
prop "works for Word8" (propShowRead :: Word8 -> Bool)
prop "works for Word16" (propShowRead :: Word16 -> Bool)
prop "works for Word32" (propShowRead :: Word32 -> Bool)
prop "works for Word64" (propShowRead :: Word64 -> Bool)
let propShowReadL :: (Show a, Read a, Eq a, FB.SimpleType a) => [a] -> Bool
propShowReadL x = read ('[' : B.unpack (FB.encodeFbParam x) ++ "]") == x
prop "works for [Float]" (propShowReadL :: [Float] -> Bool)
prop "works for [Double]" (propShowReadL :: [Double] -> Bool)
prop "works for [Int]" (propShowReadL :: [Int] -> Bool)
prop "works for [Int8]" (propShowReadL :: [Int8] -> Bool)
prop "works for [Int16]" (propShowReadL :: [Int16] -> Bool)
prop "works for [Int32]" (propShowReadL :: [Int32] -> Bool)
prop "works for [Int64]" (propShowReadL :: [Int64] -> Bool)
prop "works for [Word]" (propShowReadL :: [Word] -> Bool)
prop "works for [Word8]" (propShowReadL :: [Word8] -> Bool)
prop "works for [Word16]" (propShowReadL :: [Word16] -> Bool)
prop "works for [Word32]" (propShowReadL :: [Word32] -> Bool)
prop "works for [Word64]" (propShowReadL :: [Word64] -> Bool)
prop "works for Text" (\t -> FB.encodeFbParam t == TE.encodeUtf8 t)
prop "works for Id" $ \i ->
let toId :: Int -> FB.Id
toId = FB.Id . T.pack . show
j = abs i
in FB.encodeFbParam (toId j) == FB.encodeFbParam j
describe "parseSignedRequest" $ do
let exampleSig, exampleData :: B.ByteString
exampleSig = "vlXgu64BQGFSQrY0ZcJBZASMvYvTHu9GQ0YM9rjPSso"
exampleData = "eyJhbGdvcml0aG0iOiJITUFDLVNIQTI1NiIsIjAiOiJwYXlsb2FkIn0"
exampleCreds = FB.Credentials "name" "id" "secret"
runExampleAuth :: FB.FacebookT FB.Auth (R.ResourceT IO) a -> IO a
runExampleAuth = R.runResourceT . FB.runFacebookT exampleCreds manager
it "works for Facebook example" $ do
runExampleAuth $ do
ret <- FB.parseSignedRequest (B.concat [exampleSig, ".", exampleData])
ret &?= Just (A.object [ "algorithm" A..= ("HMAC-SHA256" :: Text)
, "0" A..= ("payload" :: Text)])
it "fails to parse the Facebook example when signature is corrupted" $ do
let corruptedSig = B.cons 'a' (B.tail exampleSig)
runExampleAuth $ do
ret <- FB.parseSignedRequest (B.concat [corruptedSig, ".", exampleData])
ret &?= (Nothing :: Maybe A.Value)
describe "FQLTime" $ do
it "seems to work" $ do
let input = "[1348678357]"
output = FB.FQLTime (read "2012-09-26 16:52:37 UTC")
A.decode input @?= Just [output]
describe "FbUTCTime" $ do
let output = FB.FbUTCTime (read "2012-09-26 16:52:37 UTC")
it "seems to work (string)" $ do
let input = "[\"2012-09-26T16:52:37+0000\"]"
A.decode input @?= Just [output]
it "seems to work (unix epoch)" $ do
let input = "[1348678357]"
A.decode input @?= Just [output]
describe "FQLList" $ do
let j :: [Int] -> Maybe (FB.FQLList Int)
j = Just . FB.FQLList
it "parses []" $ do
A.decode "[]" @?= j []
it "parses {}" $ do
A.decode "{}" @?= j []
it "parses [1234]" $ do
A.decode "[1234]" @?= j [1234]
it "parses {\"1234\": 1234}" $ do
A.decode "{\"1234\": 1234}" @?= j [1234]
describe "FQLObject" $ do
let j :: [(Text, Int)] -> Maybe (FB.FQLObject (Map.Map Text Int))
j = Just . FB.FQLObject . Map.fromList
it "parses []" $ do
A.decode "[]" @?= j []
it "parses {}" $ do
A.decode "{}" @?= j []
it "parses {\"abc\": 1234}" $ do
A.decode "{\"abc\": 1234}" @?= j [("abc", 1234)]
it "does not parse [1234]" $ do
A.decode "[1234]" @?= (Nothing `asTypeOf` j [])
describe "Id" $ do
it "can be parsed from a string" $ do
A.decode "[\"1234\"]" @?= Just [FB.Id "1234"]
it "can be parsed from an integer" $ do
A.decode "[1234]" @?= Just [FB.Id "1234"]
it "can be parsed from an object with a string" $ do
A.decode "{\"id\": \"1234\"}" @?= Just (FB.Id "1234")
it "can be parsed from an object with an integer" $ do
A.decode "{\"id\": 1234}" @?= Just (FB.Id "1234")
describe "AccessToken" $ do
it "can be round-tripped with ToJSON/FromJSON (UserKind)" $ do
A.eitherDecode (A.encode invalidUserAccessToken) @?= Right invalidUserAccessToken
it "can be round-tripped with ToJSON/FromJSON (AppKind)" $ do
A.eitherDecode (A.encode invalidAppAccessToken) @?= Right invalidAppAccessToken
-- 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
-- | 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 ctu action = do
token <- FB.getAppAccessToken
E.bracket (FB.createTestUser ctu token)
(flip FB.removeTestUser token)
action
fb-1.0.13/LICENSE 0000644 0000000 0000000 00000002761 12641032441 011361 0 ustar 00 0000000 0000000 Copyright (c)2012, Felipe Lessa
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the name of Felipe Lessa nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
fb-1.0.13/Setup.hs 0000644 0000000 0000000 00000000056 12641032441 012003 0 ustar 00 0000000 0000000 import Distribution.Simple
main = defaultMain
fb-1.0.13/fb.cabal 0000644 0000000 0000000 00000007174 12641033502 011731 0 ustar 00 0000000 0000000 name: fb
version: 1.0.13
license: BSD3
license-file: LICENSE
author: Felipe Lessa
maintainer: Felipe Lessa
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
description:
This package exports bindings to Facebook's APIs (see
). 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
().
extra-source-files:
tests/Main.hs
tests/tryIt.hs
example.hs
source-repository head
type: git
location: git://github.com/prowdsponsor/fb.git
flag debug
default: False
description: Print debugging info.
flag conduit11
description: Use conduit >= 1.1.
library
hs-source-dirs: src
ghc-options: -Wall
exposed-modules:
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
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
, data-default
, http-types
, http-conduit >= 2.0 && < 2.2
, attoparsec >= 0.10.4 && < 0.14
, 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)
build-depends:
conduit >= 1.1 && < 1.3
, conduit-extra == 1.1.*
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
test-suite runtests
type: exitcode-stdio-1.0
ghc-options: -Wall -fno-warn-orphans
hs-source-dirs: tests
main-is: Main.hs
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
, containers
, data-default
, HUnit
, QuickCheck
, hspec >= 1.9 && < 1.12
, fb
extensions:
TypeFamilies
ScopedTypeVariables
fb-1.0.13/tests/Main.hs 0000644 0000000 0000000 00000051137 12641032441 012737 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings
, Rank2Types
, ScopedTypeVariables
, GADTs
, FlexibleContexts #-}
module Main (main, getCredentials) where
import Control.Applicative
import Control.Monad (mzero)
import Control.Monad.IO.Class (MonadIO(liftIO))
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
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.Map as Map
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 Facebook as FB
import qualified Network.HTTP.Conduit as H
import qualified Test.QuickCheck as QC
import Test.HUnit ((@?=))
import Test.Hspec
import Test.Hspec.HUnit ()
import Test.Hspec.QuickCheck
-- | Grab the Facebook credentials from the environment.
getCredentials :: IO FB.Credentials
getCredentials = tryToGet `E.catch` showHelp
where
tryToGet = do
[appName, appId, appSecret] <- mapM getEnv ["APP_NAME", "APP_ID", "APP_SECRET"]
return $ FB.Credentials (T.pack appName) (T.pack appId) (T.pack appSecret)
showHelp exc | not (isDoesNotExistError exc) = E.throw exc
showHelp _ = do
putStrLn $ unlines
[ "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"
, "create a Facebook app for this purpose and then distribute"
, "its secret keys in the open."
, ""
, "Please give your app's name, id and secret on the enviroment"
, "variables APP_NAME, APP_ID and APP_SECRET, respectively. "
, "For example, before running the test you could run in the shell:"
, ""
, " $ export APP_NAME=\"example\""
, " $ export APP_ID=\"458798571203498\""
, " $ export APP_SECRET=\"28a9d0fa4272a14a9287f423f90a48f2304\""
, ""
, "Of course, these values above aren't valid and you need to"
, "replace them with your own."
, ""
, "(Exiting now with a failure code.)"]
exitFailure
invalidCredentials :: FB.Credentials
invalidCredentials = FB.Credentials "this" "isn't" "valid"
invalidUserAccessToken :: FB.UserAccessToken
invalidUserAccessToken = FB.UserAccessToken (FB.Id "invalid") "user" farInTheFuture
where
Just farInTheFuture = parseTime (error "farInTheFuture") "%Y" "3000"
-- It's actually important to use 'farInTheFuture' since we
-- don't want any tests rejecting this invalid user access
-- token before even giving it to Facebook.
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
facebookTests :: String
-> FB.Credentials
-> H.Manager
-> (forall a. FB.FacebookT FB.Auth (R.ResourceT IO) a -> IO a)
-> (forall a. FB.FacebookT FB.NoAuth (R.ResourceT IO) a -> IO a)
-> Spec
facebookTests pretitle creds manager runAuth runNoAuth = do
let describe' = describe . (pretitle ++)
describe' "getAppAccessToken" $ do
it "works and returns a valid app access token" $
runAuth $ do
token <- FB.getAppAccessToken
FB.isValid token #?= True
it "throws a FacebookException on invalid credentials" $
R.runResourceT $
FB.runFacebookT invalidCredentials manager $ do
ret <- E.try $ FB.getAppAccessToken
case ret of
Right token -> fail $ show token
Left (_ :: FB.FacebookException) -> lift $ lift (return () :: IO ())
describe' "isValid" $ do
it "returns False on a clearly invalid user access token" $
runNoAuth $ FB.isValid invalidUserAccessToken #?= False
it "returns False on a clearly invalid app access token" $
runNoAuth $ FB.isValid invalidAppAccessToken #?= False
describe' "debugToken" $ do
it "works on a test user access token" $ do
runAuth $
withTestUser D.def $ \testUser -> do
Just testUserAccessTokenData <- return (FB.tuAccessToken testUser)
appToken <- FB.getAppAccessToken
ret <- FB.debugToken appToken testUserAccessTokenData
now <- liftIO TI.getCurrentTime
FB.dtAppId ret &?= Just (FB.appId creds)
FB.dtAppName ret &?= Just (FB.appName creds)
case FB.dtExpiresAt ret of
Nothing -> fail "dtExpiresAt is Nothing"
Just t -> compare t now &?= GT
FB.dtIsValid ret &?= Just True
case FB.dtIssuedAt ret of
Nothing -> return () -- ok since it's a test user
Just t -> compare t now &?= LT
isJust (FB.dtScopes ret) &?= True
FB.dtUserId ret &?= Just (FB.tuId testUser)
case FB.dtAccessToken ret of
Nothing -> fail "dtAccessToken is Nothing"
Just t -> do
let f :: FB.UserAccessToken -> FB.FacebookT FB.Auth (R.ResourceT IO) ()
f (FB.UserAccessToken uid dt exps) = do
uid &?= FB.tuId testUser
dt &?= testUserAccessTokenData
Just exps &?= FB.dtExpiresAt ret
f t
describe' "getObject" $ do
it "is able to fetch Facebook's own page" $
runNoAuth $ do
A.Object obj <- FB.getObject "/19292868552" [] Nothing
let Just r = flip A.parseMaybe () $ const $
(,,) <$> obj A..:? "id"
<*> obj A..:? "website"
<*> obj A..:? "name"
just x = Just (x :: Text)
r &?= ( just "19292868552"
, just "http://developers.facebook.com"
, just "Facebook Developers" )
describe' "getUser" $ do
it "works for Zuckerberg" $ do
runNoAuth $ do
user <- FB.getUser (FB.Id "zuck") [] Nothing
FB.userId user &?= FB.Id "4"
FB.userName user &?= Just "Mark Zuckerberg"
FB.userFirstName user &?= Just "Mark"
FB.userMiddleName user &?= Nothing
FB.userLastName user &?= Just "Zuckerberg"
FB.userGender user &?= Just FB.Male
describe' "getPage" $ do
it "works for FB Developers" $ do
runNoAuth $ do
page <- FB.getPage (FB.Id "19292868552") [] Nothing
FB.pageId page &?= (FB.Id "19292868552")
FB.pageName page &?= Just "Facebook Developers"
FB.pageCategory page &?= Just "Product/service"
FB.pageIsPublished page &?= Just True
FB.pageCanPost page &?= Nothing
FB.pagePhone page &?= Nothing
FB.pageCheckins page &?= Nothing
FB.pageWebsite page &?= Just "http://developers.facebook.com"
describe' "fqlQuery" $ do
it "is able to query Facebook's page name from its page id" $
runNoAuth $ do
r <- FB.fqlQuery "SELECT name FROM page WHERE page_id = 20531316728" Nothing
FB.pagerData r &?= [PageName "Facebook"]
describe' "listSubscriptions" $ do
it "returns something" $ do
runAuth $ do
token <- FB.getAppAccessToken
val <- FB.listSubscriptions token
length val `seq` return ()
describe' "fetchNextPage" $ do
let fetchNextPageWorks :: FB.Pager A.Value -> FB.FacebookT anyAuth (R.ResourceT IO) ()
fetchNextPageWorks pager
| isNothing (FB.pagerNext pager) = return ()
| otherwise = FB.fetchNextPage pager >>= maybe not_ (\_ -> return ())
where not_ = fail "Pager had a next page but fetchNextPage didn't work."
it "seems to work on a public list of comments" $ do
runNoAuth $ do
fetchNextPageWorks =<< FB.getObject "/135529993185189_397300340341485/comments" [] Nothing
it "seems to work on a private list of app insights" $ do
runAuth $ do
token <- FB.getAppAccessToken
fetchNextPageWorks =<< FB.getObject "/app/insights" [] (Just token)
describe' "fetchNextPage/fetchPreviousPage" $ do
let backAndForthWorks :: FB.Pager A.Value -> FB.FacebookT anyAuth (R.ResourceT IO) ()
backAndForthWorks pager = do
Just pager2 <- FB.fetchNextPage pager
Just pager3 <- FB.fetchPreviousPage pager2
pager3 &?= pager
it "seems to work on a public list of comments" $ do
runNoAuth $ do
backAndForthWorks =<< FB.getObject "/135529993185189_397300340341485/comments" [] Nothing
it "seems to work on a private list of app insights" $ do
runAuth $ do
token <- FB.getAppAccessToken
backAndForthWorks =<< FB.getObject "/app/insights" [] (Just token)
describe' "fetchAllNextPages" $ do
let hasAtLeast :: C.Source IO A.Value -> Int -> IO ()
src `hasAtLeast` n = src C.$$ go n
where go 0 = return ()
go m = C.await >>= maybe not_ (\_ -> go (m-1))
not_ = fail $ "Source does not have at least " ++ show n ++ " elements."
it "seems to work on a public list of comments" $ do
runNoAuth $ do
pager <- FB.getObject "/135529993185189_397300340341485/comments" [] Nothing
src <- FB.fetchAllNextPages pager
liftIO $ src `hasAtLeast` 200 -- items
it "seems to work on a private list of app insights" $ do
runAuth $ do
token <- FB.getAppAccessToken
pager <- FB.getObject "/app/insights" [] (Just token)
src <- FB.fetchAllNextPages pager
let firstPageElms = length (FB.pagerData pager)
hasNextPage = isJust (FB.pagerNext pager)
if hasNextPage
then liftIO $ src `hasAtLeast` (firstPageElms * 3) -- items
else fail "This isn't an insightful app =(."
describe' "createTestUser/removeTestUser/getTestUser" $ do
it "creates and removes a new test user" $ do
runAuth $ do
token <- FB.getAppAccessToken
-- New test user information
let installed = FB.CreateTestUserInstalled
[ "read_stream"
, "read_friendlists"
, "publish_stream" ]
userInfo = FB.CreateTestUser
{ FB.ctuInstalled = installed
, FB.ctuName = Just "Gabriel"
, FB.ctuLocale = Just "en_US" }
-- Create the test user
newTestUser <- FB.createTestUser userInfo token
let newTestUserToken = (M.fromJust $ FB.incompleteTestUserAccessToken newTestUser)
-- Get the created user
createdUser <- FB.getUser (FB.tuId newTestUser) [] (Just newTestUserToken)
-- Remove the test user
True <- FB.removeTestUser newTestUser token
-- Check user attributes
FB.userId createdUser &?= FB.tuId newTestUser
FB.userName createdUser &?= Just "Gabriel"
FB.userLocale createdUser &?= Just "en_US"
-- Check if the token is valid
FB.isValid newTestUserToken #?= False
describe' "makeFriendConn" $ do
it "creates two new test users, makes them friends and deletes them" $ do
runAuth $
withTestUser D.def $ \testUser1 ->
withTestUser D.def $ \testUser2 -> do
let Just tokenUser1 = FB.incompleteTestUserAccessToken testUser1
let Just tokenUser2 = FB.incompleteTestUserAccessToken testUser2
-- Check if the new test users' tokens are valid.
FB.isValid tokenUser1 #?= True
FB.isValid tokenUser2 #?= True
-- Create a friend connection between the new test users.
FB.makeFriendConn testUser1 testUser2
-- Verify that one is a friend of the other.
user1 <- FB.getUser (FB.tuId testUser1) [] (Just tokenUser1)
user2 <- FB.getUser (FB.tuId testUser2) [] (Just tokenUser2)
friends1 <- FB.getUserFriends (FB.tuId testUser1) [] tokenUser1
friends2 <- FB.getUserFriends (FB.tuId testUser2) [] tokenUser2
FB.pagerData friends1 &?= [FB.Friend (FB.tuId testUser2) (M.fromJust (FB.userName user2))]
FB.pagerData friends2 &?= [FB.Friend (FB.tuId testUser1) (M.fromJust (FB.userName user1))]
describe' "getTestUsers" $ do
it "gets a list of test users" $ do
runAuth $ do
token <- FB.getAppAccessToken
pager <- FB.getTestUsers token
src <- FB.fetchAllNextPages pager
oldList <- liftIO $ R.runResourceT $ src C.$$ CL.consume
withTestUser D.def $ \testUser -> do
let (%?=) = (&?=) `on` fmap FB.tuId
(//) = S.difference `on` S.fromList
newList <- FB.pagerData <$> FB.getTestUsers token
S.toList (newList // oldList) %?= [testUser]
newtype PageName = PageName Text deriving (Eq, Show)
instance A.FromJSON PageName where
parseJSON (A.Object v) = PageName <$> (v A..: "name")
parseJSON _ = mzero
libraryTests :: H.Manager -> Spec
libraryTests manager = do
describe "SimpleType" $ do
it "works for Bool" $ (map FB.encodeFbParam [True, False]) @?= ["1", "0"]
let day = TI.fromGregorian 2012 12 21
time = TI.TimeOfDay 11 37 22
diffTime = TI.secondsToDiffTime (11*3600 + 37*60)
utcTime = TI.UTCTime day diffTime
localTime = TI.LocalTime day time
zonedTime = TI.ZonedTime localTime (TI.minutesToTimeZone 30)
it "works for Day" $ FB.encodeFbParam day @?= "2012-12-21"
it "works for UTCTime" $ FB.encodeFbParam utcTime @?= "20121221T1137Z"
it "works for ZonedTime" $ FB.encodeFbParam zonedTime @?= "20121221T1107Z"
let propShowRead :: (Show a, Read a, Eq a, FB.SimpleType a) => a -> Bool
propShowRead x = read (B.unpack $ FB.encodeFbParam x) == x
prop "works for Float" (propShowRead :: Float -> Bool)
prop "works for Double" (propShowRead :: Double -> Bool)
prop "works for Int" (propShowRead :: Int -> Bool)
prop "works for Int8" (propShowRead :: Int8 -> Bool)
prop "works for Int16" (propShowRead :: Int16 -> Bool)
prop "works for Int32" (propShowRead :: Int32 -> Bool)
prop "works for Int64" (propShowRead :: Int64 -> Bool)
prop "works for Word" (propShowRead :: Word -> Bool)
prop "works for Word8" (propShowRead :: Word8 -> Bool)
prop "works for Word16" (propShowRead :: Word16 -> Bool)
prop "works for Word32" (propShowRead :: Word32 -> Bool)
prop "works for Word64" (propShowRead :: Word64 -> Bool)
let propShowReadL :: (Show a, Read a, Eq a, FB.SimpleType a) => [a] -> Bool
propShowReadL x = read ('[' : B.unpack (FB.encodeFbParam x) ++ "]") == x
prop "works for [Float]" (propShowReadL :: [Float] -> Bool)
prop "works for [Double]" (propShowReadL :: [Double] -> Bool)
prop "works for [Int]" (propShowReadL :: [Int] -> Bool)
prop "works for [Int8]" (propShowReadL :: [Int8] -> Bool)
prop "works for [Int16]" (propShowReadL :: [Int16] -> Bool)
prop "works for [Int32]" (propShowReadL :: [Int32] -> Bool)
prop "works for [Int64]" (propShowReadL :: [Int64] -> Bool)
prop "works for [Word]" (propShowReadL :: [Word] -> Bool)
prop "works for [Word8]" (propShowReadL :: [Word8] -> Bool)
prop "works for [Word16]" (propShowReadL :: [Word16] -> Bool)
prop "works for [Word32]" (propShowReadL :: [Word32] -> Bool)
prop "works for [Word64]" (propShowReadL :: [Word64] -> Bool)
prop "works for Text" (\t -> FB.encodeFbParam t == TE.encodeUtf8 t)
prop "works for Id" $ \i ->
let toId :: Int -> FB.Id
toId = FB.Id . T.pack . show
j = abs i
in FB.encodeFbParam (toId j) == FB.encodeFbParam j
describe "parseSignedRequest" $ do
let exampleSig, exampleData :: B.ByteString
exampleSig = "vlXgu64BQGFSQrY0ZcJBZASMvYvTHu9GQ0YM9rjPSso"
exampleData = "eyJhbGdvcml0aG0iOiJITUFDLVNIQTI1NiIsIjAiOiJwYXlsb2FkIn0"
exampleCreds = FB.Credentials "name" "id" "secret"
runExampleAuth :: FB.FacebookT FB.Auth (R.ResourceT IO) a -> IO a
runExampleAuth = R.runResourceT . FB.runFacebookT exampleCreds manager
it "works for Facebook example" $ do
runExampleAuth $ do
ret <- FB.parseSignedRequest (B.concat [exampleSig, ".", exampleData])
ret &?= Just (A.object [ "algorithm" A..= ("HMAC-SHA256" :: Text)
, "0" A..= ("payload" :: Text)])
it "fails to parse the Facebook example when signature is corrupted" $ do
let corruptedSig = B.cons 'a' (B.tail exampleSig)
runExampleAuth $ do
ret <- FB.parseSignedRequest (B.concat [corruptedSig, ".", exampleData])
ret &?= (Nothing :: Maybe A.Value)
describe "FQLTime" $ do
it "seems to work" $ do
let input = "[1348678357]"
output = FB.FQLTime (read "2012-09-26 16:52:37 UTC")
A.decode input @?= Just [output]
describe "FbUTCTime" $ do
let output = FB.FbUTCTime (read "2012-09-26 16:52:37 UTC")
it "seems to work (string)" $ do
let input = "[\"2012-09-26T16:52:37+0000\"]"
A.decode input @?= Just [output]
it "seems to work (unix epoch)" $ do
let input = "[1348678357]"
A.decode input @?= Just [output]
describe "FQLList" $ do
let j :: [Int] -> Maybe (FB.FQLList Int)
j = Just . FB.FQLList
it "parses []" $ do
A.decode "[]" @?= j []
it "parses {}" $ do
A.decode "{}" @?= j []
it "parses [1234]" $ do
A.decode "[1234]" @?= j [1234]
it "parses {\"1234\": 1234}" $ do
A.decode "{\"1234\": 1234}" @?= j [1234]
describe "FQLObject" $ do
let j :: [(Text, Int)] -> Maybe (FB.FQLObject (Map.Map Text Int))
j = Just . FB.FQLObject . Map.fromList
it "parses []" $ do
A.decode "[]" @?= j []
it "parses {}" $ do
A.decode "{}" @?= j []
it "parses {\"abc\": 1234}" $ do
A.decode "{\"abc\": 1234}" @?= j [("abc", 1234)]
it "does not parse [1234]" $ do
A.decode "[1234]" @?= (Nothing `asTypeOf` j [])
describe "Id" $ do
it "can be parsed from a string" $ do
A.decode "[\"1234\"]" @?= Just [FB.Id "1234"]
it "can be parsed from an integer" $ do
A.decode "[1234]" @?= Just [FB.Id "1234"]
it "can be parsed from an object with a string" $ do
A.decode "{\"id\": \"1234\"}" @?= Just (FB.Id "1234")
it "can be parsed from an object with an integer" $ do
A.decode "{\"id\": 1234}" @?= Just (FB.Id "1234")
describe "AccessToken" $ do
it "can be round-tripped with ToJSON/FromJSON (UserKind)" $ do
A.eitherDecode (A.encode invalidUserAccessToken) @?= Right invalidUserAccessToken
it "can be round-tripped with ToJSON/FromJSON (AppKind)" $ do
A.eitherDecode (A.encode invalidAppAccessToken) @?= Right invalidAppAccessToken
-- 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
-- | 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 ctu action = do
token <- FB.getAppAccessToken
E.bracket (FB.createTestUser ctu token)
(flip FB.removeTestUser token)
action
fb-1.0.13/tests/tryIt.hs 0000644 0000000 0000000 00000000716 12641032441 013163 0 ustar 00 0000000 0000000 module TryIt (runFB) where
-- You may import this file from GHCi in order to try the fb
-- package. For example:
--
-- > :l tryIt
--
-- > runFB FB.getAppAccessToken
import qualified Data.Conduit as C
import qualified Facebook as FB
import qualified Network.HTTP.Conduit as H
import Main (getCredentials)
runFB :: FB.FacebookT FB.Auth (C.ResourceT IO) a -> IO a
runFB act = do
creds <- getCredentials
H.withManager $ \m -> FB.runFacebookT creds m act
fb-1.0.13/example.hs 0000644 0000000 0000000 00000000504 12641032441 012334 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
import qualified Facebook as FB
import Network.HTTP.Conduit (withManager)
import Control.Monad.IO.Class (liftIO)
main :: IO ()
main = do
withManager $ \manager -> do
FB.runNoAuthFacebookT manager $ do
u <- FB.getUser "zuck" [] Nothing
liftIO $ print (FB.userName u)