fb 0.1 → 0.2

raw patch · 5 files changed

+141/−47 lines, 5 filesdep ~http-conduitdep ~timePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: http-conduit, time

API changes (from Hackage documentation)

Files

• fb.cabal +17/−13
• src/Facebook.hs +2/−0
• src/Facebook/Auth.hs +70/−16
• src/Facebook/Base.hs +32/−12
• tests/runtests.hs +20/−6

@@ -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

@@ -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

@@ -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 <https://developers.facebook.com/blog/post/500/>.+                   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+-- <https://developers.facebook.com/docs/offline-access-deprecation/>).+-- 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: ":)

@@ -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

@@ -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)