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)
fb_sig_expires :: (HasFacebookData FacebookConnectData m) => m (Maybe POSIXTime)
fb_sig_expires = fbd _fbc_sig_expires
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
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))))
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
, 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