module Facebook.Auth
( getAppAccessToken
, getUserAccessTokenStep1
, getUserAccessTokenStep2
, RedirectUrl
, Permission
, hasExpired
, isValid
) where
import Control.Applicative
import Control.Monad.IO.Class (MonadIO(liftIO))
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Time (getCurrentTime, addUTCTime)
import Data.String (IsString(..))
import qualified Control.Exception.Lifted as E
import qualified Data.Attoparsec.Char8 as A
import qualified Data.Conduit as C
import qualified Data.Conduit.Attoparsec as C
import qualified Data.List as L
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.Base
getAppAccessToken :: C.ResourceIO m =>
Credentials
-> H.Manager
-> C.ResourceT m (AccessToken App)
getAppAccessToken creds manager = do
let req = fbreq "/oauth/access_token" Nothing $
tsq creds [("grant_type", "client_credentials")]
response <- fbhttp req manager
H.responseBody response C.$$
C.sinkParser (AccessToken <$ A.string "access_token="
<*> A.takeByteString
<*> pure Nothing)
getUserAccessTokenStep1 :: Credentials
-> RedirectUrl
-> [Permission]
-> Text
getUserAccessTokenStep1 creds redirectUrl perms =
T.concat $ "https://www.facebook.com/dialog/oauth?client_id="
: TE.decodeUtf8 (clientId creds)
: "&redirect_uri="
: redirectUrl
: (case perms of
[] -> []
_ -> "&scope=" : L.intersperse "," (map unPermission perms)
)
getUserAccessTokenStep2 :: C.ResourceIO m =>
Credentials
-> RedirectUrl
-> HT.SimpleQuery
-> H.Manager
-> C.ResourceT m (AccessToken User)
getUserAccessTokenStep2 creds redirectUrl query manager =
case query of
[code@("code", _)] -> do
now <- liftIO getCurrentTime
let req = fbreq "/oauth/access_token" Nothing $
tsq creds [code, ("redirect_uri", TE.encodeUtf8 redirectUrl)]
let toExpire i = Just (addUTCTime (fromIntegral (i :: Int)) now)
response <- fbhttp req manager
H.responseBody response C.$$
C.sinkParser (AccessToken <$ A.string "access_token="
<*> A.takeWhile (/= '?')
<* A.string "&expires="
<*> (toExpire <$> A.decimal)
<* A.endOfInput)
_ -> 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)
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 kind -> m Bool
hasExpired token =
case accessTokenExpires token of
Nothing -> return False
Just expTime -> (>= expTime) <$> liftIO getCurrentTime
isValid :: C.ResourceIO m =>
AccessToken kind
-> H.Manager
-> C.ResourceT m Bool
isValid token manager = do
expired <- hasExpired token
if expired
then return False
else httpCheck (fbreq "/19292868552" (Just token) []) manager