{-# 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
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
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))
getUserAccessTokenStep2 ::
(R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m, MonadIO m)
=> RedirectUrl
-> [Argument]
-> 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
$
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
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)
userAccessTokenParser ::
UTCTime
-> 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
getUserLogoutUrl ::
Monad m
=> UserAccessToken
-> RedirectUrl
-> FacebookT Auth m Text
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_))
]
type RedirectUrl = Text
newtype Permission =
Permission
{ Permission -> Text
unPermission :: Text
}
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
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
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"
AppAccessToken Text
_ -> Text
"/19292868552"
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) []
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]
:)
parseSignedRequest ::
(AE.FromJSON a, Monad m, MonadIO m)
=> B8.ByteString
-> 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
$
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
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))
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 -> 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
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
debugToken ::
(R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m)
=> AppAccessToken
-> AccessTokenData
-> 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}
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
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)
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