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(..))
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
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
data FacebookConfig =
FacebookConfig { apiKey :: ApiKey
, appSecret :: AppSecret
, appId :: AppId
, canvasURL :: 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 User = User { uid :: Integer }
newtype Flid = Flid { unFlid :: Integer }
data Sex = Male | Female
|])
instance Version User
$(deriveSerialize ''User)
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
data FacebookState d
= FacebookState { fbConfig :: FacebookConfig
, fbData :: d
}
instance (Monad m) => HasFacebookConfig (FacebookT (FacebookState d) m) where
askFacebookConfig = fbConfig <$> ask
instance (Monad m) => HasFacebookData d (FacebookT (FacebookState d) m) where
askFacebookData = fbData <$> ask
data FacebookStateU d
= FacebookStateU { fbuConfig :: FacebookConfig
, fbuData :: d
, fbuUser :: User
}
instance (Monad m) => HasFacebookConfig (FacebookT (FacebookStateU d) m) where
askFacebookConfig = fbuConfig <$> ask
instance (Monad m) => HasFacebookData d (FacebookT (FacebookStateU d) m) where
askFacebookData = fbuData <$> ask
instance (Monad m) => HasUser (FacebookT (FacebookStateU d) m) where
askUser = fbuUser <$> ask
data FacebookStateS d
= FacebookStateS { fbsConfig :: FacebookConfig
, fbsData :: d
, fbsUser :: User
, fbsSessionKey :: SessionKey
}
instance (Monad m) => HasFacebookConfig (FacebookT (FacebookStateS d) m) where
askFacebookConfig = fbsConfig <$> ask
instance (Monad m) => HasFacebookData d (FacebookT (FacebookStateS d) m) where
askFacebookData = fbsData <$> ask
instance (Monad m) => HasUser (FacebookT (FacebookStateS d) m) where
askUser = fbsUser <$> ask
instance (Monad m) => HasSessionKey (FacebookT (FacebookStateS d) m) where
askSessionKey = fbsSessionKey <$> ask
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
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)
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") -> False
(Just str) -> error ("key " ++ key ++ " has unparsable value " ++ str)
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")
, ("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
res <- execRequest req
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
res <- execRequest req
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
res <- execRequest req
return $ parseResponse (Proxy :: Proxy (m method)) res
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 }
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)
fbd :: (HasFacebookData d m) => (d -> a) -> m a
fbd select =
do d <- askFacebookData
return (select d)
withUser :: (HasFacebookData d (FacebookT (s d) m), HasFacebookConfig (FacebookT (s d) m))
=> User
-> FacebookT (FacebookStateU d) m a
-> FacebookT (s d) 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)