diff --git a/fb.cabal b/fb.cabal --- a/fb.cabal +++ b/fb.cabal @@ -1,5 +1,5 @@ name: fb -version: 0.2.1 +version: 0.3 license: BSD3 license-file: LICENSE author: Felipe Lessa @@ -39,17 +39,20 @@ ghc-options: -Wall exposed-modules: Facebook - Facebook.OpenGraph other-modules: + Facebook.Types + Facebook.Monad Facebook.Base Facebook.Auth - Facebook.OpenGraph.Base + Facebook.Graph 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 + , transformers-base + , monad-control , conduit >= 0.1.1.1 && < 0.2 , http-types , http-conduit >= 1.2 && < 1.3 @@ -64,6 +67,10 @@ GADTs StandaloneDeriving ScopedTypeVariables + GeneralizedNewtypeDeriving + TypeFamilies + FlexibleInstances + MultiParamTypeClasses test-suite runtests @@ -74,7 +81,7 @@ build-depends: -- 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, + base, lifted-base, transformers, bytestring, http-conduit, text, time, aeson -- Test-only dependencies diff --git a/src/Facebook.hs b/src/Facebook.hs --- a/src/Facebook.hs +++ b/src/Facebook.hs @@ -1,7 +1,14 @@ module Facebook - ( -- * Authorization and Authentication + ( -- * @FacebookT@ monad transformer + FacebookT + , runFacebookT + , runNoAuthFacebookT + , Auth + , NoAuth + + -- * Authorization and Authentication -- ** Credentials - Credentials(..) + , Credentials(..) -- ** Access token , AccessToken(..) , AccessTokenData @@ -17,9 +24,17 @@ , getUserAccessTokenStep1 , getUserAccessTokenStep2 , extendUserAccessToken + + -- * Raw access to the Graph API + , getObject + , postObject + -- * Exceptions , FacebookException(..) ) where +import Facebook.Types +import Facebook.Monad import Facebook.Base import Facebook.Auth +import Facebook.Graph diff --git a/src/Facebook/Auth.hs b/src/Facebook/Auth.hs --- a/src/Facebook/Auth.hs +++ b/src/Facebook/Auth.hs @@ -27,22 +27,26 @@ import qualified Network.HTTP.Conduit as H import qualified Network.HTTP.Types as HT + +import Facebook.Types import Facebook.Base +import Facebook.Monad -- | Get an app access token from Facebook using your -- credentials. getAppAccessToken :: C.ResourceIO m => - Credentials - -> H.Manager - -> C.ResourceT m (AccessToken App) -getAppAccessToken creds manager = do - let req = fbreq "/oauth/access_token" Nothing $ - tsq creds [("grant_type", "client_credentials")] - response <- fbhttp req manager - H.responseBody response C.$$ - C.sinkParser (AppAccessToken <$ A.string "access_token=" - <*> A.takeByteString) + FacebookT Auth m (AccessToken App) +getAppAccessToken = + runResourceInFb $ do + creds <- getCreds + let req = fbreq "/oauth/access_token" Nothing $ + tsq creds [("grant_type", "client_credentials")] + response <- fbhttp req + lift $ + H.responseBody response C.$$ + C.sinkParser (AppAccessToken <$ A.string "access_token=" + <*> A.takeByteString) -- | The first step to get an user access token. Returns the @@ -55,7 +59,7 @@ -> Text getUserAccessTokenStep1 creds redirectUrl perms = T.concat $ "https://www.facebook.com/dialog/oauth?client_id=" - : TE.decodeUtf8 (clientId creds) + : TE.decodeUtf8 (appId creds) : "&redirect_uri=" : redirectUrl : (case perms of @@ -72,20 +76,19 @@ -- to this function that will complete the user authentication -- flow and give you an @'AccessToken' 'User'@. getUserAccessTokenStep2 :: C.ResourceIO m => - Credentials - -> RedirectUrl -- ^ Should be exactly the same + RedirectUrl -- ^ Should be exactly the same -- as in 'getUserAccessTokenStep1'. -> HT.SimpleQuery - -> H.Manager - -> C.ResourceT m (AccessToken User) -getUserAccessTokenStep2 creds redirectUrl query manager = + -> FacebookT Auth m (AccessToken User) +getUserAccessTokenStep2 redirectUrl query = case query of - [code@("code", _)] -> do - now <- liftIO getCurrentTime + [code@("code", _)] -> runResourceInFb $ do + now <- liftIO getCurrentTime + creds <- getCreds let req = fbreq "/oauth/access_token" Nothing $ tsq creds [code, ("redirect_uri", TE.encodeUtf8 redirectUrl)] - response <- fbhttp req manager - H.responseBody response C.$$ C.sinkParser (userAccessTokenParser now) + response <- fbhttp req + lift $ H.responseBody response C.$$ C.sinkParser (userAccessTokenParser now) _ -> let [error_, errorReason, errorDescr] = map (fromMaybe "" . flip lookup query) ["error", "error_reason", "error_description"] @@ -151,9 +154,8 @@ -- password, logged out from Facebook or blocked your app. isValid :: C.ResourceIO m => AccessToken kind - -> H.Manager - -> C.ResourceT m Bool -isValid token manager = do + -> FacebookT anyAuth m Bool +isValid token = do expired <- hasExpired token if expired then return False @@ -170,7 +172,7 @@ -- will actually work with user access tokens, -- too, but they have another, better way of -- being checked. - in httpCheck (fbreq page (Just token) []) manager + in httpCheck (fbreq page (Just token) []) -- | Extend the expiration time of an user access token (see @@ -180,26 +182,26 @@ -- 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 +extendUserAccessToken :: + C.ResourceIO m => + AccessToken User + -> FacebookT Auth m (Either FacebookException (AccessToken User)) +extendUserAccessToken token@(UserAccessToken data_ _) = do expired <- hasExpired token if expired then return (Left hasExpiredExc) else tryToExtend where - tryToExtend = do + tryToExtend = runResourceInFb $ do + creds <- getCreds let req = fbreq "/oauth/access_token" Nothing $ tsq creds [ ("grant_type", "fb_exchange_token") , ("fb_exchange_token", data_) ] - eresponse <- E.try (fbhttp req manager) + eresponse <- E.try (fbhttp req) case eresponse of Right response -> do now <- liftIO getCurrentTime either (Left . couldn'tParseExc) Right <$> - E.try (H.responseBody response C.$$ - C.sinkParser (userAccessTokenParser now)) + E.try (lift $ H.responseBody response C.$$ + C.sinkParser (userAccessTokenParser now)) Left exc -> return (Left exc) hasExpiredExc = diff --git a/src/Facebook/Base.hs b/src/Facebook/Base.hs --- a/src/Facebook/Base.hs +++ b/src/Facebook/Base.hs @@ -1,12 +1,5 @@ module Facebook.Base - ( Credentials(..) - , AccessToken(..) - , AccessTokenData - , accessTokenData - , accessTokenExpires - , User - , App - , fbreq + ( fbreq , ToSimpleQuery(..) , asJson , asJson' @@ -19,9 +12,7 @@ import Control.Monad (mzero) import Data.ByteString.Char8 (ByteString) import Data.Text (Text) -import Data.Time (UTCTime) -import Data.Typeable (Typeable, Typeable1) -import Network.HTTP.Types (Ascii) +import Data.Typeable (Typeable) import qualified Control.Exception.Lifted as E import qualified Data.Aeson as A @@ -33,62 +24,8 @@ import qualified Network.HTTP.Types as HT --- | Credentials that you get for your app when you register on --- Facebook. -data Credentials = - Credentials { clientId :: Ascii -- ^ Your application ID. - , clientSecret :: Ascii -- ^ Your application secret key. - } - deriving (Eq, Ord, Show, Typeable) - - --- | 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. --- --- There are two kinds of access tokens: --- --- [User access token] An access token obtained after an user --- accepts your application. Let's you access more information --- about that user and act on their behalf (depending on which --- permissions you've asked for). --- --- [App access token] An access token that allows you to take --- administrative actions for your application. --- --- These access tokens are distinguished by the phantom type on --- 'AccessToken', which can be 'User' or 'App'. -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 deriving (Typeable) - --- | Phantom type used mark an 'AccessToken' as an app access --- token. -data App deriving (Typeable) +import Facebook.Types +import Facebook.Monad -- | A plain 'H.Request' to a Facebook API. Use this instead of @@ -115,8 +52,8 @@ tsq _ = id instance ToSimpleQuery Credentials where - tsq creds = (:) ("client_id", clientId creds) . - (:) ("client_secret", clientSecret creds) + tsq creds = (:) ("client_id", appId creds) . + (:) ("client_secret", appSecret creds) instance ToSimpleQuery (AccessToken kind) where tsq token = (:) ("access_token", accessTokenData token) @@ -126,9 +63,9 @@ -- response with a JSON value. asJson :: (C.ResourceThrow m, C.IsSource bsrc, A.FromJSON a) => H.Response (bsrc m ByteString) - -> C.ResourceT m (H.Response a) + -> FacebookT anyAuth (C.ResourceT m) (H.Response a) asJson (H.Response status headers body) = do - val <- body C.$$ C.sinkParser A.json' + val <- lift $ body C.$$ C.sinkParser A.json' case A.fromJSON val of A.Success r -> return (H.Response status headers r) A.Error str -> @@ -141,7 +78,7 @@ -- | Same as 'asJson', but returns only the JSON value. asJson' :: (C.ResourceThrow m, C.IsSource bsrc, A.FromJSON a) => H.Response (bsrc m ByteString) - -> C.ResourceT m a + -> FacebookT anyAuth (C.ResourceT m) a asJson' = fmap H.responseBody . asJson @@ -169,11 +106,11 @@ -- meaningful 'FacebookException'@s@. fbhttp :: C.ResourceIO m => H.Request m - -> H.Manager - -> C.ResourceT m (H.Response (C.Source m ByteString)) -fbhttp req manager = do + -> FacebookT anyAuth (C.ResourceT m) (H.Response (C.Source m ByteString)) +fbhttp req = do + manager <- getManager let req' = req { H.checkStatus = \_ _ -> Nothing } - response@(H.Response status headers _) <- H.http req' manager + response@(H.Response status headers _) <- lift (H.http req' manager) if isOkay status then return response else do @@ -205,12 +142,12 @@ -- code is 2XX (returns @True@) or not (returns @False@). httpCheck :: C.ResourceIO m => H.Request m - -> H.Manager - -> C.ResourceT m Bool -httpCheck req manager = do + -> FacebookT anyAuth m Bool +httpCheck req = runResourceInFb $ do + manager <- getManager let req' = req { H.method = HT.methodHead , H.checkStatus = \_ _ -> Nothing } - H.Response status _ _ <- H.httpLbs req' manager + H.Response status _ _ <- lift (H.httpLbs req' manager) return $! isOkay status -- Yes, we use httpLbs above so that we don't have to worry -- about consuming the responseBody. Note that the diff --git a/src/Facebook/Graph.hs b/src/Facebook/Graph.hs new file mode 100644 --- /dev/null +++ b/src/Facebook/Graph.hs @@ -0,0 +1,48 @@ +module Facebook.Graph + ( getObject + , postObject + ) where + + +-- import Control.Applicative +-- import Control.Monad (mzero) +-- import Data.ByteString.Char8 (ByteString) +-- import Data.Text (Text) +-- import Data.Typeable (Typeable, Typeable1) +import Network.HTTP.Types (Ascii) + +-- import qualified Control.Exception.Lifted as E +import qualified Data.Aeson as A +import qualified Data.Conduit as C +-- import qualified Data.Text as T +import qualified Network.HTTP.Conduit as H +import qualified Network.HTTP.Types as HT + + +import Facebook.Types +import Facebook.Monad +import Facebook.Base + + +-- | Make a raw @GET@ request to Facebook's Graph API. Returns a +-- raw JSON 'A.Value'. +getObject :: C.ResourceIO m => + Ascii -- ^ Path (should begin with a slash @\/@) + -> HT.SimpleQuery -- ^ Arguments to be passed to Facebook + -> Maybe (AccessToken kind) -- ^ Optional access token + -> FacebookT anyAuth m A.Value +getObject path query mtoken = + runResourceInFb $ + asJson' =<< fbhttp (fbreq path mtoken query) + + +-- | Make a raw @POST@ request to Facebook's Graph API. Returns +-- a raw JSON 'A.Value'. +postObject :: C.ResourceIO m => + Ascii -- ^ Path (should begin with a slash @\/@) + -> HT.SimpleQuery -- ^ Arguments to be passed to Facebook + -> AccessToken kind -- ^ Access token + -> FacebookT Auth m A.Value +postObject path query token = + runResourceInFb $ + asJson' =<< fbhttp (fbreq path (Just token) query) { H.method = HT.methodPost } diff --git a/src/Facebook/Monad.hs b/src/Facebook/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Facebook/Monad.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE UndecidableInstances #-} +module Facebook.Monad + ( FacebookT + , Auth + , NoAuth + , runFacebookT + , runNoAuthFacebookT + , getCreds + , getManager + , runResourceInFb + + -- * Re-export + , lift + ) where + +import Control.Applicative (Applicative, Alternative) +import Control.Monad (MonadPlus, liftM) +import Control.Monad.Base (MonadBase(..)) +import Control.Monad.Fix (MonadFix) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Trans.Class (MonadTrans(lift)) +import Control.Monad.Trans.Control ( MonadTransControl(..), MonadBaseControl(..) + , ComposeSt, defaultLiftBaseWith + , defaultRestoreM ) +import Control.Monad.Trans.Reader (ReaderT(..), ask) +import Data.Typeable (Typeable) + +import qualified Data.Conduit as C +import qualified Network.HTTP.Conduit as H + +import Facebook.Types + + +-- | @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 } + deriving ( Functor, Applicative, Alternative, Monad + , MonadFix, MonadPlus, MonadIO, MonadTrans ) + +instance MonadBase b m => MonadBase b (FacebookT auth m) where + liftBase = lift . liftBase + +instance MonadTransControl (FacebookT auth) where + newtype StT (FacebookT auth) a = FbStT { unFbStT :: StT (ReaderT FbData) a } + liftWith f = F $ liftWith (\run -> f (liftM FbStT . run . unF)) + restoreT = F . restoreT . liftM unFbStT + +instance MonadBaseControl b m => MonadBaseControl b (FacebookT auth m) where + newtype StM (FacebookT auth m) a = StMT {unStMT :: ComposeSt (FacebookT auth) m a} + liftBaseWith = defaultLiftBaseWith StMT + restoreM = defaultRestoreM unStMT + +-- | Phantom type stating that you have provided your +-- 'Credentials' and thus have access to the whole API. +data Auth deriving (Typeable) + +-- | Phantom type stating that you have /not/ provided your +-- 'Credentials'. This means that you'll be limited about which +-- APIs you'll be able use. +data NoAuth deriving (Typeable) + +-- | Internal data kept inside 'FacebookT'. +data FbData = FbData { fbdCreds :: Credentials -- ^ Can be 'undefined'! + , fbdManager :: !H.Manager } + deriving (Typeable) + + +-- | Run a computation in the 'FacebookT' monad transformer with +-- your credentials. +runFacebookT :: 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) + +-- | Run a computation in the 'FacebookT' monad without +-- credentials. +runNoAuthFacebookT :: H.Manager -> FacebookT NoAuth m a -> m a +runNoAuthFacebookT manager (F act) = runReaderT act (FbData creds manager) + where creds = error "runNoAuthFacebookT: never here, serious bug" + + +-- | Get the user's credentials. +getCreds :: Monad m => FacebookT Auth m Credentials +getCreds = fbdCreds `liftM` F ask + +-- | Get the 'H.Manager'. +getManager :: Monad m => FacebookT anyAuth m H.Manager +getManager = fbdManager `liftM` F ask + + +-- | Run a 'ResourceT' inside a 'FacebookT'. +runResourceInFb :: C.Resource m => + FacebookT anyAuth (C.ResourceT m) a + -> FacebookT anyAuth m a +runResourceInFb (F inner) = F $ ask >>= lift . C.runResourceT . runReaderT inner diff --git a/src/Facebook/OpenGraph.hs b/src/Facebook/OpenGraph.hs deleted file mode 100644 --- a/src/Facebook/OpenGraph.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Facebook.OpenGraph - ( -- * Raw interface to Facebook's Open Graph API - getObject - ) where - -import Facebook.OpenGraph.Base diff --git a/src/Facebook/OpenGraph/Base.hs b/src/Facebook/OpenGraph/Base.hs deleted file mode 100644 --- a/src/Facebook/OpenGraph/Base.hs +++ /dev/null @@ -1,33 +0,0 @@ -module Facebook.OpenGraph.Base - ( getObject - ) where - - --- import Control.Applicative --- import Control.Monad (mzero) --- import Data.ByteString.Char8 (ByteString) --- import Data.Text (Text) --- import Data.Typeable (Typeable, Typeable1) -import Network.HTTP.Types (Ascii) - --- import qualified Control.Exception.Lifted as E -import qualified Data.Aeson as A -import qualified Data.Conduit as C --- import qualified Data.Text as T -import qualified Network.HTTP.Conduit as H -import qualified Network.HTTP.Types as HT - - -import Facebook.Base - - --- | Make a raw request to Facebook's Open Graph API. Returns a --- raw JSON 'A.Value'. -getObject :: C.ResourceIO m => - Ascii -- ^ Path (should begin with a slash @\/@) - -> HT.SimpleQuery -- ^ Arguments to be passed to Facebook - -> Maybe (AccessToken kind) -- ^ Optional access token - -> H.Manager -- ^ HTTP connection manager. - -> C.ResourceT m A.Value -getObject path query mtoken manager = - asJson' =<< fbhttp (fbreq path mtoken query) manager diff --git a/src/Facebook/Types.hs b/src/Facebook/Types.hs new file mode 100644 --- /dev/null +++ b/src/Facebook/Types.hs @@ -0,0 +1,72 @@ +module Facebook.Types + ( Credentials(..) + , AccessToken(..) + , AccessTokenData + , accessTokenData + , accessTokenExpires + , User + , App + ) where + +import Data.Time (UTCTime) +import Data.Typeable (Typeable, Typeable1) +import Network.HTTP.Types (Ascii) + + +-- | Credentials that you get for your app when you register on +-- Facebook. +data Credentials = + Credentials { appName :: Ascii -- ^ Your application name (e.g. for OpenGraph calls). + , appId :: Ascii -- ^ Your application ID. + , appSecret :: Ascii -- ^ Your application secret key. + } + deriving (Eq, Ord, Show, Typeable) + + +-- | 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. +-- +-- There are two kinds of access tokens: +-- +-- [User access token] An access token obtained after an user +-- accepts your application. Let's you access more information +-- about that user and act on their behalf (depending on which +-- permissions you've asked for). +-- +-- [App access token] An access token that allows you to take +-- administrative actions for your application. +-- +-- These access tokens are distinguished by the phantom type on +-- 'AccessToken', which can be 'User' or 'App'. +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 deriving (Typeable) + +-- | Phantom type used mark an 'AccessToken' as an app access +-- token. +data App deriving (Typeable) diff --git a/tests/runtests.hs b/tests/runtests.hs --- a/tests/runtests.hs +++ b/tests/runtests.hs @@ -2,6 +2,7 @@ import Control.Applicative import Control.Monad.IO.Class (MonadIO(liftIO)) +import Control.Monad.Trans.Class (lift) import Data.Text (Text) import Data.Time (parseTime) import System.Environment (getEnv) @@ -12,13 +13,10 @@ import qualified Data.Aeson.Types as A import qualified Data.ByteString.Char8 as B import qualified Control.Exception.Lifted as E -import qualified Data.Conduit as C import qualified Facebook as FB -import qualified Facebook.OpenGraph as FBOG import qualified Network.HTTP.Conduit as H -import Test.HUnit -import Test.Hspec.Core (Example(..)) +import qualified Test.HUnit as HU import Test.Hspec.Monadic -- import Test.Hspec.QuickCheck import Test.Hspec.HUnit () @@ -29,8 +27,8 @@ getCredentials = tryToGet `E.catch` showHelp where tryToGet = do - [appId, appSecret] <- mapM getEnv ["APP_ID", "APP_SECRET"] - return $ FB.Credentials (B.pack appId) (B.pack appSecret) + [appName, appId, appSecret] <- mapM getEnv ["APP_NAME", "APP_ID", "APP_SECRET"] + return $ FB.Credentials (B.pack appName) (B.pack appId) (B.pack appSecret) showHelp exc | not (isDoesNotExistError exc) = E.throw exc showHelp _ = do @@ -41,14 +39,15 @@ , "create a Facebook app for this purpose and then distribute" , "its secret keys in the open." , "" - , "Please give your app id and app secret on the enviroment" - , "variables APP_ID and APP_SECRET, respectively. For example," - , "before running the test you could run in the shell:" + , "Please give your app's name, id and secret on the enviroment" + , "variables APP_NAME, APP_ID and APP_SECRET, respectively. " + , "For example, before running the test you could run in the shell:" , "" + , " $ export APP_NAME=\"example\"" , " $ export APP_ID=\"458798571203498\"" , " $ export APP_SECRET=\"28a9d0fa4272a14a9287f423f90a48f2304\"" , "" - , "Of course, the values above aren't valid and you need to" + , "Of course, these values above aren't valid and you need to" , "replace them with your own." , "" , "(Exiting now with a failure code.)"] @@ -56,7 +55,7 @@ invalidCredentials :: FB.Credentials -invalidCredentials = FB.Credentials "not" "valid" +invalidCredentials = FB.Credentials "this" "isn't" "valid" invalidUserAccessToken :: FB.AccessToken FB.User invalidUserAccessToken = FB.UserAccessToken "invalid" farInTheFuture @@ -73,39 +72,47 @@ main :: IO () main = H.withManager $ \manager -> liftIO $ do creds <- getCredentials + let runAuth :: FB.FacebookT FB.Auth IO a -> IO a + runAuth = FB.runFacebookT creds manager + runNoAuth :: FB.FacebookT FB.NoAuth IO a -> IO a + runNoAuth = FB.runNoAuthFacebookT manager hspecX $ do describe "Facebook.getAppAccessToken" $ do - it "works and returns a valid app access token" $ do - token <- FB.getAppAccessToken creds manager - valid <- FB.isValid token manager - 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 () + 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" $ + FB.runFacebookT invalidCredentials manager $ do + ret <- E.try $ FB.getAppAccessToken + case ret of + Right token -> fail $ show token + Left (_ :: FB.FacebookException) -> lift (return () :: IO ()) describe "Facebook.isValid" $ do - 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) + 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 "Facebook.OpenGraph.getObject" $ do - it "is able to fetch Facebook's own page" $ do - A.Object obj <- FBOG.getObject "/19292868552" [] Nothing manager - let Just r = flip A.parseMaybe () $ const $ - (,,) <$> obj A..:? "id" - <*> obj A..:? "website" - <*> obj A..:? "name" - just x = Just (x :: Text) - liftIO $ r @?= ( just "19292868552" - , just "http://developers.facebook.com" - , just "Facebook Platform" ) + it "is able to fetch Facebook's own page" $ + runNoAuth $ do + A.Object obj <- FB.getObject "/19292868552" [] Nothing + let Just r = flip A.parseMaybe () $ const $ + (,,) <$> obj A..:? "id" + <*> obj A..:? "website" + <*> obj A..:? "name" + just x = Just (x :: Text) + r @?= ( just "19292868552" + , just "http://developers.facebook.com" + , just "Facebook Platform" ) --- | Sad, orphan instance. -instance (m ~ IO, r ~ ()) => Example (C.ResourceT m r) where - evaluateExample = evaluateExample . C.runResourceT +-- Wrappers for HUnit operators using MonadIO + +(@?=) :: (Eq a, Show a, MonadIO m) => a -> a -> m () +v @?= e = liftIO (v HU.@?= e) + +(#?=) :: (Eq a, Show a, MonadIO m) => m a -> a -> m () +m #?= e = m >>= (@?= e)