{-# 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
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, MonadIO 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, MonadIO 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, 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)
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