happstack-facebook-0.28: Happstack/Facebook/Application.hs
{-# 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, mapMaybe)
import Data.Time.Clock.POSIX (POSIXTime)
import Happstack.Crypto.MD5 (md5, stringMD5)
import Happstack.Facebook.Common
import Happstack.Facebook.FacebookT
import qualified Network.HTTP as HTTP
import Network.Browser (Form(..),formToRequest, request, browse)
import Network.URI
import Happstack.Server (Method(POST, GET), ServerMonad, HasRqData, withDataFn, lookPairs)
-- |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
-- NOTE: the order of these fields is subject to change, so use the field labels for minimum breakage.
data FacebookData =
FacebookData
{ fbPairs :: [(String, String)]
, _fb_sig_added :: Bool
, _fb_sig_is_admin :: Maybe 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_sig_profile_user :: Maybe User
, _fb_sig_profile_session_key :: Maybe SessionKey
, _fb_sig_page_id :: Maybe Page
, _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_is_admin :: (HasFacebookData FacebookData m) => m (Maybe Bool)
fb_sig_is_admin = fbd _fb_sig_is_admin
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
-- |The user ID of the profile owner for the tab being requested.
fb_sig_profile_user :: (HasFacebookData FacebookData m) => m (Maybe User)
fb_sig_profile_user = fbd _fb_sig_profile_user
-- |The session key for the profile owner, which you use to render this user's profile tab content.
fb_sig_profile_session_key :: (HasFacebookData FacebookData m) => m (Maybe SessionKey)
fb_sig_profile_session_key = fbd _fb_sig_profile_session_key
fb_sig_page_id :: (HasFacebookData FacebookData m) => m (Maybe Page)
fb_sig_page_id = fbd _fb_sig_page_id
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'
parseFacebookData :: FacebookConfig -> [(String, String)] -> FacebookData
parseFacebookData config pairs =
let lookupString k = case lookup k pairs of
Nothing -> error ("Could not find required field " ++ k)
(Just v) -> v
read' :: (Show a, Read a) => String -> a
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_sig_is_admin = lookupMBool "fb_sig_is_admin" 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
fb_sig_profile_user' =
case lookup "fb_sig_profile_user" pairs of
(Just uid) -> Just $ User (read' uid)
Nothing -> Nothing
fb_sig_profile_session_key' = lookup "fb_sig_profile_session_key" pairs
fb_sig_page_id = case lookup "fb_sig_page_id" pairs of
(Just pid) -> Just $ Page (read' pid)
Nothing -> Nothing
valid_sig = validateSignature (appSecret config) fb_sig' pairs
in (FacebookData { fbPairs = pairs
, _fb_sig_added = fb_sig_added'
, _fb_sig_is_admin = fb_sig_is_admin
, _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_sig_profile_user = fb_sig_profile_user'
, _fb_sig_profile_session_key = fb_sig_profile_session_key'
, _fb_sig_page_id = fb_sig_page_id
, _fb_valid_sig = valid_sig
})
-- todo: add code to validate the sent fb_sig
withFacebookData :: (Functor m, Monad m, MonadPlus m, ServerMonad m, HasRqData m, MonadIO m) => FacebookConfig -> (FacebookData -> m r) -> m r
withFacebookData config f =
withDataFn
(do pairs <- lookPairs
let pairs' = mapMaybe (\(k,v) -> case v of
(Left e) -> Nothing
(Right c) -> Just (k,c)) pairs
return $ parseFacebookData config pairs')
f
withFacebook :: (Functor m, Monad m, MonadPlus m, ServerMonad m, MonadIO m, HasRqData 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
withProfileUserSP :: ( 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
withProfileUserSP handler =
do mUser <- fb_sig_profile_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
, Functor 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' :: (Functor m, 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 (Functor m, Monad m) => HasFacebookData FacebookData m where
askFacebookData :: m FacebookData
class (Functor m, Monad m) => HasUser m where
askUser :: m User
class (Functor m, Monad m) => HasSessionKey m where
askSessionKey :: m SessionKey
-}
{-
class (Functor m, 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 (Functor m, 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 (Functor m, Monad m) => HasFacebookConfig (FacebookT FacebookState m) where
askFacebookConfig = fbConfig <$> ask
instance (Functor m, 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 (Functor m, Monad m) => HasFacebookConfig (FacebookT FacebookStateU m) where
askFacebookConfig = fbuConfig <$> ask
instance (Functor m, Monad m) => HasFacebookData (FacebookT FacebookStateU m) where
askFacebookData = fbuData <$> ask
instance (Functor m, 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 (Functor m, Monad m) => HasFacebookConfig (FacebookT FacebookStateS m) where
askFacebookConfig = fbsConfig <$> ask
instance (Functor m, Monad m) => HasFacebookData (FacebookT FacebookStateS m) where
askFacebookData = fbsData <$> ask
instance (Functor m, Monad m) => HasUser (FacebookT FacebookStateS m) where
askUser = fbsUser <$> ask
instance (Functor m, 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)
-}