diff --git a/fb.cabal b/fb.cabal --- a/fb.cabal +++ b/fb.cabal @@ -1,5 +1,5 @@ name: fb -version: 0.1 +version: 0.2 license: BSD3 license-file: LICENSE author: Felipe Lessa @@ -43,22 +43,25 @@ Facebook.Base Facebook.Auth build-depends: - base >= 4 && < 5 - , lifted-base >= 0.1 && < 0.2 - , bytestring >= 0.9 && < 0.10 - , text >= 0.11 && < 0.12 - , transformers >= 0.2 && < 0.3 - , conduit >= 0.0 && < 0.2 + base >= 4 && < 5 + , lifted-base >= 0.1 && < 0.2 + , bytestring >= 0.9 && < 0.10 + , text >= 0.11 && < 0.12 + , transformers >= 0.2 && < 0.3 + , conduit >= 0.0 && < 0.2 , http-types - , http-conduit >= 1.1 && < 1.2 - , attoparsec >= 0.10 && < 0.11 - , attoparsec-conduit >= 0.0 && < 0.1 - , aeson >= 0.5 && < 0.6 - , time >= 1.2 && < 1.5 + , http-conduit >= 1.1.2.2 && < 1.2 + , attoparsec >= 0.10 && < 0.11 + , attoparsec-conduit >= 0.0 && < 0.1 + , aeson >= 0.5 && < 0.6 + , time >= 1.2 && < 1.5 extensions: DeriveDataTypeable EmptyDataDecls OverloadedStrings + GADTs + StandaloneDeriving + ScopedTypeVariables test-suite runtests @@ -70,7 +73,7 @@ -- Library dependencies used on the tests. No need to -- specify versions since they'll use the same as above. base, lifted-base, transformers, bytestring, conduit, - http-conduit + http-conduit, time -- Test-only dependencies , HUnit @@ -78,3 +81,4 @@ , fb extensions: TypeFamilies + ScopedTypeVariables diff --git a/src/Facebook.hs b/src/Facebook.hs --- a/src/Facebook.hs +++ b/src/Facebook.hs @@ -4,6 +4,7 @@ Credentials(..) -- ** Access token , AccessToken(..) + , AccessTokenData , hasExpired , isValid -- ** App access token @@ -15,6 +16,7 @@ , Permission , getUserAccessTokenStep1 , getUserAccessTokenStep2 + , extendUserAccessToken -- * Exceptions , FacebookException(..) ) where diff --git a/src/Facebook/Auth.hs b/src/Facebook/Auth.hs --- a/src/Facebook/Auth.hs +++ b/src/Facebook/Auth.hs @@ -2,6 +2,7 @@ ( getAppAccessToken , getUserAccessTokenStep1 , getUserAccessTokenStep2 + , extendUserAccessToken , RedirectUrl , Permission , hasExpired @@ -12,7 +13,7 @@ import Control.Monad.IO.Class (MonadIO(liftIO)) import Data.Maybe (fromMaybe) import Data.Text (Text) -import Data.Time (getCurrentTime, addUTCTime) +import Data.Time (getCurrentTime, addUTCTime, UTCTime) import Data.String (IsString(..)) import qualified Control.Exception.Lifted as E @@ -40,9 +41,8 @@ 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) + C.sinkParser (AppAccessToken <$ A.string "access_token=" + <*> A.takeByteString) -- | The first step to get an user access token. Returns the @@ -84,14 +84,8 @@ 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) + H.responseBody response C.$$ C.sinkParser (userAccessTokenParser now) _ -> let [error_, errorReason, errorDescr] = map (fromMaybe "" . flip lookup query) ["error", "error_reason", "error_description"] @@ -100,6 +94,19 @@ in E.throw $ FacebookException errorType (t errorDescr) +-- | Attoparsec parser for user access tokens returned by +-- Facebook as a query string. +userAccessTokenParser :: UTCTime -- 'getCurrentTime' + -> A.Parser (AccessToken User) +userAccessTokenParser now = + UserAccessToken <$ A.string "access_token=" + <*> A.takeWhile (/= '?') + <* A.string "&expires=" + <*> (toExpire <$> A.decimal) + <* A.endOfInput + where toExpire i = addUTCTime (fromIntegral (i :: Int)) now + + -- | URL where the user is redirected to after Facebook -- authenticates the user authorizes your application. This URL -- should be inside the domain registered for your Facebook @@ -150,8 +157,55 @@ expired <- hasExpired token if expired then return False - else httpCheck (fbreq "/19292868552" (Just token) []) manager - -- This is Facebook's own page. While using an access token - -- to access it shouldn't do much difference on most cases, - -- when the access token is invalid a "400 Bad Request" - -- status code is returned regardless. + else + let page = case token of + UserAccessToken _ _ -> "/me" + -- Documented way of checking if the token is valid, + -- see . + AppAccessToken _ -> "/19292868552" + -- This is Facebook's page on Facebook. While + -- this behaviour is undocumented, it will + -- return a "400 Bad Request" status code + -- whenever the access token is invalid. It + -- will actually work with user access tokens, + -- too, but they have another, better way of + -- being checked. + in httpCheck (fbreq page (Just token) []) manager + + +-- | Extend the expiration time of an user access token (see +-- ). +-- Returns @Left exc@ if there is an error while extending, or +-- @Right token@ with the new user access token (which could have +-- the same data and expiration time as before, but you can't +-- assume this). Note that expired access tokens can't be +-- extended, only valid tokens. +extendUserAccessToken :: C.ResourceIO m => + Credentials + -> AccessToken User + -> H.Manager + -> C.ResourceT m (Either FacebookException (AccessToken User)) +extendUserAccessToken creds token@(UserAccessToken data_ _) manager + = do expired <- hasExpired token + if expired then return (Left hasExpiredExc) else tryToExtend + where + tryToExtend = do + let req = fbreq "/oauth/access_token" Nothing $ + tsq creds [ ("grant_type", "fb_exchange_token") + , ("fb_exchange_token", data_) ] + eresponse <- E.try (fbhttp req manager) + case eresponse of + Right response -> do + now <- liftIO getCurrentTime + either (Left . couldn'tParseExc) Right <$> + E.try (H.responseBody response C.$$ + C.sinkParser (userAccessTokenParser now)) + Left exc -> return (Left exc) + + hasExpiredExc = + mkExc [ "the user access token has already expired, " + , "so I'll not try to extend it." ] + couldn'tParseExc (exc :: C.ParseError) = + mkExc [ "could not parse Facebook's response (" + , T.pack (show exc), ")" ] + mkExc = FbLibraryException . T.concat . ("extendUserAccessToken: ":) diff --git a/src/Facebook/Base.hs b/src/Facebook/Base.hs --- a/src/Facebook/Base.hs +++ b/src/Facebook/Base.hs @@ -1,6 +1,9 @@ module Facebook.Base ( Credentials(..) , AccessToken(..) + , AccessTokenData + , accessTokenData + , accessTokenExpires , User , App , fbreq @@ -17,7 +20,7 @@ import Data.ByteString.Char8 (ByteString) import Data.Text (Text) import Data.Time (UTCTime) -import Data.Typeable (Typeable) +import Data.Typeable (Typeable, Typeable1) import Network.HTTP.Types (Ascii) import qualified Control.Exception.Lifted as E @@ -55,23 +58,37 @@ -- -- These access tokens are distinguished by the phantom type on -- 'AccessToken', which can be 'User' or 'App'. -data AccessToken kind = - AccessToken { accessTokenData :: Ascii - -- ^ The access token itself. - , accessTokenExpires :: Maybe UTCTime - -- ^ Expire time of the access token. It may - -- never expire, in which case it will be - -- @Nothing@. - } - deriving (Eq, Ord, Show, Typeable) +data AccessToken kind where + UserAccessToken :: AccessTokenData -> UTCTime -> AccessToken User + AppAccessToken :: AccessTokenData -> AccessToken App +deriving instance Eq (AccessToken kind) +deriving instance Ord (AccessToken kind) +deriving instance Show (AccessToken kind) +deriving instance Typeable1 AccessToken + +-- | The access token data that is passed to Facebook's API +-- calls. +type AccessTokenData = Ascii + +-- | Get the access token data. +accessTokenData :: AccessToken kind -> AccessTokenData +accessTokenData (UserAccessToken d _) = d +accessTokenData (AppAccessToken d) = d + +-- | Expire time of an access token. It may never expire, in +-- which case it will be @Nothing@. +accessTokenExpires :: AccessToken kind -> Maybe UTCTime +accessTokenExpires (UserAccessToken _ expt) = Just expt +accessTokenExpires (AppAccessToken _) = Nothing + -- | Phantom type used mark an 'AccessToken' as an user access -- token. -data User +data User deriving (Typeable) -- | Phantom type used mark an 'AccessToken' as an app access -- token. -data App +data App deriving (Typeable) -- | A plain 'H.Request' to a Facebook API. Use this instead of @@ -127,9 +144,12 @@ -- | An exception that may be thrown by functions on this -- package. Includes any information provided by Facebook. data FacebookException = + -- | An exception coming from Facebook. FacebookException { fbeType :: Text , fbeMessage :: Text } + -- | An exception coming from the @fb@ package's code. + | FbLibraryException { fbeMessage :: Text } deriving (Eq, Ord, Show, Typeable) instance A.FromJSON FacebookException where diff --git a/tests/runtests.hs b/tests/runtests.hs --- a/tests/runtests.hs +++ b/tests/runtests.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} import Control.Monad.IO.Class (MonadIO(liftIO)) +import Data.Time (parseTime) import System.Environment (getEnv) import System.Exit (exitFailure) import System.IO.Error (isDoesNotExistError) @@ -52,7 +53,18 @@ invalidCredentials :: FB.Credentials invalidCredentials = FB.Credentials "not" "valid" +invalidUserAccessToken :: FB.AccessToken FB.User +invalidUserAccessToken = FB.UserAccessToken "invalid" farInTheFuture + where + Just farInTheFuture = parseTime (error "farInTheFuture") "%Y" "3000" + -- It's actually important to use 'farInTheFuture' since we + -- don't want any tests rejecting this invalid user access + -- token before even giving it to Facebook. +invalidAppAccessToken :: FB.AccessToken FB.App +invalidAppAccessToken = FB.AppAccessToken "invalid" + + main :: IO () main = H.withManager $ \manager -> liftIO $ do creds <- getCredentials @@ -64,13 +76,15 @@ liftIO (valid @?= True) it "throws a FacebookException on invalid credentials" $ do ret <- E.try $ FB.getAppAccessToken invalidCredentials manager - case ret of - Right token -> fail $ show token - Left (FB.FacebookException {}) -> return () + case ret of + Right token -> fail $ show token + Left (_ :: FB.FacebookException) -> return () describe "isValid" $ do - it "returns False on a clearly invalid access token" $ do - let token = FB.AccessToken "not valid" Nothing - valid <- FB.isValid token manager + it "returns False on a clearly invalid user access token" $ do + valid <- FB.isValid invalidUserAccessToken manager + liftIO (valid @?= False) + it "returns False on a clearly invalid app access token" $ do + valid <- FB.isValid invalidAppAccessToken manager liftIO (valid @?= False)