diff --git a/Happstack/Facebook.hs b/Happstack/Facebook.hs new file mode 100644 --- /dev/null +++ b/Happstack/Facebook.hs @@ -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: +-- +shareOnFacebook :: (XMLGenerator m) => XMLGenT m (HSX.XML m) +shareOnFacebook = +
+ + + Share on Facebook +
+ diff --git a/Happstack/Facebook/Application.hs b/Happstack/Facebook/Application.hs new file mode 100644 --- /dev/null +++ b/Happstack/Facebook/Application.hs @@ -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) +-} diff --git a/Happstack/Facebook/Common.hs b/Happstack/Facebook/Common.hs new file mode 100644 --- /dev/null +++ b/Happstack/Facebook/Common.hs @@ -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