{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}

module Facebook.Auth
  ( getAppAccessToken
  , getUserAccessTokenStep1
  , getUserAccessTokenStep2
  , getUserLogoutUrl
  , extendUserAccessToken
  , RedirectUrl
  , Permission
  , unPermission
  , hasExpired
  , isValid
  , parseSignedRequest
  , debugToken
  , DebugToken(..)
  ) where
#if __GLASGOW_HASKELL__ <= 784
import Control.Applicative
#endif
import Control.Monad (guard, mzero)
import Control.Monad.IO.Class
import Control.Monad.Trans.Maybe (MaybeT(..))
import qualified Control.Monad.Trans.Resource as R
import Crypto.Hash.Algorithms (SHA256)
import Crypto.MAC.HMAC (HMAC(..), hmac)
import Data.Aeson ((.:))
import qualified Data.Aeson as AE
import Data.Aeson.Parser (json')
import qualified Data.Aeson.Types as AE
import qualified Data.Attoparsec.ByteString.Char8 as AB
import Data.ByteArray (ScrubbedBytes, convert)
import Data.ByteArray.Encoding (Base(..), convertFromBase)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8
import qualified Data.List as L
import Data.Maybe (fromMaybe)
import Data.String (IsString(..))
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Encoding.Error as TE
import Data.Time (UTCTime, addUTCTime, getCurrentTime)
import Data.Typeable (Typeable)
import qualified Network.HTTP.Types as HT
import qualified UnliftIO.Exception as E

import Facebook.Base
import Facebook.Monad
import Facebook.Types

-- | Get an app access token from Facebook using your
-- credentials.
-- Ref: https://developers.facebook.com/docs/facebook-login/manually-build-a-login-flow
getAppAccessToken ::
     (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m, MonadIO m)
  => FacebookT Auth m AppAccessToken
getAppAccessToken :: FacebookT Auth m AppAccessToken
getAppAccessToken =
  FacebookT Auth (ResourceT m) AppAccessToken
-> FacebookT Auth m AppAccessToken
forall (m :: * -> *) anyAuth a.
(MonadResource m, MonadUnliftIO m) =>
FacebookT anyAuth (ResourceT m) a -> FacebookT anyAuth m a
runResourceInFb (FacebookT Auth (ResourceT m) AppAccessToken
 -> FacebookT Auth m AppAccessToken)
-> FacebookT Auth (ResourceT m) AppAccessToken
-> FacebookT Auth m AppAccessToken
forall a b. (a -> b) -> a -> b
$ do
    Credentials
creds <- FacebookT Auth (ResourceT m) Credentials
forall (m :: * -> *).
(Monad m, MonadIO m) =>
FacebookT Auth m Credentials
getCreds
    Request
req <-
      Text
-> Maybe (AccessToken Any)
-> SimpleQuery
-> FacebookT Auth (ResourceT m) Request
forall (m :: * -> *) anyKind anyAuth.
MonadIO m =>
Text
-> Maybe (AccessToken anyKind)
-> SimpleQuery
-> FacebookT anyAuth m Request
fbreq Text
"/oauth/access_token" Maybe (AccessToken Any)
forall a. Maybe a
Nothing (SimpleQuery -> FacebookT Auth (ResourceT m) Request)
-> SimpleQuery -> FacebookT Auth (ResourceT m) Request
forall a b. (a -> b) -> a -> b
$
      Credentials -> SimpleQuery -> SimpleQuery
forall a. ToSimpleQuery a => a -> SimpleQuery -> SimpleQuery
tsq Credentials
creds [(ByteString
"grant_type", ByteString
"client_credentials")]
    Response (ConduitT () ByteString (ResourceT m) ())
response <- Request
-> FacebookT
     Auth
     (ResourceT m)
     (Response (ConduitT () ByteString (ResourceT m) ()))
forall (m :: * -> *) anyAuth.
(MonadResource m, MonadUnliftIO m, MonadThrow m) =>
Request
-> FacebookT anyAuth m (Response (ConduitT () ByteString m ()))
fbhttp Request
req
    (Value
token :: AE.Value) <- Response (ConduitT () ByteString (ResourceT m) ())
-> FacebookT Auth (ResourceT m) Value
forall (m :: * -> *) (t :: (* -> *) -> * -> *) a.
(MonadIO m, MonadTrans t, MonadThrow m, FromJSON a) =>
Response (ConduitT () ByteString m ()) -> t m a
asJson Response (ConduitT () ByteString (ResourceT m) ())
response
    case (Value -> Parser Text) -> Value -> Maybe Text
forall a b. (a -> Parser b) -> a -> Maybe b
AE.parseMaybe Value -> Parser Text
tokenParser Value
token of
      Just Text
appToken -> AppAccessToken -> FacebookT Auth (ResourceT m) AppAccessToken
forall (m :: * -> *) a. Monad m => a -> m a
return (AppAccessToken -> FacebookT Auth (ResourceT m) AppAccessToken)
-> AppAccessToken -> FacebookT Auth (ResourceT m) AppAccessToken
forall a b. (a -> b) -> a -> b
$ Text -> AppAccessToken
AppAccessToken Text
appToken
      Maybe Text
_ ->
        FacebookException -> FacebookT Auth (ResourceT m) AppAccessToken
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO (FacebookException -> FacebookT Auth (ResourceT m) AppAccessToken)
-> FacebookException -> FacebookT Auth (ResourceT m) AppAccessToken
forall a b. (a -> b) -> a -> b
$
        Text -> FacebookException
FbLibraryException (Text
"Unable to parse: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Value -> String
forall a. Show a => a -> String
show Value
token))
  where
    tokenParser :: AE.Value -> AE.Parser AccessTokenData
    tokenParser :: Value -> Parser Text
tokenParser Value
val =
      String -> (Object -> Parser Text) -> Value -> Parser Text
forall a. String -> (Object -> Parser a) -> Value -> Parser a
AE.withObject
        String
"accessToken"
        (\Object
obj -> do
           (Text
token :: Text) <- Object
obj Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
AE..: Key
"access_token"
           Text -> Parser Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
token)
        Value
val

-- | The first step to get an user access token.  Returns the
-- Facebook URL you should redirect you user to.  Facebook will
-- authenticate the user, authorize your app and then redirect
-- the user back into the provider 'RedirectUrl'.
getUserAccessTokenStep1 ::
     (Monad m, MonadIO m)
  => RedirectUrl
  -> [Permission]
  -> FacebookT Auth m Text
getUserAccessTokenStep1 :: Text -> [Permission] -> FacebookT Auth m Text
getUserAccessTokenStep1 Text
redirectUrl [Permission]
perms = do
  Credentials
creds <- FacebookT Auth m Credentials
forall (m :: * -> *).
(Monad m, MonadIO m) =>
FacebookT Auth m Credentials
getCreds
  Text
apiVersion <- FacebookT Auth m Text
forall (m :: * -> *) anyAuth. MonadIO m => FacebookT anyAuth m Text
getApiVersion
  (FbTier -> Text) -> FacebookT Auth m Text
forall (m :: * -> *) a anyAuth.
Monad m =>
(FbTier -> a) -> FacebookT anyAuth m a
withTier ((FbTier -> Text) -> FacebookT Auth m Text)
-> (FbTier -> Text) -> FacebookT Auth m Text
forall a b. (a -> b) -> a -> b
$ \FbTier
tier ->
    let urlBase :: Text
urlBase =
          case FbTier
tier of
            FbTier
Production ->
              Text
"https://www.facebook.com/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
apiVersion Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
              Text
"/dialog/oauth?client_id="
            FbTier
Beta ->
              Text
"https://www.beta.facebook.com/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
apiVersion Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
              Text
"/dialog/oauth?client_id="
     in [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
        Text
urlBase Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:
        Credentials -> Text
appId Credentials
creds Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:
        Text
"&redirect_uri=" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:
        Text
redirectUrl Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:
        (case [Permission]
perms of
           [] -> []
           [Permission]
_ -> Text
"&scope=" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
L.intersperse Text
"," ((Permission -> Text) -> [Permission] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Permission -> Text
unPermission [Permission]
perms))

-- | The second step to get an user access token.  If the user is
-- successfully authenticate and they authorize your application,
-- then they'll be redirected back to the 'RedirectUrl' you've
-- passed to 'getUserAccessTokenStep1'.  You should take the
-- request query parameters passed to your 'RedirectUrl' and give
-- to this function that will complete the user authentication
-- flow and give you an @'UserAccessToken'@.
getUserAccessTokenStep2 ::
     (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m, MonadIO m)
  => RedirectUrl -- ^ Should be exactly the same
     -- as in 'getUserAccessTokenStep1'.
  -> [Argument] -- ^ Query parameters.
  -> FacebookT Auth m UserAccessToken
getUserAccessTokenStep2 :: Text -> SimpleQuery -> FacebookT Auth m UserAccessToken
getUserAccessTokenStep2 Text
redirectUrl SimpleQuery
query =
  case SimpleQuery
query of
    [code :: Argument
code@(ByteString
"code", ByteString
_)] ->
      FacebookT Auth (ResourceT m) UserAccessToken
-> FacebookT Auth m UserAccessToken
forall (m :: * -> *) anyAuth a.
(MonadResource m, MonadUnliftIO m) =>
FacebookT anyAuth (ResourceT m) a -> FacebookT anyAuth m a
runResourceInFb (FacebookT Auth (ResourceT m) UserAccessToken
 -> FacebookT Auth m UserAccessToken)
-> FacebookT Auth (ResourceT m) UserAccessToken
-> FacebookT Auth m UserAccessToken
forall a b. (a -> b) -> a -> b
$
      -- Get the access token data through Facebook's OAuth.
       do
        UTCTime
now <- IO UTCTime -> FacebookT Auth (ResourceT m) UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
        Credentials
creds <- FacebookT Auth (ResourceT m) Credentials
forall (m :: * -> *).
(Monad m, MonadIO m) =>
FacebookT Auth m Credentials
getCreds
        Request
req <-
          Text
-> Maybe (AccessToken Any)
-> SimpleQuery
-> FacebookT Auth (ResourceT m) Request
forall (m :: * -> *) anyKind anyAuth.
MonadIO m =>
Text
-> Maybe (AccessToken anyKind)
-> SimpleQuery
-> FacebookT anyAuth m Request
fbreq Text
"/oauth/access_token" Maybe (AccessToken Any)
forall a. Maybe a
Nothing (SimpleQuery -> FacebookT Auth (ResourceT m) Request)
-> SimpleQuery -> FacebookT Auth (ResourceT m) Request
forall a b. (a -> b) -> a -> b
$
          Credentials -> SimpleQuery -> SimpleQuery
forall a. ToSimpleQuery a => a -> SimpleQuery -> SimpleQuery
tsq Credentials
creds [Argument
code, (ByteString
"redirect_uri", Text -> ByteString
TE.encodeUtf8 Text
redirectUrl)]
        Response (ConduitT () ByteString (ResourceT m) ())
response <- Request
-> FacebookT
     Auth
     (ResourceT m)
     (Response (ConduitT () ByteString (ResourceT m) ()))
forall (m :: * -> *) anyAuth.
(MonadResource m, MonadUnliftIO m, MonadThrow m) =>
Request
-> FacebookT anyAuth m (Response (ConduitT () ByteString m ()))
fbhttp Request
req
        (Value
userToken :: AE.Value) <- Response (ConduitT () ByteString (ResourceT m) ())
-> FacebookT Auth (ResourceT m) Value
forall (m :: * -> *) (t :: (* -> *) -> * -> *) a.
(MonadIO m, MonadTrans t, MonadThrow m, FromJSON a) =>
Response (ConduitT () ByteString m ()) -> t m a
asJson Response (ConduitT () ByteString (ResourceT m) ())
response
        let (Text
token, UTCTime
expire) = UTCTime -> Value -> (Text, UTCTime)
userAccessTokenParser UTCTime
now Value
userToken
         -- Get user's ID throught Facebook's graph.
        Response (ConduitT () ByteString (ResourceT m) ())
userResponse <-
          Request
-> FacebookT
     Auth
     (ResourceT m)
     (Response (ConduitT () ByteString (ResourceT m) ()))
forall (m :: * -> *) anyAuth.
(MonadResource m, MonadUnliftIO m, MonadThrow m) =>
Request
-> FacebookT anyAuth m (Response (ConduitT () ByteString m ()))
fbhttp (Request
 -> FacebookT
      Auth
      (ResourceT m)
      (Response (ConduitT () ByteString (ResourceT m) ())))
-> FacebookT Auth (ResourceT m) Request
-> FacebookT
     Auth
     (ResourceT m)
     (Response (ConduitT () ByteString (ResourceT m) ()))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
          Text
-> Maybe UserAccessToken
-> SimpleQuery
-> FacebookT Auth (ResourceT m) Request
forall (m :: * -> *) anyKind anyAuth.
MonadIO m =>
Text
-> Maybe (AccessToken anyKind)
-> SimpleQuery
-> FacebookT anyAuth m Request
fbreq
            Text
"/me"
            (UserAccessToken -> Maybe UserAccessToken
forall a. a -> Maybe a
Just (UserId -> Text -> UTCTime -> UserAccessToken
UserAccessToken UserId
"invalid id" Text
token UTCTime
expire))
            [(ByteString
"fields", ByteString
"id")]
        (UserId
userId :: UserId) <- Response (ConduitT () ByteString (ResourceT m) ())
-> FacebookT Auth (ResourceT m) UserId
forall (m :: * -> *) (t :: (* -> *) -> * -> *) a.
(MonadIO m, MonadTrans t, MonadThrow m, FromJSON a) =>
Response (ConduitT () ByteString m ()) -> t m a
asJson Response (ConduitT () ByteString (ResourceT m) ())
userResponse
        UserAccessToken -> FacebookT Auth (ResourceT m) UserAccessToken
forall (m :: * -> *) a. Monad m => a -> m a
return (UserAccessToken -> FacebookT Auth (ResourceT m) UserAccessToken)
-> UserAccessToken -> FacebookT Auth (ResourceT m) UserAccessToken
forall a b. (a -> b) -> a -> b
$ UserId -> Text -> UTCTime -> UserAccessToken
UserAccessToken UserId
userId Text
token UTCTime
expire
    SimpleQuery
_ ->
      let [ByteString
error_, ByteString
errorReason, ByteString
errorDescr] =
            (ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map
              (ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"" (Maybe ByteString -> ByteString)
-> (ByteString -> Maybe ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> SimpleQuery -> Maybe ByteString)
-> SimpleQuery -> ByteString -> Maybe ByteString
forall a b c. (a -> b -> c) -> b -> a -> c
flip ByteString -> SimpleQuery -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup SimpleQuery
query)
              [ByteString
"error", ByteString
"error_reason", ByteString
"error_description"]
          errorType :: Text
errorType = [Text] -> Text
T.concat [ByteString -> Text
t ByteString
error_, Text
" (", ByteString -> Text
t ByteString
errorReason, Text
")"]
          t :: ByteString -> Text
t = OnDecodeError -> ByteString -> Text
TE.decodeUtf8With OnDecodeError
TE.lenientDecode
       in FacebookException -> FacebookT Auth m UserAccessToken
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO (FacebookException -> FacebookT Auth m UserAccessToken)
-> FacebookException -> FacebookT Auth m UserAccessToken
forall a b. (a -> b) -> a -> b
$ Text -> Text -> FacebookException
FacebookException Text
errorType (ByteString -> Text
t ByteString
errorDescr)

-- | Attoparsec parser for user access tokens returned by
-- Facebook as a query string.  Returns an user access token with
-- a broken 'UserId'.
userAccessTokenParser ::
     UTCTime -- ^ 'getCurrentTime'
  -> AE.Value
  -> (AccessTokenData, UTCTime)
userAccessTokenParser :: UTCTime -> Value -> (Text, UTCTime)
userAccessTokenParser UTCTime
now Value
val =
  case (Value -> Parser (Text, UTCTime)) -> Value -> Maybe (Text, UTCTime)
forall a b. (a -> Parser b) -> a -> Maybe b
AE.parseMaybe Value -> Parser (Text, UTCTime)
tokenParser Value
val of
    Just (Text
token, UTCTime
parser) -> (Text
token, UTCTime
parser)
    Maybe (Text, UTCTime)
_ -> String -> (Text, UTCTime)
forall a. HasCallStack => String -> a
error (String -> (Text, UTCTime)) -> String -> (Text, UTCTime)
forall a b. (a -> b) -> a -> b
$ String
"userAccessTokenParser: failed to parse " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Value -> String
forall a. Show a => a -> String
show Value
val
  where
    toExpire :: Int -> UTCTime
toExpire Int
expt = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (Int -> NominalDiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
expt) UTCTime
now
    tokenParser :: AE.Value -> AE.Parser (AccessTokenData, UTCTime)
    tokenParser :: Value -> Parser (Text, UTCTime)
tokenParser Value
value =
      String
-> (Object -> Parser (Text, UTCTime))
-> Value
-> Parser (Text, UTCTime)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
AE.withObject
        String
"accessToken"
        (\Object
obj -> do
           (Text
token :: Text) <- Object
obj Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
AE..: Key
"access_token"
           (Int
expires_in :: Int) <- Object
obj Object -> Key -> Parser Int
forall a. FromJSON a => Object -> Key -> Parser a
AE..: Key
"expires_in"
           (Text, UTCTime) -> Parser (Text, UTCTime)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
token, Int -> UTCTime
toExpire Int
expires_in))
        Value
value

-- | The URL an user should be redirected to in order to log them
-- out of their Facebook session.  Facebook will then redirect
-- the user to the provided URL after logging them out.  Note
-- that, at the time of this writing, Facebook's policies require
-- you to log the user out of Facebook when they ask to log out
-- of your site.
--
-- Note also that Facebook may refuse to redirect the user to the
-- provided URL if their user access token is invalid.  In order
-- to prevent this bug, we suggest that you use 'isValid' before
-- redirecting the user to the URL provided by 'getUserLogoutUrl'
-- since this function doesn't do any validity checks.
getUserLogoutUrl ::
     Monad m
  => UserAccessToken
     -- ^ The user's access token.
  -> RedirectUrl
     -- ^ URL the user should be directed to in
     -- your site domain.
  -> FacebookT Auth m Text -- ^ Logout URL in
-- @https:\/\/www.facebook.com\/@ (or on
-- @https:\/\/www.beta.facebook.com\/@ when
-- using the beta tier).
getUserLogoutUrl :: UserAccessToken -> Text -> FacebookT Auth m Text
getUserLogoutUrl (UserAccessToken UserId
_ Text
data_ UTCTime
_) Text
next = do
  (FbTier -> Text) -> FacebookT Auth m Text
forall (m :: * -> *) a anyAuth.
Monad m =>
(FbTier -> a) -> FacebookT anyAuth m a
withTier ((FbTier -> Text) -> FacebookT Auth m Text)
-> (FbTier -> Text) -> FacebookT Auth m Text
forall a b. (a -> b) -> a -> b
$ \FbTier
tier ->
    let urlBase :: ByteString
urlBase =
          case FbTier
tier of
            FbTier
Production -> ByteString
"https://www.facebook.com/logout.php?"
            FbTier
Beta -> ByteString
"https://www.beta.facebook.com/logout.php?"
     in ByteString -> Text
TE.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$
        ByteString
urlBase ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>
        Bool -> Query -> ByteString
HT.renderQuery
          Bool
False
          [ (ByteString
"next", ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (Text -> ByteString
TE.encodeUtf8 Text
next))
          , (ByteString
"access_token", ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (Text -> ByteString
TE.encodeUtf8 Text
data_))
          ]

-- | URL where the user is redirected to after Facebook
-- authenticates the user authorizes your application.  This URL
-- should be inside the domain registered for your Facebook
-- application.
type RedirectUrl = Text

-- | A permission that is asked for the user when he authorizes
-- your app.  Please refer to Facebook's documentation at
-- <https://developers.facebook.com/docs/reference/api/permissions/>
-- to see which permissions are available.
--
-- This is a @newtype@ of 'Text' that supports only 'IsString'.
-- This means that to create a 'Permission' you should use the
-- @OverloadedStrings@ language extension.  For example,
--
-- > {-# LANGUAGE OverloadedStrings #-}
-- >
-- > perms :: [Permission]
-- > perms = ["user_about_me", "email", "offline_access"]
newtype Permission =
  Permission
    { Permission -> Text
unPermission :: Text
    -- ^ Retrieves the 'Text' back from a 'Permission'.  Most of
    -- the time you won't need to use this function, but you may
    -- need it if you're a library author.
    }
  deriving (Permission -> Permission -> Bool
(Permission -> Permission -> Bool)
-> (Permission -> Permission -> Bool) -> Eq Permission
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Permission -> Permission -> Bool
$c/= :: Permission -> Permission -> Bool
== :: Permission -> Permission -> Bool
$c== :: Permission -> Permission -> Bool
Eq, Eq Permission
Eq Permission
-> (Permission -> Permission -> Ordering)
-> (Permission -> Permission -> Bool)
-> (Permission -> Permission -> Bool)
-> (Permission -> Permission -> Bool)
-> (Permission -> Permission -> Bool)
-> (Permission -> Permission -> Permission)
-> (Permission -> Permission -> Permission)
-> Ord Permission
Permission -> Permission -> Bool
Permission -> Permission -> Ordering
Permission -> Permission -> Permission
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Permission -> Permission -> Permission
$cmin :: Permission -> Permission -> Permission
max :: Permission -> Permission -> Permission
$cmax :: Permission -> Permission -> Permission
>= :: Permission -> Permission -> Bool
$c>= :: Permission -> Permission -> Bool
> :: Permission -> Permission -> Bool
$c> :: Permission -> Permission -> Bool
<= :: Permission -> Permission -> Bool
$c<= :: Permission -> Permission -> Bool
< :: Permission -> Permission -> Bool
$c< :: Permission -> Permission -> Bool
compare :: Permission -> Permission -> Ordering
$ccompare :: Permission -> Permission -> Ordering
$cp1Ord :: Eq Permission
Ord)

instance Show Permission where
  show :: Permission -> String
show = Text -> String
forall a. Show a => a -> String
show (Text -> String) -> (Permission -> Text) -> Permission -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Permission -> Text
unPermission

instance IsString Permission where
  fromString :: String -> Permission
fromString = Text -> Permission
Permission (Text -> Permission) -> (String -> Text) -> String -> Permission
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. IsString a => String -> a
fromString

-- | @True@ if the access token has expired, otherwise @False@.
hasExpired :: (Functor m, MonadIO m) => AccessToken anyKind -> m Bool
hasExpired :: AccessToken anyKind -> m Bool
hasExpired AccessToken anyKind
token =
  case AccessToken anyKind -> Maybe UTCTime
forall anyKind. AccessToken anyKind -> Maybe UTCTime
accessTokenExpires AccessToken anyKind
token of
    Maybe UTCTime
Nothing -> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    Just UTCTime
expTime -> (UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
>= UTCTime
expTime) (UTCTime -> Bool) -> m UTCTime -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime

-- | @True@ if the access token is valid.  An expired access
-- token is not valid (see 'hasExpired').  However, a non-expired
-- access token may not be valid as well.  For example, in the
-- case of an user access token, they may have changed their
-- password, logged out from Facebook or blocked your app.
isValid ::
     (R.MonadResource m, R.MonadUnliftIO m)
  => AccessToken anyKind
  -> FacebookT anyAuth m Bool
isValid :: AccessToken anyKind -> FacebookT anyAuth m Bool
isValid AccessToken anyKind
token = do
  Bool
expired <- AccessToken anyKind -> FacebookT anyAuth m Bool
forall (m :: * -> *) anyKind.
(Functor m, MonadIO m) =>
AccessToken anyKind -> m Bool
hasExpired AccessToken anyKind
token
  if Bool
expired
    then Bool -> FacebookT anyAuth m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    else let page :: Text
page =
               case AccessToken anyKind
token of
                 UserAccessToken UserId
_ Text
_ UTCTime
_ -> Text
"/me"
                 -- Documented way of checking if the token is valid,
                 -- see <https://developers.facebook.com/blog/post/500/>.
                 AppAccessToken Text
_ -> Text
"/19292868552"
             -- This is Facebook's page on Facebook.  While
             -- this behaviour is undocumented, it will
             -- return a "400 Bad Request" status code
             -- whenever the access token is invalid.  It
             -- will actually work with user access tokens,
             -- too, but they have another, better way of
             -- being checked.
          in Request -> FacebookT anyAuth m Bool
forall (m :: * -> *) anyAuth.
(MonadResource m, MonadUnliftIO m) =>
Request -> FacebookT anyAuth m Bool
httpCheck (Request -> FacebookT anyAuth m Bool)
-> FacebookT anyAuth m Request -> FacebookT anyAuth m Bool
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text
-> Maybe (AccessToken anyKind)
-> SimpleQuery
-> FacebookT anyAuth m Request
forall (m :: * -> *) anyKind anyAuth.
MonadIO m =>
Text
-> Maybe (AccessToken anyKind)
-> SimpleQuery
-> FacebookT anyAuth m Request
fbreq Text
page (AccessToken anyKind -> Maybe (AccessToken anyKind)
forall a. a -> Maybe a
Just AccessToken anyKind
token) []

-- | Extend the expiration time of an user access token (see
-- <https://developers.facebook.com/docs/offline-access-deprecation/>,
-- <https://developers.facebook.com/roadmap/offline-access-removal/>).
-- Only short-lived user access tokens may extended into
-- long-lived user access tokens, you must get a new short-lived
-- user access token if you need to extend a long-lived
-- one.  Returns @Left exc@ if there is an error while extending,
-- or @Right token@ with the new user access token (which could
-- have the same data and expiration time as before, but you
-- can't assume this).  Note that expired access tokens can't be
-- extended, only valid tokens.
extendUserAccessToken ::
     (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m, MonadIO m)
  => UserAccessToken
  -> FacebookT Auth m (Either FacebookException UserAccessToken)
extendUserAccessToken :: UserAccessToken
-> FacebookT Auth m (Either FacebookException UserAccessToken)
extendUserAccessToken token :: UserAccessToken
token@(UserAccessToken UserId
uid Text
data_ UTCTime
_) = do
  Bool
expired <- UserAccessToken -> FacebookT Auth m Bool
forall (m :: * -> *) anyKind.
(Functor m, MonadIO m) =>
AccessToken anyKind -> m Bool
hasExpired UserAccessToken
token
  if Bool
expired
    then Either FacebookException UserAccessToken
-> FacebookT Auth m (Either FacebookException UserAccessToken)
forall (m :: * -> *) a. Monad m => a -> m a
return (FacebookException -> Either FacebookException UserAccessToken
forall a b. a -> Either a b
Left FacebookException
hasExpiredExc)
    else FacebookT Auth m (Either FacebookException UserAccessToken)
tryToExtend
  where
    tryToExtend :: FacebookT Auth m (Either FacebookException UserAccessToken)
tryToExtend =
      FacebookT
  Auth (ResourceT m) (Either FacebookException UserAccessToken)
-> FacebookT Auth m (Either FacebookException UserAccessToken)
forall (m :: * -> *) anyAuth a.
(MonadResource m, MonadUnliftIO m) =>
FacebookT anyAuth (ResourceT m) a -> FacebookT anyAuth m a
runResourceInFb (FacebookT
   Auth (ResourceT m) (Either FacebookException UserAccessToken)
 -> FacebookT Auth m (Either FacebookException UserAccessToken))
-> FacebookT
     Auth (ResourceT m) (Either FacebookException UserAccessToken)
-> FacebookT Auth m (Either FacebookException UserAccessToken)
forall a b. (a -> b) -> a -> b
$ do
        Credentials
creds <- FacebookT Auth (ResourceT m) Credentials
forall (m :: * -> *).
(Monad m, MonadIO m) =>
FacebookT Auth m Credentials
getCreds
        Request
req <-
          Text
-> Maybe (AccessToken Any)
-> SimpleQuery
-> FacebookT Auth (ResourceT m) Request
forall (m :: * -> *) anyKind anyAuth.
MonadIO m =>
Text
-> Maybe (AccessToken anyKind)
-> SimpleQuery
-> FacebookT anyAuth m Request
fbreq Text
"/oauth/access_token" Maybe (AccessToken Any)
forall a. Maybe a
Nothing (SimpleQuery -> FacebookT Auth (ResourceT m) Request)
-> SimpleQuery -> FacebookT Auth (ResourceT m) Request
forall a b. (a -> b) -> a -> b
$
          Credentials -> SimpleQuery -> SimpleQuery
forall a. ToSimpleQuery a => a -> SimpleQuery -> SimpleQuery
tsq
            Credentials
creds
            [ (ByteString
"grant_type", ByteString
"fb_exchange_token")
            , (ByteString
"fb_exchange_token", Text -> ByteString
TE.encodeUtf8 Text
data_)
            ]
        Response (ConduitT () ByteString (ResourceT m) ())
response <- Request
-> FacebookT
     Auth
     (ResourceT m)
     (Response (ConduitT () ByteString (ResourceT m) ()))
forall (m :: * -> *) anyAuth.
(MonadResource m, MonadUnliftIO m, MonadThrow m) =>
Request
-> FacebookT anyAuth m (Response (ConduitT () ByteString m ()))
fbhttp Request
req
        Either FacebookException Value
userToken <- FacebookT Auth (ResourceT m) Value
-> FacebookT Auth (ResourceT m) (Either FacebookException Value)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
E.try (FacebookT Auth (ResourceT m) Value
 -> FacebookT Auth (ResourceT m) (Either FacebookException Value))
-> FacebookT Auth (ResourceT m) Value
-> FacebookT Auth (ResourceT m) (Either FacebookException Value)
forall a b. (a -> b) -> a -> b
$ Response (ConduitT () ByteString (ResourceT m) ())
-> FacebookT Auth (ResourceT m) Value
forall (m :: * -> *) (t :: (* -> *) -> * -> *) a.
(MonadIO m, MonadTrans t, MonadThrow m, FromJSON a) =>
Response (ConduitT () ByteString m ()) -> t m a
asJson Response (ConduitT () ByteString (ResourceT m) ())
response
        case Either FacebookException Value
userToken of
          Right Value
val -> do
            UTCTime
now <- IO UTCTime -> FacebookT Auth (ResourceT m) UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
            let (Text
extendedtoken, UTCTime
expire) = UTCTime -> Value -> (Text, UTCTime)
userAccessTokenParser UTCTime
now Value
val
            Either FacebookException UserAccessToken
-> FacebookT
     Auth (ResourceT m) (Either FacebookException UserAccessToken)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either FacebookException UserAccessToken
 -> FacebookT
      Auth (ResourceT m) (Either FacebookException UserAccessToken))
-> Either FacebookException UserAccessToken
-> FacebookT
     Auth (ResourceT m) (Either FacebookException UserAccessToken)
forall a b. (a -> b) -> a -> b
$ UserAccessToken -> Either FacebookException UserAccessToken
forall a b. b -> Either a b
Right (UserAccessToken -> Either FacebookException UserAccessToken)
-> UserAccessToken -> Either FacebookException UserAccessToken
forall a b. (a -> b) -> a -> b
$ UserId -> Text -> UTCTime -> UserAccessToken
UserAccessToken UserId
uid Text
extendedtoken UTCTime
expire
          Left FacebookException
exc -> Either FacebookException UserAccessToken
-> FacebookT
     Auth (ResourceT m) (Either FacebookException UserAccessToken)
forall (m :: * -> *) a. Monad m => a -> m a
return (FacebookException -> Either FacebookException UserAccessToken
forall a b. a -> Either a b
Left FacebookException
exc)
    hasExpiredExc :: FacebookException
hasExpiredExc =
      [Text] -> FacebookException
mkExc
        [ Text
"the user access token has already expired, "
        , Text
"so I'll not try to extend it."
        ]
    mkExc :: [Text] -> FacebookException
mkExc = Text -> FacebookException
FbLibraryException (Text -> FacebookException)
-> ([Text] -> Text) -> [Text] -> FacebookException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.concat ([Text] -> Text) -> ([Text] -> [Text]) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"extendUserAccessToken: " Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:)

-- | Parses a Facebook signed request
-- (<https://developers.facebook.com/docs/authentication/signed_request/>),
-- verifies its authencity and integrity using the HMAC and
-- decodes its JSON object.
parseSignedRequest ::
     (AE.FromJSON a, Monad m, MonadIO m)
  => B8.ByteString -- ^ Encoded Facebook signed request
  -> FacebookT Auth m (Maybe a)
parseSignedRequest :: ByteString -> FacebookT Auth m (Maybe a)
parseSignedRequest ByteString
signedRequest =
  MaybeT (FacebookT Auth m) a -> FacebookT Auth m (Maybe a)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (FacebookT Auth m) a -> FacebookT Auth m (Maybe a))
-> MaybeT (FacebookT Auth m) a -> FacebookT Auth m (Maybe a)
forall a b. (a -> b) -> a -> b
$
  -- Split, decode and JSON-parse
   do
    let (ByteString
encodedSignature, ByteString
encodedUnparsedPayloadWithDot) =
          (Char -> Bool) -> ByteString -> Argument
B8.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.') ByteString
signedRequest
    (Char
'.', ByteString
encodedUnparsedPayload) <-
      FacebookT Auth m (Maybe (Char, ByteString))
-> MaybeT (FacebookT Auth m) (Char, ByteString)
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (FacebookT Auth m (Maybe (Char, ByteString))
 -> MaybeT (FacebookT Auth m) (Char, ByteString))
-> FacebookT Auth m (Maybe (Char, ByteString))
-> MaybeT (FacebookT Auth m) (Char, ByteString)
forall a b. (a -> b) -> a -> b
$ Maybe (Char, ByteString)
-> FacebookT Auth m (Maybe (Char, ByteString))
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Maybe (Char, ByteString)
B8.uncons ByteString
encodedUnparsedPayloadWithDot)
    ScrubbedBytes
signature <-
      Either String ScrubbedBytes
-> MaybeT (FacebookT Auth m) ScrubbedBytes
forall (m :: * -> *) a b. Monad m => Either a b -> MaybeT m b
eitherToMaybeT (Either String ScrubbedBytes
 -> MaybeT (FacebookT Auth m) ScrubbedBytes)
-> Either String ScrubbedBytes
-> MaybeT (FacebookT Auth m) ScrubbedBytes
forall a b. (a -> b) -> a -> b
$
      Base -> ByteString -> Either String ScrubbedBytes
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> Either String bout
convertFromBase Base
Base64 (ByteString -> Either String ScrubbedBytes)
-> ByteString -> Either String ScrubbedBytes
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
addBase64Padding ByteString
encodedSignature
    ByteString
unparsedPayload <-
      Either String ByteString -> MaybeT (FacebookT Auth m) ByteString
forall (m :: * -> *) a b. Monad m => Either a b -> MaybeT m b
eitherToMaybeT (Either String ByteString -> MaybeT (FacebookT Auth m) ByteString)
-> Either String ByteString -> MaybeT (FacebookT Auth m) ByteString
forall a b. (a -> b) -> a -> b
$
      Base -> ByteString -> Either String ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> Either String bout
convertFromBase Base
Base64 (ByteString -> Either String ByteString)
-> ByteString -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
addBase64Padding ByteString
encodedUnparsedPayload
    Value
payload <- Either String Value -> MaybeT (FacebookT Auth m) Value
forall (m :: * -> *) a b. Monad m => Either a b -> MaybeT m b
eitherToMaybeT (Either String Value -> MaybeT (FacebookT Auth m) Value)
-> Either String Value -> MaybeT (FacebookT Auth m) Value
forall a b. (a -> b) -> a -> b
$ Parser Value -> ByteString -> Either String Value
forall a. Parser a -> ByteString -> Either String a
AB.parseOnly Parser Value
json' ByteString
unparsedPayload
     -- Verify signature
    SignedRequestAlgorithm Text
algo <- Value -> MaybeT (FacebookT Auth m) SignedRequestAlgorithm
forall a (m :: * -> *).
(FromJSON a, Monad m) =>
Value -> MaybeT m a
fromJson Value
payload
    Bool -> MaybeT (FacebookT Auth m) ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Text
algo Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"HMAC-SHA256")
    Credentials
creds <- FacebookT Auth m Credentials
-> MaybeT (FacebookT Auth m) Credentials
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift FacebookT Auth m Credentials
forall (m :: * -> *).
(Monad m, MonadIO m) =>
FacebookT Auth m Credentials
getCreds
    let hmacKey :: ByteString
hmacKey = Credentials -> ByteString
credsToHmacKey Credentials
creds
        expectedSignature :: HMAC SHA256
expectedSignature = ByteString -> ByteString -> HMAC SHA256
forall key message a.
(ByteArrayAccess key, ByteArrayAccess message, HashAlgorithm a) =>
key -> message -> HMAC a
hmac ByteString
hmacKey ByteString
encodedUnparsedPayload :: HMAC SHA256
    Bool -> MaybeT (FacebookT Auth m) ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard ((ScrubbedBytes
signature :: ScrubbedBytes) ScrubbedBytes -> ScrubbedBytes -> Bool
forall a. Eq a => a -> a -> Bool
== (HMAC SHA256 -> ScrubbedBytes
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
convert HMAC SHA256
expectedSignature))
     -- Parse user data type
    Value -> MaybeT (FacebookT Auth m) a
forall a (m :: * -> *).
(FromJSON a, Monad m) =>
Value -> MaybeT m a
fromJson Value
payload
  where
    eitherToMaybeT :: Monad m => Either a b -> MaybeT m b
    eitherToMaybeT :: Either a b -> MaybeT m b
eitherToMaybeT = m (Maybe b) -> MaybeT m b
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe b) -> MaybeT m b)
-> (Either a b -> m (Maybe b)) -> Either a b -> MaybeT m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe b -> m (Maybe b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe b -> m (Maybe b))
-> (Either a b -> Maybe b) -> Either a b -> m (Maybe b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Maybe b) -> (b -> Maybe b) -> Either a b -> Maybe b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe b -> a -> Maybe b
forall a b. a -> b -> a
const Maybe b
forall a. Maybe a
Nothing) b -> Maybe b
forall a. a -> Maybe a
Just
    fromJson :: (AE.FromJSON a, Monad m) => AE.Value -> MaybeT m a
    fromJson :: Value -> MaybeT m a
fromJson = Either String a -> MaybeT m a
forall (m :: * -> *) a b. Monad m => Either a b -> MaybeT m b
eitherToMaybeT (Either String a -> MaybeT m a)
-> (Value -> Either String a) -> Value -> MaybeT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Parser a) -> Value -> Either String a
forall a b. (a -> Parser b) -> a -> Either String b
AE.parseEither Value -> Parser a
forall a. FromJSON a => Value -> Parser a
AE.parseJSON
    -- credsToHmacKey :: Credentials -> MacKey ctx SHA256
    credsToHmacKey :: Credentials -> ByteString
credsToHmacKey = Credentials -> ByteString
appSecretBS

newtype SignedRequestAlgorithm =
  SignedRequestAlgorithm Text

instance AE.FromJSON SignedRequestAlgorithm where
  parseJSON :: Value -> Parser SignedRequestAlgorithm
parseJSON (AE.Object Object
v) = Text -> SignedRequestAlgorithm
SignedRequestAlgorithm (Text -> SignedRequestAlgorithm)
-> Parser Text -> Parser SignedRequestAlgorithm
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"algorithm"
  parseJSON Value
_ = Parser SignedRequestAlgorithm
forall (m :: * -> *) a. MonadPlus m => m a
mzero

-- | The @base64-bytestring@ package provides two different
-- decoding functions for @base64url@: 'Base64URL.decode' and
-- 'Base64URL.decodeLenient'.  The former is too strict for us
-- since Facebook does add padding to its signed requests, but
-- the latter is too lenient and will accept *anything*.
--
-- Instead of being too lenient, we just use this function add
-- the padding base to the encoded string, thus allowing
-- 'Base64URL.decode' to chew it.
addBase64Padding :: B.ByteString -> B.ByteString
addBase64Padding :: ByteString -> ByteString
addBase64Padding ByteString
bs
  | Int
drem Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2 = ByteString
bs ByteString -> ByteString -> ByteString
`B.append` ByteString
"=="
  | Int
drem Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
3 = ByteString
bs ByteString -> ByteString -> ByteString
`B.append` ByteString
"="
  | Bool
otherwise = ByteString
bs
  where
    drem :: Int
drem = ByteString -> Int
B.length ByteString
bs Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
4

-- | Get detailed information about an access token.
debugToken ::
     (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m)
  => AppAccessToken -- ^ Your app access token.
  -> AccessTokenData -- ^ The access token you want to debug.
  -> FacebookT Auth m DebugToken
debugToken :: AppAccessToken -> Text -> FacebookT Auth m DebugToken
debugToken AppAccessToken
appToken Text
userTokenData = do
  Request
req <-
    Text
-> Maybe AppAccessToken -> SimpleQuery -> FacebookT Auth m Request
forall (m :: * -> *) anyKind anyAuth.
MonadIO m =>
Text
-> Maybe (AccessToken anyKind)
-> SimpleQuery
-> FacebookT anyAuth m Request
fbreq Text
"/debug_token" (AppAccessToken -> Maybe AppAccessToken
forall a. a -> Maybe a
Just AppAccessToken
appToken) (SimpleQuery -> FacebookT Auth m Request)
-> SimpleQuery -> FacebookT Auth m Request
forall a b. (a -> b) -> a -> b
$
    [(ByteString
"input_token", Text -> ByteString
TE.encodeUtf8 Text
userTokenData)]
  DebugToken
ret <- Undata DebugToken -> DebugToken
forall a. Undata a -> a
undata (Undata DebugToken -> DebugToken)
-> FacebookT Auth m (Undata DebugToken)
-> FacebookT Auth m DebugToken
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Response (ConduitT () ByteString m ())
-> FacebookT Auth m (Undata DebugToken)
forall (m :: * -> *) (t :: (* -> *) -> * -> *) a.
(MonadIO m, MonadTrans t, MonadThrow m, FromJSON a) =>
Response (ConduitT () ByteString m ()) -> t m a
asJson (Response (ConduitT () ByteString m ())
 -> FacebookT Auth m (Undata DebugToken))
-> FacebookT Auth m (Response (ConduitT () ByteString m ()))
-> FacebookT Auth m (Undata DebugToken)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Request
-> FacebookT Auth m (Response (ConduitT () ByteString m ()))
forall (m :: * -> *) anyAuth.
(MonadResource m, MonadUnliftIO m, MonadThrow m) =>
Request
-> FacebookT anyAuth m (Response (ConduitT () ByteString m ()))
fbhttp Request
req)
  let muserToken :: Maybe UserAccessToken
muserToken =
        UserId -> Text -> UTCTime -> UserAccessToken
UserAccessToken (UserId -> Text -> UTCTime -> UserAccessToken)
-> Maybe UserId -> Maybe (Text -> UTCTime -> UserAccessToken)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DebugToken -> Maybe UserId
dtUserId DebugToken
ret Maybe (Text -> UTCTime -> UserAccessToken)
-> Maybe Text -> Maybe (UTCTime -> UserAccessToken)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Maybe Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
userTokenData Maybe (UTCTime -> UserAccessToken)
-> Maybe UTCTime -> Maybe UserAccessToken
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
        DebugToken -> Maybe UTCTime
dtExpiresAt DebugToken
ret
  DebugToken -> FacebookT Auth m DebugToken
forall (m :: * -> *) a. Monad m => a -> m a
return DebugToken
ret {dtAccessToken :: Maybe UserAccessToken
dtAccessToken = Maybe UserAccessToken
muserToken}

-- | Helper used in 'debugToken'.  Unfortunately, we can't use 'Pager' here.
data Undata a =
  Undata
    { Undata a -> a
undata :: a
    }

instance AE.FromJSON a => AE.FromJSON (Undata a) where
  parseJSON :: Value -> Parser (Undata a)
parseJSON (AE.Object Object
v) = a -> Undata a
forall a. a -> Undata a
Undata (a -> Undata a) -> Parser a -> Parser (Undata a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser a
forall a. FromJSON a => Object -> Key -> Parser a
AE..: Key
"data"
  parseJSON Value
_ = Parser (Undata a)
forall (m :: * -> *) a. MonadPlus m => m a
mzero

-- | Detailed information about an access token (cf. 'debugToken').
data DebugToken =
  DebugToken
    { DebugToken -> Maybe Text
dtAppId :: Maybe Text
    , DebugToken -> Maybe Text
dtAppName :: Maybe Text
    , DebugToken -> Maybe UTCTime
dtExpiresAt :: Maybe UTCTime
    , DebugToken -> Maybe Bool
dtIsValid :: Maybe Bool
    , DebugToken -> Maybe UTCTime
dtIssuedAt :: Maybe UTCTime
    , DebugToken -> Maybe [Permission]
dtScopes :: Maybe [Permission]
    , DebugToken -> Maybe UserId
dtUserId :: Maybe Id
    , DebugToken -> Maybe UserAccessToken
dtAccessToken :: Maybe UserAccessToken
    }
  deriving (DebugToken -> DebugToken -> Bool
(DebugToken -> DebugToken -> Bool)
-> (DebugToken -> DebugToken -> Bool) -> Eq DebugToken
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DebugToken -> DebugToken -> Bool
$c/= :: DebugToken -> DebugToken -> Bool
== :: DebugToken -> DebugToken -> Bool
$c== :: DebugToken -> DebugToken -> Bool
Eq, Eq DebugToken
Eq DebugToken
-> (DebugToken -> DebugToken -> Ordering)
-> (DebugToken -> DebugToken -> Bool)
-> (DebugToken -> DebugToken -> Bool)
-> (DebugToken -> DebugToken -> Bool)
-> (DebugToken -> DebugToken -> Bool)
-> (DebugToken -> DebugToken -> DebugToken)
-> (DebugToken -> DebugToken -> DebugToken)
-> Ord DebugToken
DebugToken -> DebugToken -> Bool
DebugToken -> DebugToken -> Ordering
DebugToken -> DebugToken -> DebugToken
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: DebugToken -> DebugToken -> DebugToken
$cmin :: DebugToken -> DebugToken -> DebugToken
max :: DebugToken -> DebugToken -> DebugToken
$cmax :: DebugToken -> DebugToken -> DebugToken
>= :: DebugToken -> DebugToken -> Bool
$c>= :: DebugToken -> DebugToken -> Bool
> :: DebugToken -> DebugToken -> Bool
$c> :: DebugToken -> DebugToken -> Bool
<= :: DebugToken -> DebugToken -> Bool
$c<= :: DebugToken -> DebugToken -> Bool
< :: DebugToken -> DebugToken -> Bool
$c< :: DebugToken -> DebugToken -> Bool
compare :: DebugToken -> DebugToken -> Ordering
$ccompare :: DebugToken -> DebugToken -> Ordering
$cp1Ord :: Eq DebugToken
Ord, Int -> DebugToken -> String -> String
[DebugToken] -> String -> String
DebugToken -> String
(Int -> DebugToken -> String -> String)
-> (DebugToken -> String)
-> ([DebugToken] -> String -> String)
-> Show DebugToken
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [DebugToken] -> String -> String
$cshowList :: [DebugToken] -> String -> String
show :: DebugToken -> String
$cshow :: DebugToken -> String
showsPrec :: Int -> DebugToken -> String -> String
$cshowsPrec :: Int -> DebugToken -> String -> String
Show, Typeable)

-- | Note: this instance always sets 'dtAccessToken' to
-- 'Nothing', but 'debugToken' will update this field before
-- returning the final 'DebugToken'.  This is done because we
-- need the 'AccessTokenData', which is not part of FB's
-- response.
instance AE.FromJSON DebugToken where
  parseJSON :: Value -> Parser DebugToken
parseJSON (AE.Object Object
v) =
    Maybe Text
-> Maybe Text
-> Maybe UTCTime
-> Maybe Bool
-> Maybe UTCTime
-> Maybe [Permission]
-> Maybe UserId
-> Maybe UserAccessToken
-> DebugToken
DebugToken (Maybe Text
 -> Maybe Text
 -> Maybe UTCTime
 -> Maybe Bool
 -> Maybe UTCTime
 -> Maybe [Permission]
 -> Maybe UserId
 -> Maybe UserAccessToken
 -> DebugToken)
-> Parser (Maybe Text)
-> Parser
     (Maybe Text
      -> Maybe UTCTime
      -> Maybe Bool
      -> Maybe UTCTime
      -> Maybe [Permission]
      -> Maybe UserId
      -> Maybe UserAccessToken
      -> DebugToken)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((UserId -> Text) -> Maybe UserId -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UserId -> Text
idCode (Maybe UserId -> Maybe Text)
-> Parser (Maybe UserId) -> Parser (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser (Maybe UserId)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
AE..:? Key
"app_id") Parser
  (Maybe Text
   -> Maybe UTCTime
   -> Maybe Bool
   -> Maybe UTCTime
   -> Maybe [Permission]
   -> Maybe UserId
   -> Maybe UserAccessToken
   -> DebugToken)
-> Parser (Maybe Text)
-> Parser
     (Maybe UTCTime
      -> Maybe Bool
      -> Maybe UTCTime
      -> Maybe [Permission]
      -> Maybe UserId
      -> Maybe UserAccessToken
      -> DebugToken)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    Object
v Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
AE..:? Key
"application" Parser
  (Maybe UTCTime
   -> Maybe Bool
   -> Maybe UTCTime
   -> Maybe [Permission]
   -> Maybe UserId
   -> Maybe UserAccessToken
   -> DebugToken)
-> Parser (Maybe UTCTime)
-> Parser
     (Maybe Bool
      -> Maybe UTCTime
      -> Maybe [Permission]
      -> Maybe UserId
      -> Maybe UserAccessToken
      -> DebugToken)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    ((FbUTCTime -> UTCTime) -> Maybe FbUTCTime -> Maybe UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FbUTCTime -> UTCTime
unFbUTCTime (Maybe FbUTCTime -> Maybe UTCTime)
-> Parser (Maybe FbUTCTime) -> Parser (Maybe UTCTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser (Maybe FbUTCTime)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
AE..:? Key
"expires_at") Parser
  (Maybe Bool
   -> Maybe UTCTime
   -> Maybe [Permission]
   -> Maybe UserId
   -> Maybe UserAccessToken
   -> DebugToken)
-> Parser (Maybe Bool)
-> Parser
     (Maybe UTCTime
      -> Maybe [Permission]
      -> Maybe UserId
      -> Maybe UserAccessToken
      -> DebugToken)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    Object
v Object -> Key -> Parser (Maybe Bool)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
AE..:? Key
"is_valid" Parser
  (Maybe UTCTime
   -> Maybe [Permission]
   -> Maybe UserId
   -> Maybe UserAccessToken
   -> DebugToken)
-> Parser (Maybe UTCTime)
-> Parser
     (Maybe [Permission]
      -> Maybe UserId -> Maybe UserAccessToken -> DebugToken)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    ((FbUTCTime -> UTCTime) -> Maybe FbUTCTime -> Maybe UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FbUTCTime -> UTCTime
unFbUTCTime (Maybe FbUTCTime -> Maybe UTCTime)
-> Parser (Maybe FbUTCTime) -> Parser (Maybe UTCTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser (Maybe FbUTCTime)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
AE..:? Key
"issued_at") Parser
  (Maybe [Permission]
   -> Maybe UserId -> Maybe UserAccessToken -> DebugToken)
-> Parser (Maybe [Permission])
-> Parser (Maybe UserId -> Maybe UserAccessToken -> DebugToken)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    (([Text] -> [Permission]) -> Maybe [Text] -> Maybe [Permission]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Text -> Permission) -> [Text] -> [Permission]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Permission
Permission) (Maybe [Text] -> Maybe [Permission])
-> Parser (Maybe [Text]) -> Parser (Maybe [Permission])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser (Maybe [Text])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
AE..:? Key
"scopes") Parser (Maybe UserId -> Maybe UserAccessToken -> DebugToken)
-> Parser (Maybe UserId)
-> Parser (Maybe UserAccessToken -> DebugToken)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    Object
v Object -> Key -> Parser (Maybe UserId)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
AE..:? Key
"user_id" Parser (Maybe UserAccessToken -> DebugToken)
-> Parser (Maybe UserAccessToken) -> Parser DebugToken
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    Maybe UserAccessToken -> Parser (Maybe UserAccessToken)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe UserAccessToken
forall a. Maybe a
Nothing
  parseJSON Value
_ = Parser DebugToken
forall (m :: * -> *) a. MonadPlus m => m a
mzero