happstack-facebook (empty) → 0.9
raw patch · 17 files changed
+1797/−0 lines, 17 filesdep +HTTPdep +RJsondep +URLTbuild-type:Customsetup-changed
Dependencies added: HTTP, RJson, URLT, applicative-extras, base, bytestring, containers, filepath, formlets, formlets-hsp, happstack, happstack-data, happstack-extra, happstack-ixset, happstack-server, happstack-state, happstack-util, harp, hsp, hsx, html, json, mtl, network, old-time, random, syb, time, utf8-string
Files
- Happstack/Facebook.hs +17/−0
- Happstack/Facebook/Application.hs +383/−0
- Happstack/Facebook/Common.hs +381/−0
- Happstack/Facebook/Connect.hs +157/−0
- Happstack/Facebook/FacebookT.hs +195/−0
- Happstack/Facebook/Feed.hs +137/−0
- Happstack/Facebook/Formlets.hs +46/−0
- Happstack/Facebook/Notifications.hs +77/−0
- Happstack/Facebook/Photos.hs +42/−0
- Happstack/Facebook/Status.hs +27/−0
- Happstack/Facebook/Users.hs +134/−0
- Happstack/Facebook/XdReceiver.hs +46/−0
- Setup.hs +13/−0
- debian/copyright +1/−0
- examples/ConnectDemo.hs +72/−0
- examples/FacebookConfig.hs +14/−0
- happstack-facebook.cabal +55/−0
+ Happstack/Facebook.hs view
@@ -0,0 +1,17 @@+{-# OPTIONS_GHC -F -pgmFtrhsx #-}+module Happstack.Facebook where++import HSP+import qualified HSX.XMLGenerator as HSX++-- |create a share on facebook link+-- for best results see this page:+-- <http://www.facebook.com/share_partners.php>+shareOnFacebook :: (XMLGenerator m) => XMLGenT m (HSX.XML m)+shareOnFacebook =+ <div class="share-on-facebook">+ <script>function fbs_click() {u=location.href;t=document.title;window.open('http://www.facebook.com/sharer.php?u='+encodeURIComponent(u)+'&t='+encodeURIComponent(t),'sharer','toolbar=0,status=0,width=626,height=436');return false;}</script>+ <style> html .fb_share_link { padding:2px 0 0 20px; height:16px; background:url(http://static.ak.fbcdn.net/images/share/facebook_share_icon.gif?8:26981) no-repeat top left; }</style>+ <a href="http://www.facebook.com/share.php?u=<url>" onclick="return fbs_click()" target="_blank" class="fb_share_link">Share on Facebook</a>+ </div>+
+ Happstack/Facebook/Application.hs view
@@ -0,0 +1,383 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, TypeSynonymInstances, TypeFamilies #-}+module Happstack.Facebook.Application where++import Control.Applicative+import Control.Arrow(first, second)+import Control.Monad (liftM)+import Control.Monad.Reader+import Control.Monad.State+import Control.Monad.Trans+import qualified Data.ByteString.Char8 as P+import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.ByteString.Lazy.UTF8 as L+import Data.Function (on)+import Data.List (isPrefixOf, sortBy)+import Data.Maybe (fromJust)+import Data.Time.Clock.POSIX (POSIXTime)+import Happstack.Crypto.MD5 ( md5, stringMD5)+import Happstack.Facebook.Common+import Happstack.Facebook.FacebookT+-- import qualified Happstack.Facebook.Feed as Feed+-- import Happstack.Server.Extra (lookPairsUnicode)+import Happstack.State (Proxy(..))+-- import HSP (HSPT,XML,XMLMetaData,evalHSPT,renderXML)+import qualified Network.HTTP as HTTP+import Network.Browser (Form(..),formToRequest, request, browse)+import Network.URI+import Happstack.Server+++-- |This data type holds all the informaton that facebook pass along with the request+-- http://wiki.developers.facebook.com/index.php/Your_callback_page_and_you+data FacebookData =+ FacebookData + { fbPairs :: [(String, String)]+ , _fb_sig_added :: Bool+ , _fb_sig_in_canvas :: Bool+ , _fb_sig_request_method :: Method+ , _fb_sig_position_fix :: Bool+ , _fb_user :: Maybe User+ , _fb_sig_time :: POSIXTime+ , _fb_sig_api_key :: ApiKey+-- , _fb_sig_app_id :: AppId+ , _fb_sig_locale :: String+ , _fb_sig :: String+ , _fb_sig_friends :: Maybe [User]+ , _fb_sig_session_key :: Maybe SessionKey+ , _fb_sig_expires :: Maybe POSIXTime+ , _fb_sig_profile_update_time :: Maybe POSIXTime+ , _fb_valid_sig :: Bool+ }+ deriving (Eq, Show)++-- ** convenience functions for getting information from the FacebookData++-- |has the user added our application+fb_sig_added :: (HasFacebookData FacebookData m) => m Bool+fb_sig_added = fbd _fb_sig_added++fb_sig_in_canvas :: (HasFacebookData FacebookData m) => m Bool+fb_sig_in_canvas = fbd _fb_sig_in_canvas++fb_sig_request_method :: (HasFacebookData FacebookData m) => m Method+fb_sig_request_method = fbd _fb_sig_request_method++fb_sig_position_fix :: (HasFacebookData FacebookData m) => m Bool+fb_sig_position_fix = fbd _fb_sig_position_fix++-- |get the userid +fb_user :: (HasFacebookData FacebookData m) => m (Maybe User)+fb_user = fbd _fb_user++-- |get current time+fb_sig_time :: (HasFacebookData FacebookData m) => m POSIXTime+fb_sig_time = fbd _fb_sig_time++-- |your api key+fb_sig_api_key :: (HasFacebookData FacebookData m) => m ApiKey+fb_sig_api_key = fbd _fb_sig_api_key++-- |the user's locale+fb_sig_locale :: (HasFacebookData FacebookData m) => m String+fb_sig_locale = fbd _fb_sig_locale++-- |the signature for the request+fb_sig :: (HasFacebookData FacebookData m) => m String+fb_sig = fbd _fb_sig++-- |is the signature valid+fb_valid_sig :: (HasFacebookData FacebookData m) => m Bool+fb_valid_sig = fbd _fb_valid_sig++-- |list of the users friends+-- NOTE: only available if the user is logged in+fb_sig_friends :: (HasFacebookData FacebookData m) => m (Maybe [User])+fb_sig_friends = fbd _fb_sig_friends++-- |session key+-- NOTE: only available if the user is logged in+fb_sig_session_key :: (HasFacebookData FacebookData m) => m (Maybe String)+fb_sig_session_key = fbd _fb_sig_session_key++-- |when this session key expires+-- 0 == never+-- otherwise, time in seconds since epoch`+-- NOTE: only available if the user is logged in+fb_sig_expires :: (HasFacebookData FacebookData m) => m (Maybe POSIXTime)+fb_sig_expires = fbd _fb_sig_expires++-- |time profile was last updated+-- NOTE: only available if the user is logged in+fb_sig_profile_update_time :: (HasFacebookData FacebookData m) => m (Maybe POSIXTime)+fb_sig_profile_update_time = fbd _fb_sig_profile_update_time++++validateSignature :: AppSecret -> String -> [(String, String)] -> Bool+validateSignature secret sig pairs =+ let fb_sigs = map (first (drop 7)) $ filter (\(k,v) -> isPrefixOf "fb_sig_" k) pairs+ (sig',_) = signature secret fb_sigs+ in sig == sig'++-- todo: add code to validate the sent fb_sig+withFacebookData :: (Monad m, MonadPlus m, ServerMonad m) => FacebookConfig -> (FacebookData -> m r) -> m r+withFacebookData config f =+ withDataFn + (do pairs <- lookPairs+ let lookupString k = case lookup k pairs of+ Nothing -> error ("Could not find required field " ++ k)+ (Just v) -> v+ read' str = case reads str of+ [(a,[])] -> a+ r -> error ("Failed to read " ++ str ++ " got " ++ show r)+ readTime :: String -> POSIXTime+ readTime str = realToFrac (read' str :: Double)+ fb_sig_added' = lookupBool "fb_sig_added" pairs+ fb_user' =+ case lookup "fb_sig_user" pairs of+ (Just uid) -> Just $ User (read' uid)+ Nothing -> + case lookup "fb_sig_canvas_user" pairs of+ (Just uid) ->+ Just $ User (read' uid)+ Nothing -> Nothing+ fb_sig_time' = readTime $ lookupString "fb_sig_time"+ fb_sig_api_key' = ApiKey $ lookupString "fb_sig_api_key"+ fb_sig_locale' = lookupString "fb_sig_locale"+ fb_sig' = lookupString "fb_sig"+ fb_sig_friends' = fmap (\str -> let (Right fids) = parseUserIds str in fids) $ lookup "fb_sig_friends" pairs+ fb_sig_session_key' = lookup "fb_sig_session_key" pairs+ fb_sig_expires' = fmap readTime $ lookup "fb_sig_expires" pairs+ fb_sig_profile_update_time' = fmap readTime $ lookup "fb_sig_profile_update_time" pairs+ valid_sig = validateSignature (appSecret config) fb_sig' pairs+ return (FacebookData { fbPairs = pairs + , _fb_sig_added = fb_sig_added'+ , _fb_sig_in_canvas = lookupBool "fb_sig_in_canvas" pairs+ , _fb_sig_request_method = + case lookupString "fb_sig_request_method" of+ "GET" -> GET+ "POST" -> POST+ , _fb_sig_position_fix = lookupBool "fb_sig_position_fix" pairs+ , _fb_user = fb_user'+ , _fb_sig_time = fb_sig_time'+ , _fb_sig_api_key = fb_sig_api_key'+ , _fb_sig_locale = fb_sig_locale' + , _fb_sig = fb_sig' + , _fb_sig_friends = fb_sig_friends' + , _fb_sig_session_key = fb_sig_session_key' + , _fb_sig_expires = fb_sig_expires' + , _fb_sig_profile_update_time = fb_sig_profile_update_time' + , _fb_valid_sig = valid_sig+ }))+ f++withFacebook :: (Monad m, MonadPlus m, ServerMonad m) => FacebookConfig -> FacebookT (FacebookState FacebookData) m a -> m a+withFacebook config sp = withFacebookData config $ \fbd -> withFacebook' config fbd sp++++withUserSP :: ( HasFacebookConfig (FacebookT (s d) m)+ , HasFacebookData d (FacebookT (s d) m)+ , HasFacebookData FacebookData (FacebookT (s d) m)+ , MonadPlus m+ ) + => FacebookT (FacebookStateU d) m a -> FacebookT (s d) m a+withUserSP handler =+ do mUser <- fb_user+ case mUser of+ Nothing -> mzero+ (Just user) -> withUser user handler+++withSessionSP :: ( HasFacebookConfig (FacebookT (s d) m)+ , HasFacebookData d (FacebookT (s d) m)+ , HasFacebookData FacebookData (FacebookT (s d) m)+ , HasFacebookData FacebookData (FacebookT (FacebookStateU d) m)+ , MonadPlus m+ ) + => FacebookT (FacebookStateS d) m a -> FacebookT (s d) m a+withSessionSP handler =+ do mUser <- fb_user+ case mUser of+ Nothing -> mzero+ (Just user) ->+ withUser user $+ do mSession <- fb_sig_session_key+ case mSession of+ Nothing -> mzero+ (Just sessionKey) ->+ withSession sessionKey handler+++{-+withFacebook' :: (Monad m) => FacebookConfig -> FacebookData -> ServerPartT (FacebookT FacebookState m) a -> ServerPartT m a+withFacebook' config facebookData sp =+ mapServerPartT doFacebook sp+ where+ doFacebook sp =+ runReaderT (unFacebookT sp) (FacebookState config facebookData)++{-+withFacebook' :: FacebookConfig -> FacebookData -> ServerPartT (HSPT (FacebookT IO)) a -> ServerPartT IO a+withFacebook' config facebookData sp =+ mapServerPartT doHSPT sp+ where+ doHSPT hspt =+ evalStateT (unFacebookT (evalHSPT Nothing hspt >>= return .snd)) (FacebookState config facebookData)+-}++-- callMethodE :: (HasFacebookConfig m, MonadIO m, FacebookMethod m method) =>+-- method -> m (Either FacebookError (FacebookResponse method))+{-+callMethodE :: forall method m. (HasFacebookConfig m, MonadIO m, FacebookMethod m method) => method -> m (Either FacebookError (FacebookResponse method))+callMethodE method =+ do configData <- askFacebookConfig+ params <- toParams method+ req <- return $ buildRequest configData params+ -- liftIO (putStrLn $ "FB Request: " ++ (show $ req (CallId 0)))+ res <- execRequest req+ -- liftIO (putStrLn $ "FB Response: " ++ (show res))+ return $ parseResponse' (Proxy :: Proxy (m method)) res ++callMethod :: forall method m. (HasFacebookConfig m, MonadIO m, FacebookMethod m method) => method -> m (Either String (FacebookResponse method))+callMethod method =+ do configData <- askFacebookConfig+ params <- toParams method+ req <- return $ buildRequest configData params+ -- liftIO (putStrLn $ "FB Request: " ++ (show $ req (CallId 0)))+ res <- execRequest req+ -- liftIO (putStrLn $ "FB Response: " ++ (show res))+ return $ parseResponse (Proxy :: Proxy (m method)) res +-}+{-+class (Monad m) => HasFacebookData FacebookData m where+ askFacebookData :: m FacebookData++class (Monad m) => HasUser m where+ askUser :: m User++class (Monad m) => HasSessionKey m where+ askSessionKey :: m SessionKey+-}++{-+++class (Monad m) => HasFacebookConfig m where+ askFacebookConfig :: m FacebookConfig++-}-}+{-+-- |our facebook code will live in the Facebook monad. Currently this+-- monad just provides some environment data. The Facebook monad lets+-- us embed Facebook Markup Language using literal XML via HSP.++type Facebook = HSPT (FacebookT IO)++instance Applicative Facebook where+ pure = return+ (<*>) = ap++-}+++{-+buildRequest :: (HasFacebookConfig m) => Parameters -> m (CallId -> HTTP.Request String)+buildRequest parameters = + do fbConfig <- askFacebookConfig+ -- uid <- liftM (maybe "" (show . uid)) fb_user -- FIXME : not all calls require this+ return $ \cid ->+ let (sig, args) = signature (appSecret fbConfig) $+ [ ("api_key", unApiKey $ apiKey fbConfig)+ , ("call_id", show (toInteger cid))+ , ("format","json")+ , ("uid", uid)+ , ("v","1.0")+ ] ++ parameters+ in formToRequest (Form HTTP.POST fbRESTURI (args ++ [("sig",sig)]))+ where+ fbRESTURI :: URI+ fbRESTURI = fromJust $ parseURI "http://api.facebook.com/restserver.php"+-}++{-++class (Monad m) => HasFacebookData m where+ askFacebookData :: m FacebookData++-- |the State that lives in the facebook monad+data FacebookState + = FacebookState { fbConfig :: FacebookConfig -- our api id, etc,+ , fbData :: FacebookData -- user specific information that facebook provides+ }++instance (Monad m) => HasFacebookConfig (FacebookT FacebookState m) where+ askFacebookConfig = fbConfig <$> ask++instance (Monad m) => HasFacebookData (FacebookT FacebookState m) where+ askFacebookData = fbData <$> ask++data FacebookStateU + = FacebookStateU { fbuConfig :: FacebookConfig -- our api id, etc,+ , fbuData :: FacebookData -- user specific information that facebook provides+ , fbuUser :: User+ }++instance (Monad m) => HasFacebookConfig (FacebookT FacebookStateU m) where+ askFacebookConfig = fbuConfig <$> ask++instance (Monad m) => HasFacebookData (FacebookT FacebookStateU m) where+ askFacebookData = fbuData <$> ask++instance (Monad m) => HasUser (FacebookT FacebookStateU m) where+ askUser = fbuUser <$> ask++withUser :: (HasFacebookConfig n, HasFacebookData n) => FacebookT FacebookStateU m a -> n (Maybe (m a))+withUser (FacebookT action) =+ do c <- askFacebookConfig+ d <- askFacebookData+ u <- fb_user+ case u of+ Nothing -> return Nothing+ (Just u) ->+ return $ Just (runReaderT action (FacebookStateU c d u))++-- ** Facebook with Session Key++data FacebookStateS+ = FacebookStateS { fbsConfig :: FacebookConfig -- our api id, etc,+ , fbsData :: FacebookData -- user specific information that facebook provides+ , fbsUser :: User+ , fbsSessionKey :: SessionKey+ }++instance (Monad m) => HasFacebookConfig (FacebookT FacebookStateS m) where+ askFacebookConfig = fbsConfig <$> ask++instance (Monad m) => HasFacebookData (FacebookT FacebookStateS m) where+ askFacebookData = fbsData <$> ask++instance (Monad m) => HasUser (FacebookT FacebookStateS m) where+ askUser = fbsUser <$> ask++instance (Monad m) => HasSessionKey (FacebookT FacebookStateS m) where+ askSessionKey = fbsSessionKey <$> ask++withSession :: (HasUser n, HasFacebookConfig n, HasFacebookData n) => FacebookT FacebookStateS m a -> n (Maybe (m a))+withSession (FacebookT action) =+ do c <- askFacebookConfig+ d <- askFacebookData+ u <- askUser+ s <- fb_sig_session_key+ case s of+ Nothing -> return Nothing+ (Just s) ->+ return $ Just (runReaderT action (FacebookStateS c d u s))+++-- |function to read some FacebookData from the Facebook environment+fbd :: (HasFacebookData m) => (FacebookData -> a) -> m a+fbd select = + do d <- askFacebookData+ return (select d)+-}
+ Happstack/Facebook/Common.hs view
@@ -0,0 +1,381 @@+{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, FlexibleContexts, ScopedTypeVariables, TemplateHaskell, TypeFamilies, TypeSynonymInstances, UndecidableInstances #-}+module Happstack.Facebook.Common where++import Control.Applicative(Applicative((<*>), pure), (<$>))+import Control.Arrow(first, second)+import qualified Data.ByteString.Char8 as P+import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.ByteString.Lazy.UTF8 as L+import Control.Monad(mzero, ap)+import Control.Monad.Reader(MonadReader(..),ReaderT(..))+import Control.Monad.Trans(MonadTrans(..))+import Control.Monad.Trans(MonadIO(liftIO))+import qualified Data.ByteString.Char8 as P+import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.ByteString.Lazy.UTF8 as L+import Data.Either (partitionEithers)+import Data.Function (on)+import Data.Generics (Data, Typeable)+import Data.Ix (Ix)+import Data.List (intercalate, isPrefixOf, sortBy)+import Data.Maybe (fromJust)+import Data.Time.Clock.POSIX (POSIXTime)+import qualified Data.Map as Map+import Happstack.Crypto.MD5 ( md5, stringMD5)+import Happstack.Data (Default(..), Version(..),deriveAll, deriveNewData, deriveSerialize)+import Happstack.Facebook.FacebookT+import Happstack.State (Proxy(..))+import Happstack.Server -- (Method(..))+import HSP (XML,XMLMetaData)+import HSX.XMLGenerator(XMLGenT(..))+import Network.Browser (Form(..),formToRequest, request, browse)+import qualified Network.HTTP as HTTP+import Network.URI+import System.Time (ClockTime(TOD),getClockTime)+import Text.RJson -- FIXME: use different JSON library?++data FacebookConfig = + FacebookConfig { apiKey :: ApiKey+ , appSecret :: AppSecret+ , appId :: AppId+ , canvasURL :: URI+ , connectURL :: URI+ }+ deriving (Show, Eq)++newtype ApiKey = ApiKey { unApiKey :: String } deriving (Read, Show, Eq, Ord)+newtype AppSecret = AppSecret { unAppSecret :: String } deriving (Read, Show, Eq, Ord)+newtype AppId = AppId { unAppId :: String } deriving (Read, Show, Eq, Ord)++newtype CallId = CallId Integer+ deriving (Enum, Eq, Integral, Num, Ord, Read, Real, Show, Ix)++-- |+$(deriveAll [''Eq, ''Ord, ''Read, ''Show, ''Ix, ''Default]+ [d| newtype User = User { uid :: Integer }+ newtype Flid = Flid { unFlid :: Integer }+ data Sex = Male | Female+ |])+instance Version User+$(deriveSerialize ''User)++instance Version Sex+$(deriveSerialize ''Sex)++instance Version Flid+$(deriveSerialize ''Flid)++$(deriveAll [''Eq, ''Ord, ''Read, ''Show, ''Default]+ [d|+ data FriendList = FriendList { flid :: Flid, name :: String } + |])++instance Version FriendList+$(deriveSerialize ''FriendList)++$(deriveAll [''Eq, ''Ord, ''Read, ''Show, ''Ix, ''Default]+ [d| newtype PhotoId = PhotoId { pid :: Integer } |])++$(deriveAll [''Eq, ''Ord, ''Read, ''Show, ''Ix, ''Default]+ [d| newtype AlbumId = AlbumId { aid :: Integer } |])++type SessionKey = String++type Parameters = [(String, String)]++data UidRequired = UidRequired+data SessionRequired = SessionRequired+data None = None++class (Monad m) => FacebookMethod m method where+ type FacebookResponse method+ toParams :: method -> m Parameters+ parseResponse :: Proxy (m method) -> String -> Either String (FacebookResponse method)++class (Monad m) => HasFacebookConfig m where+ askFacebookConfig :: m FacebookConfig++class (Monad m) => HasUser m where+ askUser :: m User++class (Monad m) => HasSessionKey m where+ askSessionKey :: m SessionKey++class (Monad m) => HasFacebookData d m where+ askFacebookData :: m d++-- |the State that lives in the facebook monad+data FacebookState d+ = FacebookState { fbConfig :: FacebookConfig -- our api id, etc,+ , fbData :: d -- user specific information that facebook provides+ }++instance (Monad m) => HasFacebookConfig (FacebookT (FacebookState d) m) where+ askFacebookConfig = fbConfig <$> ask++instance (Monad m) => HasFacebookData d (FacebookT (FacebookState d) m) where+ askFacebookData = fbData <$> ask++data FacebookStateU d+ = FacebookStateU { fbuConfig :: FacebookConfig -- our api id, etc,+ , fbuData :: d -- user specific information that facebook provides+ , fbuUser :: User+ }++instance (Monad m) => HasFacebookConfig (FacebookT (FacebookStateU d) m) where+ askFacebookConfig = fbuConfig <$> ask++instance (Monad m) => HasFacebookData d (FacebookT (FacebookStateU d) m) where+ askFacebookData = fbuData <$> ask++instance (Monad m) => HasUser (FacebookT (FacebookStateU d) m) where+ askUser = fbuUser <$> ask+++data FacebookStateS d+ = FacebookStateS { fbsConfig :: FacebookConfig -- our api id, etc,+ , fbsData :: d -- user specific information that facebook provides+ , fbsUser :: User+ , fbsSessionKey :: SessionKey+ }+++instance (Monad m) => HasFacebookConfig (FacebookT (FacebookStateS d) m) where+ askFacebookConfig = fbsConfig <$> ask+++instance (Monad m) => HasFacebookData d (FacebookT (FacebookStateS d) m) where+ askFacebookData = fbsData <$> ask++instance (Monad m) => HasUser (FacebookT (FacebookStateS d) m) where+ askUser = fbsUser <$> ask++instance (Monad m) => HasSessionKey (FacebookT (FacebookStateS d) m) where+ askSessionKey = fbsSessionKey <$> ask+++-- ** XMLGenT +++instance (HasFacebookConfig m) => (HasFacebookConfig (XMLGenT m)) where+ askFacebookConfig = XMLGenT $ askFacebookConfig++instance (HasFacebookData d m) => (HasFacebookData d (XMLGenT m)) where+ askFacebookData = XMLGenT $ askFacebookData++instance (HasUser m) => (HasUser (XMLGenT m)) where+ askUser = XMLGenT $ askUser++instance (HasSessionKey m) => (HasSessionKey (XMLGenT m)) where+ askSessionKey = XMLGenT $ askSessionKey+++assocToJSON :: [(String, String)] -> JsonData+assocToJSON assoc = JDObject $ Map.fromList (map (second toJson) assoc)+++parseResponseBool :: String -> Either String Bool+parseResponseBool str =+ case fromJsonString [] str of+ (Right [b]) -> Right b+ (Left e) -> Left e++parseUserIds :: String -> Either String [User]+parseUserIds str = + case partitionEithers $ map (fmap User . read') (commas str) of+ ([], users) -> Right users+ (errors,_) -> Left $ show errors+ where+ commas :: String -> [String]+ commas = words . map (\c -> if (c==',') then ' ' else c)+ read' str = case reads str of+ [(a,[])] -> Right a+ r -> Left ("Failed to read " ++ str ++ " got " ++ show r)+++-- |helper function+lookupBool :: String -> [(String, String)] -> Bool+lookupBool key assoc =+ case lookup key assoc of+ Nothing -> error ("required key " ++ key ++ " was not found.")+ (Just "0") -> False+ (Just "1") -> False+ (Just str) -> error ("key " ++ key ++ " has unparsable value " ++ str)+++toCommaList :: [String] -> String+toCommaList = intercalate ","++class RequiresSession a++callId :: (MonadIO m) => m CallId+callId = + do (TOD x y) <- liftIO getClockTime+ return (CallId (x + y))++buildRequest :: FacebookConfig -> Parameters -> (CallId -> HTTP.Request String)+buildRequest fbConfig parameters =+ \cid ->+ let (sig, args) = signature (appSecret fbConfig) $+ [ ("api_key", unApiKey $ apiKey fbConfig)+ , ("call_id", show (toInteger cid))+ , ("format","json")+ -- , ("uid", uid)+ , ("v","1.0")+ ] ++ parameters+ in formToRequest (Form HTTP.POST fbRESTURI (args ++ [("sig",sig)]))+ where+ fbRESTURI :: URI+ fbRESTURI = fromJust $ parseURI "http://api.facebook.com/restserver.php"++buildRequestM :: (HasFacebookConfig m) => Parameters -> m (CallId -> HTTP.Request String)+buildRequestM parameters = + do c <- askFacebookConfig + return $ buildRequest c parameters++execRequest :: (MonadIO m) => (CallId -> HTTP.Request String) -> m String+execRequest req =+ do cid <- callId+ (_uri, res) <- liftIO $ browse (request (req cid))+ let body = HTTP.rspBody res+ return body++callMethod :: forall method m. (HasFacebookConfig m, MonadIO m, FacebookMethod m method) => method -> m (Either FacebookError (FacebookResponse method))+callMethod method =+ do configData <- askFacebookConfig+ params <- toParams method+ req <- return $ buildRequest configData params+ -- liftIO (putStrLn $ "FB Request: " ++ (show $ req (CallId 0)))+ res <- execRequest req+ -- liftIO (putStrLn $ "FB Response: " ++ (show res))+ return $ parseResponse' (Proxy :: Proxy (m method)) res ++callMethodWithConfig :: forall method m. (MonadIO m, FacebookMethod m method) => FacebookConfig -> method -> m (Either FacebookError (FacebookResponse method))+callMethodWithConfig configData method =+ do params <- toParams method+ req <- return $ buildRequest configData params+ -- liftIO (putStrLn $ "FB Request: " ++ (show $ req (CallId 0)))+ res <- execRequest req+ -- liftIO (putStrLn $ "FB Response: " ++ (show res))+ return $ parseResponse' (Proxy :: Proxy (m method)) res ++callMethodOld :: forall method m. (HasFacebookConfig m, MonadIO m, FacebookMethod m method) => method -> m (Either String (FacebookResponse method))+callMethodOld method =+ do configData <- askFacebookConfig+ params <- toParams method+ req <- return $ buildRequest configData params+ -- liftIO (putStrLn $ "FB Request: " ++ (show $ req (CallId 0)))+ res <- execRequest req+ -- liftIO (putStrLn $ "FB Response: " ++ (show res))+ return $ parseResponse (Proxy :: Proxy (m method)) res +++-- |calculate the sig, and return the args in sorted order. The sig is *not* added to the args.+signature :: AppSecret -> [(String, String)] -> (String, [(String, String)])+signature (AppSecret appSecret) unsortedArgs =+ let args = sortBy (compare `on` fst) unsortedArgs+ argStr = concatMap (\(k,v) -> k ++ '=' : v) args+ sig = stringMD5 (md5 (L.pack (argStr ++ appSecret)))+ in (sig, args)+++data FacebookError+ = FacebookError+ { error_code :: Integer+ , error_msg :: String+ , request_args :: Parameters+ }+ | ParseError String+ deriving (Eq, Ord, Read, Show)++parseResponse' :: (FacebookMethod m method) => Proxy (m method) -> String -> Either FacebookError (FacebookResponse method)+parseResponse' method responseString+ | "{\"error_code\":" `isPrefixOf` responseString =+ Left (parseError responseString)+ | otherwise = + case parseResponse method responseString of+ (Left str) -> Left (ParseError str)+ (Right r) -> Right r++parseError :: String -> FacebookError+parseError responseString =+ case parseJsonString responseString of+ (Left e) -> ParseError e+ (Right (JDObject json)) -> + FacebookError { error_code = + let (Just (JDNumber d)) = Map.lookup "error_code" json+ in floor d+ , error_msg = + let (Just (JDString str)) = Map.lookup "error_msg" json+ in str+ , request_args =+ let (Just (JDArray args)) = Map.lookup "request_args" json+ in map fromKeyValue args+ }+ where+ fromKeyValue :: JsonData -> (String, String)+ fromKeyValue (JDObject json) = (fromJD $ fromJust $ Map.lookup "key" json, fromJD $ fromJust $ Map.lookup "value" json)+ fromJD (JDString str) = str+ fromJD (JDNumber d) = show d+++data ActionLink = ActionLink String String+ deriving (Data, Typeable, Eq, Ord, Read, Show)++actionLinkToJSON (ActionLink text uri) =+ JDObject $ Map.fromList [ ("text", (toJson text))+ , ("href", (toJson uri))+ ]+++newtype FbXML = FbXML { unFbXML :: XML }+++-- FIXME: the <style> and <script> tags should be encoded like html not xhtml+{-+instance ToMessage FbXML where+ toContentType _ = P.pack "application/xml; charset=utf-8"+ toMessage (FbXML xml) = L.fromString (renderAsFBML xml)++instance ToMessage (Maybe XMLMetaData, FbXML) where+ toContentType _ = P.pack "application/xml; charset=utf-8"+ toMessage (_,FbXML xml) = L.fromString (renderAsFBML xml)+-}++instance ToMessage FbXML where+ toContentType _ = P.pack "text/html; charset=utf-8"+ toMessage (FbXML xml) = L.fromString (renderAsFBML xml)++instance ToMessage (Maybe XMLMetaData, FbXML) where+ toContentType _ = P.pack "text/html; charset=utf-8"+ toMessage (_,FbXML xml) = L.fromString (renderAsFBML xml)++withFacebook' :: (Monad m) => FacebookConfig -> d -> FacebookT (FacebookState d) m a -> m a+withFacebook' config facebookData m = runReaderT (unFacebookT m) (FacebookState config facebookData)++-- |function to read some FacebookConnectData from the Facebook environment+fbd :: (HasFacebookData d m) => (d -> a) -> m a+fbd select = + do d <- askFacebookData+ return (select d)++withUser :: (HasFacebookData d (FacebookT (s d) m), HasFacebookConfig (FacebookT (s d) m))+ => User+ -> FacebookT (FacebookStateU d) m a+ -> FacebookT (s d) m a+withUser u (FacebookT action) =+ do c <- askFacebookConfig+ d <- askFacebookData+ FacebookT $ ReaderT $ const (runReaderT action (FacebookStateU c d u))++withSession :: (HasUser (FacebookT (s d) m), HasFacebookData d (FacebookT (s d) m), HasFacebookConfig (FacebookT (s d) m)) => + SessionKey + -> FacebookT (FacebookStateS d) m a + -> FacebookT (s d) m a+withSession s (FacebookT action) =+ do c <- askFacebookConfig+ d <- askFacebookData+ u <- askUser+ FacebookT $ ReaderT $ const $ runReaderT action (FacebookStateS c d u s)+-- FacebookT $ ReaderT (runReaderT action (FacebookStateS c d u s))+
+ Happstack/Facebook/Connect.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, ScopedTypeVariables #-}+module Happstack.Facebook.Connect where++import Control.Applicative ((<$>))+import Control.Monad(MonadPlus(mzero))+import Control.Monad.Reader (ask, asks, runReaderT)+import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.ByteString.Lazy.UTF8 as L+import Data.Char (toLower)+import Data.Function+import Data.List+import Data.Time.Clock.POSIX (POSIXTime)+import Happstack.Crypto.MD5 ( md5, stringMD5)+import Happstack.Facebook.Common+import Happstack.Facebook.FacebookT+import Happstack.Server++data FacebookConnectData =+ FacebookConnectData + { _fbc_cookies :: [(String,Cookie)]+ , _fbc_sig_expires :: Maybe POSIXTime+ , _fbc_sig_session_key :: Maybe SessionKey+ , _fbc_sig_ss :: Maybe String+ , _fbc_user :: Maybe User+ , _fbc_sig :: Maybe String+ }+ deriving (Eq, Show)+++-- ** convenience functions for getting information from the FacebookConnectData+-- |when this session key expires+-- 0 == never+-- otherwise, time in seconds since epoch`+-- NOTE: only available if the user is logged in+fb_sig_expires :: (HasFacebookData FacebookConnectData m) => m (Maybe POSIXTime)+fb_sig_expires = fbd _fbc_sig_expires++-- |session key+-- NOTE: only available if the user is logged in+fb_sig_session_key :: (HasFacebookData FacebookConnectData m) => m (Maybe SessionKey)+fb_sig_session_key = fbd _fbc_sig_session_key++fb_sig_ss :: (HasFacebookData FacebookConnectData m) => m (Maybe String)+fb_sig_ss = fbd _fbc_sig_ss++fb_user :: (HasFacebookData FacebookConnectData m) => m (Maybe User)+fb_user = fbd _fbc_user++-- |the signature for the request+fb_sig :: (HasFacebookData FacebookConnectData m) => m (Maybe String)+fb_sig = fbd _fbc_sig++validateSignature :: AppSecret -> FacebookConnectData -> Bool+validateSignature secret d = (Just sig) == (_fbc_sig d)+ where sorted = sortBy (compare `on` fst) (_fbc_cookies d)+ dataStr = concatMap (\(k,v) -> k ++ '=' : (cookieValue v)) sorted+ sig = stringMD5 (md5 (L.pack (dataStr++(unAppSecret secret)))) ++-- todo: add code to validate the sent fb_sig+{-+withFacebookConnectData :: (Monad m) => FacebookConfig -> (FacebookConnectData -> ServerPartT m r) -> ServerPartT m r+withFacebookConnectData config f =+ withDataFn buildFBCData f+ where read' str = case reads str of+ [(a,[])] -> a+ r -> error ("Failed to read " ++ str ++ " got " ++ show r)+ readTime :: String -> POSIXTime+ readTime str = realToFrac (read' str :: Double)+ lookupString :: String -> RqData (Maybe String)+ lookupString k = do+ cookies <- asks snd+ return $ fmap cookieValue $ lookup (map toLower (unApiKey (apiKey config) ++k)) cookies+ buildFBCData :: RqData FacebookConnectData+ buildFBCData = do+ expires <- lookupString "_expires"+ sesKey <- lookupString "_session_key" + ss <- lookupString "_ss" + sig <- lookupString ""+ user <- lookupString "_user"+ cookies <- asks snd+ return $ FacebookConnectData+ (filter (isPrefixOf (unApiKey (apiKey config)++"_") . fst) cookies)+ (fmap readTime expires) sesKey ss (fmap (User . read) user) sig+-}++-- TODO: add code to validate the sent fb_sig+withFacebookConnectData :: + ( Monad m+ , MonadPlus m+ , ServerMonad m+ ) => FacebookConfig -> (FacebookConnectData -> m r) -> m r+withFacebookConnectData config f =+ withDataFn buildFBCData f+ where read' str = case reads str of+ [(a,[])] -> a+ r -> error ("Failed to read " ++ str ++ " got " ++ show r)+ readTime :: String -> POSIXTime+ readTime str = realToFrac (read' str :: Double)+ lookupString :: String -> RqData (Maybe String)+ lookupString k = do+ cookies <- asks snd+ return $ fmap cookieValue $ lookup (map toLower (unApiKey (apiKey config) ++k)) cookies+ buildFBCData :: RqData FacebookConnectData+ buildFBCData = do+ expires <- lookupString "_expires"+ sesKey <- lookupString "_session_key" + ss <- lookupString "_ss" + sig <- lookupString ""+ user <- lookupString "_user"+ cookies <- asks snd+ return $ FacebookConnectData+ (filter (isPrefixOf (unApiKey (apiKey config)++"_") . fst) cookies)+ (fmap readTime expires) sesKey ss (fmap (User . read) user) sig++{-+withFacebookConnect :: (Monad m) => FacebookConfig -> FacebookT (FacebookState FacebookConnectData) (ServerPartT m) a -> ServerPartT m a+withFacebookConnect config sp = withFacebookConnectData config $ \fbd -> withFacebook' config fbd sp+-}++withFacebookConnect :: + ( Monad m+ , MonadPlus m+ , ServerMonad m+ ) => FacebookConfig -> FacebookT (FacebookState FacebookConnectData) m a -> m a+withFacebookConnect config sp = withFacebookConnectData config $ \fbd -> withFacebook' config fbd sp++withUserSP :: ( HasFacebookConfig (FacebookT (s d) m)+ , HasFacebookData d (FacebookT (s d) m)+ , HasFacebookData FacebookConnectData (FacebookT (s d) m)+ , MonadPlus m+ ) + => FacebookT (FacebookStateU d) m a -> FacebookT (s d) m a+withUserSP handler =+ do mUser <- fb_user+ case mUser of+ Nothing -> mzero+ (Just user) -> withUser user handler+++withSessionSP :: ( HasFacebookConfig (FacebookT (s d) m)+ , HasFacebookData d (FacebookT (s d) m)+ , HasFacebookData FacebookConnectData (FacebookT (s d) m)+ , HasFacebookData FacebookConnectData (FacebookT (FacebookStateU d) m)+ , MonadPlus m+ ) + => FacebookT (FacebookStateS d) m a -> FacebookT (s d) m a+withSessionSP handler =+ do mUser <- fb_user+ case mUser of+ Nothing -> mzero+ (Just user) ->+ withUser user $+ do mSession <- fb_sig_session_key+ case mSession of+ Nothing -> mzero+ (Just sessionKey) ->+ withSession sessionKey handler
+ Happstack/Facebook/FacebookT.hs view
@@ -0,0 +1,195 @@+{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances, TypeFamilies, GeneralizedNewtypeDeriving, UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Happstack.Facebook.FacebookT where++import HSP+import Control.Applicative (Applicative((<*>), pure), Alternative((<|>), empty), WrappedMonad(WrapMonad, unwrapMonad), (<$>))+import Control.Monad.Identity+import Control.Monad.Reader+import Data.List (intersperse)+import qualified HSX.XMLGenerator as HSX+import Happstack.Server (ServerMonad(askRq, localRq), FilterMonad(setFilter,composeFilter,getFilter), WebMonad(finishWith))+import URLT (ShowURL(showURL), URL)++newtype FacebookT s m a =+ FacebookT { unFacebookT :: ReaderT s m a }+ deriving (Functor, Monad, MonadFix, MonadPlus, MonadIO, MonadTrans)++instance (Monad m) => Applicative (FacebookT s m) where+ pure = FacebookT . return+ (FacebookT m) <*> (FacebookT n) = FacebookT (m `ap` n)++instance (MonadPlus m) => Alternative (FacebookT s m) where+ empty = unwrapMonad empty+ f <|> g = unwrapMonad $ (WrapMonad f) <|> (WrapMonad g)++instance (ServerMonad m) => ServerMonad (FacebookT s m) where+ askRq = lift askRq+ localRq f (FacebookT m) = FacebookT (mapReaderT (localRq f) m)++instance (FilterMonad a m) => FilterMonad a (FacebookT s m) where+ setFilter f = lift (setFilter f)+ composeFilter f = lift (composeFilter f)+ getFilter (FacebookT m) = FacebookT (mapReaderT getFilter m)++instance (WebMonad a m) => WebMonad a (FacebookT s m) where+ finishWith = lift . finishWith++-- normally we would just derive this, but trhsx can't handle it+-- (haddock used to break as well, I wonder if that is fixed now?)+instance (Monad m) => MonadReader s (FacebookT s m) where+ ask = FacebookT ask+ local f (FacebookT m) = FacebookT (local f m)++instance (ShowURL m) => ShowURL (FacebookT s m) where+ type URL (FacebookT s m) = URL m+ showURL u = FacebookT $ ReaderT $ const (showURL u)++instance (Monad m) => HSX.XMLGen (FacebookT s m) where+ type HSX.XML (FacebookT s m) = XML+ newtype HSX.Child (FacebookT s m) = FChild { unFChild :: XML }+ newtype HSX.Attribute (FacebookT s m) = FAttr { unFAttr :: Attribute }+ genElement n attrs children = + do attribs <- map unFAttr <$> asAttr attrs+ childer <- flattenCDATA . map unFChild <$> asChild children+ HSX.XMLGenT $ return (Element+ (toName n)+ attribs+ childer+ )+ xmlToChild = FChild++flattenCDATA :: [XML] -> [XML]+flattenCDATA cxml = + case flP cxml [] of+ [] -> []+ [CDATA _ ""] -> []+ xs -> xs + where+ flP :: [XML] -> [XML] -> [XML]+ flP [] bs = reverse bs+ flP [x] bs = reverse (x:bs)+ flP (x:y:xs) bs = case (x,y) of+ (CDATA e1 s1, CDATA e2 s2) | e1 == e2 -> flP (CDATA e1 (s1++s2) : xs) bs+ _ -> flP (y:xs) (x:bs)+++instance (Monad m) => HSX.EmbedAsAttr (FacebookT s m) Attribute where+ asAttr = return . (:[]) . FAttr ++instance (Monad m) => HSX.EmbedAsAttr (FacebookT s m) (Attr String Char) where+ asAttr (n := c) = asAttr (n := [c])++instance (Monad m) => HSX.EmbedAsAttr (FacebookT s m) (Attr String String) where+ asAttr (n := str) = asAttr $ MkAttr (toName n, pAttrVal str)++instance (Monad m) => HSX.EmbedAsAttr (FacebookT s m) (Attr (String, String) String) where+ asAttr (n := str) = asAttr $ MkAttr (toName n, pAttrVal str)++instance (Monad m) => HSX.EmbedAsAttr (FacebookT s m) (Attr String Bool) where+ asAttr (n := True) = asAttr $ MkAttr (toName n, pAttrVal "true")+ asAttr (n := False) = asAttr $ MkAttr (toName n, pAttrVal "false")++instance (Monad m) => HSX.EmbedAsAttr (FacebookT s m) (Attr String Int) where+ asAttr (n := i) = asAttr $ MkAttr (toName n, pAttrVal (show i))++instance (Monad m) => EmbedAsChild (FacebookT s m) Char where+ asChild = XMLGenT . return . (:[]) . FChild . pcdata . (:[])++instance (Monad m) => EmbedAsChild (FacebookT s m) String where+ asChild = XMLGenT . return . (:[]) . FChild . pcdata++instance (Monad m) => EmbedAsChild (FacebookT s m) XML where+ asChild = XMLGenT . return . (:[]) . FChild++instance (Monad m) => EmbedAsChild (FacebookT s m) () where+ asChild () = return []++instance (Monad m) => AppendChild (FacebookT s m) XML where+ appAll xml children = do+ chs <- children+ case xml of+ CDATA _ _ -> return xml+ Element n as cs -> return $ Element n as (cs ++ (map unFChild chs))++instance (Monad m) => SetAttr (FacebookT s m) XML where+ setAll xml hats = do+ attrs <- hats+ case xml of+ CDATA _ _ -> return xml+ Element n as cs -> return $ Element n (foldr (:) as (map unFAttr attrs)) cs++instance (Monad m) => XMLGenerator (FacebookT s m)+++------------------------------------------------------------------+-- Rendering++-- TODO: indents are incorrectly calculated++-- | Pretty-prints XML values.+renderAsFBML :: XML -> String+renderAsFBML xml = renderAsFBML' 0 xml ""++data TagType = Open | Close | Single++renderAsFBML' :: Int -> XML -> ShowS+renderAsFBML' _ (CDATA needsEscape cd) = showString (if needsEscape then escape cd else cd)+-- renderAsFBML' n (Element name attrs []) = renderTag Single n name attrs+renderAsFBML' n elm@(Element name@(Nothing, nm) attrs children)+ | nm == "area" = renderTagEmpty children+ | nm == "base" = renderTagEmpty children+ | nm == "br" = renderTagEmpty children+ | nm == "col" = renderTagEmpty children+ | nm == "hr" = renderTagEmpty children+ | nm == "img" = renderTagEmpty children+ | nm == "input" = renderTagEmpty children+ | nm == "link" = renderTagEmpty children+ | nm == "meta" = renderTagEmpty children+ | nm == "param" = renderTagEmpty children+ | nm == "script" = renderElement n (Element name attrs (map asCDATA children))+ | nm == "style" = renderElement n (Element name attrs (map asCDATA children))+ where + renderTagEmpty [] = renderTag Open n name attrs+ renderTagEmpty _ = renderElement n elm -- this case should not happen in valid HTML+ asCDATA :: XML -> XML+ asCDATA (CDATA _ cd) = (CDATA False cd)+ asCDATA o = o -- this case should not happen in valid HTML+renderAsFBML' n elm = renderElement n elm++renderElement :: Int -> XML -> String -> String+renderElement n (Element name attrs children) =+ let open = renderTag Open n name attrs + cs = renderChildren n children + close = renderTag Close n name []+ in open . cs . close+ where+ renderChildren :: Int -> Children -> ShowS+ renderChildren n' cs = foldl (.) id $ map (renderAsFBML' (n'+2)) cs+ +renderTag :: TagType -> Int -> Name -> Attributes -> ShowS +renderTag typ n name attrs = + let (start,end) = case typ of+ Open -> (showChar '<', showChar '>')+ Close -> (showString "</", showChar '>')+ -- Single -> (showChar '<', showString "/>")+ nam = showName name+ as = renderAttrs attrs+ in start . nam . as . end++ where renderAttrs :: Attributes -> ShowS+ renderAttrs [] = nl+ renderAttrs attrs' = showChar ' ' . ats . nl+ where ats = foldl (.) id $ intersperse (showChar ' ') $ fmap renderAttr attrs'+++ renderAttr :: Attribute -> ShowS+ renderAttr (MkAttr (nam, (Value needsEscape val))) = showName nam . showChar '=' . renderAttrVal (if needsEscape then escape val else val)++ renderAttrVal :: String -> ShowS+ renderAttrVal s = showChar '\"' . showString s . showChar '\"'++ showName (Nothing, s) = showString s+ showName (Just d, s) = showString d . showChar ':' . showString s++ nl = showChar '\n' . showString (replicate n ' ')
+ Happstack/Facebook/Feed.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses, TypeFamilies #-}+module Happstack.Facebook.Feed {-# DEPRECATED "Facebook has deprecated this API http://www.insidefacebook.com/2009/10/23/facebook-changing-feed-story-image-specs-deprecating-some-feed-apis/" #-} where++import Data.Generics (Data, Typeable)+import Data.Ix (Ix)+import qualified Data.Map as Map+import Data.Maybe (catMaybes)+import Happstack.Facebook.Common+import Text.RJson++-- ** Feed++newtype BundleId+ = BundleId { unBundledId :: Integer }+ deriving (Data, Typeable, Eq, Ord, Read, Show, Ix)++instance ToJson BundleId where+ toJson (BundleId bid) = toJson bid++data StorySize+ = OneLine+ | Short+ deriving (Data, Typeable, Read, Show, Eq, Ord, Ix)++instance Enum StorySize where+ succ OneLine = Short+ succ Short = error "tried to take `succ' of maxBound" + pred OneLine = error "tried to take `pred` of minBound"+ pred Short = OneLine+ toEnum 1 = OneLine+ toEnum 2 = Short+ fromEnum OneLine = 1+ fromEnum Short = 2++ enumFrom OneLine = [OneLine, Short]+ enumFrom Short = [Short]++ enumFromTo from to = takeWhile (<= to) $ enumFrom from++-- |Deactivates a previously registered template bundle+data DeactivateTemplateBundleById+ = DeactivateTemplateBundleById BundleId+ deriving (Data, Typeable, Read, Show, Eq, Ord, Ix)++instance (Monad m) => FacebookMethod m DeactivateTemplateBundleById where+ type FacebookResponse DeactivateTemplateBundleById = Bool+ parseResponse _ = parseResponseBool+ toParams (DeactivateTemplateBundleById (BundleId bid)) =+ return [ ("method","Feed.deactivateTemplateBundleById")+ , ("template_bundle_id", toJsonString bid)+ ]++-- data FeedGetRegisteredTemplateBundles+-- = FeedGetRegisteredTemplateBundles++-- instance FacebookMethod FeedGetRegisteredTemplateBundles where+-- type FacebookResponse FeedGetRegisteredTemplateBundles = [TemplateBundle]++data PublishUserAction + = PublishUserAction BundleId (Maybe StorySize) Parameters + deriving (Data, Typeable, Read, Show, Eq, Ord)++instance RequiresSession PublishUserAction++instance (HasSessionKey m) => FacebookMethod m PublishUserAction where+ type FacebookResponse PublishUserAction = String+ parseResponse _ = Right . id+ toParams (PublishUserAction (BundleId bid) mStorySize templateData) =+ do sessionKey <- askSessionKey+ return $ catMaybes $+ [ Just ("method", "Feed.publishUserAction")+ , Just ("template_bundle_id", show bid)+ , Just ("template_data", show $ assocToJSON templateData)+ , Just ("session_key", sessionKey)+ , fmap (\size -> ("story_size", show $ fromEnum size)) mStorySize+ ]++-- |FeedData is used to supply data for the feedStory/multiFeedStory callback+-- <http://wiki.developers.facebook.com/index.php/Feed_Forms>+data FeedData + = FeedData + { target :: Target + , template_id :: BundleId+ , template_data :: [(String, String)]+ , next :: String+ }+ deriving (Eq, Ord, Read, Show, Typeable, Data)++data Target = SingleFeed | MultiFeed+ deriving (Eq, Ord, Read, Show, Typeable, Data)++instance ToJson FeedData where+ toJson feedData =+ JDObject $ Map.fromList+ [ ("method", toJson (case target feedData of SingleFeed -> "feedStory" ; MultiFeed -> "multiFeedStory")) + , ("content", JDObject $ Map.fromList+ [("feed", JDObject $ Map.fromList+ [ ("template_id", toJson (template_id feedData))+ , ("template_data", assocToJSON (template_data feedData))+ ])+ , ("next", toJson (next feedData))+ ])+ ]++-- NOTE: there is little reason to supply more than one story per size these days+data TemplateBundle + = TemplateBundle+ { oneLineTemplateBundle :: [String]+ , shortTemplateBundle :: [(Maybe String, String)]+ , actionLinks :: [ActionLink]+ }+ deriving (Eq, Ord, Read, Show, Typeable, Data)++data RegisterTemplateBundle+ = RegisterTemplateBundle TemplateBundle+ deriving (Eq, Ord, Read, Show, Typeable, Data)++instance (Monad m) => FacebookMethod m RegisterTemplateBundle where+ type FacebookResponse RegisterTemplateBundle = BundleId+ parseResponse _ str = + case fromJsonString (undefined :: Integer) str of+ Right bid -> Right (BundleId bid)+ (Left e) -> Left $ "Failed to parse BundleId JSON object: " ++ str+ toParams (RegisterTemplateBundle templateBundle) =+ return $ catMaybes $+ [ Just ("method","Feed.registerTemplateBundle")+ , Just ("one_line_story_templates", toJsonString (oneLineTemplateBundle templateBundle))+ , Just ("short_story_templates", show $ JDArray (flip map (shortTemplateBundle templateBundle) $ + \(mTitle, body) ->+ JDObject $ Map.fromList $ catMaybes $+ [ fmap (\title -> ("template_title", toJson title)) mTitle+ , Just ("template_body", toJson body)+ ]))+ , if (null $ actionLinks templateBundle) + then Nothing + else Just ("action_links", show $ JDArray (map actionLinkToJSON $ actionLinks templateBundle))+ ]
+ Happstack/Facebook/Formlets.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -F -pgmFtrhsx #-}+module Happstack.Facebook.Formlets + ( module HSP.Formlets+ , formletPart+ ) where++import Control.Arrow+import Control.Applicative+import Control.Applicative.Error+import Control.Monad+import Control.Monad.Trans+import Happstack.Server.Extra () -- ServerMonad (XMLGenT m)+-- import Happstack.Server.HSX -- ServerMonad (XMLGenT m)+import Happstack.Facebook.Common(FbXML(..))+import HSP+import HSP.Formlets+import qualified HSX.XMLGenerator as HSX+import Happstack.Server as Happstack+import Text.Formlets++-- ^ turn a formlet into XML+ServerPartT which can be embedded in a larger document+formletPart ::+ (EmbedAsChild m xml, EmbedAsAttr m (Attr String String), MonadIO m, Functor m, ToMessage b, FilterMonad Response m, WebMonad Response m, MonadPlus m, ServerMonad m) + => String -- ^ prefix used to ensure field names are unique+ -> String -- ^ url to POST form results to+ -> (a -> XMLGenT m b) -- ^ handler used when form validates+ -> ([ErrorMsg] -> [XMLGenT m (HSX.XML m)] -> XMLGenT m b) -- ^ handler used when form does not validate+ -> Form xml IO a -- ^ the formlet+ -> XMLGenT m (HSX.XML m)+formletPart prefix action handleSuccess handleFailure form = + withDataFn lookPairs $ \env ->+ let (collector, formXML,_) = runFormState (map (second Left) env) prefix form+ in + msum [ dir "submit" $ methodSP POST $ XMLGenT $ Happstack.escape . fmap toResponse $ unXMLGenT $ + do res <- liftIO collector+ case res of+ (Success a) -> handleSuccess a+ (Failure faults) -> handleFailure faults [ <form action=action method="POST" enctype="multipart/form-data;charset=UTF-8" accept-charset="UTF-8" >+ <% formXML %>+ </form> ]++ , methodSP POST $ <form action=action method="POST" enctype="multipart/form-data;charset=UTF-8" accept-charset="UTF-8" >+ <% formXML %>+ </form>+ ]
+ Happstack/Facebook/Notifications.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses, TypeFamilies #-}+module Happstack.Facebook.Notifications where++import Data.Generics (Data, Typeable)+import Data.Ix (Ix)+import Data.Maybe (catMaybes)+import Happstack.Facebook.Common+import Text.RJson++-- * Notifications++-- ** Notifications.get++data Get+ = Get+ deriving (Eq, Ord, Read, Show, Data, Typeable, Ix)++-- ** Notifications.send++data Send + = Send + { to_ids :: [User]+ , notification :: String+ , notificationType :: Maybe NotificationType+ }+ deriving (Eq, Ord, Read, Show, Data, Typeable)++data NotificationType+ = UserToUser | AppToUser+ deriving (Eq, Ord, Read, Show, Data, Typeable, Ix)++instance (HasSessionKey m) => FacebookMethod m Send where+ type FacebookResponse Send = [User]+ parseResponse _ jstr = + case fromJsonString [] jstr of+ Left e -> error $ "Notifications.send: " ++ show e+ Right str -> parseUserIds str+ toParams (Send to_ids notification mNotificationType) =+ do sessionKey <- askSessionKey+ return $ catMaybes $ + [ Just ("method", "Notifications.send")+ , Just ("to_ids", show $ JDArray (map (toJson . uid) to_ids))+ , Just ("notification", notification)+ , Just ("session_key", sessionKey)+ , fmap (\notificationType ->+ ("type", case notificationType of+ UserToUser -> "user_to_user"+ AppToUser -> "app_to_user")) mNotificationType+ ]+++-- ** Notifications.send (sessionless)++data SendNS+ = SendNS + { to_idsNS :: [User]+ , notificationNS :: String+ }+ deriving (Eq, Ord, Read, Show, Data, Typeable)++instance (Monad m) => FacebookMethod m SendNS where+ type FacebookResponse SendNS = [User]+ parseResponse _ jstr = + case fromJsonString [] jstr of+ Left e -> error $ "Notifications.send: " ++ show e+ Right str -> parseUserIds str+ toParams (SendNS to_ids notification) =+ do return $ catMaybes $ + [ Just ("method", "Notifications.send")+ , Just ("to_ids", show $ JDArray (map (toJson . uid) to_ids))+ , Just ("notification", notification)+ , Just ("type", "app_to_user")+ ]++-- notificationsSend :: [User] -> String -> Maybe NotificationType -> Facebook (Either FacebookError [User])+-- notificationsSend users msg ntype = callMethodE (NotificationsSend users msg ntype)+
+ Happstack/Facebook/Photos.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses, TypeFamilies #-}+module Happstack.Facebook.Photos where++import Data.Generics (Data, Typeable)+import Data.Maybe (catMaybes)+import Happstack.Facebook.Common+import Text.RJson++-- ** Photos+-- <http://wiki.developers.facebook.com/index.php/Photos.get>++data Get+ = Get+ { subj_id :: Maybe User -- perhaps this should be a Bool?+ , album :: Maybe AlbumId+ , photos :: Maybe [PhotoId]+ }+ deriving (Data, Typeable, Read, Show, Eq, Ord)++instance RequiresSession Get++instance (HasSessionKey m) => FacebookMethod m Get where+ type FacebookResponse Get = String+ parseResponse _ jstr = Right jstr+{-+ case fromJsonString [] jstr of+ Left e -> error $ "Photos.get: " ++ show e+ Right str -> str+-}+ toParams (Get mSubjId mAlbum mPhotos) =+ do sessionKey <- askSessionKey+ return $ catMaybes $ + [ Just ("method", "Photos.get")+ , Just ("session_key", sessionKey)+ , fmap (\subj -> ("subj_id", show (uid subj))) mSubjId+ , fmap (\albumId -> ("aid", show (aid albumId))) mAlbum+ , fmap (\pids -> ("pids", toCommaList $ map (show . pid) pids)) mPhotos+ ]++-- get :: Maybe User -> Maybe AlbumId -> Maybe [PhotoId] -> Facebook (Either FacebookError String)+-- get mUser mAlbum mPhotos = callMethodE (Get mUser mAlbum mPhotos)+
+ Happstack/Facebook/Status.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses, TypeFamilies #-}+module Happstack.Facebook.Status where++import Data.Generics (Data, Typeable)+import qualified Data.Map as Map+import Data.Maybe (catMaybes)+import Happstack.Facebook.Common+import Text.RJson++-- ** Status++data Set + = Set String+ deriving (Data, Typeable, Eq, Ord, Read, Show)++-- according to the docs, you only need uid *or* session_key, but+-- never both. However, it did not work for me with out the session+-- key.+instance (HasSessionKey m) => FacebookMethod m Set where+ type FacebookResponse Set = String+ parseResponse _ = Right . id+ toParams (Set status) =+ do sessionKey <- askSessionKey+ return $ catMaybes $ [ Just ("method","Status.set")+ , Just ("status", status)+ , Just ("session_key", sessionKey)+ ]
+ Happstack/Facebook/Users.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses, TypeFamilies #-}+module Happstack.Facebook.Users where++import Control.Applicative+import Control.Applicative.Error+import Control.Monad (mzero)+import Data.Traversable (sequenceA)+import Data.Generics (Data, Typeable)+import Data.Ix (Ix)+import qualified Data.Map as Map+import Data.List (intercalate)+import Data.Maybe (catMaybes)+import Data.Time (Day, TimeZone)+import Data.Time.LocalTime (hoursToTimeZone)+import Happstack.Facebook.Common hiding (uid, name)+import qualified Happstack.Facebook.Common as C+import Text.JSON++-- * Users++-- ** Users.getStandardInfo++-- TODO: add Data instances once TimeZone and Day have them++data GetStandardInfo+ = GetStandardInfo [User] [StandardInfoField]+ deriving (Eq, Ord, Read, Show, Typeable)++data StandardInfoField+ = UID+ | FirstName+ | LastName+ | Name+ | TimeZone+ | Birthday+ | Sex+-- | Affiliations -- ^ not supported but could be if you write the parser instance+ | Locale+ | ProfileURL+ | ProxiedEmail+ deriving (Eq, Ord, Read, Show, Data, Typeable, Ix, Enum)++instance JSON StandardInfoField where+ showJSON UID = showJSON "uid"+ showJSON FirstName = showJSON "first_name"+ showJSON LastName = showJSON "last_name"+ showJSON Name = showJSON "name"+ showJSON TimeZone = showJSON "timezone"+ showJSON Birthday = showJSON "birthday"+ showJSON Sex = showJSON "sex"+-- showJSON Affiliations = showJSON "affiliations"+ showJSON Locale = showJSON "locale"+ showJSON ProfileURL = showJSON "profile_url"+ showJSON ProxiedEmail = showJSON "proxied_email"+ readJSON (JSString jsstr) =+ let str = fromJSString jsstr in+ case str of+ "uid" -> Ok UID+ "first_name" -> Ok FirstName+ "last_name" -> Ok LastName+ "name" -> Ok Name+ "timezone" -> Ok TimeZone+ "birthday" -> Ok Birthday+ "sex" -> Ok Sex+ "locale" -> Ok Locale+ "profile_url" -> Ok ProfileURL+ "proxied_email" -> Ok ProxiedEmail+ o -> Error $ "Could not parse " ++ o ++ " as a StandardInfoField."+ readJSON jsval = Error $ "Could not parse " ++ show jsval ++ " as a StandardInfoField."++data StandardInfo+ = StandardInfo { uid :: Maybe User+ , firstName :: Maybe String+ , lastName :: Maybe String+ , name :: Maybe String+ , timeZone :: Maybe TimeZone+ , birthday :: Maybe String+ , sex :: Maybe Sex+-- , affiliations :: + , locale :: Maybe String+ , profileURL :: Maybe String+ , proxiedEmail :: Maybe String+ }+ deriving (Eq, Ord, Read, Show, Typeable)++-- parseStandardInfos :: JSValue -> Result [StandardInfo]+-- parseStandardInfos (JSArray vals) = sequenceA $ map parseStandardInfo vals+ +instance JSON StandardInfo where+ readJSON = parseStandardInfo++-- [{"birthday":"January 6, 1977","first_name":"Jane","last_name":"Rahre","name":"Jane Rahre","sex":"female","timezone":-5,"uid":100000160317250,"locale":"en_US","profile_url":"http:\/\/www.facebook.com\/profile.php?id=100000160317250"}]++parseStandardInfo :: JSValue -> Result StandardInfo+parseStandardInfo (JSObject obj) =+ Ok $ StandardInfo { uid = User <$> val "uid"+ , firstName = val "first_name"+ , lastName = val "last_name"+ , name = val "name"+ , timeZone = toTZ <$> val "timezone"+ , birthday = val "birthday" -- FIXME: parse to Day+ , sex = parseSex =<< val "sex"+ , locale = val "locale" -- FIXME+ , profileURL = val "profile_url" -- FIXME+ , proxiedEmail = val "proxied_email"+ }+ where+ val :: (JSON a) => String -> Maybe a+ val name = r2m $ valFromObj name obj+ r2m :: Result a -> Maybe a+ r2m (Ok a) = Just a+ r2m _ = Nothing+ toTZ :: Int -> TimeZone+ toTZ = hoursToTimeZone+ parseSex "male" = return Male+ parseSex "female" = return Female+ parseSex o = mzero+parseStandardInfo o =+ Error $ "Can not parse as StandardInfo: " ++ show o++instance (HasSessionKey m) => FacebookMethod m GetStandardInfo where+ type FacebookResponse GetStandardInfo = [StandardInfo]+ parseResponse _ jstr =+ case (decode jstr) of+ (Ok a) -> Right a+ (Error msg) -> Left msg+ toParams (GetStandardInfo users fields) =+ do sessionKey <- askSessionKey+ return $ catMaybes $ + [ Just ("method", "Users.getStandardInfo")+ , Just ("session_key", sessionKey)+ , Just ("uids", intercalate "," $ map (show . C.uid) users)+ , Just ("fields", encode fields)+ ]
+ Happstack/Facebook/XdReceiver.hs view
@@ -0,0 +1,46 @@+{-# OPTIONS_GHC -F -pgmFtrhsx #-}+module Happstack.Facebook.XdReceiver where++import Control.Applicative((<$>))+import Control.Monad (MonadPlus(..))+import Control.Monad.Trans(MonadIO(..))+import Happstack.Server (ServerMonad(..), Response, dir)+import HSP+import Happstack.Server.HSP.HTML (webHSP)+import Happstack.Facebook.Common+import qualified HSX.XMLGenerator as HSX+import Network.URI (uriPath)+import System.FilePath ((</>), splitPath)++xdReceiverPart :: (MonadIO m, MonadPlus m, ServerMonad m, HasFacebookConfig m) => m Response+xdReceiverPart =+ do config <- askFacebookConfig+ let parts = case splitPath $ uriPath (connectURL config) of+ ("/": rest) -> rest+ o -> o+ dirs parts $ dir "xd_receiver.htm" $ webHSP xdReceiverXML+ where+ dirs :: (ServerMonad m, MonadPlus m) => [String] -> m a -> m a+ dirs [] m = m+ dirs (d:ds) m = dir d $ dirs ds m++-- <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">+xdReceiverXML :: (XMLGenerator m) => XMLGenT m (HSX.XML m)+xdReceiverXML =+ <html>+ <body>+ <script src="http://static.ak.connect.facebook.com/js/api_lib/v0.4/XdCommReceiver.js" type="text/javascript"></script>+ </body>+ </html>++fbInit :: (XMLGenerator m, HasFacebookConfig m ) => ApiKey -> XMLGenT m (HSX.XML m)+fbInit (ApiKey apiKey) = + do config <- askFacebookConfig+ let path = (uriPath (connectURL config)) </> "xd_receiver.htm" + <script type="text/javascript">+ FB.init("<% apiKey %>", "<% path %>");+ </script>++fbFeatureLoader :: (XMLGenerator m) => XMLGenT m (HSX.XML m)+fbFeatureLoader =+ <script src="http://static.ak.connect.facebook.com/js/api_lib/v0.4/FeatureLoader.js.php/en_US" type="text/javascript"></script>
+ Setup.hs view
@@ -0,0 +1,13 @@+#!/usr/bin/env runghc++module Main where++import Distribution.Simple+import Distribution.Simple.Program++trhsxProgram = simpleProgram "trhsx"++main :: IO ()+main = defaultMainWithHooks simpleUserHooks {+ hookedPrograms = [trhsxProgram]+ }
+ debian/copyright view
@@ -0,0 +1,1 @@+BSD
+ examples/ConnectDemo.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -F -pgmFtrhsx #-}+module Main where++import Control.Applicative ((<$>))+import Control.Monad (msum)+import Happstack.Server (FilterMonad, Response, ServerPart, nullConf, simpleHTTP, toResponse)+import Happstack.Facebook.Common (FacebookConfig(apiKey), HasFacebookConfig(askFacebookConfig), HasUser(askUser), FbXML(FbXML), User(uid))+import Happstack.Facebook.Connect (withFacebookConnect, withSessionSP)+import Happstack.Facebook.XdReceiver (fbInit, fbFeatureLoader, xdReceiverPart)+import HSP+import FacebookConfig (facebookConfig)+import qualified HSX.XMLGenerator as HSX++main :: IO ()+main = simpleHTTP nullConf impl++impl :: ServerPart Response+impl = + msum [ withFacebookConnect facebookConfig $ + msum [ xdReceiverPart -- xd_receiver.htm+ , withSessionSP $ fbml (do user <- askUser+ appTemplate "Members Area" () + <div>+ <h1>Welcome to the Members Area</h1>+ <p>Hello, <fb:name uid=(show $ uid user) useyou=False />.</p> + <p>You look like this <fb:profile-pic uid=(show $ uid user) facebook-logo=True />.</p>+ </div>+ )+ , fbml (appTemplate "Login" ()+ <div>+ <h1>Connect using Facebook Connect</h1>+ <fb:login-button onlogin="facebook_onlogin();"></fb:login-button>+ </div>)+ ]+ ]++fbml :: + ( Functor m+ , FilterMonad Response m+ , XMLGenerator m+ ) + => XMLGenT m XML+ -> m Response+fbml xml = toResponse . FbXML <$> (unXMLGenT xml)++-- http://wiki.developers.facebook.com/index.php/Connect/Setting_Up_Your_Site+appTemplate :: + ( Functor m+ , HasFacebookConfig m+ , XMLGenerator m+ , EmbedAsChild m headers+ , EmbedAsChild m body+ , EmbedAsAttr m (Attr (String, String) String)+ ) + => String + -> headers + -> body + -> XMLGenT m (HSX.XML m)+appTemplate title headers body =+ <html xmlns="http://www.w3.org/1999/xhtml" xmlns:fb="http://www.facebook.com/2008/fbml">+ <head>+ <% headers %>+ <meta http-equiv="Content-Type" content="text/html; charset=UTF-8" />+ <title><% title %></title>+ </head>+ <body>+ <% fbFeatureLoader %> -- enables XFBML, Facebook Javascript calls, etc+ <% body %>+ <% fbInit =<< (apiKey <$> askFacebookConfig) %> -- script which causes XFBML to be rendered+ </body>+ </html>
+ examples/FacebookConfig.hs view
@@ -0,0 +1,14 @@+module FacebookConfig {-# WARNING "This demo requires that you provide your own facebook connect configuration information. http://www.facebook.com/developers/?ref=sb" #-} (facebookConfig) where++import Data.Maybe (fromJust)+import Happstack.Facebook.Common (FacebookConfig(..), ApiKey(..), AppId(..), AppSecret(..))+import Network.URI (parseURI)++facebookConfig :: FacebookConfig+facebookConfig =+ FacebookConfig { apiKey = ApiKey ""+ , appSecret = AppSecret ""+ , appId = AppId ""+ , canvasURL = fromJust $ parseURI ""+ , connectURL = fromJust $ parseURI ""+ }
+ happstack-facebook.cabal view
@@ -0,0 +1,55 @@+Name: happstack-facebook+Version: 0.9+License: BSD3+License-file: debian/copyright+Author: jeremy@seereason.com+Maintainer: partners@seereason.com+Synopsis: A package for building Facebook applications using Happstack+Description: A package for building Facebook applications using Happstack+Homepage: http://src.seereason.com/ghc6103/happstack-facebook/+Bug-Reports: http://bugzilla.seereason.com/+Build-Type: Custom+Cabal-version: >= 1.4.0.0+Category: Web, Language++Flag base4+ Description: Choose the even newer, even smaller, split-up base package.++Flag formlets+ Description: Include formlets support. Disabled for now because it requires a forked version of formlets.+ Default: False++Library+ Build-Depends: base, hsp >= 0.4.4, harp >= 0.4, happstack-ixset, happstack-data, happstack-util, mtl, random, happstack-state, html, happstack-server, hsx >= 0.4.4, applicative-extras >= 0.1.3, utf8-string, bytestring, RJson, old-time, network, HTTP >= 4000, time, containers, happstack, json, URLT >= 0.10, filepath+ if flag(base4)+ Build-Depends: base >= 4 && < 5, syb+ Extensions: MultiParamTypeClasses,+ TypeFamilies,+ FlexibleContexts,+ FlexibleInstances,+ TypeSynonymInstances,+ OverlappingInstances,+ UndecidableInstances+ Exposed-Modules: Happstack.Facebook + Happstack.Facebook.Notifications+ Happstack.Facebook.FacebookT+ Happstack.Facebook.Status+ Happstack.Facebook.Photos+ Happstack.Facebook.Feed+ Happstack.Facebook.Common+ Happstack.Facebook.Application+ Happstack.Facebook.Connect+ Happstack.Facebook.XdReceiver+ Happstack.Facebook.Users+ if flag(formlets)+ Exposed-Modules: Happstack.Facebook.Formlets+ Build-Depends: happstack-extra, formlets, formlets-hsp++ GHC-options: -O2 -Wall -fwarn-missing-signatures -fno-warn-name-shadowing -fwarn-orphans -fwarn-tabs -fwarn-unused-binds -fwarn-unused-imports++Executable demo+ Main-Is: ConnectDemo.hs+ Other-modules: FacebookConfig+ Hs-source-dirs: . examples+ GHC-options: -threaded -O2 -Wall -fwarn-missing-signatures -fno-warn-name-shadowing -fwarn-orphans -fwarn-tabs -fwarn-unused-binds -fwarn-unused-imports+ Build-Tools: trhsx