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, liftM, mzero)
import Control.Monad.IO.Class (MonadIO(liftIO))
import Control.Monad.Trans.Maybe (MaybeT(..))
import Crypto.Classes (constTimeEq)
import Crypto.Hash.CryptoAPI (SHA256)
import Crypto.HMAC (hmac', MacKey(..))
import Data.Aeson ((.:))
import Data.Aeson.Parser (json')
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Time (getCurrentTime, addUTCTime, UTCTime)
import Data.Typeable (Typeable)
import Data.String (IsString(..))
import qualified UnliftIO.Exception as E
import qualified Control.Monad.Trans.Resource as R
import qualified Data.Aeson as AE
import qualified Data.Aeson.Types as AE
import qualified Data.Attoparsec.ByteString.Char8 as AB
import qualified Data.ByteString as B
import qualified Data.ByteString.Base64.URL as Base64URL
import qualified Data.ByteString.Char8 as B8
import qualified Data.List as L
import qualified Data.Serialize as Cereal
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Encoding.Error as TE
import qualified Network.HTTP.Types as HT
import Facebook.Types
import Facebook.Base
import Facebook.Monad
getAppAccessToken
:: (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow 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
=> RedirectUrl -> [Permission] -> FacebookT Auth m Text
getUserAccessTokenStep1 redirectUrl perms = do
creds <- getCreds
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)
=> 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)
=> 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)
=> 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 $ Base64URL.decode $ addBase64Padding encodedSignature
unparsedPayload <- eitherToMaybeT $ Base64URL.decode $ addBase64Padding encodedUnparsedPayload
payload <- eitherToMaybeT $ AB.parseOnly json' unparsedPayload
SignedRequestAlgorithm algo <- fromJson payload
guard (algo == "HMAC-SHA256")
hmacKey <- credsToHmacKey `liftM` lift getCreds
let expectedSignature = Cereal.encode $ hmac' hmacKey encodedUnparsedPayload
guard (signature `constTimeEq` 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 :: Credentials -> MacKey ctx SHA256
credsToHmacKey = MacKey . 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