module Facebook.TestUsers
( TestUser(..)
, CreateTestUser(..)
, CreateTestUserInstalled(..)
, getTestUsers
, disassociateTestuser
, removeTestUser
, createTestUser
, makeFriendConn
, incompleteTestUserAccessToken
) where
import Control.Applicative ((<$>), (<*>))
import Control.Monad (unless, mzero)
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
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
:: (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow 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
:: (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m)
=> AppAccessToken
-> 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)
=> 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)
removeTestUser
:: (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m)
=> TestUser
-> AppAccessToken
-> FacebookT Auth m Bool
removeTestUser testUser _token = do
getObjectBool
("/" <> (idCode $ tuId testUser))
[("method", "delete")]
(Just _token)
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 ()
incompleteTestUserAccessToken :: TestUser -> Maybe UserAccessToken
incompleteTestUserAccessToken t = do
tokenData <- tuAccessToken t
let farFuture = UTCTime (ModifiedJulianDay 100000) 0
return (UserAccessToken (tuId t) tokenData farFuture)
getObjectBool
:: (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m)
=> Text
-> [Argument]
-> Maybe (AccessToken anyKind)
-> 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