diff --git a/example.hs b/example.hs new file mode 100644 --- /dev/null +++ b/example.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE OverloadedStrings #-} + +import qualified Facebook as FB + +import Network.HTTP.Conduit (withManager) +import Control.Monad.IO.Class (liftIO) + +main :: IO () +main = do + withManager $ \manager -> do + FB.runNoAuthFacebookT manager $ do + u <- FB.getUser "zuck" [] Nothing + liftIO $ print (FB.userName u) diff --git a/fb.cabal b/fb.cabal --- a/fb.cabal +++ b/fb.cabal @@ -1,5 +1,5 @@ name: fb -version: 0.7.5 +version: 0.8 license: BSD3 license-file: LICENSE author: Felipe Lessa @@ -27,6 +27,7 @@ extra-source-files: tests/runtests.hs + example.hs source-repository head @@ -52,14 +53,14 @@ , lifted-base >= 0.1 && < 0.2 , bytestring >= 0.9 && < 0.10 , text >= 0.11 && < 0.12 - , transformers >= 0.2 && < 0.3 + , transformers >= 0.2 && < 0.4 , transformers-base , monad-control - , conduit >= 0.2 && < 0.3 + , conduit >= 0.4 && < 0.5 , http-types - , http-conduit >= 1.2 && < 1.3 + , http-conduit >= 1.4 && < 1.5 , attoparsec >= 0.10 && < 0.11 - , attoparsec-conduit >= 0.2 && < 0.3 + , attoparsec-conduit >= 0.4 && < 0.5 , aeson >= 0.5 && < 0.7 , time >= 1.2 && < 1.5 , old-locale @@ -85,12 +86,12 @@ -- Library dependencies used on the tests. No need to -- specify versions since they'll use the same as above. base, lifted-base, transformers, bytestring, - http-conduit, text, time, aeson + conduit, http-conduit, text, time, aeson -- Test-only dependencies , HUnit , QuickCheck - , hspec >= 0.9.1 && < 0.10 + , hspec >= 0.9.1 && < 1.1 , fb extensions: TypeFamilies diff --git a/src/Facebook/Auth.hs b/src/Facebook/Auth.hs --- a/src/Facebook/Auth.hs +++ b/src/Facebook/Auth.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts, GADTs, ScopedTypeVariables, OverloadedStrings #-} module Facebook.Auth ( getAppAccessToken , getUserAccessTokenStep1 @@ -13,6 +14,7 @@ import Control.Applicative import Control.Monad (join) import Control.Monad.IO.Class (MonadIO(liftIO)) +import Control.Monad.Trans.Control (MonadBaseControl) import Data.Aeson ((.:)) import Data.Aeson.Types (parseEither) import Data.Maybe (fromMaybe) @@ -41,7 +43,7 @@ -- | Get an app access token from Facebook using your -- credentials. -getAppAccessToken :: C.ResourceIO m => +getAppAccessToken :: (C.MonadResource m, MonadBaseControl IO m) => FacebookT Auth m AppAccessToken getAppAccessToken = runResourceInFb $ do @@ -86,7 +88,7 @@ -- 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 :: C.ResourceIO m => +getUserAccessTokenStep2 :: (MonadBaseControl IO m, C.MonadResource m) => RedirectUrl -- ^ Should be exactly the same -- as in 'getUserAccessTokenStep1'. -> [Argument] -- ^ Query parameters. @@ -211,7 +213,7 @@ -- 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 :: C.ResourceIO m => +isValid :: (MonadBaseControl IO m, C.MonadResource m) => AccessToken anyKind -> FacebookT anyAuth m Bool isValid token = do @@ -241,10 +243,9 @@ -- 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 => - UserAccessToken - -> FacebookT Auth m (Either FacebookException UserAccessToken) +extendUserAccessToken :: (MonadBaseControl IO m, C.MonadResource m) => + UserAccessToken + -> FacebookT Auth m (Either FacebookException UserAccessToken) extendUserAccessToken token@(UserAccessToken _ data_ _) = do expired <- hasExpired token if expired then return (Left hasExpiredExc) else tryToExtend diff --git a/src/Facebook/Base.hs b/src/Facebook/Base.hs --- a/src/Facebook/Base.hs +++ b/src/Facebook/Base.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, OverloadedStrings #-} module Facebook.Base ( fbreq , ToSimpleQuery(..) @@ -15,6 +16,7 @@ import Data.Typeable (Typeable) import qualified Control.Exception.Lifted as E +import Control.Monad.Trans.Control (MonadBaseControl) import qualified Data.Aeson as A import qualified Data.Attoparsec.Char8 as AT import qualified Data.ByteString as B @@ -71,9 +73,9 @@ -- | Converts a plain 'H.Response' coming from 'H.http' into a -- JSON value. -asJson :: (C.ResourceThrow m, C.IsSource bsrc, A.FromJSON a) => - H.Response (bsrc m ByteString) - -> FacebookT anyAuth (C.ResourceT m) a +asJson :: (C.MonadThrow m, A.FromJSON a) => + H.Response (C.Source m ByteString) + -> FacebookT anyAuth m a asJson response = do val <- lift $ H.responseBody response C.$$ C.sinkParser A.json' case A.fromJSON val of @@ -84,14 +86,14 @@ , " Facebook's response as a JSON value (" , T.pack str, ")" ] + -- | Converts a plain 'H.Response' into a string 'ByteString'. -asBS :: (C.ResourceThrow m, C.IsSource bsrc) => - H.Response (bsrc m ByteString) - -> FacebookT anyAuth (C.ResourceT m) ByteString +asBS :: (Monad m) => + H.Response (C.Source m ByteString) + -> FacebookT anyAuth m ByteString asBS response = lift $ H.responseBody response C.$$ fmap B.concat CL.consume - -- | An exception that may be thrown by functions on this -- package. Includes any information provided by Facebook. data FacebookException = @@ -114,13 +116,13 @@ -- | Same as 'H.http', but tries to parse errors and throw -- meaningful 'FacebookException'@s@. -fbhttp :: C.ResourceIO m => +fbhttp :: (MonadBaseControl IO m, C.MonadResource m) => H.Request m - -> FacebookT anyAuth (C.ResourceT m) (H.Response (C.Source m ByteString)) + -> FacebookT anyAuth m (H.Response (C.Source m ByteString)) fbhttp req = do manager <- getManager let req' = req { H.checkStatus = \_ _ -> Nothing } - response@(H.Response status headers _) <- lift (H.http req' manager) + response@(H.Response status _ headers _) <- lift (H.http req' manager) if isOkay status then return response else do @@ -150,14 +152,15 @@ -- | Send a @HEAD@ request just to see if the resposne status -- code is 2XX (returns @True@) or not (returns @False@). -httpCheck :: C.ResourceIO m => - H.Request m +httpCheck :: (MonadBaseControl IO m, C.MonadResource m) => + H.Request (C.ResourceT m) -> FacebookT anyAuth m Bool + httpCheck req = runResourceInFb $ do manager <- getManager let req' = req { H.method = HT.methodHead , H.checkStatus = \_ _ -> Nothing } - H.Response status _ _ <- lift (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 --- a/src/Facebook/Graph.hs +++ b/src/Facebook/Graph.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, OverloadedStrings #-} module Facebook.Graph ( getObject , postObject @@ -6,6 +7,7 @@ import Control.Applicative +import Control.Monad.Trans.Control (MonadBaseControl) -- import Control.Monad (mzero) -- import Data.ByteString.Char8 (ByteString) -- import Data.Text (Text) @@ -27,7 +29,7 @@ -- | Make a raw @GET@ request to Facebook's Graph API. Returns a -- raw JSON 'A.Value'. -getObject :: (C.ResourceIO m, A.FromJSON a) => +getObject :: (C.MonadResource m, MonadBaseControl IO m, A.FromJSON a) => Ascii -- ^ Path (should begin with a slash @\/@) -> [Argument] -- ^ Arguments to be passed to Facebook -> Maybe (AccessToken anyKind) -- ^ Optional access token @@ -39,7 +41,7 @@ -- | Make a raw @POST@ request to Facebook's Graph API. Returns -- a raw JSON 'A.Value'. -postObject :: (C.ResourceIO m, A.FromJSON a) => +postObject :: (C.MonadResource m, MonadBaseControl IO m, A.FromJSON a) => Ascii -- ^ Path (should begin with a slash @\/@) -> [Argument] -- ^ Arguments to be passed to Facebook -> AccessToken anyKind -- ^ Access token diff --git a/src/Facebook/Monad.hs b/src/Facebook/Monad.hs --- a/src/Facebook/Monad.hs +++ b/src/Facebook/Monad.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeFamilies, UndecidableInstances #-} module Facebook.Monad ( FacebookT , Auth @@ -127,7 +127,7 @@ -- | Run a 'ResourceT' inside a 'FacebookT'. -runResourceInFb :: C.Resource m => +runResourceInFb :: (C.MonadResource m, MonadBaseControl IO 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/Object/User.hs b/src/Facebook/Object/User.hs --- a/src/Facebook/Object/User.hs +++ b/src/Facebook/Object/User.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, OverloadedStrings #-} module Facebook.Object.User ( User(..) , Gender(..) @@ -6,6 +7,7 @@ import Control.Applicative import Control.Monad (mzero) +import Control.Monad.Trans.Control (MonadBaseControl) import Data.Aeson ((.:), (.:?)) -- import Data.ByteString.Char8 (ByteString) import Data.Text (Text) @@ -78,7 +80,7 @@ -- back by Facebook. The user ID may be @\"me\"@, in which -- case you must provide an user access token and information -- about the token's owner is given. -getUser :: C.ResourceIO m => +getUser :: (C.MonadResource m, MonadBaseControl IO m) => UserId -- ^ User ID or @\"me\"@. -> [Argument] -- ^ Arguments to be passed to Facebook. -> Maybe UserAccessToken -- ^ Optional user access token. diff --git a/src/Facebook/OpenGraph.hs b/src/Facebook/OpenGraph.hs --- a/src/Facebook/OpenGraph.hs +++ b/src/Facebook/OpenGraph.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts, OverloadedStrings #-} module Facebook.OpenGraph ( createAction , Action(..) @@ -7,6 +8,7 @@ -- import Control.Applicative import Control.Arrow (first) +import Control.Monad.Trans.Control (MonadBaseControl) -- import Control.Monad (mzero) -- import Data.ByteString.Char8 (ByteString) import Data.Function (on) @@ -43,7 +45,7 @@ -- > [ "recipe" #= "http://example.com/cookie.html" -- > , "when" #= now ] -- > token -createAction :: C.ResourceIO m => +createAction :: (C.MonadResource m, MonadBaseControl IO m) => Action -- ^ Action kind to be created. -> [Argument] -- ^ Arguments of the action. -> Maybe AppAccessToken @@ -55,7 +57,7 @@ -> FacebookT Auth m Id createAction (Action action) query mapptoken usertoken = do creds <- getCreds - let post :: C.ResourceIO m => Ascii -> AccessToken anyKind -> FacebookT Auth m Id + let post :: (C.MonadResource m, MonadBaseControl IO m) => Ascii -> AccessToken anyKind -> FacebookT Auth m Id post prepath = postObject (prepath <> appName creds <> ":" <> action) query case mapptoken of Nothing -> post "/me/" usertoken diff --git a/src/Facebook/Types.hs b/src/Facebook/Types.hs --- a/src/Facebook/Types.hs +++ b/src/Facebook/Types.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable, GADTs, StandaloneDeriving #-} module Facebook.Types ( Credentials(..) , AccessToken(..) diff --git a/tests/runtests.hs b/tests/runtests.hs --- a/tests/runtests.hs +++ b/tests/runtests.hs @@ -13,6 +13,7 @@ import qualified Data.Aeson as A import qualified Data.Aeson.Types as A +import qualified Data.Conduit as C import qualified Data.ByteString.Char8 as B import qualified Data.Text as T import qualified Data.Text.Encoding as TE @@ -82,21 +83,21 @@ -- Run the tests twice, once in Facebook's production tier... facebookTests "Production tier: " manager - (FB.runFacebookT creds manager) - (FB.runNoAuthFacebookT manager) + (C.runResourceT . FB.runFacebookT creds manager) + (C.runResourceT . FB.runNoAuthFacebookT manager) -- ...and the other in Facebook's beta tier. facebookTests "Beta tier: " manager - (FB.beta_runFacebookT creds manager) - (FB.beta_runNoAuthFacebookT manager) + (C.runResourceT . FB.beta_runFacebookT creds manager) + (C.runResourceT . FB.beta_runNoAuthFacebookT manager) -- Tests that don't depend on which tier is chosen. libraryTests facebookTests :: String -> H.Manager - -> (forall a. FB.FacebookT FB.Auth IO a -> IO a) - -> (forall a. FB.FacebookT FB.NoAuth IO a -> IO a) + -> (forall a. FB.FacebookT FB.Auth (C.ResourceT IO) a -> IO a) + -> (forall a. FB.FacebookT FB.NoAuth (C.ResourceT IO) a -> IO a) -> Specs facebookTests pretitle manager runAuth runNoAuth = do let describe' = describe . (pretitle ++) @@ -106,11 +107,12 @@ token <- FB.getAppAccessToken FB.isValid token #?= True it "throws a FacebookException on invalid credentials" $ + C.runResourceT $ FB.runFacebookT invalidCredentials manager $ do ret <- E.try $ FB.getAppAccessToken case ret of Right token -> fail $ show token - Left (_ :: FB.FacebookException) -> lift (return () :: IO ()) + Left (_ :: FB.FacebookException) -> lift $ lift (return () :: IO ()) describe' "isValid" $ do it "returns False on a clearly invalid user access token" $