fb-2.1.1.1/src/ 0000755 0000000 0000000 00000000000 14231701244 011214 5 ustar 00 0000000 0000000 fb-2.1.1.1/src/Facebook/ 0000755 0000000 0000000 00000000000 14231701244 012725 5 ustar 00 0000000 0000000 fb-2.1.1.1/src/Facebook/Object/ 0000755 0000000 0000000 00000000000 14231701244 014133 5 ustar 00 0000000 0000000 fb-2.1.1.1/tests/ 0000755 0000000 0000000 00000000000 14231701244 011567 5 ustar 00 0000000 0000000 fb-2.1.1.1/src/Facebook.hs 0000644 0000000 0000000 00000005742 14231701244 013271 0 ustar 00 0000000 0000000 module Facebook
(
-- * @FacebookT@ monad transformer
FacebookT
, runFacebookT
, runNoAuthFacebookT
, mapFacebookT
, beta_runFacebookT
, beta_runNoAuthFacebookT
, Auth
, NoAuth
-- * Authorization and Authentication
-- ** Credentials
, Credentials(..)
-- ** Access token
, AccessToken(..)
, UserAccessToken
, AppAccessToken
, AccessTokenData
, 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.hs 0000644 0000000 0000000 00000040617 14231701244 014172 0 ustar 00 0000000 0000000 {-# 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.hs 0000644 0000000 0000000 00000017277 14231701244 014151 0 ustar 00 0000000 0000000 {-#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.hs 0000644 0000000 0000000 00000005607 14231701244 013713 0 ustar 00 0000000 0000000 {-# 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.hs 0000644 0000000 0000000 00000021273 14231701244 014327 0 ustar 00 0000000 0000000 {-# 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.hs 0000644 0000000 0000000 00000016701 14231701244 014324 0 ustar 00 0000000 0000000 {-# 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.hs 0000644 0000000 0000000 00000005232 14231701244 015706 0 ustar 00 0000000 0000000 {-# 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.hs 0000644 0000000 0000000 00000005154 14231701244 016040 0 ustar 00 0000000 0000000 {-# 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.hs 0000644 0000000 0000000 00000006034 14231701244 016535 0 ustar 00 0000000 0000000 {-# 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.hs 0000644 0000000 0000000 00000004617 14231701244 015552 0 ustar 00 0000000 0000000 {-# 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.hs 0000644 0000000 0000000 00000005023 14231701244 015343 0 ustar 00 0000000 0000000 {-# 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.hs 0000644 0000000 0000000 00000007444 14231701244 015416 0 ustar 00 0000000 0000000 {-# 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.hs 0000644 0000000 0000000 00000010260 14231701244 014316 0 ustar 00 0000000 0000000 {-# 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.hs 0000644 0000000 0000000 00000020274 14231701244 014770 0 ustar 00 0000000 0000000 {-# 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.hs 0000644 0000000 0000000 00000016760 14231701244 015234 0 ustar 00 0000000 0000000 {-# 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.hs 0000644 0000000 0000000 00000020456 14231701244 014374 0 ustar 00 0000000 0000000 {-# 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.hs 0000644 0000000 0000000 00000053224 14231701244 013015 0 ustar 00 0000000 0000000 {-# 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/LICENSE 0000644 0000000 0000000 00000002761 14231701244 011440 0 ustar 00 0000000 0000000 Copyright (c)2012, Felipe Lessa
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the name of Felipe Lessa nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
fb-2.1.1.1/Setup.hs 0000644 0000000 0000000 00000000056 14231701244 012062 0 ustar 00 0000000 0000000 import Distribution.Simple
main = defaultMain
fb-2.1.1.1/fb.cabal 0000644 0000000 0000000 00000006003 14231701244 011777 0 ustar 00 0000000 0000000 cabal-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.hs 0000644 0000000 0000000 00000000716 14231701244 013242 0 ustar 00 0000000 0000000 module TryIt (runFB) where
-- You may import this file from GHCi in order to try the fb
-- package. For example:
--
-- > :l tryIt
--
-- > runFB FB.getAppAccessToken
import qualified Data.Conduit as C
import qualified Facebook as FB
import qualified Network.HTTP.Conduit as H
import Main (getCredentials)
runFB :: FB.FacebookT FB.Auth (C.ResourceT IO) a -> IO a
runFB act = do
creds <- getCredentials
H.withManager $ \m -> FB.runFacebookT creds m act
fb-2.1.1.1/example.hs 0000644 0000000 0000000 00000000504 14231701244 012413 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
import qualified Facebook as FB
import Network.HTTP.Conduit (withManager)
import Control.Monad.IO.Class (liftIO)
main :: IO ()
main = do
withManager $ \manager -> do
FB.runNoAuthFacebookT manager $ do
u <- FB.getUser "zuck" [] Nothing
liftIO $ print (FB.userName u)
fb-2.1.1.1/README.md 0000644 0000000 0000000 00000003210 14231701244 011700 0 ustar 00 0000000 0000000 fb
--
[](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.md 0000644 0000000 0000000 00000002435 14231701244 012242 0 ustar 00 0000000 0000000 # 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