fb (empty) → 0.1
raw patch · 7 files changed
+572/−0 lines, 7 filesdep +HUnitdep +aesondep +attoparsecsetup-changed
Dependencies added: HUnit, aeson, attoparsec, attoparsec-conduit, base, bytestring, conduit, fb, hspec, http-conduit, http-types, lifted-base, text, time, transformers
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- fb.cabal +80/−0
- src/Facebook.hs +23/−0
- src/Facebook/Auth.hs +157/−0
- src/Facebook/Base.hs +201/−0
- tests/runtests.hs +79/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ fb.cabal view
@@ -0,0 +1,80 @@+name: fb+version: 0.1+license: BSD3+license-file: LICENSE+author: Felipe Lessa+maintainer: Felipe Lessa <felipe.lessa@gmail.com>+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+ <http://developers.facebook.com/>). 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+ (<https://github.com/meteficha/fb/issues>).++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
+ src/Facebook.hs view
@@ -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
+ src/Facebook/Auth.hs view
@@ -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+-- <https://developers.facebook.com/docs/reference/api/permissions/>+-- 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.
+ src/Facebook/Base.hs view
@@ -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
+ tests/runtests.hs view
@@ -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