TestUsers.hs

{-# LANGUAGE FlexibleContexts #-}
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 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.
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.
createTestUser :: (R.MonadResource m, MonadBaseControl IO 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, MonadBaseControl IO 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)


-- | Remove an existing test user.
removeTestUser :: (R.MonadResource m, MonadBaseControl IO 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 =
  getObjectBool ("/" <> idCode (tuId testUser)) [("method","delete")] token
  where token = incompleteTestUserAccessToken testUser


-- | 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, 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 ()


-- | 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, MonadBaseControl IO 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
   bs <- asBS =<< fbhttp =<< fbreq path mtoken query
   return (bs == "true")