fb-2.1.1.1/src/0000755000000000000000000000000014231701244011214 5ustar0000000000000000fb-2.1.1.1/src/Facebook/0000755000000000000000000000000014231701244012725 5ustar0000000000000000fb-2.1.1.1/src/Facebook/Object/0000755000000000000000000000000014231701244014133 5ustar0000000000000000fb-2.1.1.1/tests/0000755000000000000000000000000014231701244011567 5ustar0000000000000000fb-2.1.1.1/src/Facebook.hs0000644000000000000000000000574214231701244013271 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 , ApiVersion , hasExpired , isValid , setApiVersion , getApiVersion -- ** App access token , AppKind , getAppAccessToken -- ** User access token , UserKind , RedirectUrl , Permission , getUserAccessTokenStep1 , getUserAccessTokenStep2 , getUserLogoutUrl , extendUserAccessToken , debugToken , DebugToken(..) -- ** Signed requests , parseSignedRequest , addAppSecretProof , makeAppSecretProof -- * Facebook's Graph API -- ** User , User(..) , UserId , Gender(..) , getUser , searchUsers , getUserCheckins , Friend(..) , getUserFriends , getUserFriendLists -- ** Page , Page(..) , getPage , 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 , disassociateTestuser , 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.Auth import Facebook.Base import Facebook.FQL import Facebook.Graph import Facebook.Monad import Facebook.Object.Action import Facebook.Object.Checkin import Facebook.Object.FriendList import Facebook.Object.Order import Facebook.Object.Page import Facebook.Object.User import Facebook.Pager import Facebook.RealTime import Facebook.TestUsers import Facebook.Types fb-2.1.1.1/src/Facebook/Auth.hs0000644000000000000000000004061714231701244014172 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module Facebook.Auth ( getAppAccessToken , getUserAccessTokenStep1 , getUserAccessTokenStep2 , getUserLogoutUrl , extendUserAccessToken , RedirectUrl , Permission , unPermission , hasExpired , isValid , parseSignedRequest , debugToken , DebugToken(..) ) where #if __GLASGOW_HASKELL__ <= 784 import Control.Applicative #endif import Control.Monad (guard, mzero) import Control.Monad.IO.Class import Control.Monad.Trans.Maybe (MaybeT(..)) import qualified Control.Monad.Trans.Resource as R import Crypto.Hash.Algorithms (SHA256) import Crypto.MAC.HMAC (HMAC(..), hmac) import Data.Aeson ((.:)) import qualified Data.Aeson as AE import Data.Aeson.Parser (json') import qualified Data.Aeson.Types as AE import qualified Data.Attoparsec.ByteString.Char8 as AB import Data.ByteArray (ScrubbedBytes, convert) import Data.ByteArray.Encoding (Base(..), convertFromBase) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B8 import qualified Data.List as L import Data.Maybe (fromMaybe) import Data.String (IsString(..)) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.Text.Encoding.Error as TE import Data.Time (UTCTime, addUTCTime, getCurrentTime) import Data.Typeable (Typeable) import qualified Network.HTTP.Types as HT import qualified UnliftIO.Exception as E import Facebook.Base import Facebook.Monad import Facebook.Types -- | Get an app access token from Facebook using your -- credentials. -- Ref: https://developers.facebook.com/docs/facebook-login/manually-build-a-login-flow getAppAccessToken :: (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m, MonadIO 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 (token :: AE.Value) <- asJson response case AE.parseMaybe tokenParser token of Just appToken -> return $ AppAccessToken appToken _ -> E.throwIO $ FbLibraryException ("Unable to parse: " <> (T.pack $ show token)) where tokenParser :: AE.Value -> AE.Parser AccessTokenData tokenParser val = AE.withObject "accessToken" (\obj -> do (token :: Text) <- obj AE..: "access_token" return token) val -- | 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, MonadIO m) => RedirectUrl -> [Permission] -> FacebookT Auth m Text getUserAccessTokenStep1 redirectUrl perms = do creds <- getCreds apiVersion <- getApiVersion withTier $ \tier -> let urlBase = case tier of Production -> "https://www.facebook.com/" <> apiVersion <> "/dialog/oauth?client_id=" Beta -> "https://www.beta.facebook.com/" <> apiVersion <> "/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 :: (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m, MonadIO 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 $ -- Get the access token data through Facebook's OAuth. do now <- liftIO getCurrentTime creds <- getCreds req <- fbreq "/oauth/access_token" Nothing $ tsq creds [code, ("redirect_uri", TE.encodeUtf8 redirectUrl)] response <- fbhttp req (userToken :: AE.Value) <- asJson response let (token, expire) = userAccessTokenParser now userToken -- Get user's ID throught Facebook's graph. userResponse <- fbhttp =<< fbreq "/me" (Just (UserAccessToken "invalid id" token expire)) [("fields", "id")] (userId :: UserId) <- asJson userResponse return $ UserAccessToken userId token expire _ -> 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.throwIO $ 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' -> AE.Value -> (AccessTokenData, UTCTime) userAccessTokenParser now val = case AE.parseMaybe tokenParser val of Just (token, parser) -> (token, parser) _ -> error $ "userAccessTokenParser: failed to parse " ++ show val where toExpire expt = addUTCTime (fromIntegral expt) now tokenParser :: AE.Value -> AE.Parser (AccessTokenData, UTCTime) tokenParser value = AE.withObject "accessToken" (\obj -> do (token :: Text) <- obj AE..: "access_token" (expires_in :: Int) <- obj AE..: "expires_in" return (token, toExpire expires_in)) value -- | 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 :: (R.MonadResource m, R.MonadUnliftIO 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 :: (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m, MonadIO 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_) ] response <- fbhttp req userToken <- E.try $ asJson response case userToken of Right val -> do now <- liftIO getCurrentTime let (extendedtoken, expire) = userAccessTokenParser now val return $ Right $ UserAccessToken uid extendedtoken expire 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, MonadIO m) => B8.ByteString -- ^ Encoded Facebook signed request -> FacebookT Auth m (Maybe a) parseSignedRequest signedRequest = runMaybeT $ -- Split, decode and JSON-parse do let (encodedSignature, encodedUnparsedPayloadWithDot) = B8.break (== '.') signedRequest ('.', encodedUnparsedPayload) <- MaybeT $ return (B8.uncons encodedUnparsedPayloadWithDot) signature <- eitherToMaybeT $ convertFromBase Base64 $ addBase64Padding encodedSignature unparsedPayload <- eitherToMaybeT $ convertFromBase Base64 $ addBase64Padding encodedUnparsedPayload payload <- eitherToMaybeT $ AB.parseOnly json' unparsedPayload -- Verify signature SignedRequestAlgorithm algo <- fromJson payload guard (algo == "HMAC-SHA256") creds <- lift getCreds let hmacKey = credsToHmacKey creds expectedSignature = hmac hmacKey encodedUnparsedPayload :: HMAC SHA256 guard ((signature :: ScrubbedBytes) == (convert 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 = 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 :: (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow 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-2.1.1.1/src/Facebook/Base.hs0000644000000000000000000001727714231701244014151 0ustar0000000000000000{-#LANGUAGE DeriveDataTypeable#-} {-#LANGUAGE FlexibleContexts#-} {-#LANGUAGE OverloadedStrings#-} {-#LANGUAGE CPP#-} module Facebook.Base ( fbreq , ToSimpleQuery(..) , asJson , asJsonHelper , asBS , FacebookException(..) , fbhttp , fbhttpHelper , httpCheck ) where import Control.Applicative import Control.Monad.IO.Class (MonadIO) import Data.ByteString.Char8 (ByteString) import Data.Text (Text) import qualified UnliftIO.Exception as E import Control.Monad.Trans.Class (MonadTrans) import qualified Control.Monad.Trans.Resource as R import qualified Data.Aeson as A import qualified Data.Attoparsec.ByteString.Char8 as AT import qualified Data.ByteString as B import qualified Data.Conduit as C import Data.Conduit ((.|)) import qualified Data.Conduit.Attoparsec as C import qualified Data.Conduit.List as CL import qualified Data.Conduit.Binary as CB 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 qualified Data.ByteString.Lazy as L #if DEBUG import Control.Monad.IO.Class (MonadIO, liftIO) import Text.Printf (printf) #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 :: MonadIO m => Text -- ^ Path. Should start from "/". -> Maybe (AccessToken anyKind) -- ^ Access token. -> HT.SimpleQuery -- ^ Parameters. -> FacebookT anyAuth m H.Request fbreq path mtoken query = do apiVersion <- getApiVersion creds <- getMCreds let appSecretProofAdder = case creds of Just c@( Credentials _ _ _ True ) -> addAppSecretProof c _ -> const id withTier $ \tier -> let host = case tier of Production -> "graph.facebook.com" Beta -> "graph.beta.facebook.com" in H.defaultRequest { H.secure = True , H.host = host , H.port = 443 , H.path = TE.encodeUtf8 ("/" <> apiVersion <> path) , H.redirectCount = 3 , H.queryString = HT.renderSimpleQuery False $ appSecretProofAdder mtoken $ maybe id tsq mtoken query #if MIN_VERSION_http_client(0,5,0) , H.responseTimeout = H.responseTimeoutMicro 120000000 -- 2 minutes #else , H.responseTimeout = Just 120000000 -- 2 minutes #endif } -- | 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.ConduitT () ByteString m ()) -> t m a asJson = lift . asJsonHelper asJsonHelper :: (MonadIO m, R.MonadThrow m, A.FromJSON a) => H.Response (C.ConduitT () ByteString m ()) -> 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 <- C.runConduit $ (H.responseBody response) .| C.sinkParser A.json' #endif case A.fromJSON val of A.Success r -> return r A.Error str -> E.throwIO $ 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.ConduitT () ByteString m ()) -> FacebookT anyAuth m ByteString asBS response = lift $ C.runConduit $ H.responseBody response .| fmap B.concat CL.consume -- | Same as 'H.http', but tries to parse errors and throw -- meaningful 'FacebookException'@s@. fbhttp :: (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m) => H.Request -> FacebookT anyAuth m (H.Response (C.ConduitT () ByteString m ())) fbhttp req = do manager <- getManager lift (fbhttpHelper manager req) fbhttpHelper :: (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m) => H.Manager -> H.Request -> m (H.Response (C.ConduitT () ByteString m ())) fbhttpHelper manager req = do #if MIN_VERSION_http_client(0,5,0) let req' = req { H.checkResponse = \_ _ -> return () } #else let req' = req { H.checkStatus = \_ _ _ -> Nothing } #endif #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 #if DEBUG _ <- liftIO $ printf "fbhttp response status: %s\n" (show status) #endif if isOkay status then return response else do #if MIN_VERSION_http_client(0,5,0) fullResp <- C.runConduit $ (H.responseBody response) .| CB.sinkLbs let res' = fmap (const ()) response let statusexc = H.HttpExceptionRequest req $ H.StatusCodeException res' (L.toStrict fullResp) #else let cookies = H.responseCookieJar response let statusexc = H.StatusCodeException status headers cookies #endif val <- E.try $ asJsonHelper response case val :: Either E.SomeException FacebookException of Right fbexc -> E.throwIO 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 :: (R.MonadResource m, R.MonadUnliftIO m) => H.Request -> FacebookT anyAuth m Bool httpCheck req = runResourceInFb $ do manager <- getManager let req' = req { H.method = HT.methodHead #if MIN_VERSION_http_client(0,5,0) , H.checkResponse = \_ _ -> return () #else , H.checkStatus = \_ _ _ -> Nothing #endif } 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-2.1.1.1/src/Facebook/FQL.hs0000644000000000000000000000560714231701244013713 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} module Facebook.FQL ( fqlQuery , FQLTime(..) , FQLList(..) , FQLObject(..) ) where import Control.Applicative ((<$>)) 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 #if MIN_VERSION_aeson(2,0,0) import qualified Data.Aeson.KeyMap as Keys #else import qualified Data.HashMap.Strict as Keys #endif 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, R.MonadUnliftIO m, R.MonadThrow 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 (Keys.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-2.1.1.1/src/Facebook/Graph.hs0000644000000000000000000002127314231701244014327 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} module Facebook.Graph ( getObject , postObject , deleteObject , searchObjects , ( #= ) , SimpleType(..) , Place(..) , Location(..) , GeoCoordinates(..) , Tag(..) ) where #if __GLASGOW_HASKELL__ <= 784 import Control.Applicative #endif import Control.Monad (mzero) 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 #if MIN_VERSION_aeson(1,0,0) import Data.Aeson.Text (encodeToTextBuilder) #else import Data.Aeson.Encode (encodeToTextBuilder) #endif 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, R.MonadUnliftIO m, R.MonadThrow 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, R.MonadUnliftIO m, R.MonadThrow 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, R.MonadUnliftIO m, R.MonadThrow 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, R.MonadUnliftIO m, R.MonadThrow 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, R.MonadUnliftIO m, R.MonadThrow 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 . encodeToTextBuilder 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-2.1.1.1/src/Facebook/Monad.hs0000644000000000000000000001670114231701244014324 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} module Facebook.Monad ( FacebookT , Auth , NoAuth , FbTier(..) , runFacebookT , runNoAuthFacebookT , beta_runFacebookT , beta_runNoAuthFacebookT , getApiVersion , getCreds , getMCreds , getManager , getTier , withTier , addAppSecretProof , makeAppSecretProof , runResourceInFb , mapFacebookT , setApiVersion -- * Re-export , lift ) where import Control.Applicative (Alternative, Applicative) import Control.Monad (MonadPlus, liftM) import Control.Monad.Base (MonadBase(..)) import Control.Monad.Fail (MonadFail(..)) 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.Reader (ReaderT(..), ask, mapReaderT) import qualified Control.Monad.Trans.Resource as R import Crypto.Hash.Algorithms (SHA256) import Crypto.MAC.HMAC (HMAC(..), hmac) import Data.ByteArray.Encoding (Base(..), convertToBase) import qualified Data.Text.Encoding as TE import Data.Typeable (Typeable) import Facebook.Types import qualified Network.HTTP.Conduit as H import qualified Network.HTTP.Types as HT import UnliftIO import qualified UnliftIO.Exception as E -- | @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 -- FbData -> m a } deriving ( Functor , Applicative , Alternative , Monad , MonadFix , MonadPlus , MonadIO , MonadTrans , R.MonadThrow , MonadFail ) instance (MonadUnliftIO m) => MonadUnliftIO (FacebookT auth m) where withRunInIO inner = F $ ReaderT $ \r -> withRunInIO $ \run -> inner (\fbT -> run $ (flip runReaderT) r (unF fbT)) 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 -- | 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 :: Maybe Credentials , fbdManager :: !H.Manager , fbdTier :: !FbTier , fbdApiVersion :: IORef ApiVersion } deriving (Typeable) -- | Which Facebook tier should be used (see -- ). data FbTier = Production | Beta deriving (Eq, Ord, Show, Read, Enum, Typeable) defaultApiVersion :: ApiVersion defaultApiVersion = "v3.2" -- | Set the Graph API version. setApiVersion :: (MonadIO m) => ApiVersion -> FacebookT anyAuth m () setApiVersion apiVersion = do ref <- fbdApiVersion `liftM` F ask atomicModifyIORef' ref (\_ -> (apiVersion, ())) return () -- | Run a computation in the 'FacebookT' monad transformer with -- your credentials. runFacebookT :: (MonadIO m) => Credentials -- ^ Your app's credentials. -> H.Manager -- ^ Connection manager (see 'H.withManager'). -> FacebookT Auth m a -> m a runFacebookT creds manager (F act) = do apiref <- newIORef defaultApiVersion runReaderT act (FbData (Just creds) manager Production apiref) addAppSecretProof :: Credentials -> Maybe (AccessToken anykind) -> HT.SimpleQuery -> HT.SimpleQuery addAppSecretProof (Credentials _ _ _ False) _ query = query addAppSecretProof creds mtoken query = makeAppSecretProof creds mtoken <> query -- | Make an appsecret_proof in case the given credentials access token is a -- user access token. -- See: https://developers.facebook.com/docs/graph-api/securing-requests/#appsecret_proof makeAppSecretProof :: Credentials -- ^ App credentials -> Maybe (AccessToken anyKind) -- ^ -> HT.SimpleQuery makeAppSecretProof creds (Just (UserAccessToken _ accessToken _)) = [(TE.encodeUtf8 "appsecret_proof", proof)] where hmacData :: HMAC SHA256 hmacData = hmac (appSecretBS creds) (TE.encodeUtf8 accessToken) proof = convertToBase Base16 hmacData makeAppSecretProof _ _ = [] -- | Run a computation in the 'FacebookT' monad without -- credentials. runNoAuthFacebookT :: (MonadIO m) => H.Manager -- ^ Connection manager (see 'H.withManager'). -> FacebookT NoAuth m a -> m a runNoAuthFacebookT manager (F act) = do apiref <- newIORef defaultApiVersion runReaderT act (FbData Nothing manager Production apiref) -- | Same as 'runFacebookT', but uses Facebook's beta tier (see -- ). beta_runFacebookT :: (MonadIO m) => Credentials -> H.Manager -> FacebookT Auth m a -> m a beta_runFacebookT creds manager (F act) = do apiref <- newIORef defaultApiVersion runReaderT act (FbData (Just creds) manager Beta apiref) -- | Same as 'runNoAuthFacebookT', but uses Facebook's beta tier -- (see ). beta_runNoAuthFacebookT :: (MonadIO m) => H.Manager -> FacebookT NoAuth m a -> m a beta_runNoAuthFacebookT manager (F act) = do apiref <- newIORef defaultApiVersion runReaderT act (FbData Nothing manager Beta apiref) -- | Get the user's credentials, fail if they are not available. getCreds :: (Monad m, MonadIO m) => FacebookT Auth m Credentials getCreds = do mCreds <- getMCreds case mCreds of Nothing -> E.throwIO $ FbLibraryException "Couldn't get credentials." Just creds -> return creds -- | Get the user's credentials. getMCreds :: Monad m => FacebookT anyAuth m (Maybe Credentials) getMCreds = fbdCreds `liftM` F ask -- | Get the Graph API version. getApiVersion :: MonadIO m => FacebookT anyAuth m ApiVersion getApiVersion = do ref <- fbdApiVersion `liftM` F ask apiVersion <- readIORef ref pure apiVersion -- | 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, MonadUnliftIO 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-2.1.1.1/src/Facebook/Object/Action.hs0000644000000000000000000000523214231701244015706 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} module Facebook.Object.Action ( createAction , Action(..) ) where import Control.Arrow (first) import Control.Monad.IO.Class 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, R.MonadUnliftIO m, R.MonadThrow m, MonadIO 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, R.MonadUnliftIO m, R.MonadThrow 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-2.1.1.1/src/Facebook/Object/Checkin.hs0000644000000000000000000000515414231701244016040 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module Facebook.Object.Checkin ( Checkin(..) , CheckinFrom(..) , getCheckin , createCheckin ) where #if __GLASGOW_HASKELL__ <= 784 import Control.Applicative #endif import Control.Monad (mzero) 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, R.MonadUnliftIO m, R.MonadThrow 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, R.MonadUnliftIO m, R.MonadThrow 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-2.1.1.1/src/Facebook/Object/FriendList.hs0000644000000000000000000000603414231701244016535 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module Facebook.Object.FriendList ( FriendList(..) , FriendListType(..) , getUserFriendLists , getFriendListMembers ) where #if __GLASGOW_HASKELL__ <= 784 import Control.Applicative #endif import Control.Monad (mzero) 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, R.MonadUnliftIO m, R.MonadThrow 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, R.MonadUnliftIO m, R.MonadThrow 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-2.1.1.1/src/Facebook/Object/Order.hs0000644000000000000000000000461714231701244015552 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} module Facebook.Object.Order ( Order(..) , OrderId , OrderStatus(..) , OrderApplication(..) , getOrder ) where import Control.Monad (mzero) 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, R.MonadUnliftIO m, R.MonadThrow m) => OrderId -- ^ Order ID. -> UserAccessToken -- ^ User access token. -> FacebookT anyAuth m Order getOrder id_ mtoken = getObject ("/" <> idCode id_) [] (Just mtoken) fb-2.1.1.1/src/Facebook/Object/Page.hs0000644000000000000000000000502314231701244015343 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} module Facebook.Object.Page ( Page(..) , getPage , getPage_ , searchPages ) where import Control.Monad (mzero) 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, R.MonadUnliftIO m, R.MonadThrow 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_) -- | Get a page using its ID. The user access token is optional. getPage_ :: (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m) => Id -- ^ Page ID -> [Argument] -- ^ Arguments to be passed to Facebook -> Maybe AppAccessToken -- ^ 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, R.MonadUnliftIO m, R.MonadThrow 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-2.1.1.1/src/Facebook/Object/User.hs0000644000000000000000000000744414231701244015416 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} module Facebook.Object.User ( User(..) , Gender(..) , getUser , searchUsers , getUserCheckins , Friend(..) , getUserFriends ) where import Control.Monad (mzero) 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, R.MonadUnliftIO m, R.MonadThrow 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, R.MonadUnliftIO m, R.MonadThrow 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, R.MonadUnliftIO m, R.MonadThrow 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, R.MonadUnliftIO m, R.MonadThrow 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-2.1.1.1/src/Facebook/Pager.hs0000644000000000000000000001026014231701244014316 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable #-} module Facebook.Pager ( Pager(..) , fetchNextPage , fetchPreviousPage , fetchAllNextPages , fetchAllPreviousPages ) where import Control.Monad (mzero) import Control.Monad.IO.Class (liftIO) 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, A.FromJSON a, R.MonadThrow m, R.MonadUnliftIO m) => 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, A.FromJSON a, R.MonadThrow m, R.MonadUnliftIO m) => Pager a -> FacebookT anyAuth m (Maybe (Pager a)) fetchPreviousPage = fetchHelper pagerPrevious -- | (Internal) See 'fetchNextPage' and 'fetchPreviousPage'. fetchHelper :: (R.MonadResource m, A.FromJSON a, R.MonadThrow m, R.MonadUnliftIO m) => (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.parseRequest 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, A.FromJSON a, R.MonadUnliftIO n, R.MonadThrow n) => Pager a -> FacebookT anyAuth m (C.ConduitT () a n ()) 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, A.FromJSON a, R.MonadUnliftIO n, R.MonadThrow n) => Pager a -> FacebookT anyAuth m (C.ConduitT () a n ()) fetchAllPreviousPages = fetchAllHelper pagerPrevious -- | (Internal) See 'fetchAllNextPages' and 'fetchAllPreviousPages'. fetchAllHelper :: (Monad m, A.FromJSON a, R.MonadUnliftIO n, R.MonadThrow n) => (Pager a -> Maybe String) -> Pager a -> FacebookT anyAuth m (C.ConduitT () a n ()) 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.parseRequest 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-2.1.1.1/src/Facebook/RealTime.hs0000644000000000000000000002027414231701244014770 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} module Facebook.RealTime ( RealTimeUpdateObject(..) , RealTimeUpdateField , RealTimeUpdateUrl , RealTimeUpdateToken , modifySubscription , RealTimeUpdateSubscription(..) , listSubscriptions , verifyRealTimeUpdateNotifications , getRealTimeUpdateNotifications , RealTimeUpdateNotification(..) , RealTimeUpdateNotificationUserEntry(..) ) where import Control.Applicative ((<$>), (<*>)) import Control.Monad (liftM, mzero, void) import Control.Monad.IO.Class import qualified Control.Monad.Trans.Resource as R import Crypto.Hash.Algorithms (SHA1) import Crypto.MAC.HMAC (HMAC(..), hmac) import qualified Data.Aeson as A import Data.ByteArray (ScrubbedBytes, convert) import Data.ByteArray.Encoding (Base(..), convertToBase) import qualified Data.ByteString as B import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.Conduit as C import qualified Data.Conduit.List as CL import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) import qualified Data.Text.Encoding as TE import Data.Typeable (Typeable) import qualified Network.HTTP.Conduit as H import qualified Network.HTTP.Types as HT import Facebook.Base import Facebook.Graph import Facebook.Monad import Facebook.Pager import Facebook.Types -- | 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, R.MonadUnliftIO m, R.MonadThrow 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, MonadIO 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, R.MonadUnliftIO m, R.MonadThrow m) => AppAccessToken -> FacebookT Auth m [RealTimeUpdateSubscription] listSubscriptions apptoken = do path <- getSubscriptionsPath pager <- getObject path [] (Just apptoken) src <- fetchAllNextPages pager lift $ C.runConduit $ src C..| CL.consume -- | Verifi(es the input's authenticity (i.e. it comes from, MonadIO m) -- 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, MonadIO 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 hmacData :: HMAC SHA1 hmacData = hmac (appSecretBS creds) (L.toStrict body) hash :: B.ByteString hash = convertToBase Base16 hmacData expected = "sha1=" <> hash return $! if ((convert sig :: ScrubbedBytes) == (convert 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, MonadIO m) => 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-2.1.1.1/src/Facebook/TestUsers.hs0000644000000000000000000001676014231701244015234 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} module Facebook.TestUsers ( TestUser(..) , CreateTestUser(..) , CreateTestUserInstalled(..) , getTestUsers , disassociateTestuser , removeTestUser , createTestUser , makeFriendConn , incompleteTestUserAccessToken ) where import Control.Applicative ((<$>), (<*>)) import Control.Monad (unless, mzero) import Control.Monad.IO.Class import Data.ByteString.Lazy (fromStrict) import Data.Default import Data.Text import Data.Text.Encoding (encodeUtf8) import Data.Time (UTCTime(..), Day(..)) import Data.Typeable (Typeable) import Data.Aeson import Data.Aeson.Types import qualified UnliftIO.Exception 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. -- Ref: https://developers.facebook.com/docs/graph-api/reference/v2.8/app/accounts/test-users 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. -- Ref: https://developers.facebook.com/docs/graph-api/reference/v2.8/app/accounts/test-users#publish createTestUser :: (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m, MonadIO 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, R.MonadUnliftIO m, R.MonadThrow m, MonadIO 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) disassociateTestuser :: (R.MonadUnliftIO m, R.MonadThrow m, R.MonadResource m, MonadIO m) => TestUser -> AppAccessToken -> FacebookT Auth m Bool disassociateTestuser testUser _token = do creds <- getCreds getObjectBool ("/" <> (appId creds) <> "/accounts/test-users") [("uid", encodeUtf8 $ idCode $ tuId testUser), ("method", "delete")] (Just _token) -- | Remove an existing test user. removeTestUser :: (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow 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 = do getObjectBool ("/" <> (idCode $ tuId testUser)) [("method", "delete")] (Just _token) -- | Make a friend connection between two test users. -- -- This is how Facebook's API work: two calls must be made. The first -- call has the format: \"\/userA_id\/friends\/userB_id\" with the -- access token of user A as query parameter. The second call has the -- format: \"\/userB_id\/friends\/userA_id\" with the access token of -- user B as query parameter. The first call creates a friend request -- and the second call accepts the friend request. makeFriendConn :: (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m) => TestUser -> TestUser -> FacebookT Auth m () makeFriendConn (TestUser {tuAccessToken = Nothing}) _ = E.throwIO $ 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.throwIO $ 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.throwIO $ FbLibraryException "Couldn't make friend request." unless r2 $ E.throwIO $ 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, R.MonadUnliftIO m, R.MonadThrow 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 req <- fbreq path mtoken query response <- fbhttp req bs <- asBS response let respJson :: Maybe Value = decode (fromStrict bs) maybe (return False) (\val -> maybe (return False) return (parseMaybe isTrue val)) respJson where isTrue :: Value -> Parser Bool isTrue val = withObject "success" (\obj -> do (status :: Bool) <- obj .: "success" return status) val fb-2.1.1.1/src/Facebook/Types.hs0000644000000000000000000002045614231701244014374 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving#-} {-# LANGUAGE StandaloneDeriving#-} {-# LANGUAGE GADTs#-} {-# LANGUAGE DeriveDataTypeable#-} {-# LANGUAGE CPP#-} module Facebook.Types ( Credentials(..) , ApiVersion , appIdBS , appSecretBS , AccessToken(..) , UserAccessToken , AppAccessToken , AccessTokenData , Id(..) , UserId , accessTokenData , accessTokenExpires , accessTokenUserId , UserKind , AppKind , Argument , (<>) , FbUTCTime(..) , FacebookException(..) ) where import Control.Applicative ((<$>), (<*>), pure) import Control.Monad (mzero) import qualified UnliftIO.Exception as E import Data.ByteString (ByteString) import Data.Int (Int64) #if !(MIN_VERSION_base(4,11,0)) import Data.Monoid (Monoid, mappend) #endif import Data.String (IsString) import Data.Text (Text) import Data.Time (UTCTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Data.Typeable (Typeable) #if MIN_VERSION_time(1,5,0) import Data.Time (defaultTimeLocale, parseTimeM) #else import System.Locale (defaultTimeLocale) import Data.Time (parseTime) #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. , appSecretProof :: Bool -- ^ To enable app secret proof verification } 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 -- | Graph API version. -- See: https://developers.facebook.com/docs/graph-api/changelog type ApiVersion = Text -- | 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 Typeable 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'. #if !(MIN_VERSION_base(4,11,0)) (<>) :: Monoid a => a -> a -> a (<>) = mappend #endif ---------------------------------------------------------------------- -- | /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) = #if MIN_VERSION_time(1,5,0) case parseTimeM True defaultTimeLocale "%FT%T%z" (T.unpack t) of #else case parseTime defaultTimeLocale "%FT%T%z" (T.unpack t) of #endif 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" -- | 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 fb-2.1.1.1/tests/Main.hs0000644000000000000000000005322414231701244013015 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, Rank2Types, ScopedTypeVariables, GADTs, FlexibleContexts #-} module Main ( main , getCredentials ) where import Control.Monad (mzero) import Control.Monad.IO.Class (MonadIO(liftIO)) import Control.Monad.Trans.Class (lift) 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 Data.Int (Int16, Int32, Int64, Int8) import Data.List ((\\)) import qualified Data.Map as Map import Data.Maybe (isJust, isNothing) import qualified Data.Maybe as M import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.Time as TI import Data.Word (Word, Word16, Word32, Word64, Word8) import qualified Facebook as FB import qualified Network.HTTP.Conduit as H import System.Environment (getEnv) import System.Exit (exitFailure) import System.IO.Error (isDoesNotExistError) import qualified Test.QuickCheck as QC import qualified UnliftIO.Exception as E import Test.HUnit ((@?=)) import Test.Hspec 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) True showHelp exc | not (isDoesNotExistError exc) = E.throwIO 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" False invalidUserAccessToken :: FB.UserAccessToken invalidUserAccessToken = FB.UserAccessToken (FB.Id "invalid") "user" farInTheFuture where Just farInTheFuture = TI.parseTimeM True TI.defaultTimeLocale "%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 = do manager <- H.newManager H.tlsManagerSettings liftIO $ do creds <- getCredentials hspec $ -- Run the tests twice, once in Facebook's production tier... do 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' "setApiVersion" $ do it "Check default apiVersion" $ runNoAuth $ FB.getApiVersion #?= "v3.2" it "Change apiVersion" $ (runNoAuth $ do FB.setApiVersion "v100" FB.getApiVersion) #?= "v100" 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" $ do val <- runAuth $ -- Needs permission now: https://developers.facebook.com/docs/graph-api/reference/page#Reading do token <- FB.getAppAccessToken A.Object obj <- FB.getObject "/220746347971798" [] (Just token) let Just r = flip A.parseMaybe () $ const $ (,) <$> obj A..:? "id" <*> obj A..:? "name" return r val `shouldBe` (Just "220746347971798" :: Maybe Text, Just "Ruskin Bond" :: Maybe Text) describe' "getPage" $ do it "works for FB Developers" $ do runAuth $ do token <- FB.getAppAccessToken page <- FB.getPage_ (FB.Id "220746347971798") [] (Just token) FB.pageId page &?= (FB.Id "220746347971798") FB.pageName page &?= Just "Ruskin Bond" FB.pageCategory page &?= Nothing FB.pageIsPublished page &?= Nothing FB.pageCanPost page &?= Nothing FB.pagePhone page &?= Nothing FB.pageCheckins page &?= Nothing FB.pageWebsite page &?= Nothing 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 runAuth $ -- Postid: https://www.facebook.com/nytimes/posts/10150628170209999 -- Page id found using this technique: https://www.facebook.com/help/community/question/?id=529591157094317 do token <- FB.getAppAccessToken fetchNextPageWorks =<< FB.getObject "/5281959998_10150628170209999/comments" [] (Just token) it "seems to work on a private list of app insights" $ do runAuth $ do token <- FB.getAppAccessToken fetchNextPageWorks =<< FB.getObject ("/" <> FB.appId creds <> "/app_insights/api_calls") [] (Just token) describe' "fetchNextPage/fetchPreviousPage" $ do let backAndForthWorks :: FB.Pager A.Value -> FB.FacebookT anyAuth (R.ResourceT IO) () backAndForthWorks pager = do pager2 <- FB.fetchNextPage pager case pager2 of Nothing -> True &?= True Just pager2' -> do Just pager3 <- FB.fetchPreviousPage pager2' pager3 &?= pager it "seems to work on a public list of comments" $ do runAuth $ do token <- FB.getAppAccessToken backAndForthWorks =<< FB.getObject "/5281959998_10150628170209999/comments" [("filter", "stream")] (Just token) it "seems to work on a private list of app insights" $ do runAuth $ do token <- FB.getAppAccessToken backAndForthWorks =<< FB.getObject ("/" <> FB.appId creds <> "/app_insights/api_calls") [] (Just token) describe' "fetchAllNextPages" $ do let hasAtLeast :: C.ConduitT () A.Value IO () -> Int -> IO () src `hasAtLeast` n = C.runConduit $ 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 runAuth $ do token <- FB.getAppAccessToken pager <- FB.getObject "/63441126719_10154249531391720/comments" [] (Just token) 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 ("/" <> FB.appId creds <> "/app_insights/api_calls") [] (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 return () -- 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 removed <- FB.removeTestUser newTestUser token -- Check user attributes FB.userId createdUser &?= FB.tuId newTestUser FB.userName createdUser &?= Just "Gabriel" -- FB.userLocale createdUser &?= Just "en_US" -- fix this test later -- Check if the token is valid FB.isValid newTestUserToken #?= False removed &?= True 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 $ C.runConduit $ src C..| CL.consume withTestUser D.def $ \testUser -> do newList <- FB.pagerData <$> FB.getTestUsers token let newList' = map FB.tuId newList oldList' = map FB.tuId oldList ((FB.tuId testUser) `elem` (newList' \\ oldList')) &?= True 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" False 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 "addAppSecretProof" $ do it "appends appsecret_proof to the query when passing an access token" $ do now <- liftIO TI.getCurrentTime let token = FB.UserAccessToken "id" "token" now query = [("test", "whatever")] secretProofQ creds = FB.makeAppSecretProof creds (Just token) creds <- getCredentials FB.addAppSecretProof creds (Just token) query @?= secretProofQ creds <> query 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 describe "makeAppSecretProof" $ do it "generates correct hmac" $ let creds = FB.Credentials "name" "id" "secret" True uToken = FB.UserAccessToken (FB.Id "user") "accesstoken" undefined proof = FB.makeAppSecretProof creds $ Just uToken expectedProof = "65138b7ea24e641d38c91befa22b6281953980d1bfd0322956bc29959e1a910c" in proof @?= [("appsecret_proof", expectedProof)] -- 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, R.MonadUnliftIO m, R.MonadThrow 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-2.1.1.1/LICENSE0000644000000000000000000000276114231701244011440 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-2.1.1.1/Setup.hs0000644000000000000000000000005614231701244012062 0ustar0000000000000000import Distribution.Simple main = defaultMain fb-2.1.1.1/fb.cabal0000644000000000000000000000600314231701244011777 0ustar0000000000000000cabal-version: 1.12 -- This file has been generated from package.yaml by hpack version 0.34.5. -- -- see: https://github.com/sol/hpack name: fb version: 2.1.1.1 synopsis: Bindings to Facebook's API. 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 (). category: Web stability: Experimental homepage: https://github.com/psibi/fb bug-reports: https://github.com/psibi/fb/issues author: Felipe Lessa, Sibi Prabakaran maintainer: Sibi copyright: Felipe Lessa and Sibi Prabakaran license: BSD3 license-file: LICENSE build-type: Simple extra-source-files: tests/Main.hs tests/tryIt.hs example.hs README.md CHANGELOG.md source-repository head type: git location: git@github.com:psibi/fb.git flag debug description: Print debugging info. manual: False default: False library exposed-modules: Facebook other-modules: Facebook.Auth Facebook.Base Facebook.FQL Facebook.Graph Facebook.Monad Facebook.Object.Action Facebook.Object.Checkin Facebook.Object.FriendList Facebook.Object.Order Facebook.Object.Page Facebook.Object.User Facebook.Pager Facebook.RealTime Facebook.TestUsers Facebook.Types Paths_fb hs-source-dirs: src ghc-options: -Wall build-depends: aeson >=0.8.0.2 , attoparsec >=0.10.4 , base ==4.* , bytestring >=0.9 , conduit >=1.3.0 , conduit-extra , cryptonite , data-default , http-client >=0.4.30 , http-conduit >=2.3.0 , http-types , memory , monad-logger , resourcet , text >=0.11 , time >=1.4 , transformers >=0.2 , transformers-base , unliftio , unliftio-core , unordered-containers if flag(debug) cpp-options: -DDEBUG default-language: Haskell2010 test-suite runtests type: exitcode-stdio-1.0 main-is: Main.hs other-modules: Paths_fb hs-source-dirs: tests ghc-options: -Wall -fno-warn-orphans build-depends: HUnit , QuickCheck , aeson , base , bytestring , conduit , containers , data-default , fb , hspec >=2.5.0 , http-conduit , resourcet , text , time , transformers , unliftio default-language: Haskell2010 fb-2.1.1.1/tests/tryIt.hs0000644000000000000000000000071614231701244013242 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-2.1.1.1/example.hs0000644000000000000000000000050414231701244012413 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) fb-2.1.1.1/README.md0000644000000000000000000000321014231701244011700 0ustar0000000000000000fb -- [![Build Status](https://dev.azure.com/psibi2000/Haskell%20Projects/_apis/build/status/psibi.fb?branchName=master)](https://dev.azure.com/psibi2000/Haskell%20Projects/_build/latest?definitionId=16&branchName=master) Haskell bindings to Facebook's API ## Example code to get User Access token ```haskell {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} import Facebook import Network.HTTP.Client import Network.HTTP.Client.TLS import Control.Monad.Trans.Control import Control.Monad.Trans.Resource import Control.Monad.IO.Class import Data.Monoid ((<>)) import Data.ByteString.Char8 (pack) import Data.Text hiding (pack) import Data.Aeson import qualified Data.Text.Encoding as TE myCreds :: Credentials myCreds = Credentials { appName = "Your_APP_Name" , appId = "your_app_id" , appSecret = "xxxxxxxxxxxxxxxxx" , appSecretProof = False } main :: IO () main = do mgr <- newManager tlsManagerSettings let redirectUrl = "https://www.yourdomain.com/" runResourceT $ runFacebookT myCreds mgr $ do url1 <- getUserAccessTokenStep1 redirectUrl ["public_profile", "email"] liftIO $ print ("Paste the url in browser and get code: " <> url1) code <- liftIO $ getLine token <- getUserAccessTokenStep2 redirectUrl [("code", pack code)] liftIO $ print token ``` ## Snippet to get your Profile Picture: ``` (picture :: Value) <- getObject "/me/picture" [("redirect", "0")] (Just token) liftIO $ print picture ``` ## Snippet to get your firstname, lastname: ``` user <- getUser "me" [("fields", "first_name,last_name")] (Just token) liftIO $ print user ``` fb-2.1.1.1/CHANGELOG.md0000644000000000000000000000243514231701244012242 0ustar0000000000000000# Version 2.1.1.1 * Add support for Aeson v2+. # Version 2.1.0 * Same release as 2.0.1 bound follows PVP properly # Version 2.0.1 * Fix MonadUnliftIO instance for FacebookT * Have upper bound on unliftio and related packages # Version 2.0.0 * Remove following dependency: - base16-bytestring - base64-bytestring - cereal - crypto-api - cryptohash - cryptohash-cryptoapi - old-locale * Introduce new dependency: - cryptonite - memory * Add new function setApiVersion * Add Graph API version parameter. Avoid hardcoded `v2.8`. * Expose setApiVersion and getApiVersion function * Default API endpoint updated to `v3.2` * Add appsecret_proof verification. * Fix appsecret_proof verification encoding. # Version 1.2.1 * Make it work for ghc-8.4. See [#3](https://github.com/psibi/fb/issues/3) # Version 1.2.0 * Rewrote fb for conduit-1.3.0 * Fixed various warnings and did general cleanup * Fixed fetchNextPage/fetchPreviousPage test by adding ("filter", "stream") for comments api. * Made lower bound of http-conduit to 2.3.0 # Version 1.1.1 * Make versioned call. By default now it uses `v2.8. * `disassociateTestuser` function added. * `getPage_` function added which accepts `AppAccessToken` as opposed to `getPage` function. * Fixed a bug in `getObjectBool` * Travis CI added