{-# 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 =
runResourceInFb $ do
creds <- getCreds
req <-
fbreq "/oauth/access_token" Nothing $
tsq creds [("grant_type", "client_credentials")]
response <- fbhttp req
(token :: AE.Value) <- asJson response
case AE.parseMaybe tokenParser token of
Just appToken -> return $ AppAccessToken appToken
_ ->
E.throwIO $
FbLibraryException ("Unable to parse: " <> (T.pack $ show token))
where
tokenParser :: AE.Value -> AE.Parser AccessTokenData
tokenParser val =
AE.withObject
"accessToken"
(\obj -> do
(token :: Text) <- obj AE..: "access_token"
return token)
val
getUserAccessTokenStep1 ::
(Monad m, MonadIO m)
=> RedirectUrl
-> [Permission]
-> FacebookT Auth m Text
getUserAccessTokenStep1 redirectUrl perms = do
creds <- getCreds
apiVersion <- getApiVersion
withTier $ \tier ->
let urlBase =
case tier of
Production ->
"https://www.facebook.com/" <> apiVersion <>
"/dialog/oauth?client_id="
Beta ->
"https://www.beta.facebook.com/" <> apiVersion <>
"/dialog/oauth?client_id="
in T.concat $
urlBase :
appId creds :
"&redirect_uri=" :
redirectUrl :
(case perms of
[] -> []
_ -> "&scope=" : L.intersperse "," (map unPermission perms))
getUserAccessTokenStep2 ::
(R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m, MonadIO m)
=> RedirectUrl
-> [Argument]
-> FacebookT Auth m UserAccessToken
getUserAccessTokenStep2 redirectUrl query =
case query of
[code@("code", _)] ->
runResourceInFb $
do
now <- liftIO getCurrentTime
creds <- getCreds
req <-
fbreq "/oauth/access_token" Nothing $
tsq creds [code, ("redirect_uri", TE.encodeUtf8 redirectUrl)]
response <- fbhttp req
(userToken :: AE.Value) <- asJson response
let (token, expire) = userAccessTokenParser now userToken
userResponse <-
fbhttp =<<
fbreq
"/me"
(Just (UserAccessToken "invalid id" token expire))
[("fields", "id")]
(userId :: UserId) <- asJson userResponse
return $ UserAccessToken userId token expire
_ ->
let [error_, errorReason, errorDescr] =
map
(fromMaybe "" . flip lookup query)
["error", "error_reason", "error_description"]
errorType = T.concat [t error_, " (", t errorReason, ")"]
t = TE.decodeUtf8With TE.lenientDecode
in E.throwIO $ FacebookException errorType (t errorDescr)
userAccessTokenParser ::
UTCTime
-> AE.Value
-> (AccessTokenData, UTCTime)
userAccessTokenParser now val =
case AE.parseMaybe tokenParser val of
Just (token, parser) -> (token, parser)
_ -> error $ "userAccessTokenParser: failed to parse " ++ show val
where
toExpire expt = addUTCTime (fromIntegral expt) now
tokenParser :: AE.Value -> AE.Parser (AccessTokenData, UTCTime)
tokenParser value =
AE.withObject
"accessToken"
(\obj -> do
(token :: Text) <- obj AE..: "access_token"
(expires_in :: Int) <- obj AE..: "expires_in"
return (token, toExpire expires_in))
value
getUserLogoutUrl ::
Monad m
=> UserAccessToken
-> RedirectUrl
-> FacebookT Auth m Text
getUserLogoutUrl (UserAccessToken _ data_ _) next = do
withTier $ \tier ->
let urlBase =
case tier of
Production -> "https://www.facebook.com/logout.php?"
Beta -> "https://www.beta.facebook.com/logout.php?"
in TE.decodeUtf8 $
urlBase <>
HT.renderQuery
False
[ ("next", Just (TE.encodeUtf8 next))
, ("access_token", Just (TE.encodeUtf8 data_))
]
type RedirectUrl = Text
newtype Permission =
Permission
{ unPermission :: Text
}
deriving (Eq, Ord)
instance Show Permission where
show = show . unPermission
instance IsString Permission where
fromString = Permission . fromString
hasExpired :: (Functor m, MonadIO m) => AccessToken anyKind -> m Bool
hasExpired token =
case accessTokenExpires token of
Nothing -> return False
Just expTime -> (>= expTime) <$> liftIO getCurrentTime
isValid ::
(R.MonadResource m, R.MonadUnliftIO m)
=> AccessToken anyKind
-> FacebookT anyAuth m Bool
isValid token = do
expired <- hasExpired token
if expired
then return False
else let page =
case token of
UserAccessToken _ _ _ -> "/me"
AppAccessToken _ -> "/19292868552"
in httpCheck =<< fbreq page (Just token) []
extendUserAccessToken ::
(R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m, MonadIO m)
=> UserAccessToken
-> FacebookT Auth m (Either FacebookException UserAccessToken)
extendUserAccessToken token@(UserAccessToken uid data_ _) = do
expired <- hasExpired token
if expired
then return (Left hasExpiredExc)
else tryToExtend
where
tryToExtend =
runResourceInFb $ do
creds <- getCreds
req <-
fbreq "/oauth/access_token" Nothing $
tsq
creds
[ ("grant_type", "fb_exchange_token")
, ("fb_exchange_token", TE.encodeUtf8 data_)
]
response <- fbhttp req
userToken <- E.try $ asJson response
case userToken of
Right val -> do
now <- liftIO getCurrentTime
let (extendedtoken, expire) = userAccessTokenParser now val
return $ Right $ UserAccessToken uid extendedtoken expire
Left exc -> return (Left exc)
hasExpiredExc =
mkExc
[ "the user access token has already expired, "
, "so I'll not try to extend it."
]
mkExc = FbLibraryException . T.concat . ("extendUserAccessToken: " :)
parseSignedRequest ::
(AE.FromJSON a, Monad m, MonadIO m)
=> B8.ByteString
-> FacebookT Auth m (Maybe a)
parseSignedRequest signedRequest =
runMaybeT $
do
let (encodedSignature, encodedUnparsedPayloadWithDot) =
B8.break (== '.') signedRequest
('.', encodedUnparsedPayload) <-
MaybeT $ return (B8.uncons encodedUnparsedPayloadWithDot)
signature <-
eitherToMaybeT $
convertFromBase Base64 $ addBase64Padding encodedSignature
unparsedPayload <-
eitherToMaybeT $
convertFromBase Base64 $ addBase64Padding encodedUnparsedPayload
payload <- eitherToMaybeT $ AB.parseOnly json' unparsedPayload
SignedRequestAlgorithm algo <- fromJson payload
guard (algo == "HMAC-SHA256")
creds <- lift getCreds
let hmacKey = credsToHmacKey creds
expectedSignature = hmac hmacKey encodedUnparsedPayload :: HMAC SHA256
guard ((signature :: ScrubbedBytes) == (convert expectedSignature))
fromJson payload
where
eitherToMaybeT :: Monad m => Either a b -> MaybeT m b
eitherToMaybeT = MaybeT . return . either (const Nothing) Just
fromJson :: (AE.FromJSON a, Monad m) => AE.Value -> MaybeT m a
fromJson = eitherToMaybeT . AE.parseEither AE.parseJSON
credsToHmacKey = appSecretBS
newtype SignedRequestAlgorithm =
SignedRequestAlgorithm Text
instance AE.FromJSON SignedRequestAlgorithm where
parseJSON (AE.Object v) = SignedRequestAlgorithm <$> v .: "algorithm"
parseJSON _ = mzero
addBase64Padding :: B.ByteString -> B.ByteString
addBase64Padding bs
| drem == 2 = bs `B.append` "=="
| drem == 3 = bs `B.append` "="
| otherwise = bs
where
drem = B.length bs `mod` 4
debugToken ::
(R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m)
=> AppAccessToken
-> AccessTokenData
-> FacebookT Auth m DebugToken
debugToken appToken userTokenData = do
req <-
fbreq "/debug_token" (Just appToken) $
[("input_token", TE.encodeUtf8 userTokenData)]
ret <- undata <$> (asJson =<< fbhttp req)
let muserToken =
UserAccessToken <$> dtUserId ret <*> return userTokenData <*>
dtExpiresAt ret
return ret {dtAccessToken = muserToken}
data Undata a =
Undata
{ undata :: a
}
instance AE.FromJSON a => AE.FromJSON (Undata a) where
parseJSON (AE.Object v) = Undata <$> v AE..: "data"
parseJSON _ = mzero
data DebugToken =
DebugToken
{ dtAppId :: Maybe Text
, dtAppName :: Maybe Text
, dtExpiresAt :: Maybe UTCTime
, dtIsValid :: Maybe Bool
, dtIssuedAt :: Maybe UTCTime
, dtScopes :: Maybe [Permission]
, dtUserId :: Maybe Id
, dtAccessToken :: Maybe UserAccessToken
}
deriving (Eq, Ord, Show, Typeable)
instance AE.FromJSON DebugToken where
parseJSON (AE.Object v) =
DebugToken <$> (fmap idCode <$> v AE..:? "app_id") <*>
v AE..:? "application" <*>
(fmap unFbUTCTime <$> v AE..:? "expires_at") <*>
v AE..:? "is_valid" <*>
(fmap unFbUTCTime <$> v AE..:? "issued_at") <*>
(fmap (map Permission) <$> v AE..:? "scopes") <*>
v AE..:? "user_id" <*>
pure Nothing
parseJSON _ = mzero