{-# 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
, _fbc_valid_sig :: Bool
}
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
fb_sig_cookies :: (HasFacebookData FacebookConnectData m) => m [(String, Cookie)]
fb_sig_cookies = fbd _fbc_cookies
-- |is the signature valid
fb_valid_sig :: (HasFacebookData FacebookConnectData m) => m Bool
fb_valid_sig = fbd _fbc_valid_sig
validateSignature :: AppSecret -> Maybe String -> [(String, Cookie)] -> Bool
validateSignature secret sig cookies = sig == sig'
where sorted = sortBy (compare `on` fst) cookies
dataStr = concatMap (\(k,v) -> k ++ '=' : (cookieValue v)) sorted
sig' = Just $ 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
let fbcCookies = map (\(k,v) -> (drop ((length (unApiKey (apiKey config)))+1) k, v)) $ filter (isPrefixOf ((unApiKey (apiKey config))++"_") . fst) cookies
return $ FacebookConnectData
{ _fbc_cookies = fbcCookies
, _fbc_sig_expires = (fmap readTime expires)
, _fbc_sig_session_key = sesKey
, _fbc_sig_ss = ss
, _fbc_user = (fmap (User . read) user)
, _fbc_sig = sig
, _fbc_valid_sig = (validateSignature (appSecret config) sig fbcCookies)
}
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
-- |clear the facebook connect cookies effectively logging the user out
fbcLogout :: (HasFacebookData FacebookConnectData m, HasFacebookConfig m, FilterMonad Response m) => m ()
fbcLogout =
do cookies <- fb_sig_cookies
config <- askFacebookConfig
let clear c =
do let key = unApiKey (apiKey config) ++"_"++ c
cookie = (mkCookie key "0")
addCookie 0 cookie
mapM (clear . fst) cookies
return ()