fb-1.0.13/src/0000755000000000000000000000000012641032441011135 5ustar0000000000000000fb-1.0.13/src/Facebook/0000755000000000000000000000000012641032441012646 5ustar0000000000000000fb-1.0.13/src/Facebook/Object/0000755000000000000000000000000012641032441014054 5ustar0000000000000000fb-1.0.13/tests/0000755000000000000000000000000012641032441011510 5ustar0000000000000000fb-1.0.13/src/Facebook.hs0000644000000000000000000000615512641032441013211 0ustar0000000000000000module 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.hs0000644000000000000000000001634112641032441014313 0ustar0000000000000000{-# 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.hs0000644000000000000000000001412312641032441014241 0ustar0000000000000000{-# 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.hs0000644000000000000000000001676212641032441014070 0ustar0000000000000000{-# 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.hs0000644000000000000000000004146712641032441014117 0ustar0000000000000000{-# 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.hs0000644000000000000000000001023312641032441014237 0ustar0000000000000000{-# 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.hs0000644000000000000000000002222512641032441014246 0ustar0000000000000000{-# 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.hs0000644000000000000000000000534712641032441015636 0ustar0000000000000000{-# 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.hs0000644000000000000000000000636112641032441016461 0ustar0000000000000000{-# 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.hs0000644000000000000000000000565512641032441015767 0ustar0000000000000000{-# 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.hs0000644000000000000000000001032412641032441015326 0ustar0000000000000000{-# 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.hs0000644000000000000000000000537312641032441015274 0ustar0000000000000000{-# 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.hs0000644000000000000000000000545412641032441015473 0ustar0000000000000000{-# 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.hs0000644000000000000000000002060112641032441014703 0ustar0000000000000000{-# 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.hs0000644000000000000000000000564712641032441013640 0ustar0000000000000000{-# 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.hs0000644000000000000000000001552212641032441015150 0ustar0000000000000000{-# 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.hs0000644000000000000000000005113712641032441012737 0ustar0000000000000000{-# 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/LICENSE0000644000000000000000000000276112641032441011361 0ustar0000000000000000Copyright (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.hs0000644000000000000000000000005612641032441012003 0ustar0000000000000000import Distribution.Simple main = defaultMain fb-1.0.13/fb.cabal0000644000000000000000000000717412641033502011731 0ustar0000000000000000name: 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.hs0000644000000000000000000005113712641032441012737 0ustar0000000000000000{-# 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.hs0000644000000000000000000000071612641032441013163 0ustar0000000000000000module 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.hs0000644000000000000000000000050412641032441012334 0ustar0000000000000000{-# 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)