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)
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)
-}