module Facebook.Auth
( getAppAccessToken
, getUserAccessTokenStep1
, getUserAccessTokenStep2
, getUserLogoutUrl
, extendUserAccessToken
, RedirectUrl
, Permission
, unPermission
, hasExpired
, isValid
, parseSignedRequest
) where
import Control.Applicative
import Control.Monad (guard, join, liftM, mzero)
import Control.Monad.IO.Class (MonadIO(liftIO))
import Control.Monad.Trans.Control (MonadBaseControl)
import Control.Monad.Trans.Maybe (MaybeT(..))
import Crypto.Classes (constTimeEq)
import Crypto.Hash.SHA256 (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.String (IsString(..))
import qualified Control.Exception.Lifted as E
import qualified Data.Aeson as AE
import qualified Data.Aeson.Types as AE
import qualified Data.Attoparsec.Char8 as AB
import qualified Data.Attoparsec.Text as A
import qualified Data.ByteString as B
import qualified Data.ByteString.Base64.URL as Base64URL
import qualified Data.ByteString.Char8 as B8
import qualified Data.Conduit as C
import qualified Data.Conduit.Attoparsec as C
import qualified Data.Conduit.Text as CT
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.Conduit as H
import qualified Network.HTTP.Types as HT
import Facebook.Types
import Facebook.Base
import Facebook.Monad
getAppAccessToken :: (C.MonadResource m, MonadBaseControl IO 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
lift $
H.responseBody response C.$$+-
CT.decode CT.utf8 C.=$
C.sinkParser (AppAccessToken <$ A.string "access_token="
<*> A.takeText)
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/dialog/oauth?client_id="
Beta -> "https://www.beta.facebook.com/dialog/oauth?client_id="
in T.concat $ urlBase
: appId creds
: "&redirect_uri="
: redirectUrl
: (case perms of
[] -> []
_ -> "&scope=" : L.intersperse "," (map unPermission perms)
)
getUserAccessTokenStep2 :: (MonadBaseControl IO m, C.MonadResource 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)]
preToken <- fmap (userAccessTokenParser now) . asBS =<< fbhttp req
userInfo <- asJson =<< fbhttp =<< fbreq "/me" (Just preToken) [("fields", "id")]
case (AE.parseEither (.: "id") userInfo, preToken) of
(Left str, _) ->
E.throw $ FbLibraryException $ T.concat
[ "getUserAccessTokenStep2: failed to get the UserId ("
, T.pack str, ")" ]
(Right (userId :: UserId), UserAccessToken _ d e) ->
return (UserAccessToken userId d e)
_ -> 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.throw $ FacebookException errorType (t errorDescr)
userAccessTokenParser :: UTCTime
-> B.ByteString
-> UserAccessToken
userAccessTokenParser now bs =
let q = HT.parseQuery bs; lookup' a = join (lookup a q)
in case (,) <$> lookup' "access_token" <*> lookup' "expires" of
(Just (tok, expt)) -> UserAccessToken userId (dec tok) (toExpire expt)
_ -> error $ "userAccessTokenParser: failed to parse " ++ show bs
where toExpire expt = let i = read (B8.unpack expt) :: Int
in addUTCTime (fromIntegral i) now
userId = error "userAccessTokenParser: never here"
dec = TE.decodeUtf8With TE.lenientDecode
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
}
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 :: (MonadBaseControl IO m, C.MonadResource 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 :: (MonadBaseControl IO m, C.MonadResource 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_) ]
eresponse <- E.try (asBS =<< fbhttp req)
case eresponse of
Right response -> do
now <- liftIO getCurrentTime
return (Right $ case userAccessTokenParser now response of
UserAccessToken _ data' expires' ->
UserAccessToken uid data' expires')
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