{-# OPTIONS -fcontext-stack=25 #-} {-# LANGUAGE TemplateHaskell, FlexibleInstances, CPP, ImplicitParams, RecursiveDo, DeriveDataTypeable, PatternSignatures, ScopedTypeVariables, MultiParamTypeClasses, FunctionalDependencies, OverlappingInstances, UndecidableInstances, FlexibleContexts #-} module Happstack.Server.Facebook where import Control.Monad.Reader import Data.Char import Data.List import Data.Maybe import Happstack.Data import Happstack.Contrib.Atom (Email(..)) import Happstack.Contrib.HList import Happstack.Server.SURI import Network.URI (URI) import Happstack.Server.SimpleHTTP hiding (escape,Method) import Happstack.Crypto.MD5 ( md5, stringMD5) import System.Directory import Data.Generics import qualified Network.Browser as Browser import qualified Network.HTTP as HTTP import Control.Monad.Identity import Happstack.Server.XSLT import Happstack.Server.HTTP.Types (Response,rsBody) import qualified Data.ByteString.Lazy.Char8 as L import System.Time {-- Conceptually the demo app should expose functionality in website and facebook at once 1. facebook wrapper should take an fbconf and a require app added parameter 2. ServerParts that are depended on fb_Ses@(FB_Ses uid sessionId appadded) can we make them implicit parameters so the user doesn't have to see it? 3. if we get the parameters in a post then check valid and assign. 4. if we get parameters in a cookie then check valid and assign. 5. set cookie on initial login 6. calling API functions by typename before _response of returned XML Friends_get_response [uid] <- fb $ Fields fs .&. Title t * make the response types be instances of HasArgs so fb can enforce * define InCouple class that enforces that a type is inside the couple somewhere. * enhance xml lib to allow matching if the constructor prefix matches. Then we get modify fb to drop _response in element name before converting. Friends_get_response [uid] <- fb $ Fields fs .&. Title t -- and it all typechecks! also need to get pairs to drop the constructor names if present. careful to only do so if they are present! e.g. UserName "alex" should become userName=alex. But UserInfo (UserName "alex") should become userName=alex uids fields title markup uids1 uids2 so use heterogenous list of things that are convertible --} $(deriveAll [''Show,''Read,''Default, ''Eq, ''Ord] [d| data Friends_getAppUsers_response = Friends_getAppUsers_response [Uid] data Friends_get_response = Friends_get_response [Uid] newtype Uid = Uid Integer newtype Friends = Friends [Integer] newtype Uids1 = Uids1 [Integer] newtype Uids2 = Uids2 [Integer] newtype Uids = Uids [Integer] -- used in array posted from multi-friend-input newtype Requested = Requested [Ids] newtype Ids = Ids Integer newtype Fields = Fields [String] newtype Title = Title String newtype Method = Method String data Fb_config = Fb_config Api_key Secret App_id Canvas_id Admins newtype Secret = Secret String newtype Api_key = Api_key String newtype App_id = App_id Int newtype Canvas_id = Canvas_id String newtype Admins = Admins [Uid] newtype Session_key=Session_key String newtype Fb_sig_expires=Fb_sig_expires Int data FBSession = FBSession Fb_sig_in_canvas Fb_sig_added Fb_sig_time Fb_sig_api_key Fb_sig ---optional fields Fb_sig_user Fb_sig_friends Fb_sig_session_key Fb_sig_expires Fb_sig_profile_update_time --stuff that is just carried here (Maybe (XSLTCmd,XSLPath)) newtype Tbool = Tbool Bool newtype Tlist = Tlist [Int] data Friend_info = Friend_info Uid Uid Are_friends newtype Are_friends = Are_friends Bool data Friends_areFriends_response = Friends_areFriends_response [Friend_info] newtype Users_getInfo_response = Users_getInfo_response [User] data Profile_setFBML_response = Profile_setFBML_response Bool data Profile_getFBML_response = Profile_getFBML_response String newtype Notifications_send_response = Notifications_send_response String newtype To_ids = To_ids [Integer] newtype Notification = Notification String data Error_response = Error_response Error_code newtype Error_code=Error_code Int newtype Fb_sig_in_canvas = Fb_sig_in_canvas Bool newtype Fb_sig_added = Fb_sig_added Bool newtype Fb_sig_time = Fb_sig_time Integer newtype Fb_sig_api_key = Fb_sig_api_key String newtype Fb_sig = Fb_sig String newtype Fb_sig_user = Fb_sig_user Integer newtype Fb_sig_friends = Fb_sig_friends [Integer] -- add automatic comma sep parse newtype Fb_sig_session_key= Fb_sig_session_key String newtype Fb_sig_profile_update_time = Fb_sig_profile_update_time Integer data User = User Uid (Maybe About_me) Affiliations -- we may need more lets see newtype About_me = About_me String newtype Affiliations = Affiliations [Affiliation] data Affiliation = Affiliation Nid Name Type Status Year newtype Nid = Nid Integer newtype Name = Name String newtype Type = Type String -- should be fixed later to enumeration newtype Status = Status String -- not sure what is here newtype Year = Year Int newtype AppUsers = AppUsers [Uid] data InviteInfo = InviteInfo Uid AppUsers BaseURL --- used for producing invites data NoFriends = NoFriends newtype InstallURL = InstallURL String newtype BaseURL = BaseURL String |] ) instance Version Uid instance Version Element $(deriveSerializeFor [ ''Uid , ''Element ]) (.$) :: a -> (a -> b) -> b a .$ b = b a fb'::(?fb::Int)=>Int fb' = ?fb type FBInfo = (Api_key,Secret,FBSession) friends_getAppUsers::(?fbSession::FBSession) => IO AppUsers friends_getAppUsers = do Friends_getAppUsers_response uids <- fb (?fbSession::FBSession) () return $ AppUsers $ gFind uids users_getInfo :: (?fbSession::FBSession, Data a) => a -> [String] -> IO [User] users_getInfo uids fields = do Users_getInfo_response users <- fb (?fbSession::FBSession) $ (Uids $ gFind uids) .&. (Fields fields) return users getNetworks::(?fbSession::FBSession)=>IO (Maybe Affiliations) getNetworks = return . gFind =<< users_getInfo [uid] ["affiliations"] --now we want to shift this so that the stuff is rendered in the present layer notifications_send :: (ToMessage b, Xml b, ToMessage c, Xml c, ?fbSession::FBSession, Data a, Show a) => a -> b -> c -> IO String notifications_send uids notifObj emailObj = do print "UIDS=" print uids let (xsltcmd::XSLTCmd ,xslpath::XSLPath) = gFind' (?fbSession::FBSession) aux x = do let els = toPublicXml x if null els then return "" else do let res = toResponse els xres <- doXslt xsltcmd xslpath res (return . L.unpack . rsBody) xres aux :: (ToMessage a,Xml a)=> a -> IO String (notification::String) <- aux notifObj (email::String) <- aux emailObj Notifications_send_response confirm <- fb (?fbSession::FBSession) $ (To_ids $ gFind uids) .&. (Notification notification) -- .&. (Email email) .&. (if null email then Nothing else Just $ Email email) print "CONFIRM" print confirm return confirm profile_setFBML :: (?fbSession::FBSession, Xml a, Xml b, Show a, Show b, Data a, Data b, Eq a, Eq b) => a -> b -> IO Bool profile_setFBML u_id markup = do --can markup be passed as straight string of fbml? --how do we call out to xsl for this? Profile_setFBML_response x <- fb (?fbSession::FBSession) $ u_id .&. markup return x profile_getFBML :: (?fbSession::FBSession, Xml a, Show a, Data a, Eq a) => a -> IO String profile_getFBML u_id = do Profile_getFBML_response markup <- fb (?fbSession::FBSession) $ u_id --does this need decoding? return markup friends_areFriends :: (?fbInfo::FBInfo, Data a, Data b) => a -> b -> IO [Friend_info] friends_areFriends uids1 uids2 = do Friends_areFriends_response friendInfos <- fb (?fbInfo::FBInfo) $ (Uids1 $ gFind uids1) .&. (Uids2 $ gFind uids2) return friendInfos getMbUid :: (?fbSession::FBSession, Monad m) => () -> m (Maybe Uid) getMbUid () = return mbUid getUid :: (?fbSession::FBSession, Monad m) => () -> m Uid getUid () = getMbUid () >>= return . fromJust mbUid::(?fbSession::FBSession) => (Maybe Uid) mbUid = fmap toUid $ gFind ?fbSession uid::(?fbSession::FBSession) => (Uid) uid = fromJust mbUid friends::(?fbSession::FBSession) => (Friends) friends = fromJust $ fmap toFriends $ gFind (?fbSession::FBSession) numFriends::(?fbSession::FBSession) => Int numFriends = let (Friends fs) = friends in length fs getAppURLs :: IO (BaseURL, InstallURL) getAppURLs = do config <- getConfig let Api_key key = gFind' config Canvas_id cid = gFind' config installURL = InstallURL $ "http://www.facebook.com/install.php?api_key="++key baseURL = BaseURL $ "http://apps.facebook/com/"++cid return (baseURL,installURL) getInstallURL::(?fbSession::FBSession) => String -> IO InstallURL getInstallURL (next) = do config <- getConfig let Api_key key = gFind' config return $ InstallURL $ "http://www.facebook.com/install.php?api_key="++key++ if null next then "" else "&next="++escape next getBaseURL :: IO BaseURL getBaseURL = do config <- getConfig let (Canvas_id cid) = gFind' config return $ BaseURL $ "http://apps.facebook/com/"++cid++"/" --there is no invite info if all user's friends are app users getInviteInfo::(?fbSession::FBSession) => IO (Maybe InviteInfo) getInviteInfo = do appUsers@(AppUsers apps) <-friends_getAppUsers -- let (Friends fs) = friends if numFriends == length apps then return Nothing else do return . Just . InviteInfo uid appUsers =<< getBaseURL isAppAdded::(?fbSession::FBSession) => Bool isAppAdded = maybe (error "no fb_sig_added") (const appAdded) mbAdded where mbAdded = gFind ?fbSession Fb_sig_added appAdded = fromJust mbAdded getConfig :: IO Fb_config getConfig = --yes reading a file is bad but roundtripping to fb sucks too do let configPath = "config/facebook.xml" fe <- doesFileExist configPath when (not fe) $ error $ "you need a "++configPath++ "file of type fb_config" configData <- readFile configPath -- need error message if this fails print configData let (fb_config::Fb_config) = runIdentity $ fromString Flexible configData return fb_config getAdmins::IO [Uid] getAdmins = getConfig >>= return . gFind getIsAdmin::(?fbSession::FBSession) => IO Bool getIsAdmin = getAdmins >>= return . elem uid fb :: (Show a, FromString a, Xml b, Show b, Data b, Eq b, Data a, Default a, Data t) => t -> b -> IO a fb fbSession a = mdo fb_config <- getConfig TOD t _ <- getClockTime let req = makeReq t (fbSession,fb_config) a resp print "REQ=" print req res <- spost fbserver req let body = HTTP.rspBody $ snd res print (body::String) print "body printed" let resp = runIdentity $ fromString Flexible body print resp print "resp returned" return resp fbserver :: Network.URI.URI fbserver=suri $ fromJust $ parse "http://api.facebook.com/restserver.php" toUid :: Fb_sig_user -> Uid toUid (Fb_sig_user u_id) = Uid u_id toFriends :: Fb_sig_friends -> Friends toFriends (Fb_sig_friends fs) = Friends fs toSesKey :: Fb_sig_session_key -> Session_key toSesKey (Fb_sig_session_key s) = Session_key s makeReq :: (Xml b, Show b, Data b, Eq b, Show a, Data t, Default t, Data a1) => a -> a1 -> b -> t -> [([Char], [Char])] makeReq t fbInfo a resp= req where [example,_] = [defaultValue,resp] cons = first toLower $ show $ toConstr example fbCmd' = map (\x->if x=='_' then '.' else x) $ "facebook."++ cons meth = Method $ if ".response" `isSuffixOf` fbCmd' then take (length fbCmd'- (length "_response")) fbCmd' else fbCmd' sesKey = (fmap toSesKey (gFind fbInfo::Maybe Fb_sig_session_key)) args = ("v","1.0"):("call_id",show t): (toPairs $ apikey .&. meth .&. sesKey .&. a) s_args = sort args Secret secret = fromJust $ gFind fbInfo (apikey::Api_key) = fromJust $ gFind fbInfo raw = concatMap (\(x,y)->x++'=':y) s_args ++ (secret) sig = stringMD5 (md5 (L.pack raw)) req = s_args++[("sig",sig)] spost :: URI -> [(String,String)] -> IO (URI, HTTP.Response String) spost u q = Browser.browse $ Browser.request $ Browser.formToRequest $ Browser.Form HTTP.POST u q consIf :: Bool -> a -> [a] -> [a] consIf False _ list = list consIf _ x list = x:list fbApp :: (MonadIO m, ToMessage r, ServerMonad m, MonadPlus m) => XSLTCmd -> XSLPath -> (FBSession -> m r) -> m Response fbApp xslproc stylesheet app -- api_key secret app = xslt xslproc stylesheet $ withData fun where fun (fbSes::FBSession) = app $ gSet (Just (xslproc,stylesheet)) fbSes onlyInstalled :: (?fbSession::FBSession, MonadIO m, FilterMonad Response m, ServerMonad m) => [m [Char]] -> [m [Char]] onlyInstalled app = if isAppAdded then app else [uriRest $ \uri -> fbSeeOther . gFind' =<< liftIO (getInstallURL uri) ] postAdd :: (Monad m, ServerMonad m, FilterMonad Response m) => [m String] postAdd = [uriRest $ \uri -> fbSeeOther uri] -- = fbSeeOther :: (Monad m, FilterMonad Response m) => [Char] -> m [Char] fbSeeOther s = ok $ "" --can make it typesafe. now we just need to deal with response class HasArgs a b | a -> b instance (HasT args Uid,HasT args Title) => HasArgs Friends_get_response args f::(Default r,HasArgs r args) => args -> r f _ = defaultValue tf :: [Uid] Friends_get_response tf = f (Uid 123 .&. Title "abc" .&. Secret "abc")