diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,23 @@ +# Version 2.0.0 + +* Remove following dependency: + - base16-bytestring + - base64-bytestring + - cereal + - crypto-api + - cryptohash + - cryptohash-cryptoapi + - old-locale +* Introduce new dependency: + - cryptonite + - memory +* Add new function setApiVersion +* Add Graph API version parameter. Avoid hardcoded `v2.8`. +* Expose setApiVersion and getApiVersion function +* Default API endpoint updated to `v3.2` +* Add appsecret_proof verification. +* Fix appsecret_proof verification encoding. + # Version 1.2.1 * Make it work for ghc-8.4. See [#3](https://github.com/psibi/fb/issues/3) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -30,6 +30,7 @@ { appName = "Your_APP_Name" , appId = "your_app_id" , appSecret = "xxxxxxxxxxxxxxxxx" + , appSecretProof = False } main :: IO () diff --git a/fb.cabal b/fb.cabal --- a/fb.cabal +++ b/fb.cabal @@ -1,11 +1,13 @@ --- This file has been generated from package.yaml by hpack version 0.21.2. +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.2. -- -- see: https://github.com/sol/hpack -- --- hash: 1f1f3544be4d2d1dbdab5e0286e45bc861f216f4b24d04227e926c4cc51ab272 +-- hash: 1165a61ce7ffe062813385420ff4c80c2e0089e64221cfd0d045a3cf1654b8a8 name: fb -version: 1.2.1 +version: 2.0.0 synopsis: Bindings to Facebook's API. description: This package exports bindings to Facebook's APIs (see ). Does not have any external @@ -29,14 +31,12 @@ license: BSD3 license-file: LICENSE build-type: Simple -cabal-version: >= 1.10 - extra-source-files: - CHANGELOG.md - example.hs - README.md tests/Main.hs tests/tryIt.hs + example.hs + README.md + CHANGELOG.md source-repository head type: git @@ -72,27 +72,22 @@ ghc-options: -Wall build-depends: aeson >=0.8.0.2 - , attoparsec >=0.10.4 && <0.14 + , attoparsec >=0.10.4 , base >=4 && <5 - , base16-bytestring >=0.1 - , base64-bytestring >=0.1.1 - , bytestring >=0.9 && <0.11 - , cereal >=0.3 && <0.6 + , bytestring >=0.9 , conduit >=1.3.0 , conduit-extra >=1.3.0 - , crypto-api >=0.11 && <0.14 - , cryptohash >=0.7 - , cryptohash-cryptoapi ==0.1.* + , cryptonite , data-default , http-client >=0.4.30 , http-conduit >=2.3.0 , http-types + , memory , monad-logger >=0.3.28 - , old-locale , resourcet >=1.2.0 - , text >=0.11 && <1.3 + , text >=0.11 , time >=1.4 - , transformers >=0.2 && <0.6 + , transformers >=0.2 , transformers-base , unliftio , unliftio-core diff --git a/src/Facebook.hs b/src/Facebook.hs --- a/src/Facebook.hs +++ b/src/Facebook.hs @@ -1,7 +1,7 @@ module Facebook - ( - -- * @FacebookT@ monad transformer - FacebookT + ( + -- * @FacebookT@ monad transformer + FacebookT , runFacebookT , runNoAuthFacebookT , mapFacebookT @@ -17,8 +17,11 @@ , UserAccessToken , AppAccessToken , AccessTokenData + , ApiVersion , hasExpired , isValid + , setApiVersion + , getApiVersion -- ** App access token , AppKind , getAppAccessToken @@ -34,6 +37,8 @@ , DebugToken(..) -- ** Signed requests , parseSignedRequest + , addAppSecretProof + , makeAppSecretProof -- * Facebook's Graph API -- ** User , User(..) @@ -126,18 +131,18 @@ , unPermission ) where -import Facebook.Types -import Facebook.Monad -import Facebook.Base import Facebook.Auth -import Facebook.Pager +import Facebook.Base +import Facebook.FQL import Facebook.Graph -import Facebook.Object.Page -import Facebook.Object.User +import Facebook.Monad import Facebook.Object.Action import Facebook.Object.Checkin -import Facebook.Object.Order import Facebook.Object.FriendList +import Facebook.Object.Order +import Facebook.Object.Page +import Facebook.Object.User +import Facebook.Pager import Facebook.RealTime -import Facebook.FQL import Facebook.TestUsers +import Facebook.Types diff --git a/src/Facebook/Auth.hs b/src/Facebook/Auth.hs --- a/src/Facebook/Auth.hs +++ b/src/Facebook/Auth.hs @@ -22,58 +22,56 @@ #if __GLASGOW_HASKELL__ <= 784 import Control.Applicative #endif -import Control.Monad (guard, liftM, mzero) -import Control.Monad.IO.Class (MonadIO(liftIO)) +import Control.Monad (guard, mzero) +import Control.Monad.IO.Class 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 Crypto.Hash.Algorithms (SHA256) +import Crypto.MAC.HMAC (HMAC(..), hmac) +import Data.Aeson ((.:)) import qualified Data.Aeson as AE +import Data.Aeson.Parser (json') import qualified Data.Aeson.Types as AE import qualified Data.Attoparsec.ByteString.Char8 as AB +import Data.ByteArray (ScrubbedBytes, convert) +import Data.ByteArray.Encoding (Base(..), convertFromBase) 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 Data.Maybe (fromMaybe) +import Data.String (IsString(..)) +import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.Text.Encoding.Error as TE +import Data.Time (UTCTime, addUTCTime, getCurrentTime) +import Data.Typeable (Typeable) import qualified Network.HTTP.Types as HT +import qualified UnliftIO.Exception as E -import Facebook.Types import Facebook.Base import Facebook.Monad +import Facebook.Types -- | Get an app access token from Facebook using your -- credentials. -- Ref: https://developers.facebook.com/docs/facebook-login/manually-build-a-login-flow -getAppAccessToken - :: (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m) +getAppAccessToken :: + (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m, MonadIO 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)) + 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 = @@ -88,29 +86,31 @@ -- Facebook URL you should redirect you user to. Facebook will -- authenticate the user, authorize your app and then redirect -- the user back into the provider 'RedirectUrl'. -getUserAccessTokenStep1 - :: Monad m - => RedirectUrl -> [Permission] -> FacebookT Auth m Text +getUserAccessTokenStep1 :: + (Monad m, MonadIO 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)) + apiVersion <- getApiVersion + 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)) -- | The second step to get an user access token. If the user is -- successfully authenticate and they authorize your application, @@ -119,8 +119,8 @@ -- request query parameters passed to your 'RedirectUrl' and give -- to this function that will complete the user authentication -- flow and give you an @'UserAccessToken'@. -getUserAccessTokenStep2 - :: (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m) +getUserAccessTokenStep2 :: + (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m, MonadIO m) => RedirectUrl -- ^ Should be exactly the same -- as in 'getUserAccessTokenStep1'. -> [Argument] -- ^ Query parameters. @@ -130,23 +130,24 @@ [code@("code", _)] -> runResourceInFb $ -- Get the access token data through Facebook's OAuth. - 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 + 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 -- Get user's ID throught Facebook's graph. - userResponse <- - fbhttp =<< - fbreq - "/me" - (Just (UserAccessToken "invalid id" token expire)) - [("fields", "id")] - (userId :: UserId) <- asJson userResponse - return $ UserAccessToken userId token expire + 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 @@ -154,13 +155,13 @@ ["error", "error_reason", "error_description"] errorType = T.concat [t error_, " (", t errorReason, ")"] t = TE.decodeUtf8With TE.lenientDecode - in E.throwIO $ FacebookException errorType (t errorDescr) + in E.throwIO $ FacebookException errorType (t errorDescr) -- | Attoparsec parser for user access tokens returned by -- Facebook as a query string. Returns an user access token with -- a broken 'UserId'. -userAccessTokenParser - :: UTCTime -- ^ 'getCurrentTime' +userAccessTokenParser :: + UTCTime -- ^ 'getCurrentTime' -> AE.Value -> (AccessTokenData, UTCTime) userAccessTokenParser now val = @@ -191,8 +192,8 @@ -- to prevent this bug, we suggest that you use 'isValid' before -- redirecting the user to the URL provided by 'getUserLogoutUrl' -- since this function doesn't do any validity checks. -getUserLogoutUrl - :: Monad m +getUserLogoutUrl :: + Monad m => UserAccessToken -- ^ The user's access token. -> RedirectUrl @@ -203,19 +204,18 @@ -- @https:\/\/www.beta.facebook.com\/@ when -- using the beta tier). 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_)) - ] + 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_)) + ] -- | URL where the user is redirected to after Facebook -- authenticates the user authorizes your application. This URL @@ -236,12 +236,14 @@ -- > -- > perms :: [Permission] -- > perms = ["user_about_me", "email", "offline_access"] -newtype Permission = Permission - { unPermission :: Text +newtype Permission = + Permission + { unPermission :: Text -- ^ Retrieves the 'Text' back from a 'Permission'. Most of -- the time you won't need to use this function, but you may -- need it if you're a library author. - } deriving (Eq, Ord) + } + deriving (Eq, Ord) instance Show Permission where show = show . unPermission @@ -250,9 +252,7 @@ fromString = Permission . fromString -- | @True@ if the access token has expired, otherwise @False@. -hasExpired - :: (Functor m, MonadIO m) - => AccessToken anyKind -> m Bool +hasExpired :: (Functor m, MonadIO m) => AccessToken anyKind -> m Bool hasExpired token = case accessTokenExpires token of Nothing -> return False @@ -263,9 +263,10 @@ -- access token may not be valid as well. For example, in the -- case of an user access token, they may have changed their -- password, logged out from Facebook or blocked your app. -isValid - :: (R.MonadResource m, R.MonadUnliftIO m) - => AccessToken anyKind -> FacebookT anyAuth m Bool +isValid :: + (R.MonadResource m, R.MonadUnliftIO m) + => AccessToken anyKind + -> FacebookT anyAuth m Bool isValid token = do expired <- hasExpired token if expired @@ -283,7 +284,7 @@ -- will actually work with user access tokens, -- too, but they have another, better way of -- being checked. - in httpCheck =<< fbreq page (Just token) [] + in httpCheck =<< fbreq page (Just token) [] -- | Extend the expiration time of an user access token (see -- , @@ -296,8 +297,8 @@ -- 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 - :: (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m) +extendUserAccessToken :: + (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m, MonadIO m) => UserAccessToken -> FacebookT Auth m (Either FacebookException UserAccessToken) extendUserAccessToken token@(UserAccessToken uid data_ _) = do @@ -307,23 +308,23 @@ 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) + 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, " @@ -335,38 +336,41 @@ -- (), -- verifies its authencity and integrity using the HMAC and -- decodes its JSON object. -parseSignedRequest - :: (AE.FromJSON a, Monad m) +parseSignedRequest :: + (AE.FromJSON a, Monad m, MonadIO m) => B8.ByteString -- ^ Encoded Facebook signed request -> FacebookT Auth m (Maybe a) parseSignedRequest signedRequest = runMaybeT $ -- Split, decode and JSON-parse - 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 + do + let (encodedSignature, encodedUnparsedPayloadWithDot) = + B8.break (== '.') signedRequest + ('.', encodedUnparsedPayload) <- + MaybeT $ return (B8.uncons encodedUnparsedPayloadWithDot) + signature <- + eitherToMaybeT $ + convertFromBase Base64 $ addBase64Padding encodedSignature + unparsedPayload <- + eitherToMaybeT $ + convertFromBase Base64 $ addBase64Padding encodedUnparsedPayload + payload <- eitherToMaybeT $ AB.parseOnly json' unparsedPayload -- Verify signature - SignedRequestAlgorithm algo <- fromJson payload - guard (algo == "HMAC-SHA256") - hmacKey <- credsToHmacKey `liftM` lift getCreds - let expectedSignature = Cereal.encode $ hmac' hmacKey encodedUnparsedPayload - guard (signature `constTimeEq` expectedSignature) + SignedRequestAlgorithm algo <- fromJson payload + guard (algo == "HMAC-SHA256") + creds <- lift getCreds + let hmacKey = credsToHmacKey creds + expectedSignature = hmac hmacKey encodedUnparsedPayload :: HMAC SHA256 + guard ((signature :: ScrubbedBytes) == (convert expectedSignature)) -- Parse user data type - fromJson payload + fromJson payload where - eitherToMaybeT - :: Monad m - => Either a b -> MaybeT m b + 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 :: (AE.FromJSON a, Monad m) => AE.Value -> MaybeT m a fromJson = eitherToMaybeT . AE.parseEither AE.parseJSON - credsToHmacKey :: Credentials -> MacKey ctx SHA256 - credsToHmacKey = MacKey . appSecretBS + -- credsToHmacKey :: Credentials -> MacKey ctx SHA256 + credsToHmacKey = appSecretBS newtype SignedRequestAlgorithm = SignedRequestAlgorithm Text @@ -393,8 +397,8 @@ drem = B.length bs `mod` 4 -- | Get detailed information about an access token. -debugToken - :: (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m) +debugToken :: + (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m) => AppAccessToken -- ^ Your app access token. -> AccessTokenData -- ^ The access token you want to debug. -> FacebookT Auth m DebugToken @@ -406,32 +410,31 @@ let muserToken = UserAccessToken <$> dtUserId ret <*> return userTokenData <*> dtExpiresAt ret - return - ret - { dtAccessToken = muserToken - } + return ret {dtAccessToken = muserToken} -- | Helper used in 'debugToken'. Unfortunately, we can't use 'Pager' here. -data Undata a = Undata - { undata :: a - } +data Undata a = + Undata + { undata :: a + } -instance AE.FromJSON a => - AE.FromJSON (Undata a) where +instance AE.FromJSON a => AE.FromJSON (Undata a) where parseJSON (AE.Object v) = Undata <$> v AE..: "data" parseJSON _ = mzero -- | Detailed information about an access token (cf. 'debugToken'). -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) +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) -- | Note: this instance always sets 'dtAccessToken' to -- 'Nothing', but 'debugToken' will update this field before diff --git a/src/Facebook/Base.hs b/src/Facebook/Base.hs --- a/src/Facebook/Base.hs +++ b/src/Facebook/Base.hs @@ -2,6 +2,7 @@ {-#LANGUAGE FlexibleContexts#-} {-#LANGUAGE OverloadedStrings#-} {-#LANGUAGE CPP#-} + module Facebook.Base ( fbreq , ToSimpleQuery(..) @@ -12,15 +13,12 @@ , fbhttp , fbhttpHelper , httpCheck - , apiVersion ) where import Control.Applicative -import Control.Monad (mzero) import Control.Monad.IO.Class (MonadIO) import Data.ByteString.Char8 (ByteString) import Data.Text (Text) -import Data.Typeable (Typeable) import qualified UnliftIO.Exception as E import Control.Monad.Trans.Class (MonadTrans) @@ -47,17 +45,23 @@ import Facebook.Types import Facebook.Monad -apiVersion :: Text -apiVersion = "v2.8" - -- | A plain 'H.Request' to a Facebook API. Use this instead of -- 'def' when creating new 'H.Request'@s@ for Facebook. -fbreq :: Monad m => - Text -- ^ Path. Should start from "/". +fbreq :: MonadIO m + => Text -- ^ Path. Should start from "/". -> Maybe (AccessToken anyKind) -- ^ Access token. -> HT.SimpleQuery -- ^ Parameters. -> FacebookT anyAuth m H.Request -fbreq path mtoken query = +fbreq path mtoken query = do + + apiVersion <- getApiVersion + creds <- getMCreds + + let appSecretProofAdder = case creds of + Just c@( Credentials _ _ _ True ) -> addAppSecretProof c + _ -> const id + + withTier $ \tier -> let host = case tier of Production -> "graph.facebook.com" @@ -68,8 +72,8 @@ , H.path = TE.encodeUtf8 ("/" <> apiVersion <> path) , H.redirectCount = 3 , H.queryString = - HT.renderSimpleQuery False $ - maybe id tsq mtoken query + HT.renderSimpleQuery False + $ appSecretProofAdder mtoken $ maybe id tsq mtoken query #if MIN_VERSION_http_client(0,5,0) , H.responseTimeout = H.responseTimeoutMicro 120000000 -- 2 minutes #else @@ -126,26 +130,6 @@ H.Response (C.ConduitT () ByteString m ()) -> FacebookT anyAuth m ByteString asBS response = lift $ C.runConduit $ H.responseBody response .| fmap B.concat CL.consume - - --- | 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, Read, Typeable) - -instance A.FromJSON FacebookException where - parseJSON (A.Object v) = - FacebookException <$> v A..: "type" - <*> v A..: "message" - parseJSON _ = mzero - -instance E.Exception FacebookException where -- | Same as 'H.http', but tries to parse errors and throw diff --git a/src/Facebook/Monad.hs b/src/Facebook/Monad.hs --- a/src/Facebook/Monad.hs +++ b/src/Facebook/Monad.hs @@ -8,6 +8,7 @@ {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} module Facebook.Monad ( FacebookT @@ -18,69 +19,86 @@ , runNoAuthFacebookT , beta_runFacebookT , beta_runNoAuthFacebookT + , getApiVersion , getCreds + , getMCreds , getManager , getTier , withTier + , addAppSecretProof + , makeAppSecretProof , runResourceInFb , mapFacebookT + , setApiVersion -- * Re-export , lift ) where -import Control.Applicative (Applicative, Alternative) +import Control.Applicative (Alternative, Applicative) import Control.Monad (MonadPlus, liftM) import Control.Monad.Base (MonadBase(..)) +import Control.Monad.Fail (MonadFail(..)) import Control.Monad.Fix (MonadFix) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Logger (MonadLogger(..)) import Control.Monad.Trans.Class (MonadTrans(lift)) -import UnliftIO import Control.Monad.Trans.Reader (ReaderT(..), ask, mapReaderT) -import Data.Typeable (Typeable) import qualified Control.Monad.Trans.Resource as R - -import qualified Network.HTTP.Conduit as H - +import Crypto.Hash.Algorithms (SHA256) +import Crypto.MAC.HMAC (HMAC(..), hmac) +import Data.ByteArray.Encoding (Base(..), convertToBase) +import qualified Data.Text.Encoding as TE +import Data.Typeable (Typeable) import Facebook.Types +import qualified Network.HTTP.Conduit as H +import qualified Network.HTTP.Types as HT +import UnliftIO +import qualified UnliftIO.Exception as E -- | @FacebookT auth m a@ is this library's monad transformer. -- Contains information needed to issue commands and queries to -- Facebook. The phantom type @auth@ may be either 'Auth' (you -- have supplied your 'Credentials') or 'NoAuth' (you have not -- supplied any 'Credentials'). -newtype FacebookT auth m a = F - { unF :: ReaderT FbData m a -- FbData -> m a - } deriving (Functor, Applicative, Alternative, Monad, MonadFix, MonadPlus, MonadIO, MonadTrans, R.MonadThrow) +newtype FacebookT auth m a = + F + { unF :: ReaderT FbData m a -- FbData -> m a + } + deriving ( Functor + , Applicative + , Alternative + , Monad + , MonadFix + , MonadPlus + , MonadIO + , MonadTrans + , R.MonadThrow + , MonadFail + ) deriving instance (R.MonadResource m, MonadBase IO m) => R.MonadResource (FacebookT auth m) -instance MonadBase b m => - MonadBase b (FacebookT auth m) where +instance MonadBase b m => MonadBase b (FacebookT auth m) where liftBase = lift . liftBase -- askUnliftIO = ReaderT $ \r -> -- withUnliftIO $ \u -> -- return (UnliftIO (unliftIO u . flip runReaderT r)) -instance (MonadIO m, MonadUnliftIO m) => - MonadUnliftIO (FacebookT auth m) where +instance (MonadIO m, MonadUnliftIO m) => MonadUnliftIO (FacebookT auth m) where askUnliftIO :: FacebookT auth m (UnliftIO (FacebookT auth m)) askUnliftIO = F - (ReaderT $ - \(r :: FbData) -> - withUnliftIO $ - \(u :: UnliftIO m) -> - return - (UnliftIO - (\(x :: FacebookT auth m a) -> - (unliftIO u ((flip runReaderT r) (unF x)))))) + (ReaderT $ \(r :: FbData) -> + withUnliftIO $ \(u :: UnliftIO m) -> + return + (UnliftIO + (\(x :: FacebookT auth m a) -> + (unliftIO u ((flip runReaderT r) (unF x)))))) -- | Since @fb-0.14.8@. -instance MonadLogger m => - MonadLogger (FacebookT auth m) where +instance MonadLogger m => MonadLogger (FacebookT auth m) where monadLoggerLog loc src lvl msg = lift (monadLoggerLog loc src lvl msg) -- | Phantom type stating that you have provided your @@ -95,11 +113,14 @@ deriving (Typeable) -- | Internal data kept inside 'FacebookT'. -data FbData = FbData - { fbdCreds :: Credentials -- ^ Can be 'undefined'! - , fbdManager :: !H.Manager - , fbdTier :: !FbTier - } deriving (Typeable) +data FbData = + FbData + { fbdCreds :: Maybe Credentials + , fbdManager :: !H.Manager + , fbdTier :: !FbTier + , fbdApiVersion :: IORef ApiVersion + } + deriving (Typeable) -- | Which Facebook tier should be used (see -- ). @@ -108,64 +129,114 @@ | Beta deriving (Eq, Ord, Show, Read, Enum, Typeable) +defaultApiVersion :: ApiVersion +defaultApiVersion = "v3.2" + +-- | Set the Graph API version. +setApiVersion :: (MonadIO m) => ApiVersion -> FacebookT anyAuth m () +setApiVersion apiVersion = do + ref <- fbdApiVersion `liftM` F ask + atomicModifyIORef' ref (\_ -> (apiVersion, ())) + return () + -- | Run a computation in the 'FacebookT' monad transformer with -- your credentials. -runFacebookT - :: Credentials -- ^ Your app's credentials. +runFacebookT :: + (MonadIO m) + => Credentials -- ^ Your app's credentials. -> H.Manager -- ^ Connection manager (see 'H.withManager'). -> FacebookT Auth m a -> m a -runFacebookT creds manager (F act) = - runReaderT act (FbData creds manager Production) +runFacebookT creds manager (F act) = do + apiref <- newIORef defaultApiVersion + runReaderT act (FbData (Just creds) manager Production apiref) +addAppSecretProof :: + Credentials + -> Maybe (AccessToken anykind) + -> HT.SimpleQuery + -> HT.SimpleQuery +addAppSecretProof (Credentials _ _ _ False) _ query = query +addAppSecretProof creds mtoken query = makeAppSecretProof creds mtoken <> query + +-- | Make an appsecret_proof in case the given credentials access token is a +-- user access token. +-- See: https://developers.facebook.com/docs/graph-api/securing-requests/#appsecret_proof +makeAppSecretProof :: + Credentials -- ^ App credentials + -> Maybe (AccessToken anyKind) -- ^ + -> HT.SimpleQuery +makeAppSecretProof creds (Just (UserAccessToken _ accessToken _)) = + [(TE.encodeUtf8 "appsecret_proof", proof)] + where + hmacData :: HMAC SHA256 + hmacData = hmac (appSecretBS creds) (TE.encodeUtf8 accessToken) + proof = convertToBase Base16 hmacData +makeAppSecretProof _ _ = [] + -- | Run a computation in the 'FacebookT' monad without -- credentials. -runNoAuthFacebookT :: H.Manager -> FacebookT NoAuth m a -> m a -runNoAuthFacebookT manager (F act) = - let creds = error "runNoAuthFacebookT: never here, serious bug" - in runReaderT act (FbData creds manager Production) +runNoAuthFacebookT :: + (MonadIO m) + => H.Manager -- ^ Connection manager (see 'H.withManager'). + -> FacebookT NoAuth m a + -> m a +runNoAuthFacebookT manager (F act) = do + apiref <- newIORef defaultApiVersion + runReaderT act (FbData Nothing manager Production apiref) -- | Same as 'runFacebookT', but uses Facebook's beta tier (see -- ). -beta_runFacebookT :: Credentials -> H.Manager -> FacebookT Auth m a -> m a -beta_runFacebookT creds manager (F act) = - runReaderT act (FbData creds manager Beta) +beta_runFacebookT :: + (MonadIO m) => Credentials -> H.Manager -> FacebookT Auth m a -> m a +beta_runFacebookT creds manager (F act) = do + apiref <- newIORef defaultApiVersion + runReaderT act (FbData (Just creds) manager Beta apiref) -- | Same as 'runNoAuthFacebookT', but uses Facebook's beta tier -- (see ). -beta_runNoAuthFacebookT :: H.Manager -> FacebookT NoAuth m a -> m a -beta_runNoAuthFacebookT manager (F act) = - let creds = error "beta_runNoAuthFacebookT: never here, serious bug" - in runReaderT act (FbData creds manager Beta) +beta_runNoAuthFacebookT :: + (MonadIO m) => H.Manager -> FacebookT NoAuth m a -> m a +beta_runNoAuthFacebookT manager (F act) = do + apiref <- newIORef defaultApiVersion + runReaderT act (FbData Nothing manager Beta apiref) +-- | Get the user's credentials, fail if they are not available. +getCreds :: (Monad m, MonadIO m) => FacebookT Auth m Credentials +getCreds = do + mCreds <- getMCreds + case mCreds of + Nothing -> E.throwIO $ FbLibraryException "Couldn't get credentials." + Just creds -> return creds + -- | Get the user's credentials. -getCreds - :: Monad m - => FacebookT Auth m Credentials -getCreds = fbdCreds `liftM` F ask +getMCreds :: Monad m => FacebookT anyAuth m (Maybe Credentials) +getMCreds = fbdCreds `liftM` F ask +-- | Get the Graph API version. +getApiVersion :: MonadIO m => FacebookT anyAuth m ApiVersion +getApiVersion = do + ref <- fbdApiVersion `liftM` F ask + apiVersion <- readIORef ref + pure apiVersion + -- | Get the 'H.Manager'. -getManager - :: Monad m - => FacebookT anyAuth m H.Manager +getManager :: Monad m => FacebookT anyAuth m H.Manager getManager = fbdManager `liftM` F ask -- | Get the 'FbTier'. -getTier - :: Monad m - => FacebookT anyAuth m FbTier +getTier :: Monad m => FacebookT anyAuth m FbTier getTier = fbdTier `liftM` F ask -- | Run a pure function that depends on the 'FbTier' being used. -withTier - :: Monad m - => (FbTier -> a) -> FacebookT anyAuth m a +withTier :: Monad m => (FbTier -> a) -> FacebookT anyAuth m a withTier = flip liftM getTier -- | Run a 'ResourceT' inside a 'FacebookT'. -runResourceInFb - :: (R.MonadResource m, MonadUnliftIO m) - => FacebookT anyAuth (R.ResourceT m) a -> FacebookT anyAuth m a +runResourceInFb :: + (R.MonadResource m, MonadUnliftIO m) + => FacebookT anyAuth (R.ResourceT m) a + -> FacebookT anyAuth m a runResourceInFb (F inner) = F $ ask >>= lift . R.runResourceT . runReaderT inner -- | Transform the computation inside a 'FacebookT'. diff --git a/src/Facebook/Object/Action.hs b/src/Facebook/Object/Action.hs --- a/src/Facebook/Object/Action.hs +++ b/src/Facebook/Object/Action.hs @@ -8,6 +8,7 @@ ) where import Control.Arrow (first) +import Control.Monad.IO.Class import Data.Function (on) import Data.String (IsString(..)) import Data.Text (Text) @@ -27,7 +28,7 @@ -- > , "when" #= now ] -- > token createAction - :: (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m) + :: (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m, MonadIO m) => Action -- ^ Action kind to be created. -> [Argument] -- ^ Arguments of the action. -> Maybe AppAccessToken diff --git a/src/Facebook/Object/Page.hs b/src/Facebook/Object/Page.hs --- a/src/Facebook/Object/Page.hs +++ b/src/Facebook/Object/Page.hs @@ -72,7 +72,7 @@ -> [Argument] -- ^ Arguments to be passed to Facebook -> Maybe AppAccessToken -- ^ Optional user access token -> FacebookT anyAuth m Page -getPage_ id_ = getObject $ ("/" <> idCode id_) +getPage_ id_ = getObject $ "/" <> idCode id_ -- | Search pages by keyword. The user access token is optional. searchPages diff --git a/src/Facebook/RealTime.hs b/src/Facebook/RealTime.hs --- a/src/Facebook/RealTime.hs +++ b/src/Facebook/RealTime.hs @@ -17,30 +17,31 @@ import Control.Applicative ((<$>), (<*>)) import Control.Monad (liftM, mzero, void) -import Crypto.Hash.CryptoAPI (SHA1) -import Data.ByteString.Char8 (ByteString) -import Data.Text (Text) -import Data.Text.Encoding (encodeUtf8) -import Data.Typeable (Typeable) - +import Control.Monad.IO.Class import qualified Control.Monad.Trans.Resource as R -import qualified Crypto.Classes as Crypto -import qualified Crypto.HMAC as Crypto +import Crypto.Hash.Algorithms (SHA1) +import Crypto.MAC.HMAC (HMAC(..), hmac) import qualified Data.Aeson as A -import qualified Data.ByteString.Base16 as Base16 +import Data.ByteArray (ScrubbedBytes, convert) +import Data.ByteArray.Encoding (Base(..), convertToBase) +import qualified Data.ByteString as B +import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.Conduit as C import qualified Data.Conduit.List as CL +import Data.Text (Text) import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) import qualified Data.Text.Encoding as TE +import Data.Typeable (Typeable) import qualified Network.HTTP.Conduit as H import qualified Network.HTTP.Types as HT -import Facebook.Types -import Facebook.Monad import Facebook.Base import Facebook.Graph +import Facebook.Monad import Facebook.Pager +import Facebook.Types -- | The type of objects that a real-time update refers to. data RealTimeUpdateObject @@ -89,8 +90,8 @@ -- If there was any previous subscription for the given -- 'RealTimeUpdateObject', it's overriden by this one (even if -- the other subscription had a different callback URL). -modifySubscription - :: (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m) +modifySubscription :: + (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m) => RealTimeUpdateObject -- ^ Type of objects whose subscription you -- and to add or modify. @@ -112,31 +113,27 @@ , "callback_url" #= callbackUrl , "verify_token" #= verifyToken ] - runResourceInFb $ - do req <- fbreq path (Just apptoken) args - void $ - fbhttp - req - { H.method = HT.methodPost - } + runResourceInFb $ do + req <- fbreq path (Just apptoken) args + void $ fbhttp req {H.method = HT.methodPost} return () -- | (Internal) Get the subscription's path. -getSubscriptionsPath - :: Monad m - => FacebookT Auth m Text +getSubscriptionsPath :: (Monad m, MonadIO m) => FacebookT Auth m Text getSubscriptionsPath = do creds <- getCreds return $ T.concat ["/", appId creds, "/subscriptions"] -- | Information returned by Facebook about a real-time update -- notification subscription. -data RealTimeUpdateSubscription = RealTimeUpdateSubscription - { rtusObject :: RealTimeUpdateObject - , rtusCallbackUrl :: RealTimeUpdateUrl - , rtusFields :: [RealTimeUpdateField] - , rtusActive :: Bool - } deriving (Eq, Ord, Show, Typeable) +data RealTimeUpdateSubscription = + RealTimeUpdateSubscription + { rtusObject :: RealTimeUpdateObject + , rtusCallbackUrl :: RealTimeUpdateUrl + , rtusFields :: [RealTimeUpdateField] + , rtusActive :: Bool + } + deriving (Eq, Ord, Show, Typeable) instance A.FromJSON RealTimeUpdateSubscription where parseJSON (A.Object v) = @@ -146,24 +143,25 @@ parseJSON _ = mzero -- | List current real-time update subscriptions. -listSubscriptions - :: (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m) - => AppAccessToken -> FacebookT Auth m [RealTimeUpdateSubscription] +listSubscriptions :: + (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m) + => AppAccessToken + -> FacebookT Auth m [RealTimeUpdateSubscription] listSubscriptions apptoken = do path <- getSubscriptionsPath pager <- getObject path [] (Just apptoken) src <- fetchAllNextPages pager lift $ C.runConduit $ src C..| CL.consume --- | Verifies the input's authenticity (i.e. it comes from +-- | Verifi(es the input's authenticity (i.e. it comes from, MonadIO m) -- Facebook) and integrity by calculating its HMAC-SHA1 (using -- your application secret as the key) and verifying that it -- matches the value from the HTTP request's @X-Hub-Signature@ -- header's value. If it's not valid, @Nothing@ is returned, -- otherwise @Just data@ is returned where @data@ is the original -- data. -verifyRealTimeUpdateNotifications - :: Monad m +verifyRealTimeUpdateNotifications :: + (Monad m, MonadIO m) => ByteString -- ^ @X-Hub-Signature@ HTTP header's value. -> L.ByteString @@ -171,12 +169,13 @@ -> FacebookT Auth m (Maybe L.ByteString) verifyRealTimeUpdateNotifications sig body = do creds <- getCreds - let key :: Crypto.MacKey ctx SHA1 - key = Crypto.MacKey (appSecretBS creds) - hash = Crypto.hmac key body - expected = "sha1=" <> Base16.encode (Crypto.encode hash) + let hmacData :: HMAC SHA1 + hmacData = hmac (appSecretBS creds) (L.toStrict body) + hash :: B.ByteString + hash = convertToBase Base16 hmacData + expected = "sha1=" <> hash return $! - if sig `Crypto.constTimeEq` expected + if ((convert sig :: ScrubbedBytes) == (convert expected)) then Just body else Nothing @@ -185,14 +184,15 @@ -- signature is invalid or the data can't be parsed (use -- 'verifyRealTimeUpdateNotifications' if you need to distinguish -- between these two error conditions). -getRealTimeUpdateNotifications - :: (Monad m, A.FromJSON a) +getRealTimeUpdateNotifications :: + (Monad m, A.FromJSON a, MonadIO m) => ByteString -- ^ @X-Hub-Signature@ HTTP header's value. -> L.ByteString -- ^ Request body with JSON-encoded notifications. -> FacebookT Auth m (Maybe (RealTimeUpdateNotification a)) -getRealTimeUpdateNotifications = (liftM (>>= A.decode) .) . verifyRealTimeUpdateNotifications +getRealTimeUpdateNotifications = + (liftM (>>= A.decode) .) . verifyRealTimeUpdateNotifications -- | When data changes and there's a valid subscription, Facebook -- will @POST@ to your 'RealTimeUpdateUrl' with a JSON-encoded @@ -207,23 +207,26 @@ -- the value of 'rtunObject'. -- -- We recommend using 'getRealTimeUpdateNotifications'. -data RealTimeUpdateNotification a = RealTimeUpdateNotification - { rtunObject :: RealTimeUpdateObject - , rtunEntries :: [a] - } deriving (Eq, Ord, Show, Typeable) +data RealTimeUpdateNotification a = + RealTimeUpdateNotification + { rtunObject :: RealTimeUpdateObject + , rtunEntries :: [a] + } + deriving (Eq, Ord, Show, Typeable) -instance A.FromJSON a => - A.FromJSON (RealTimeUpdateNotification a) where +instance A.FromJSON a => A.FromJSON (RealTimeUpdateNotification a) where parseJSON (A.Object v) = RealTimeUpdateNotification <$> v A..: "object" <*> v A..: "entry" parseJSON _ = mzero -- | A notification for the 'UserRTUO' object. -data RealTimeUpdateNotificationUserEntry = RealTimeUpdateNotificationUserEntry - { rtuneUserId :: Id - , rtuneChangedFields :: [RealTimeUpdateField] - , rtuneTime :: Integer - } deriving (Eq, Ord, Show, Typeable) +data RealTimeUpdateNotificationUserEntry = + RealTimeUpdateNotificationUserEntry + { rtuneUserId :: Id + , rtuneChangedFields :: [RealTimeUpdateField] + , rtuneTime :: Integer + } + deriving (Eq, Ord, Show, Typeable) instance A.FromJSON RealTimeUpdateNotificationUserEntry where parseJSON (A.Object v) = diff --git a/src/Facebook/TestUsers.hs b/src/Facebook/TestUsers.hs --- a/src/Facebook/TestUsers.hs +++ b/src/Facebook/TestUsers.hs @@ -16,6 +16,7 @@ import Control.Applicative ((<$>), (<*>)) import Control.Monad (unless, mzero) +import Control.Monad.IO.Class import Data.ByteString.Lazy (fromStrict) import Data.Default import Data.Text @@ -94,7 +95,7 @@ -- | Create a new test user. -- Ref: https://developers.facebook.com/docs/graph-api/reference/v2.8/app/accounts/test-users#publish createTestUser - :: (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m) + :: (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m, MonadIO m) => CreateTestUser -- ^ How the test user should be -- created. -> AppAccessToken -- ^ Access token for your app. @@ -106,7 +107,7 @@ -- | Get a list of test users. getTestUsers - :: (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m) + :: (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m, MonadIO m) => AppAccessToken -- ^ Access token for your app. -> FacebookT Auth m (Pager TestUser) getTestUsers token = do @@ -114,7 +115,7 @@ getObject ("/" <> appId creds <> "/accounts/test-users") [] (Just token) disassociateTestuser - :: (R.MonadUnliftIO m, R.MonadThrow m, R.MonadResource m) + :: (R.MonadUnliftIO m, R.MonadThrow m, R.MonadResource m, MonadIO m) => TestUser -> AppAccessToken -> FacebookT Auth m Bool disassociateTestuser testUser _token = do creds <- getCreds diff --git a/src/Facebook/Types.hs b/src/Facebook/Types.hs --- a/src/Facebook/Types.hs +++ b/src/Facebook/Types.hs @@ -7,6 +7,7 @@ module Facebook.Types ( Credentials(..) + , ApiVersion , appIdBS , appSecretBS , AccessToken(..) @@ -23,10 +24,12 @@ , Argument , (<>) , FbUTCTime(..) + , FacebookException(..) ) where import Control.Applicative ((<$>), (<*>), pure) import Control.Monad (mzero) +import qualified UnliftIO.Exception as E import Data.ByteString (ByteString) import Data.Int (Int64) #if !(MIN_VERSION_base(4,11,0)) @@ -57,6 +60,7 @@ { appName :: Text -- ^ Your application name (e.g. for Open Graph calls). , appId :: Text -- ^ Your application ID. , appSecret :: Text -- ^ Your application secret key. + , appSecretProof :: Bool -- ^ To enable app secret proof verification } deriving (Eq, Ord, Show, Read, Typeable) -- | 'appId' for 'ByteString'. @@ -67,6 +71,11 @@ appSecretBS :: Credentials -> ByteString appSecretBS = TE.encodeUtf8 . appSecret + +-- | Graph API version. +-- See: https://developers.facebook.com/docs/graph-api/changelog +type ApiVersion = Text + -- | An access token. While you can make some API calls without -- an access token, many require an access token and some will -- give you more information with an appropriate access token. @@ -234,3 +243,23 @@ parseJSON _ = fail "could not parse FbUTCTime from something which is not a string or number" + +-- | 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, Read, Typeable) + +instance A.FromJSON FacebookException where + parseJSON (A.Object v) = + FacebookException <$> v A..: "type" + <*> v A..: "message" + parseJSON _ = mzero + +instance E.Exception FacebookException where + diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -6,22 +6,9 @@ , getCredentials ) where -import Control.Applicative import Control.Monad (mzero) import Control.Monad.IO.Class (MonadIO(liftIO)) import Control.Monad.Trans.Class (lift) -import Data.Function (on) -import Data.Int (Int8, Int16, Int32, Int64) -import Data.Maybe (isJust, isNothing) -import Data.Text (Text) -import Data.Time (parseTime) -import Data.Word (Word, Word8, Word16, Word32, Word64) -import System.Environment (getEnv) -import System.Exit (exitFailure) -import System.IO.Error (isDoesNotExistError) -import Data.List ((\\)) -import Data.Monoid ((<>)) -import qualified UnliftIO.Exception as E import qualified Control.Monad.Trans.Resource as R import qualified Data.Aeson as A import qualified Data.Aeson.Types as A @@ -29,15 +16,24 @@ import qualified Data.Conduit as C import qualified Data.Conduit.List as CL import qualified Data.Default as D +import Data.Int (Int16, Int32, Int64, Int8) +import Data.List ((\\)) import qualified Data.Map as Map +import Data.Maybe (isJust, isNothing) import qualified Data.Maybe as M -import qualified Data.Set as S +import Data.Monoid ((<>)) +import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.Time as TI +import Data.Word (Word, Word16, Word32, Word64, Word8) import qualified Facebook as FB import qualified Network.HTTP.Conduit as H +import System.Environment (getEnv) +import System.Exit (exitFailure) +import System.IO.Error (isDoesNotExistError) import qualified Test.QuickCheck as QC +import qualified UnliftIO.Exception as E import Test.HUnit ((@?=)) import Test.Hspec @@ -50,7 +46,8 @@ tryToGet = do [appName, appId, appSecret] <- mapM getEnv ["APP_NAME", "APP_ID", "APP_SECRET"] - return $ FB.Credentials (T.pack appName) (T.pack appId) (T.pack appSecret) + return $ + FB.Credentials (T.pack appName) (T.pack appId) (T.pack appSecret) True showHelp exc | not (isDoesNotExistError exc) = E.throwIO exc showHelp _ = do @@ -78,12 +75,13 @@ exitFailure invalidCredentials :: FB.Credentials -invalidCredentials = FB.Credentials "this" "isn't" "valid" +invalidCredentials = FB.Credentials "this" "isn't" "valid" False invalidUserAccessToken :: FB.UserAccessToken -invalidUserAccessToken = FB.UserAccessToken (FB.Id "invalid") "user" farInTheFuture +invalidUserAccessToken = + FB.UserAccessToken (FB.Id "invalid") "user" farInTheFuture where - Just farInTheFuture = parseTime (error "farInTheFuture") "%Y" "3000" + Just farInTheFuture = TI.parseTimeM True TI.defaultTimeLocale "%Y" "3000" -- It's actually important to use 'farInTheFuture' since we -- don't want any tests rejecting this invalid user access @@ -94,28 +92,29 @@ main :: IO () main = do manager <- H.newManager H.tlsManagerSettings - liftIO $ - do creds <- getCredentials - hspec $ + liftIO $ do + creds <- getCredentials + hspec $ -- Run the tests twice, once in Facebook's production tier... - do facebookTests - "Production tier: " - creds - manager - (R.runResourceT . FB.runFacebookT creds manager) - (R.runResourceT . FB.runNoAuthFacebookT manager) + do + facebookTests + "Production tier: " + creds + manager + (R.runResourceT . (FB.runFacebookT creds manager)) + (R.runResourceT . (FB.runNoAuthFacebookT manager)) -- ...and the other in Facebook's beta tier. - facebookTests - "Beta tier: " - creds - manager - (R.runResourceT . FB.beta_runFacebookT creds manager) - (R.runResourceT . FB.beta_runNoAuthFacebookT manager) + facebookTests + "Beta tier: " + creds + manager + (R.runResourceT . (FB.beta_runFacebookT creds manager)) + (R.runResourceT . (FB.beta_runNoAuthFacebookT manager)) -- Tests that don't depend on which tier is chosen. - libraryTests manager + libraryTests manager -facebookTests - :: String +facebookTests :: + String -> FB.Credentials -> H.Manager -> (forall a. FB.FacebookT FB.Auth (R.ResourceT IO) a -> IO a) @@ -123,247 +122,233 @@ -> Spec facebookTests pretitle creds manager runAuth runNoAuth = do let describe' = describe . (pretitle ++) - describe' "getAppAccessToken" $ - do it "works and returns a valid app access token" $ - runAuth $ - do token <- FB.getAppAccessToken - FB.isValid token #?= True - it "throws a FacebookException on invalid credentials" $ - R.runResourceT $ - FB.runFacebookT invalidCredentials manager $ - do ret <- E.try $ FB.getAppAccessToken - case ret of - Right token -> fail $ show token - Left (_ :: FB.FacebookException) -> - lift $ lift (return () :: IO ()) - describe' "isValid" $ - do it "returns False on a clearly invalid user access token" $ - runNoAuth $ FB.isValid invalidUserAccessToken #?= False - it "returns False on a clearly invalid app access token" $ - runNoAuth $ FB.isValid invalidAppAccessToken #?= False - describe' "debugToken" $ - do it "works on a test user access token" $ - do runAuth $ - withTestUser D.def $ - \testUser -> do - Just testUserAccessTokenData <- - return (FB.tuAccessToken testUser) - appToken <- FB.getAppAccessToken - ret <- FB.debugToken appToken testUserAccessTokenData - now <- liftIO TI.getCurrentTime - FB.dtAppId ret &?= Just (FB.appId creds) - FB.dtAppName ret &?= Just (FB.appName creds) - case FB.dtExpiresAt ret of - Nothing -> fail "dtExpiresAt is Nothing" - Just t -> compare t now &?= GT - FB.dtIsValid ret &?= Just True - case FB.dtIssuedAt ret of - Nothing -> return () -- ok since it's a test user - Just t -> compare t now &?= LT - isJust (FB.dtScopes ret) &?= True - FB.dtUserId ret &?= Just (FB.tuId testUser) - case FB.dtAccessToken ret of - Nothing -> fail "dtAccessToken is Nothing" - Just t -> do - let f - :: FB.UserAccessToken - -> FB.FacebookT FB.Auth (R.ResourceT IO) () - f (FB.UserAccessToken uid dt exps) = do - uid &?= FB.tuId testUser - dt &?= testUserAccessTokenData - Just exps &?= FB.dtExpiresAt ret - f t - describe' "getObject" $ - do it "is able to fetch Facebook's own page" $ - do val <- - runAuth $ -- Needs permission now: https://developers.facebook.com/docs/graph-api/reference/page#Reading - do token <- FB.getAppAccessToken - A.Object obj <- FB.getObject "/19292868552" [] (Just token) - let Just r = - flip A.parseMaybe () $ - const $ (,) <$> obj A..:? "id" <*> obj A..:? "name" - return r - val `shouldBe` - ( Just "19292868552" :: Maybe Text - , Just "Facebook for Developers" :: Maybe Text) - describe' "getPage" $ - do it "works for FB Developers" $ - do runAuth $ - do token <- FB.getAppAccessToken - page <- FB.getPage_ (FB.Id "19292868552") [] (Just token) - FB.pageId page &?= (FB.Id "19292868552") - FB.pageName page &?= Just "Facebook for Developers" - FB.pageCategory page &?= Nothing - FB.pageIsPublished page &?= Nothing - FB.pageCanPost page &?= Nothing - FB.pagePhone page &?= Nothing - FB.pageCheckins page &?= Nothing - FB.pageWebsite page &?= Nothing - describe' "listSubscriptions" $ - do it "returns something" $ - do runAuth $ - do token <- FB.getAppAccessToken - val <- FB.listSubscriptions token - length val `seq` return () - describe' "fetchNextPage" $ - do let fetchNextPageWorks :: FB.Pager A.Value - -> FB.FacebookT anyAuth (R.ResourceT IO) () - fetchNextPageWorks pager - | isNothing (FB.pagerNext pager) = return () - | otherwise = - FB.fetchNextPage pager >>= maybe not_ (\_ -> return ()) - where - not_ = - fail "Pager had a next page but fetchNextPage didn't work." - it "seems to work on a public list of comments" $ - do runAuth $ + describe' "getAppAccessToken" $ do + it "works and returns a valid app access token" $ + runAuth $ do + token <- FB.getAppAccessToken + FB.isValid token #?= True + it "throws a FacebookException on invalid credentials" $ + R.runResourceT $ + FB.runFacebookT invalidCredentials manager $ do + ret <- E.try $ FB.getAppAccessToken + case ret of + Right token -> fail $ show token + Left (_ :: FB.FacebookException) -> lift $ lift (return () :: IO ()) + describe' "setApiVersion" $ do + it "Check default apiVersion" $ runNoAuth $ FB.getApiVersion #?= "v3.2" + it "Change apiVersion" $ + (runNoAuth $ do + FB.setApiVersion "v100" + FB.getApiVersion) #?= + "v100" + describe' "isValid" $ do + it "returns False on a clearly invalid user access token" $ + runNoAuth $ FB.isValid invalidUserAccessToken #?= False + it "returns False on a clearly invalid app access token" $ + runNoAuth $ FB.isValid invalidAppAccessToken #?= False + describe' "debugToken" $ do + it "works on a test user access token" $ do + runAuth $ + withTestUser D.def $ \testUser -> do + Just testUserAccessTokenData <- return (FB.tuAccessToken testUser) + appToken <- FB.getAppAccessToken + ret <- FB.debugToken appToken testUserAccessTokenData + now <- liftIO TI.getCurrentTime + FB.dtAppId ret &?= Just (FB.appId creds) + FB.dtAppName ret &?= Just (FB.appName creds) + case FB.dtExpiresAt ret of + Nothing -> fail "dtExpiresAt is Nothing" + Just t -> compare t now &?= GT + FB.dtIsValid ret &?= Just True + case FB.dtIssuedAt ret of + Nothing -> return () -- ok since it's a test user + Just t -> compare t now &?= LT + isJust (FB.dtScopes ret) &?= True + FB.dtUserId ret &?= Just (FB.tuId testUser) + case FB.dtAccessToken ret of + Nothing -> fail "dtAccessToken is Nothing" + Just t -> do + let f :: FB.UserAccessToken + -> FB.FacebookT FB.Auth (R.ResourceT IO) () + f (FB.UserAccessToken uid dt exps) = do + uid &?= FB.tuId testUser + dt &?= testUserAccessTokenData + Just exps &?= FB.dtExpiresAt ret + f t + describe' "getObject" $ do + it "is able to fetch Facebook's own page" $ do + val <- + runAuth $ -- Needs permission now: https://developers.facebook.com/docs/graph-api/reference/page#Reading + do + token <- FB.getAppAccessToken + A.Object obj <- FB.getObject "/220746347971798" [] (Just token) + let Just r = + flip A.parseMaybe () $ + const $ (,) <$> obj A..:? "id" <*> obj A..:? "name" + return r + val `shouldBe` + (Just "220746347971798" :: Maybe Text, Just "Ruskin Bond" :: Maybe Text) + describe' "getPage" $ do + it "works for FB Developers" $ do + runAuth $ do + token <- FB.getAppAccessToken + page <- FB.getPage_ (FB.Id "220746347971798") [] (Just token) + FB.pageId page &?= (FB.Id "220746347971798") + FB.pageName page &?= Just "Ruskin Bond" + FB.pageCategory page &?= Nothing + FB.pageIsPublished page &?= Nothing + FB.pageCanPost page &?= Nothing + FB.pagePhone page &?= Nothing + FB.pageCheckins page &?= Nothing + FB.pageWebsite page &?= Nothing + describe' "listSubscriptions" $ do + it "returns something" $ do + runAuth $ do + token <- FB.getAppAccessToken + val <- FB.listSubscriptions token + length val `seq` return () + describe' "fetchNextPage" $ do + let fetchNextPageWorks :: + FB.Pager A.Value -> FB.FacebookT anyAuth (R.ResourceT IO) () + fetchNextPageWorks pager + | isNothing (FB.pagerNext pager) = return () + | otherwise = FB.fetchNextPage pager >>= maybe not_ (\_ -> return ()) + where + not_ = fail "Pager had a next page but fetchNextPage didn't work." + it "seems to work on a public list of comments" $ do + runAuth $ -- Postid: https://www.facebook.com/nytimes/posts/10150628170209999 -- Page id found using this technique: https://www.facebook.com/help/community/question/?id=529591157094317 - do token <- FB.getAppAccessToken - fetchNextPageWorks =<< - FB.getObject - "/5281959998_10150628170209999/comments" - [] - (Just token) - it "seems to work on a private list of app insights" $ - do runAuth $ - do token <- FB.getAppAccessToken - fetchNextPageWorks =<< - FB.getObject - ("/" <> FB.appId creds <> "/app_insights/api_calls") - [] - (Just token) - describe' "fetchNextPage/fetchPreviousPage" $ - do let backAndForthWorks :: FB.Pager A.Value - -> FB.FacebookT anyAuth (R.ResourceT IO) () - backAndForthWorks pager = do - pager2 <- FB.fetchNextPage pager - case pager2 of - Nothing -> True &?= True - Just pager2' -> do - Just pager3 <- FB.fetchPreviousPage pager2' - pager3 &?= pager - it "seems to work on a public list of comments" $ - do runAuth $ - do token <- FB.getAppAccessToken - backAndForthWorks =<< - FB.getObject - "/5281959998_10150628170209999/comments" - [("filter", "stream")] - (Just token) - it "seems to work on a private list of app insights" $ - do runAuth $ - do token <- FB.getAppAccessToken - backAndForthWorks =<< - FB.getObject - ("/" <> FB.appId creds <> "/app_insights/api_calls") - [] - (Just token) - describe' "fetchAllNextPages" $ - do let hasAtLeast :: C.Source IO A.Value -> Int -> IO () - src `hasAtLeast` n = src C.$$ go n - where - go 0 = return () - go m = C.await >>= maybe not_ (\_ -> go (m - 1)) - not_ = - fail $ - "Source does not have at least " ++ show n ++ " elements." - it "seems to work on a public list of comments" $ - do runAuth $ - do token <- FB.getAppAccessToken - pager <- - FB.getObject - "/63441126719_10154249531391720/comments" - [] - (Just token) - src <- FB.fetchAllNextPages pager - liftIO $ src `hasAtLeast` 200 -- items - it "seems to work on a private list of app insights" $ - do runAuth $ - do token <- FB.getAppAccessToken - pager <- - FB.getObject - ("/" <> FB.appId creds <> "/app_insights/api_calls") - [] - (Just token) - src <- FB.fetchAllNextPages pager - let firstPageElms = length (FB.pagerData pager) - hasNextPage = isJust (FB.pagerNext pager) - if hasNextPage - then liftIO $ src `hasAtLeast` (firstPageElms * 3) -- items - else return () -- fail "This isn't an insightful app =(." - describe' "createTestUser/removeTestUser/getTestUser" $ - do it "creates and removes a new test user" $ - do runAuth $ - do token <- FB.getAppAccessToken + do + token <- FB.getAppAccessToken + fetchNextPageWorks =<< + FB.getObject "/5281959998_10150628170209999/comments" [] (Just token) + it "seems to work on a private list of app insights" $ do + runAuth $ do + token <- FB.getAppAccessToken + fetchNextPageWorks =<< + FB.getObject + ("/" <> FB.appId creds <> "/app_insights/api_calls") + [] + (Just token) + describe' "fetchNextPage/fetchPreviousPage" $ do + let backAndForthWorks :: + FB.Pager A.Value -> FB.FacebookT anyAuth (R.ResourceT IO) () + backAndForthWorks pager = do + pager2 <- FB.fetchNextPage pager + case pager2 of + Nothing -> True &?= True + Just pager2' -> do + Just pager3 <- FB.fetchPreviousPage pager2' + pager3 &?= pager + it "seems to work on a public list of comments" $ do + runAuth $ do + token <- FB.getAppAccessToken + backAndForthWorks =<< + FB.getObject + "/5281959998_10150628170209999/comments" + [("filter", "stream")] + (Just token) + it "seems to work on a private list of app insights" $ do + runAuth $ do + token <- FB.getAppAccessToken + backAndForthWorks =<< + FB.getObject + ("/" <> FB.appId creds <> "/app_insights/api_calls") + [] + (Just token) + describe' "fetchAllNextPages" $ do + let hasAtLeast :: C.ConduitT () A.Value IO () -> Int -> IO () + src `hasAtLeast` n = C.runConduit $ src C..| go n + where + go 0 = return () + go m = C.await >>= maybe not_ (\_ -> go (m - 1)) + not_ = + fail $ "Source does not have at least " ++ show n ++ " elements." + it "seems to work on a public list of comments" $ do + runAuth $ do + token <- FB.getAppAccessToken + pager <- + FB.getObject "/63441126719_10154249531391720/comments" [] (Just token) + src <- FB.fetchAllNextPages pager + liftIO $ src `hasAtLeast` 200 -- items + it "seems to work on a private list of app insights" $ do + runAuth $ do + token <- FB.getAppAccessToken + pager <- + FB.getObject + ("/" <> FB.appId creds <> "/app_insights/api_calls") + [] + (Just token) + src <- FB.fetchAllNextPages pager + let firstPageElms = length (FB.pagerData pager) + hasNextPage = isJust (FB.pagerNext pager) + if hasNextPage + then liftIO $ src `hasAtLeast` (firstPageElms * 3) -- items + else return () -- fail "This isn't an insightful app =(." + describe' "createTestUser/removeTestUser/getTestUser" $ do + it "creates and removes a new test user" $ do + runAuth $ do + token <- FB.getAppAccessToken -- New test user information - let installed = - FB.CreateTestUserInstalled - ["read_stream", "read_friendlists", "publish_stream"] - userInfo = - FB.CreateTestUser - { FB.ctuInstalled = installed - , FB.ctuName = Just "Gabriel" - , FB.ctuLocale = Just "en_US" - } + let installed = + FB.CreateTestUserInstalled + ["read_stream", "read_friendlists", "publish_stream"] + userInfo = + FB.CreateTestUser + { FB.ctuInstalled = installed + , FB.ctuName = Just "Gabriel" + , FB.ctuLocale = Just "en_US" + } -- Create the test user - newTestUser <- FB.createTestUser userInfo token - let newTestUserToken = - (M.fromJust $ FB.incompleteTestUserAccessToken newTestUser) + newTestUser <- FB.createTestUser userInfo token + let newTestUserToken = + (M.fromJust $ FB.incompleteTestUserAccessToken newTestUser) -- Get the created user - createdUser <- - FB.getUser (FB.tuId newTestUser) [] (Just newTestUserToken) + createdUser <- + FB.getUser (FB.tuId newTestUser) [] (Just newTestUserToken) -- Remove the test user - removed <- FB.removeTestUser newTestUser token + removed <- FB.removeTestUser newTestUser token -- Check user attributes - FB.userId createdUser &?= FB.tuId newTestUser - FB.userName createdUser &?= Just "Gabriel" - -- FB.userLocale createdUser &?= Just "en_US" -- fix this test later + FB.userId createdUser &?= FB.tuId newTestUser + FB.userName createdUser &?= Just "Gabriel" + -- FB.userLocale createdUser &?= Just "en_US" -- fix this test later -- Check if the token is valid - FB.isValid newTestUserToken #?= False - removed &?= True - describe' "makeFriendConn" $ - do it "creates two new test users, makes them friends and deletes them" $ - do runAuth $ - withTestUser D.def $ - \testUser1 -> - withTestUser D.def $ - \testUser2 -> do - let Just tokenUser1 = FB.incompleteTestUserAccessToken testUser1 - let Just tokenUser2 = FB.incompleteTestUserAccessToken testUser2 + FB.isValid newTestUserToken #?= False + removed &?= True + describe' "makeFriendConn" $ do + it "creates two new test users, makes them friends and deletes them" $ do + runAuth $ + withTestUser D.def $ \testUser1 -> + withTestUser D.def $ \testUser2 -> do + let Just tokenUser1 = FB.incompleteTestUserAccessToken testUser1 + let Just tokenUser2 = FB.incompleteTestUserAccessToken testUser2 -- Check if the new test users' tokens are valid. - FB.isValid tokenUser1 #?= True - FB.isValid tokenUser2 #?= True + FB.isValid tokenUser1 #?= True + FB.isValid tokenUser2 #?= True -- Create a friend connection between the new test users. - FB.makeFriendConn testUser1 testUser2 + FB.makeFriendConn testUser1 testUser2 -- Verify that one is a friend of the other. - user1 <- FB.getUser (FB.tuId testUser1) [] (Just tokenUser1) - user2 <- FB.getUser (FB.tuId testUser2) [] (Just tokenUser2) - friends1 <- FB.getUserFriends (FB.tuId testUser1) [] tokenUser1 - friends2 <- FB.getUserFriends (FB.tuId testUser2) [] tokenUser2 - FB.pagerData friends1 &?= - [ FB.Friend - (FB.tuId testUser2) - (M.fromJust (FB.userName user2)) - ] - FB.pagerData friends2 &?= - [ FB.Friend - (FB.tuId testUser1) - (M.fromJust (FB.userName user1)) - ] - describe' "getTestUsers" $ - do it "gets a list of test users" $ - do runAuth $ - do token <- FB.getAppAccessToken - pager <- FB.getTestUsers token - src <- FB.fetchAllNextPages pager - oldList <- liftIO $ R.runResourceT $ src C.$$ CL.consume - withTestUser D.def $ - \testUser -> do - newList <- FB.pagerData <$> FB.getTestUsers token - let newList' = map FB.tuId newList - oldList' = map FB.tuId oldList - ((FB.tuId testUser) `elem` (newList' \\ oldList')) &?= True + user1 <- FB.getUser (FB.tuId testUser1) [] (Just tokenUser1) + user2 <- FB.getUser (FB.tuId testUser2) [] (Just tokenUser2) + friends1 <- FB.getUserFriends (FB.tuId testUser1) [] tokenUser1 + friends2 <- FB.getUserFriends (FB.tuId testUser2) [] tokenUser2 + FB.pagerData friends1 &?= + [FB.Friend (FB.tuId testUser2) (M.fromJust (FB.userName user2))] + FB.pagerData friends2 &?= + [FB.Friend (FB.tuId testUser1) (M.fromJust (FB.userName user1))] + describe' "getTestUsers" $ do + it "gets a list of test users" $ do + runAuth $ do + token <- FB.getAppAccessToken + pager <- FB.getTestUsers token + src <- FB.fetchAllNextPages pager + oldList <- liftIO $ R.runResourceT $ C.runConduit $ src C..| CL.consume + withTestUser D.def $ \testUser -> do + newList <- FB.pagerData <$> FB.getTestUsers token + let newList' = map FB.tuId newList + oldList' = map FB.tuId oldList + ((FB.tuId testUser) `elem` (newList' \\ oldList')) &?= True newtype PageName = PageName Text @@ -375,138 +360,140 @@ libraryTests :: H.Manager -> Spec libraryTests manager = do - describe "SimpleType" $ - do it "works for Bool" $ (map FB.encodeFbParam [True, False]) @?= ["1", "0"] - let day = TI.fromGregorian 2012 12 21 - time = TI.TimeOfDay 11 37 22 - diffTime = TI.secondsToDiffTime (11 * 3600 + 37 * 60) - utcTime = TI.UTCTime day diffTime - localTime = TI.LocalTime day time - zonedTime = TI.ZonedTime localTime (TI.minutesToTimeZone 30) - it "works for Day" $ FB.encodeFbParam day @?= "2012-12-21" - it "works for UTCTime" $ FB.encodeFbParam utcTime @?= "20121221T1137Z" - it "works for ZonedTime" $ - FB.encodeFbParam zonedTime @?= "20121221T1107Z" - let propShowRead - :: (Show a, Read a, Eq a, FB.SimpleType a) - => a -> Bool - propShowRead x = read (B.unpack $ FB.encodeFbParam x) == x - prop "works for Float" (propShowRead :: Float -> Bool) - prop "works for Double" (propShowRead :: Double -> Bool) - prop "works for Int" (propShowRead :: Int -> Bool) - prop "works for Int8" (propShowRead :: Int8 -> Bool) - prop "works for Int16" (propShowRead :: Int16 -> Bool) - prop "works for Int32" (propShowRead :: Int32 -> Bool) - prop "works for Int64" (propShowRead :: Int64 -> Bool) - prop "works for Word" (propShowRead :: Word -> Bool) - prop "works for Word8" (propShowRead :: Word8 -> Bool) - prop "works for Word16" (propShowRead :: Word16 -> Bool) - prop "works for Word32" (propShowRead :: Word32 -> Bool) - prop "works for Word64" (propShowRead :: Word64 -> Bool) - let propShowReadL - :: (Show a, Read a, Eq a, FB.SimpleType a) - => [a] -> Bool - propShowReadL x = - read ('[' : B.unpack (FB.encodeFbParam x) ++ "]") == x - prop "works for [Float]" (propShowReadL :: [Float] -> Bool) - prop "works for [Double]" (propShowReadL :: [Double] -> Bool) - prop "works for [Int]" (propShowReadL :: [Int] -> Bool) - prop "works for [Int8]" (propShowReadL :: [Int8] -> Bool) - prop "works for [Int16]" (propShowReadL :: [Int16] -> Bool) - prop "works for [Int32]" (propShowReadL :: [Int32] -> Bool) - prop "works for [Int64]" (propShowReadL :: [Int64] -> Bool) - prop "works for [Word]" (propShowReadL :: [Word] -> Bool) - prop "works for [Word8]" (propShowReadL :: [Word8] -> Bool) - prop "works for [Word16]" (propShowReadL :: [Word16] -> Bool) - prop "works for [Word32]" (propShowReadL :: [Word32] -> Bool) - prop "works for [Word64]" (propShowReadL :: [Word64] -> Bool) - prop "works for Text" (\t -> FB.encodeFbParam t == TE.encodeUtf8 t) - prop "works for Id" $ - \i -> - let toId :: Int -> FB.Id - toId = FB.Id . T.pack . show - j = abs i - in FB.encodeFbParam (toId j) == FB.encodeFbParam j - describe "parseSignedRequest" $ - do let exampleSig, exampleData :: B.ByteString - exampleSig = "vlXgu64BQGFSQrY0ZcJBZASMvYvTHu9GQ0YM9rjPSso" - exampleData = - "eyJhbGdvcml0aG0iOiJITUFDLVNIQTI1NiIsIjAiOiJwYXlsb2FkIn0" - exampleCreds = FB.Credentials "name" "id" "secret" - runExampleAuth :: FB.FacebookT FB.Auth (R.ResourceT IO) a -> IO a - runExampleAuth = R.runResourceT . FB.runFacebookT exampleCreds manager - it "works for Facebook example" $ - do runExampleAuth $ - do ret <- - FB.parseSignedRequest - (B.concat [exampleSig, ".", exampleData]) - ret &?= - Just - (A.object - [ "algorithm" A..= ("HMAC-SHA256" :: Text) - , "0" A..= ("payload" :: Text) - ]) - it "fails to parse the Facebook example when signature is corrupted" $ - do let corruptedSig = B.cons 'a' (B.tail exampleSig) - runExampleAuth $ - do ret <- - FB.parseSignedRequest - (B.concat [corruptedSig, ".", exampleData]) - ret &?= (Nothing :: Maybe A.Value) - describe "FQLTime" $ - do it "seems to work" $ - do let input = "[1348678357]" - output = FB.FQLTime (read "2012-09-26 16:52:37 UTC") - A.decode input @?= Just [output] - describe "FbUTCTime" $ - do let output = FB.FbUTCTime (read "2012-09-26 16:52:37 UTC") - it "seems to work (string)" $ - do let input = "[\"2012-09-26T16:52:37+0000\"]" - A.decode input @?= Just [output] - it "seems to work (unix epoch)" $ - do let input = "[1348678357]" - A.decode input @?= Just [output] - describe "FQLList" $ - do let j :: [Int] -> Maybe (FB.FQLList Int) - j = Just . FB.FQLList - it "parses []" $ do A.decode "[]" @?= j [] - it "parses {}" $ do A.decode "{}" @?= j [] - it "parses [1234]" $ do A.decode "[1234]" @?= j [1234] - it "parses {\"1234\": 1234}" $ - do A.decode "{\"1234\": 1234}" @?= j [1234] - describe "FQLObject" $ - do let j :: [(Text, Int)] -> Maybe (FB.FQLObject (Map.Map Text Int)) - j = Just . FB.FQLObject . Map.fromList - it "parses []" $ do A.decode "[]" @?= j [] - it "parses {}" $ do A.decode "{}" @?= j [] - it "parses {\"abc\": 1234}" $ - do A.decode "{\"abc\": 1234}" @?= j [("abc", 1234)] - it "does not parse [1234]" $ - do A.decode "[1234]" @?= (Nothing `asTypeOf` j []) - describe "Id" $ - do it "can be parsed from a string" $ - do A.decode "[\"1234\"]" @?= Just [FB.Id "1234"] - it "can be parsed from an integer" $ - do A.decode "[1234]" @?= Just [FB.Id "1234"] - it "can be parsed from an object with a string" $ - do A.decode "{\"id\": \"1234\"}" @?= Just (FB.Id "1234") - it "can be parsed from an object with an integer" $ - do A.decode "{\"id\": 1234}" @?= Just (FB.Id "1234") - describe "AccessToken" $ - do it "can be round-tripped with ToJSON/FromJSON (UserKind)" $ - do A.eitherDecode (A.encode invalidUserAccessToken) @?= Right invalidUserAccessToken - it "can be round-tripped with ToJSON/FromJSON (AppKind)" $ - do A.eitherDecode (A.encode invalidAppAccessToken) @?= Right invalidAppAccessToken + describe "SimpleType" $ do + it "works for Bool" $ (map FB.encodeFbParam [True, False]) @?= ["1", "0"] + let day = TI.fromGregorian 2012 12 21 + time = TI.TimeOfDay 11 37 22 + diffTime = TI.secondsToDiffTime (11 * 3600 + 37 * 60) + utcTime = TI.UTCTime day diffTime + localTime = TI.LocalTime day time + zonedTime = TI.ZonedTime localTime (TI.minutesToTimeZone 30) + it "works for Day" $ FB.encodeFbParam day @?= "2012-12-21" + it "works for UTCTime" $ FB.encodeFbParam utcTime @?= "20121221T1137Z" + it "works for ZonedTime" $ FB.encodeFbParam zonedTime @?= "20121221T1107Z" + let propShowRead :: (Show a, Read a, Eq a, FB.SimpleType a) => a -> Bool + propShowRead x = read (B.unpack $ FB.encodeFbParam x) == x + prop "works for Float" (propShowRead :: Float -> Bool) + prop "works for Double" (propShowRead :: Double -> Bool) + prop "works for Int" (propShowRead :: Int -> Bool) + prop "works for Int8" (propShowRead :: Int8 -> Bool) + prop "works for Int16" (propShowRead :: Int16 -> Bool) + prop "works for Int32" (propShowRead :: Int32 -> Bool) + prop "works for Int64" (propShowRead :: Int64 -> Bool) + prop "works for Word" (propShowRead :: Word -> Bool) + prop "works for Word8" (propShowRead :: Word8 -> Bool) + prop "works for Word16" (propShowRead :: Word16 -> Bool) + prop "works for Word32" (propShowRead :: Word32 -> Bool) + prop "works for Word64" (propShowRead :: Word64 -> Bool) + let propShowReadL :: (Show a, Read a, Eq a, FB.SimpleType a) => [a] -> Bool + propShowReadL x = read ('[' : B.unpack (FB.encodeFbParam x) ++ "]") == x + prop "works for [Float]" (propShowReadL :: [Float] -> Bool) + prop "works for [Double]" (propShowReadL :: [Double] -> Bool) + prop "works for [Int]" (propShowReadL :: [Int] -> Bool) + prop "works for [Int8]" (propShowReadL :: [Int8] -> Bool) + prop "works for [Int16]" (propShowReadL :: [Int16] -> Bool) + prop "works for [Int32]" (propShowReadL :: [Int32] -> Bool) + prop "works for [Int64]" (propShowReadL :: [Int64] -> Bool) + prop "works for [Word]" (propShowReadL :: [Word] -> Bool) + prop "works for [Word8]" (propShowReadL :: [Word8] -> Bool) + prop "works for [Word16]" (propShowReadL :: [Word16] -> Bool) + prop "works for [Word32]" (propShowReadL :: [Word32] -> Bool) + prop "works for [Word64]" (propShowReadL :: [Word64] -> Bool) + prop "works for Text" (\t -> FB.encodeFbParam t == TE.encodeUtf8 t) + prop "works for Id" $ \i -> + let toId :: Int -> FB.Id + toId = FB.Id . T.pack . show + j = abs i + in FB.encodeFbParam (toId j) == FB.encodeFbParam j + describe "parseSignedRequest" $ do + let exampleSig, exampleData :: B.ByteString + exampleSig = "vlXgu64BQGFSQrY0ZcJBZASMvYvTHu9GQ0YM9rjPSso" + exampleData = "eyJhbGdvcml0aG0iOiJITUFDLVNIQTI1NiIsIjAiOiJwYXlsb2FkIn0" + exampleCreds = FB.Credentials "name" "id" "secret" False + runExampleAuth :: FB.FacebookT FB.Auth (R.ResourceT IO) a -> IO a + runExampleAuth = R.runResourceT . FB.runFacebookT exampleCreds manager + it "works for Facebook example" $ do + runExampleAuth $ do + ret <- FB.parseSignedRequest (B.concat [exampleSig, ".", exampleData]) + ret &?= + Just + (A.object + [ "algorithm" A..= ("HMAC-SHA256" :: Text) + , "0" A..= ("payload" :: Text) + ]) + it "fails to parse the Facebook example when signature is corrupted" $ do + let corruptedSig = B.cons 'a' (B.tail exampleSig) + runExampleAuth $ do + ret <- FB.parseSignedRequest (B.concat [corruptedSig, ".", exampleData]) + ret &?= (Nothing :: Maybe A.Value) + describe "addAppSecretProof" $ do + it "appends appsecret_proof to the query when passing an access token" $ do + now <- liftIO TI.getCurrentTime + let token = FB.UserAccessToken "id" "token" now + query = [("test", "whatever")] + secretProofQ creds = FB.makeAppSecretProof creds (Just token) + creds <- getCredentials + FB.addAppSecretProof creds (Just token) query @?= secretProofQ creds <> + query + describe "FQLTime" $ do + it "seems to work" $ do + let input = "[1348678357]" + output = FB.FQLTime (read "2012-09-26 16:52:37 UTC") + A.decode input @?= Just [output] + describe "FbUTCTime" $ do + let output = FB.FbUTCTime (read "2012-09-26 16:52:37 UTC") + it "seems to work (string)" $ do + let input = "[\"2012-09-26T16:52:37+0000\"]" + A.decode input @?= Just [output] + it "seems to work (unix epoch)" $ do + let input = "[1348678357]" + A.decode input @?= Just [output] + describe "FQLList" $ do + let j :: [Int] -> Maybe (FB.FQLList Int) + j = Just . FB.FQLList + it "parses []" $ do A.decode "[]" @?= j [] + it "parses {}" $ do A.decode "{}" @?= j [] + it "parses [1234]" $ do A.decode "[1234]" @?= j [1234] + it "parses {\"1234\": 1234}" $ do A.decode "{\"1234\": 1234}" @?= j [1234] + describe "FQLObject" $ do + let j :: [(Text, Int)] -> Maybe (FB.FQLObject (Map.Map Text Int)) + j = Just . FB.FQLObject . Map.fromList + it "parses []" $ do A.decode "[]" @?= j [] + it "parses {}" $ do A.decode "{}" @?= j [] + it "parses {\"abc\": 1234}" $ do + A.decode "{\"abc\": 1234}" @?= j [("abc", 1234)] + it "does not parse [1234]" $ do + A.decode "[1234]" @?= (Nothing `asTypeOf` j []) + describe "Id" $ do + it "can be parsed from a string" $ do + A.decode "[\"1234\"]" @?= Just [FB.Id "1234"] + it "can be parsed from an integer" $ do + A.decode "[1234]" @?= Just [FB.Id "1234"] + it "can be parsed from an object with a string" $ do + A.decode "{\"id\": \"1234\"}" @?= Just (FB.Id "1234") + it "can be parsed from an object with an integer" $ do + A.decode "{\"id\": 1234}" @?= Just (FB.Id "1234") + describe "AccessToken" $ do + it "can be round-tripped with ToJSON/FromJSON (UserKind)" $ do + A.eitherDecode (A.encode invalidUserAccessToken) @?= + Right invalidUserAccessToken + it "can be round-tripped with ToJSON/FromJSON (AppKind)" $ do + A.eitherDecode (A.encode invalidAppAccessToken) @?= + Right invalidAppAccessToken + describe "makeAppSecretProof" $ do + it "generates correct hmac" $ + let creds = FB.Credentials "name" "id" "secret" True + uToken = FB.UserAccessToken (FB.Id "user") "accesstoken" undefined + proof = FB.makeAppSecretProof creds $ Just uToken + expectedProof = + "65138b7ea24e641d38c91befa22b6281953980d1bfd0322956bc29959e1a910c" + in proof @?= [("appsecret_proof", expectedProof)] -- Wrappers for HUnit operators using MonadIO -(&?=) - :: (Eq a, Show a, MonadIO m) - => a -> a -> m () +(&?=) :: (Eq a, Show a, MonadIO m) => a -> a -> m () v &?= e = liftIO (v @?= e) -( #?= ) - :: (Eq a, Show a, MonadIO m) - => m a -> a -> m () +(#?=) :: (Eq a, Show a, MonadIO m) => m a -> a -> m () m #?= e = m >>= (&?= e) -- | Sad, orphan instance. @@ -516,8 +503,8 @@ -- | Perform an action with a new test user. Remove the new test user -- after the action is performed. -withTestUser - :: (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m) +withTestUser :: + (R.MonadResource m, R.MonadUnliftIO m, R.MonadThrow m) => FB.CreateTestUser -> (FB.TestUser -> FB.FacebookT FB.Auth m a) -> FB.FacebookT FB.Auth m a