haxl-facebook (empty) → 0.1.0.0
raw patch · 6 files changed
+336/−0 lines, 6 filesdep +aesondep +asyncdep +basesetup-changed
Dependencies added: aeson, async, base, conduit, data-default, fb, hashable, haxl, http-client-tls, http-conduit, resourcet, text, time, transformers, unordered-containers, vector
Files
- FB.hs +25/−0
- FB/DataSource.hs +116/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- TestFB.hs +84/−0
- haxl-facebook.cabal +79/−0
+ FB.hs view
@@ -0,0 +1,25 @@+module FB+ ( getObject+ , getUser+ , getUserFriends+ , Id(..), Friend(..), User(..)+ ) where++import FB.DataSource+import Data.Aeson+import Facebook (Id(..), Friend(..), User(..))++import Haxl.Core++-- | Fetch an arbitrary object in the Facebook graph.+getObject :: Id -> GenHaxl u Object+getObject id = dataFetch (GetObject id)++-- | Fetch a Facebook user.+getUser :: Id -> GenHaxl u User+getUser id = dataFetch (GetUser id)++-- | Fetch the friends of a Facebook user that are registered with the+-- current app.+getUserFriends :: Id -> GenHaxl u [Friend]+getUserFriends id = dataFetch (GetUserFriends id)
+ FB/DataSource.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE OverloadedStrings, StandaloneDeriving, RecordWildCards,+ GADTs, TypeFamilies, MultiParamTypeClasses, DeriveDataTypeable,+ FlexibleInstances #-}+-- QSem was deprecated in 7.6, but no more+{-# OPTIONS_GHC -fno-warn-deprecations #-}+module FB.DataSource+ ( FacebookReq(..)+ , initGlobalState+ , Credentials(..)+ , UserAccessToken+ , AccessToken(..)+ ) where++import Network.HTTP.Conduit+import Facebook as FB+import Control.Monad.Trans.Resource+import Data.Hashable+import Data.Typeable+import Network.HTTP.Client.TLS (tlsManagerSettings)+import Data.Conduit+import Data.Conduit.List hiding (mapM, mapM_)+import Data.Monoid+import Data.Aeson+import Control.Concurrent.Async+import Control.Concurrent.QSem+import Control.Exception++import Haxl.Core++data FacebookReq a where+ GetObject :: Id -> FacebookReq Object+ GetUser :: UserId -> FacebookReq User+ GetUserFriends :: UserId -> FacebookReq [Friend]+ deriving Typeable++deriving instance Eq (FacebookReq a)+deriving instance Show (FacebookReq a)++instance Show1 FacebookReq where show1 = show++instance Hashable (FacebookReq a) where+ hashWithSalt s (GetObject (Id id)) = hashWithSalt s (0::Int,id)+ hashWithSalt s (GetUser (Id id)) = hashWithSalt s (1::Int,id)+ hashWithSalt s (GetUserFriends (Id id)) = hashWithSalt s (2::Int,id)++instance StateKey FacebookReq where+ data State FacebookReq =+ FacebookState+ { credentials :: Credentials+ , userAccessToken :: UserAccessToken+ , manager :: Manager+ , numThreads :: Int+ }++instance DataSourceName FacebookReq where+ dataSourceName _ = "Facebook"++instance DataSource u FacebookReq where+ fetch = facebookFetch++initGlobalState+ :: Int+ -> Credentials+ -> UserAccessToken+ -> IO (State FacebookReq)++initGlobalState threads creds token = do+ manager <- newManager tlsManagerSettings+ return FacebookState+ { credentials = creds+ , manager = manager+ , userAccessToken = token+ , numThreads = threads+ }++facebookFetch+ :: State FacebookReq+ -> Flags+ -> u+ -> [BlockedFetch FacebookReq]+ -> PerformFetch++facebookFetch FacebookState{..} _flags _user bfs =+ AsyncFetch $ \inner -> do+ sem <- newQSem numThreads+ asyncs <- mapM (fetchAsync credentials manager userAccessToken sem) bfs+ inner+ mapM_ wait asyncs++fetchAsync+ :: Credentials -> Manager -> UserAccessToken -> QSem+ -> BlockedFetch FacebookReq+ -> IO (Async ())+fetchAsync creds manager tok sem (BlockedFetch req rvar) =+ async $ bracket_ (waitQSem sem) (signalQSem sem) $ do+ e <- Control.Exception.try $+ runResourceT $ runFacebookT creds manager $ fetchReq tok req+ case e of+ Left ex -> putFailure rvar (ex :: SomeException)+ Right a -> putSuccess rvar a++fetchReq+ :: UserAccessToken+ -> FacebookReq a+ -> FacebookT Auth (ResourceT IO) a++fetchReq tok (GetObject (Id id)) =+ getObject ("/" <> id) [] (Just tok)++fetchReq _tok (GetUser id) =+ getUser id [] Nothing++fetchReq tok (GetUserFriends id) = do+ f <- getUserFriends id [] tok+ source <- fetchAllNextPages f+ source $$ consume
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014, Facebook, Inc.++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 Simon Marlow 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
+ TestFB.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE RebindableSyntax, OverloadedStrings #-}+module Main (main) where++import Control.Exception as E+import Data.Aeson+import Data.HashMap.Strict ((!))+import Data.Time.Calendar+import Data.Time.Clock+import FB+import FB.DataSource+import Haxl.Core+import Haxl.Prelude+import System.Environment+import System.Exit+import System.IO.Error+import qualified Data.HashMap.Strict as HashMap+import qualified Data.Text as T+import qualified Data.Vector as Vector++main = do+ (creds, access_token) <- getCredentials+ facebookState <- initGlobalState 10 creds access_token+ env <- initEnv (stateSet facebookState stateEmpty) ()+ r <- runHaxl env $ do+ likes <- getObject "me/likes"+ mapM getObject (likeIds likes) -- these happen concurrently+ print r++likeIds :: Object -> [Id]+likeIds likes = do+ Array arr <- [likes ! "data"]+ Object obj <- Vector.toList arr+ String id <- [obj ! "id"]+ return (Id id)++-- Modifed from the test in the fb package:+-- https://github.com/meteficha/fb/blob/master/tests/Main.hs+-- Copyright (c)2012, Felipe Lessa++-- | Grab the Facebook credentials from the environment.+getCredentials :: IO (Credentials, UserAccessToken)+getCredentials = tryToGet `E.catch` showHelp+ where+ tryToGet = do+ [appName, appId, appSecret, accessToken] <-+ mapM getEnv ["APP_NAME", "APP_ID", "APP_SECRET", "ACCESS_TOKEN"]+ now <- getCurrentTime+ let creds = Credentials (T.pack appName)+ (T.pack appId)+ (T.pack appSecret)+ access_token = UserAccessToken+ (Id "me")+ (T.pack accessToken)+ now+ return (creds, access_token)++ showHelp exc | not (isDoesNotExistError exc) = E.throw exc+ showHelp _ = do+ putStrLn $ unlines+ [ "In order to run the tests from the 'haxl-facebook' package, you"+ , "need developer access to a Facebook app. Create an app by"+ , "going to http://developers.facebook.com, select \"Create a New"+ , " App\" from the \"Apps\" menu at the top. Then create an"+ , "access token using the Graph API explorer:"+ , " https://developers.facebook.com/tools/explorer"+ , "Select your app from the \"Application\" menu at the top, then hit"+ , "\"Get Access Token\". The access token will last about 2 hours."+ , ""+ , "Please supply your app's name, id and secret in the environment"+ , "variables APP_NAME, APP_ID and APP_SECRET, respectively, and"+ , "the access token in ACCESS_TOKEN."+ , ""+ , "For example, before running the test you could run in the shell:"+ , ""+ , " $ export APP_NAME=\"test\""+ , " $ export APP_ID=\"000000000000000\""+ , " $ export APP_SECRET=\"xxxxxxxxxxxxxxxxxxxxxxxxxxxx\""+ , " $ export ACCESS_TOKEN=\"xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\""+ , ""+ , "Of course, these values above aren't valid and you need to"+ , "replace them with your own."+ , ""+ , "(Exiting now with a failure code.)"]+ exitFailure
+ haxl-facebook.cabal view
@@ -0,0 +1,79 @@+name: haxl-facebook+version: 0.1.0.0+synopsis: An example Haxl data source for accessing the+ Facebook Graph API+homepage: https://github.com/facebook/Haxl+bug-reports: https://github.com/facebook/Haxl/issues+license: BSD3+license-file: LICENSE+author: Facebook, Inc.+maintainer: The Haxl Team <haxl-team@fb.com>+copyright: 2014 (C) 2014 Facebook, Inc.+category: Concurrency, Network+build-type: Simple+cabal-version: >=1.10++library+ build-depends:+ base >=4.6 && <4.8,+ aeson >=0.6 && <0.8,+ fb >=1.0 && <1.1,+ http-conduit >=2.1 && <2.2,+ resourcet >=1.1 && <1.2,+ text >=0.11 && <1.2,+ transformers >=0.3 && <0.5,+ hashable >=1.2 && <1.3,+ data-default >=0.5 && <0.6,+ http-client-tls >=0.2 && <0.3,+ time >=1.4 && <1.5,+ conduit >=1.1 && <1.2,+ async >=2.0 && <2.1,+ haxl == 0.1.*++ other-extensions:+ OverloadedStrings,+ StandaloneDeriving,+ RecordWildCards,+ GADTs,+ TypeFamilies,+ MultiParamTypeClasses,+ DeriveDataTypeable++ exposed-modules:+ FB,+ FB.DataSource++ ghc-options:+ -Wall -fno-warn-name-shadowing++ default-language:+ Haskell2010++test-suite test+ type:+ exitcode-stdio-1.0++ main-is:+ TestFB.hs++ build-depends:+ base >=4.6 && <4.8,+ aeson >=0.6 && <0.8,+ fb >=1.0 && <1.1,+ http-conduit >=2.1 && <2.2,+ resourcet >=1.1 && <1.2,+ text >=0.11 && <1.2,+ transformers >=0.3 && <0.5,+ hashable >=1.2 && <1.3,+ data-default >=0.5 && <0.6,+ http-client-tls >=0.2 && <0.3,+ time >=1.4 && <1.5,+ conduit >=1.1 && <1.2,+ async >=2.0 && <2.1,+ haxl == 0.1.*,+ unordered-containers == 0.2.*,+ time == 1.4.*,+ vector >= 0.10 && < 0.11++ default-language:+ Haskell2010