TestUsers.hs

{-# 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 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)
  => 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)
  => 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)
  => 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