diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2012, Felipe Lessa + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Felipe Lessa nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/fb.cabal b/fb.cabal new file mode 100644 --- /dev/null +++ b/fb.cabal @@ -0,0 +1,80 @@ +name: fb +version: 0.1 +license: BSD3 +license-file: LICENSE +author: Felipe Lessa +maintainer: Felipe Lessa +synopsis: Bindings to Facebook's API. +category: Web +stability: Experimental +cabal-version: >= 1.8 +build-type: Simple +homepage: https://github.com/meteficha/facebook + +description: + This package exports bindings to Facebook's APIs (see + ). Does not have any external + dependencies and tries to use as little resources (such as + memory, sockets and CPU) as possible by using packages such as + @aeson@, @attoparsec@, @bytestring@, @conduit@, @http-conduit@, + @text@ and others. + . + While we would like to have a complete binding to Facebook's + API, this package is being developed on demand. If you need + something that has not been implemented yet, please send a pull + request or file an issue on GitHub + (). + +extra-source-files: + tests/runtests.hs + + +source-repository head + type: git + location: git://github.com/meteficha/fb.git + + +library + hs-source-dirs: src + ghc-options: -Wall + exposed-modules: + Facebook + other-modules: + Facebook.Base + Facebook.Auth + build-depends: + base >= 4 && < 5 + , lifted-base >= 0.1 && < 0.2 + , bytestring >= 0.9 && < 0.10 + , text >= 0.11 && < 0.12 + , transformers >= 0.2 && < 0.3 + , conduit >= 0.0 && < 0.2 + , http-types + , http-conduit >= 1.1 && < 1.2 + , attoparsec >= 0.10 && < 0.11 + , attoparsec-conduit >= 0.0 && < 0.1 + , aeson >= 0.5 && < 0.6 + , time >= 1.2 && < 1.5 + extensions: + DeriveDataTypeable + EmptyDataDecls + OverloadedStrings + + +test-suite runtests + type: exitcode-stdio-1.0 + ghc-options: -Wall -fno-warn-orphans + hs-source-dirs: tests + main-is: runtests.hs + 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, + http-conduit + + -- Test-only dependencies + , HUnit + , hspec == 0.9.* + , fb + extensions: + TypeFamilies diff --git a/src/Facebook.hs b/src/Facebook.hs new file mode 100644 --- /dev/null +++ b/src/Facebook.hs @@ -0,0 +1,23 @@ +module Facebook + ( -- * Authorization and Authentication + -- ** Credentials + Credentials(..) + -- ** Access token + , AccessToken(..) + , hasExpired + , isValid + -- ** App access token + , App + , getAppAccessToken + -- ** User access token + , User + , RedirectUrl + , Permission + , getUserAccessTokenStep1 + , getUserAccessTokenStep2 + -- * Exceptions + , FacebookException(..) + ) where + +import Facebook.Base +import Facebook.Auth diff --git a/src/Facebook/Auth.hs b/src/Facebook/Auth.hs new file mode 100644 --- /dev/null +++ b/src/Facebook/Auth.hs @@ -0,0 +1,157 @@ +module Facebook.Auth + ( getAppAccessToken + , getUserAccessTokenStep1 + , getUserAccessTokenStep2 + , RedirectUrl + , Permission + , hasExpired + , isValid + ) where + +import Control.Applicative +import Control.Monad.IO.Class (MonadIO(liftIO)) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Data.Time (getCurrentTime, addUTCTime) +import Data.String (IsString(..)) + +import qualified Control.Exception.Lifted as E +import qualified Data.Attoparsec.Char8 as A +import qualified Data.Conduit as C +import qualified Data.Conduit.Attoparsec as C +import qualified Data.List as L +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Text.Encoding.Error as TE +import qualified Network.HTTP.Conduit as H +import qualified Network.HTTP.Types as HT + +import Facebook.Base + + +-- | 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 (AccessToken <$ A.string "access_token=" + <*> A.takeByteString + <*> pure Nothing) + + +-- | The first step to get an user access token. Returns the +-- 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 :: Credentials + -> RedirectUrl + -> [Permission] + -> Text +getUserAccessTokenStep1 creds redirectUrl perms = + T.concat $ "https://www.facebook.com/dialog/oauth?client_id=" + : TE.decodeUtf8 (clientId 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, +-- then they'll be redirected back to the 'RedirectUrl' you've +-- passed to 'getUserAccessTokenStep1'. You should take the +-- request query parameters passed to your 'RedirectUrl' and give +-- 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 + -- as in 'getUserAccessTokenStep1'. + -> HT.SimpleQuery + -> H.Manager + -> C.ResourceT m (AccessToken User) +getUserAccessTokenStep2 creds redirectUrl query manager = + case query of + [code@("code", _)] -> do + now <- liftIO getCurrentTime + let req = fbreq "/oauth/access_token" Nothing $ + tsq creds [code, ("redirect_uri", TE.encodeUtf8 redirectUrl)] + let toExpire i = Just (addUTCTime (fromIntegral (i :: Int)) now) + response <- fbhttp req manager + H.responseBody response C.$$ + C.sinkParser (AccessToken <$ A.string "access_token=" + <*> A.takeWhile (/= '?') + <* A.string "&expires=" + <*> (toExpire <$> A.decimal) + <* A.endOfInput) + _ -> let [error_, errorReason, errorDescr] = + map (fromMaybe "" . flip lookup query) + ["error", "error_reason", "error_description"] + errorType = T.concat [t error_, " (", t errorReason, ")"] + t = TE.decodeUtf8With TE.lenientDecode + in E.throw $ FacebookException errorType (t errorDescr) + + +-- | URL where the user is redirected to after Facebook +-- authenticates the user authorizes your application. This URL +-- should be inside the domain registered for your Facebook +-- application. +type RedirectUrl = Text + + +-- | A permission that is asked for the user when he authorizes +-- your app. Please refer to Facebook's documentation at +-- +-- to see which permissions are available. +-- +-- This is a @newtype@ of 'Text' that supports only 'IsString'. +-- This means that to create a 'Permission' you should use the +-- @OverloadedStrings@ language extension. For example, +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > +-- > perms :: [Permission] +-- > perms = ["user_about_me", "email", "offline_access"] +newtype Permission = Permission { unPermission :: Text } + +instance Show Permission where + show = show . unPermission + +instance IsString Permission where + fromString = Permission . fromString + + +-- | @True@ if the access token has expired, otherwise @False@. +hasExpired :: (Functor m, MonadIO m) => AccessToken kind -> m Bool +hasExpired token = + case accessTokenExpires token of + Nothing -> return False + Just expTime -> (>= expTime) <$> liftIO getCurrentTime + + +-- | @True@ if the access token is valid. An expired access +-- token is not valid (see 'hasExpired'). However, a non-expired +-- 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 => + AccessToken kind + -> H.Manager + -> C.ResourceT m Bool +isValid token manager = do + expired <- hasExpired token + if expired + then return False + else httpCheck (fbreq "/19292868552" (Just token) []) manager + -- This is Facebook's own page. While using an access token + -- to access it shouldn't do much difference on most cases, + -- when the access token is invalid a "400 Bad Request" + -- status code is returned regardless. diff --git a/src/Facebook/Base.hs b/src/Facebook/Base.hs new file mode 100644 --- /dev/null +++ b/src/Facebook/Base.hs @@ -0,0 +1,201 @@ +module Facebook.Base + ( Credentials(..) + , AccessToken(..) + , User + , App + , fbreq + , ToSimpleQuery(..) + , asJson + , asJson' + , FacebookException(..) + , fbhttp + , httpCheck + ) where + +import Control.Applicative +import Control.Monad (mzero) +import Data.ByteString.Char8 (ByteString) +import Data.Text (Text) +import Data.Time (UTCTime) +import Data.Typeable (Typeable) +import Network.HTTP.Types (Ascii) + +import qualified Control.Exception.Lifted as E +import qualified Data.Aeson as A +import qualified Data.Attoparsec.Char8 as AT +import qualified Data.Conduit as C +import qualified Data.Conduit.Attoparsec as C +import qualified Data.Text as T +import qualified Network.HTTP.Conduit as H +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 = + AccessToken { accessTokenData :: Ascii + -- ^ The access token itself. + , accessTokenExpires :: Maybe UTCTime + -- ^ Expire time of the access token. It may + -- never expire, in which case it will be + -- @Nothing@. + } + deriving (Eq, Ord, Show, Typeable) + +-- | Phantom type used mark an 'AccessToken' as an user access +-- token. +data User + +-- | Phantom type used mark an 'AccessToken' as an app access +-- token. +data App + + +-- | A plain 'H.Request' to a Facebook API. Use this instead of +-- 'H.def' when creating new 'H.Request'@s@ for Facebook. +fbreq :: HT.Ascii -> Maybe (AccessToken kind) -> HT.SimpleQuery -> H.Request m +fbreq path mtoken query = + H.def { H.secure = True + , H.host = "graph.facebook.com" + , H.port = 443 + , H.path = path + , H.redirectCount = 3 + , H.queryString = + HT.renderSimpleQuery False $ + maybe id tsq mtoken query + } + + +-- | Class for types that may be passed on queries to Facebook's +-- API. +class ToSimpleQuery a where + -- | Prepend to the given query the parameters necessary to + -- pass this data type to Facebook. + tsq :: a -> HT.SimpleQuery -> HT.SimpleQuery + tsq _ = id + +instance ToSimpleQuery Credentials where + tsq creds = (:) ("client_id", clientId creds) . + (:) ("client_secret", clientSecret creds) + +instance ToSimpleQuery (AccessToken kind) where + tsq token = (:) ("access_token", accessTokenData token) + + +-- | Converts a plain 'H.Response' coming from 'H.http' into a +-- response with a JSON value. +asJson :: (C.ResourceThrow m, C.BufferSource bsrc, A.FromJSON a) => + H.Response (bsrc m ByteString) + -> C.ResourceT m (H.Response a) +asJson (H.Response status headers body) = do + val <- body C.$$ C.sinkParser A.json' + case A.fromJSON val of + A.Error str -> fail $ "Facebook.Base.asJson: " ++ str + A.Success r -> return (H.Response status headers r) + + +-- | Same as 'asJson', but returns only the JSON value. +asJson' :: (C.ResourceThrow m, C.BufferSource bsrc, A.FromJSON a) => + H.Response (bsrc m ByteString) + -> C.ResourceT m a +asJson' = fmap H.responseBody . asJson + + +-- | An exception that may be thrown by functions on this +-- package. Includes any information provided by Facebook. +data FacebookException = + FacebookException { fbeType :: Text + , fbeMessage :: Text + } + deriving (Eq, Ord, Show, 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 +-- meaningful 'FacebookException'@s@. +fbhttp :: C.ResourceIO m => + H.Request m + -> H.Manager + -> C.ResourceT m (H.Response (C.BufferedSource m ByteString)) +fbhttp req manager = do + let req' = req { H.checkStatus = \_ _ -> Nothing } + response@(H.Response status headers _) <- H.http req' manager + if isOkay status + then return response + else do + let statusexc = H.StatusCodeException status headers + val <- E.try $ asJson' response + case val :: Either E.SomeException FacebookException of + Right fbexc -> E.throw fbexc + Left _ -> do + case AT.parse wwwAuthenticateParser <$> + lookup "WWW-Authenticate" headers of + Just (AT.Done _ fbexc) -> E.throw fbexc + _ -> E.throw statusexc + + +-- | Try to parse the @WWW-Authenticate@ header of a Facebook +-- response. +wwwAuthenticateParser :: AT.Parser FacebookException +wwwAuthenticateParser = + FacebookException <$ AT.string "OAuth \"Facebook Platform\" " + <*> text + <* AT.char ' ' + <*> text + where + text = T.pack <$ AT.char '"' <*> many tchar <* AT.char '"' + tchar = (AT.char '\\' *> AT.anyChar) <|> AT.notChar '"' + + +-- | 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 + -> H.Manager + -> C.ResourceT m Bool +httpCheck req manager = do + let req' = req { H.method = HT.methodHead + , H.checkStatus = \_ _ -> Nothing } + H.Response status _ _ <- 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 + -- responseBody should be empty since we're using HEAD, but + -- I don't know if this is guaranteed. + + +-- | @True@ if the the 'Status' is ok (i.e. @2XX@). +isOkay :: HT.Status -> Bool +isOkay status = + let sc = HT.statusCode status + in 200 <= sc && sc < 300 diff --git a/tests/runtests.hs b/tests/runtests.hs new file mode 100644 --- /dev/null +++ b/tests/runtests.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE OverloadedStrings #-} + +import Control.Monad.IO.Class (MonadIO(liftIO)) +import System.Environment (getEnv) +import System.Exit (exitFailure) +import System.IO.Error (isDoesNotExistError) + +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 Network.HTTP.Conduit as H + +import Test.HUnit +import Test.Hspec.Core (Example(..)) +import Test.Hspec.Monadic +-- import Test.Hspec.QuickCheck +import Test.Hspec.HUnit () + + +-- | Grab the Facebook credentials from the environment. +getCredentials :: IO FB.Credentials +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) + + showHelp exc | not (isDoesNotExistError exc) = E.throw exc + showHelp _ = do + putStrLn $ unlines + [ "In order to run the tests from the 'fb' package, you need" + , "developer access to a Facebook app. The tests are designed" + , "so that your app isn't going to be hurt, but we may not" + , "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:" + , "" + , " $ export APP_ID=\"458798571203498\"" + , " $ export APP_SECRET=\"28a9d0fa4272a14a9287f423f90a48f2304\"" + , "" + , "Of course, the values above aren't valid and you need to" + , "replace them with your own." + , "" + , "(Exiting now with a failure code.)"] + exitFailure + + +invalidCredentials :: FB.Credentials +invalidCredentials = FB.Credentials "not" "valid" + + +main :: IO () +main = H.withManager $ \manager -> liftIO $ do + creds <- getCredentials + hspecX $ do + describe "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 () + describe "isValid" $ do + it "returns False on a clearly invalid access token" $ do + let token = FB.AccessToken "not valid" Nothing + valid <- FB.isValid token manager + liftIO (valid @?= False) + + +-- | Sad, orphan instance. +instance (m ~ IO, r ~ ()) => Example (C.ResourceT m r) where + evaluateExample = evaluateExample . C.runResourceT