{-# 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(..), mapReaderT)
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?
import URLT(URLT)
data FacebookConfig =
FacebookConfig { apiKey :: ApiKey
, appSecret :: AppSecret
, appId :: AppId
, canvasURL :: URI
, canvasCallbackURL :: URI
, tabURL :: Maybe 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 Flid = Flid { unFlid :: Integer }
data Sex = Male | Female
|])
newtype User = User { uid :: Integer }
deriving (Eq, Ord, Read, Show, Ix, Typeable, Data)
$(deriveNewData [''User])
instance Version User
$(deriveSerialize ''User)
newtype Page = Page { pageId :: Integer }
deriving (Eq, Ord, Read, Show, Ix, Typeable, Data)
$(deriveNewData [''Page])
instance Version Page
$(deriveSerialize ''Page)
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 <$> askFacebookState
instance (Monad m) => HasFacebookData d (FacebookT (FacebookState d) m) where
askFacebookData = fbData <$> askFacebookState
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 <$> askFacebookState
instance (Monad m) => HasFacebookData d (FacebookT (FacebookStateU d) m) where
askFacebookData = fbuData <$> askFacebookState
instance (Monad m) => HasUser (FacebookT (FacebookStateU d) m) where
askUser = fbuUser <$> askFacebookState
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 <$> askFacebookState
instance (Monad m) => HasFacebookData d (FacebookT (FacebookStateS d) m) where
askFacebookData = fbsData <$> askFacebookState
instance (Monad m) => HasUser (FacebookT (FacebookStateS d) m) where
askUser = fbsUser <$> askFacebookState
instance (Monad m) => HasSessionKey (FacebookT (FacebookStateS d) m) where
askSessionKey = fbsSessionKey <$> askFacebookState
-- ** 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
-- ** ServerPartT
instance (HasFacebookData d m) => HasFacebookData d (ServerPartT m) where
askFacebookData = lift askFacebookData
instance (HasFacebookConfig m) => HasFacebookConfig (ServerPartT m) where
askFacebookConfig = lift askFacebookConfig
instance (HasUser m) => HasUser (ServerPartT m) where
askUser = lift askUser
instance (HasSessionKey m) => HasSessionKey (ServerPartT m) where
askSessionKey = lift askSessionKey
-- ** URLT
instance (HasFacebookData d m) => HasFacebookData d (URLT u m) where
askFacebookData = lift askFacebookData
instance (HasFacebookConfig m) => HasFacebookConfig (URLT url m) where
askFacebookConfig = lift askFacebookConfig
instance (HasUser m) => HasUser (URLT url m) where
askUser = lift askUser
instance (HasSessionKey m) => HasSessionKey (URLT url m) where
askSessionKey = lift 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") -> True
(Just str) -> error ("key " ++ key ++ " has unparsable value " ++ str)
lookupMBool :: String -> [(String, String)] -> Maybe Bool
lookupMBool key assoc =
case lookup key assoc of
Nothing -> Nothing
(Just "0") -> Just False
(Just "1") -> Just True
(Just str) -> Nothing
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 <style> and <script> tags should be encoded like html not xhtml
{-
instance ToMessage FbXML where
toContentType _ = P.pack "application/xml; charset=utf-8"
toMessage (FbXML xml) = L.fromString (renderAsFBML xml)
instance ToMessage (Maybe XMLMetaData, FbXML) where
toContentType _ = P.pack "application/xml; charset=utf-8"
toMessage (_,FbXML xml) = L.fromString (renderAsFBML xml)
-}
instance ToMessage FbXML where
toContentType _ = P.pack "text/html; charset=utf-8"
toMessage (FbXML xml) = L.fromString (renderAsFBML xml)
instance ToMessage (Maybe XMLMetaData, FbXML) where
toContentType _ = P.pack "text/html; charset=utf-8"
toMessage (_,FbXML xml) = L.fromString (renderAsFBML xml)
withFacebook' :: (Monad m) => FacebookConfig -> d -> FacebookT (FacebookState d) m a -> m a
withFacebook' config facebookData m = runReaderT (unFacebookT m) (FacebookState config facebookData)
-- |function to read some FacebookConnectData from the Facebook environment
fbd :: (HasFacebookData d m) => (d -> a) -> m a
fbd select =
do d <- askFacebookData
return (select d)
-- TODO: figure how to implement this so that it can be called when the FacebookT is embed inside other monad transformers
withUser ::
( HasFacebookConfig (FacebookT r m)
, HasFacebookData d (FacebookT r m)
)
=> User -> FacebookT (FacebookStateU d) m a -> FacebookT r m a
withUser u (FacebookT action) =
do c <- askFacebookConfig
d <- askFacebookData
FacebookT $ ReaderT $ const (runReaderT action (FacebookStateU c d u))
withSession :: (HasUser (FacebookT (s d) m), HasFacebookData d (FacebookT (s d) m), HasFacebookConfig (FacebookT (s d) m)) =>
SessionKey
-> FacebookT (FacebookStateS d) m a
-> FacebookT (s d) m a
withSession s (FacebookT action) =
do c <- askFacebookConfig
d <- askFacebookData
u <- askUser
FacebookT $ ReaderT $ const $ runReaderT action (FacebookStateS c d u s)
-- FacebookT $ ReaderT (runReaderT action (FacebookStateS c d u s))