module Facebook.TestUsers
( TestUser(..)
, CreateTestUser(..)
, CreateTestUserInstalled(..)
, getTestUsers
, removeTestUser
, createTestUser
, makeFriendConn
, incompleteTestUserAccessToken
) where
import Control.Applicative ((<$>), (<*>))
import Control.Monad (unless, mzero)
import Control.Monad.Trans.Control (MonadBaseControl)
import Data.Default
import Data.Text
import Data.Time (UTCTime(..), Day(..))
import Data.Typeable (Typeable)
import qualified Control.Exception.Lifted as E
import qualified Data.Aeson as A
import qualified Data.ByteString.Char8 as B
import qualified Data.Conduit as C
import Facebook.Auth
import Facebook.Base
import Facebook.Graph
import Facebook.Monad
import Facebook.Types
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 CreateTestUser =
CreateTestUser
{ ctuInstalled :: CreateTestUserInstalled
, ctuName :: Maybe Text
, ctuLocale :: Maybe Text
}
data CreateTestUserInstalled =
CreateTestUserNotInstalled
| CreateTestUserInstalled { ctuiPermissions :: [Permission] }
| CreateTestUserFbDefault
instance Default CreateTestUser where
def = CreateTestUser def def def
instance Default CreateTestUserInstalled where
def = CreateTestUserFbDefault
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 ]
createTestUser :: (C.MonadResource m, MonadBaseControl IO m)
=> CreateTestUser
-> AppAccessToken
-> 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)
getTestUsers :: (C.MonadResource m, MonadBaseControl IO m)
=> AppAccessToken
-> FacebookT Auth m (Pager TestUser)
getTestUsers token = do
creds <- getCreds
getObject ("/" <> appId creds <> "/accounts/test-users") [] (Just token)
removeTestUser :: (C.MonadResource m, MonadBaseControl IO m)
=> TestUser
-> AppAccessToken
-> FacebookT Auth m Bool
removeTestUser testUser token =
getObjectBool ("/" <> idCode (tuId testUser)) [("method","delete")] (Just token)
makeFriendConn :: (C.MonadResource m, MonadBaseControl IO m)
=> TestUser
-> TestUser
-> FacebookT Auth m ()
makeFriendConn (TestUser { tuAccessToken = Nothing }) _ = E.throw $
FbLibraryException "The test user passed on the first argument doesn't have\
\ a token. Both users must have a token."
makeFriendConn _ (TestUser { tuAccessToken = Nothing }) = E.throw $
FbLibraryException "The test user passed on the second argument doesn't have\
\ a token. Both users must have a token."
makeFriendConn (TestUser {tuId = id1, tuAccessToken = (Just token1)}) (TestUser {tuId = id2, tuAccessToken = (Just token2)}) = do
let friendReq userId1 userId2 token =
getObjectBool ("/" <> idCode userId1 <> "/friends/" <> idCode userId2)
[ "method" #= ("post" :: B.ByteString),
"access_token" #= token ]
Nothing
r1 <- friendReq id1 id2 token1
r2 <- friendReq id2 id1 token2
unless r1 $ E.throw $ FbLibraryException "Couldn't make friend request."
unless r2 $ E.throw $ FbLibraryException "Couldn't accept friend request."
return ()
incompleteTestUserAccessToken :: TestUser -> Maybe UserAccessToken
incompleteTestUserAccessToken t = do
tokenData <- tuAccessToken t
let farFuture = UTCTime (ModifiedJulianDay 100000) 0
return (UserAccessToken (tuId t) tokenData farFuture)
getObjectBool :: (C.MonadResource m, MonadBaseControl IO m)
=> Text
-> [Argument]
-> Maybe (AccessToken anyKind)
-> FacebookT anyAuth m Bool
getObjectBool path query mtoken =
runResourceInFb $ do
bs <- asBS =<< fbhttp =<< fbreq path mtoken query
return (bs == "true")