{-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -F -pgmFtrhsx #-} module Main where import Control.Applicative ((<$>)) import Control.Monad (msum) import Happstack.Server (FilterMonad, Response, ServerPart, nullConf, simpleHTTP, toResponse) import Happstack.Facebook.Common (FacebookConfig(apiKey), HasFacebookConfig(askFacebookConfig), HasUser(askUser), FbXML(FbXML), User(uid)) import Happstack.Facebook.Connect (withFacebookConnect, withSessionSP) import Happstack.Facebook.XdReceiver (fbInit, fbFeatureLoader, xdReceiverPart) import HSP import FacebookConfig (facebookConfig) import qualified HSX.XMLGenerator as HSX main :: IO () main = simpleHTTP nullConf impl impl :: ServerPart Response impl = msum [ withFacebookConnect facebookConfig $ msum [ xdReceiverPart -- xd_receiver.htm , withSessionSP $ fbml (do user <- askUser appTemplate "Members Area" ()

Welcome to the Members Area

Hello, .

You look like this .

) , fbml (appTemplate "Login" ()

Connect using Facebook Connect

) ] ] fbml :: ( Functor m , FilterMonad Response m , XMLGenerator m ) => XMLGenT m XML -> m Response fbml xml = toResponse . FbXML <$> (unXMLGenT xml) -- http://wiki.developers.facebook.com/index.php/Connect/Setting_Up_Your_Site appTemplate :: ( Functor m , HasFacebookConfig m , XMLGenerator m , EmbedAsChild m headers , EmbedAsChild m body , EmbedAsAttr m (Attr (String, String) String) ) => String -> headers -> body -> XMLGenT m (HSX.XML m) appTemplate title headers body = <% headers %> <% title %> <% fbFeatureLoader %> -- enables XFBML, Facebook Javascript calls, etc <% body %> <% fbInit =<< (apiKey <$> askFacebookConfig) %> -- script which causes XFBML to be rendered