diff --git a/happstack-contrib.cabal b/happstack-contrib.cabal --- a/happstack-contrib.cabal +++ b/happstack-contrib.cabal @@ -1,5 +1,5 @@ Name: happstack-contrib -Version: 0.1 +Version: 0.2.1 Synopsis: Web related tools and services. Description: Collection of standalone applications License: BSD3 @@ -16,21 +16,39 @@ Flag tests Description: Build the testsuite, and include the tests in the library - Default: True + Default: False Library Exposed-modules: - HAppS.Server.Facebook - HAppS.Store.FlashMsgs - HAppS.Store.HelpReqs + Happstack.Server.Facebook + Happstack.Store.FlashMsgs + Happstack.Store.HelpReqs + Happstack.Contrib.Atom + Happstack.Contrib.HList + Happstack.Contrib.HListBase if flag(tests) Exposed-modules: - HAppS.Contrib.Tests + Happstack.Contrib.Tests + Happstack.Contrib.Tests.HList001 + Happstack.Contrib.Tests.HList002 + Happstack.Contrib.Tests.HasT001 - Build-Depends: base, network, old-time, bytestring, happstack-server, - mtl, HTTP >= 4000.0.2, directory, happstack-util, happstack-data, - happstack-state, happstack-ixset + build-depends: base, + bytestring, + directory, + happstack-server >= 0.2.1 && < 0.3, + happstack-util >= 0.2.1 && < 0.3, + happstack-state >= 0.2.1 && < 0.3, + happstack-ixset >= 0.2.1 && < 0.3, + happstack-data >= 0.2.1 && < 0.3, + HTTP >= 4000.0.2, + mtl, + network, + old-time + + if flag(tests) + build-depends: template-haskell hs-source-dirs: src diff --git a/src/HAppS/Server/Facebook.hs b/src/HAppS/Server/Facebook.hs deleted file mode 100644 --- a/src/HAppS/Server/Facebook.hs +++ /dev/null @@ -1,433 +0,0 @@ -{-# OPTIONS -fcontext-stack=25 #-} -{-# LANGUAGE TemplateHaskell, FlexibleInstances, CPP, ImplicitParams, RecursiveDo, DeriveDataTypeable, PatternSignatures, - ScopedTypeVariables, MultiParamTypeClasses, FunctionalDependencies, OverlappingInstances, UndecidableInstances #-} -module HAppS.Server.Facebook where -import Control.Monad.Reader - -import Data.Char -import Data.List -import Data.Maybe - -import HAppS.Data -import HAppS.Data.Atom (Email(..)) -import HAppS.Server.SURI -import Network.URI (URI) -import HAppS.Server.SimpleHTTP hiding (escape,Method) - -import HAppS.Crypto.MD5 ( md5, stringMD5) -import System.Directory - -import Data.Generics - -import qualified Network.Browser as Browser -import qualified Network.HTTP as HTTP -import Control.Monad.Identity - -import HAppS.Server.XSLT -import HAppS.Server.HTTP.Types (Response,rsBody) -import qualified Data.ByteString.Lazy.Char8 as L -import System.Time -{-- -Conceptually the demo app should expose functionality in website and facebook at once - -1. facebook wrapper should take an fbconf and a require app added parameter -2. ServerParts that are depended on fb_Ses@(FB_Ses uid sessionId appadded) - can we make them implicit parameters so the user doesn't have to see it? -3. if we get the parameters in a post then check valid and assign. -4. if we get parameters in a cookie then check valid and assign. -5. set cookie on initial login -6. calling API functions by typename before _response of returned XML - Friends_get_response [uid] <- fb $ Fields fs .&. Title t - -* make the response types be instances of HasArgs so fb can enforce -* define InCouple class that enforces that a type is inside the couple somewhere. -* enhance xml lib to allow matching if the constructor prefix matches. Then we get - modify fb to drop _response in element name before converting. - - Friends_get_response [uid] <- fb $ Fields fs .&. Title t -- and it all typechecks! - -also need to get pairs to drop the constructor names if present. -careful to only do so if they are present! e.g. UserName "alex" should become -userName=alex. But UserInfo (UserName "alex") should become userName=alex - - - - -uids fields title markup -uids1 uids2 - -so use heterogenous list of things that are convertible ---} - -$(deriveAll [''Show,''Read,''Default, ''Eq, ''Ord] - [d| - - - data Friends_getAppUsers_response = Friends_getAppUsers_response [Uid] - data Friends_get_response = Friends_get_response [Uid] - - newtype Uid = Uid Integer - newtype Friends = Friends [Integer] - newtype Uids1 = Uids1 [Integer] - newtype Uids2 = Uids2 [Integer] - newtype Uids = Uids [Integer] - - -- used in array posted from multi-friend-input - newtype Requested = Requested [Ids] - newtype Ids = Ids Integer - - newtype Fields = Fields [String] - newtype Title = Title String - newtype Method = Method String - - - - data Fb_config = Fb_config Api_key Secret App_id Canvas_id Admins - newtype Secret = Secret String - newtype Api_key = Api_key String - newtype App_id = App_id Int - newtype Canvas_id = Canvas_id String - newtype Admins = Admins [Uid] - - - newtype Session_key=Session_key String - newtype Fb_sig_expires=Fb_sig_expires Int - - data FBSession = FBSession - Fb_sig_in_canvas - Fb_sig_added - Fb_sig_time - Fb_sig_api_key - Fb_sig - ---optional fields - Fb_sig_user - Fb_sig_friends - Fb_sig_session_key - Fb_sig_expires - Fb_sig_profile_update_time - --stuff that is just carried here - (Maybe (XSLTCmd,XSLPath)) - - newtype Tbool = Tbool Bool - newtype Tlist = Tlist [Int] - data Friend_info = Friend_info Uid Uid Are_friends - newtype Are_friends = Are_friends Bool - data Friends_areFriends_response = Friends_areFriends_response [Friend_info] - newtype Users_getInfo_response = Users_getInfo_response [User] - data Profile_setFBML_response = Profile_setFBML_response Bool - data Profile_getFBML_response = Profile_getFBML_response String - - newtype Notifications_send_response = Notifications_send_response String - newtype To_ids = To_ids [Integer] - newtype Notification = Notification String - data Error_response = Error_response Error_code - newtype Error_code=Error_code Int - - newtype Fb_sig_in_canvas = Fb_sig_in_canvas Bool - newtype Fb_sig_added = Fb_sig_added Bool - newtype Fb_sig_time = Fb_sig_time Integer - newtype Fb_sig_api_key = Fb_sig_api_key String - newtype Fb_sig = Fb_sig String - newtype Fb_sig_user = Fb_sig_user Integer - newtype Fb_sig_friends = Fb_sig_friends [Integer] -- add automatic comma sep parse - newtype Fb_sig_session_key= Fb_sig_session_key String - newtype Fb_sig_profile_update_time = Fb_sig_profile_update_time Integer - - data User = User Uid (Maybe About_me) Affiliations -- we may need more lets see - newtype About_me = About_me String - newtype Affiliations = Affiliations [Affiliation] - data Affiliation = Affiliation Nid Name Type Status Year - newtype Nid = Nid Integer - newtype Name = Name String - newtype Type = Type String -- should be fixed later to enumeration - newtype Status = Status String -- not sure what is here - newtype Year = Year Int - - newtype AppUsers = AppUsers [Uid] - data InviteInfo = InviteInfo Uid AppUsers BaseURL --- used for producing invites - data NoFriends = NoFriends - newtype InstallURL = InstallURL String - newtype BaseURL = BaseURL String - |] - ) - -instance Version Uid -instance Version Element - -$(deriveSerializeFor [ ''Uid - , ''Element ]) - - -(.$) :: a -> (a -> b) -> b -a .$ b = b a -fb'::(?fb::Int)=>Int -fb' = ?fb -type FBInfo = (Api_key,Secret,FBSession) - -friends_getAppUsers::(?fbSession::FBSession) => IO AppUsers -friends_getAppUsers = - do - Friends_getAppUsers_response uids <- fb (?fbSession::FBSession) () - return $ AppUsers $ gFind uids - -users_getInfo :: (?fbSession::FBSession, Data a) => a -> [String] -> IO [User] -users_getInfo uids fields = - do - Users_getInfo_response users <- fb (?fbSession::FBSession) $ (Uids $ gFind uids) .&. (Fields fields) - return users - -getNetworks::(?fbSession::FBSession)=>IO (Maybe Affiliations) -getNetworks = return . gFind =<< users_getInfo [uid] ["affiliations"] - - ---now we want to shift this so that the stuff is rendered in the present layer -notifications_send :: (ToMessage b, - Xml b, - ToMessage c, - Xml c, - ?fbSession::FBSession, - Data a, - Show a) => - a -> b -> c -> IO String -notifications_send uids notifObj emailObj = - do - print "UIDS=" - print uids - let (xsltcmd::XSLTCmd - ,xslpath::XSLPath) = gFind' (?fbSession::FBSession) - aux x = do - let els = toPublicXml x - if null els then return "" else do - let res = toResponse els - xres <- doXslt xsltcmd xslpath res - (return . L.unpack . rsBody) xres - - aux :: (ToMessage a,Xml a)=> a -> IO String - (notification::String) <- aux notifObj - (email::String) <- aux emailObj - Notifications_send_response confirm <- - fb (?fbSession::FBSession) $ - (To_ids $ gFind uids) .&. - (Notification notification) - -- .&. (Email email) - .&. (if null email then Nothing else Just $ Email email) - print "CONFIRM" - print confirm - return confirm - -profile_setFBML :: (?fbSession::FBSession, - Xml a, - Xml b, - Show a, - Show b, - Data a, - Data b, - Eq a, - Eq b) => - a -> b -> IO Bool -profile_setFBML u_id markup = - do - --can markup be passed as straight string of fbml? - --how do we call out to xsl for this? - Profile_setFBML_response x <- fb (?fbSession::FBSession) $ u_id .&. markup - return x - -profile_getFBML :: (?fbSession::FBSession, - Xml a, - Show a, - Data a, - Eq a) => - a -> IO String -profile_getFBML u_id = - do - Profile_getFBML_response markup <- fb (?fbSession::FBSession) $ u_id - --does this need decoding? - return markup - -friends_areFriends :: (?fbInfo::FBInfo, Data a, Data b) => - a -> b -> IO [Friend_info] -friends_areFriends uids1 uids2 = - do - Friends_areFriends_response friendInfos <- - fb (?fbInfo::FBInfo) $ (Uids1 $ gFind uids1) .&. (Uids2 $ gFind uids2) - return friendInfos - -getMbUid :: (?fbSession::FBSession, Monad m) => () -> m (Maybe Uid) -getMbUid () = return mbUid -getUid :: (?fbSession::FBSession, Monad m) => () -> m Uid -getUid () = getMbUid () >>= return . fromJust -mbUid::(?fbSession::FBSession) => (Maybe Uid) -mbUid = fmap toUid $ gFind ?fbSession -uid::(?fbSession::FBSession) => (Uid) -uid = fromJust mbUid -friends::(?fbSession::FBSession) => (Friends) -friends = fromJust $ fmap toFriends $ gFind (?fbSession::FBSession) -numFriends::(?fbSession::FBSession) => Int -numFriends = let (Friends fs) = friends in length fs - -getAppURLs :: IO (BaseURL, InstallURL) -getAppURLs = - do - config <- getConfig - let Api_key key = gFind' config - Canvas_id cid = gFind' config - installURL = InstallURL $ - "http://www.facebook.com/install.php?api_key="++key - baseURL = BaseURL $ "http://apps.facebook/com/"++cid - return (baseURL,installURL) - -getInstallURL::(?fbSession::FBSession) => String -> IO InstallURL -getInstallURL (next) = - do - config <- getConfig - let Api_key key = gFind' config - return $ InstallURL $ "http://www.facebook.com/install.php?api_key="++key++ - if null next then "" else "&next="++escape next - -getBaseURL :: IO BaseURL -getBaseURL = do - config <- getConfig - let (Canvas_id cid) = gFind' config - return $ BaseURL $ "http://apps.facebook/com/"++cid++"/" - ---there is no invite info if all user's friends are app users -getInviteInfo::(?fbSession::FBSession) => IO (Maybe InviteInfo) -getInviteInfo = do - appUsers@(AppUsers apps) <-friends_getAppUsers - -- let (Friends fs) = friends - if numFriends == length apps then return Nothing else do - return . Just . InviteInfo uid appUsers =<< getBaseURL - - -isAppAdded::(?fbSession::FBSession) => Bool -isAppAdded = maybe (error "no fb_sig_added") (const appAdded) mbAdded - where - mbAdded = gFind ?fbSession - Fb_sig_added appAdded = fromJust mbAdded - -getConfig :: IO Fb_config -getConfig = --yes reading a file is bad but roundtripping to fb sucks too - do - let configPath = "config/facebook.xml" - fe <- doesFileExist configPath - when (not fe) $ error $ "you need a "++configPath++ "file of type fb_config" - configData <- readFile configPath -- need error message if this fails - print configData - let (fb_config::Fb_config) = runIdentity $ fromString Flexible configData - return fb_config - - -getAdmins::IO [Uid] -getAdmins = getConfig >>= return . gFind - -getIsAdmin::(?fbSession::FBSession) => IO Bool -getIsAdmin = getAdmins >>= return . elem uid - - -fb :: (Show a, - FromString a, - Xml b, - Show b, - Data b, - Eq b, - Data a, - Default a, - Data t) => - t -> b -> IO a -fb fbSession a = - mdo - fb_config <- getConfig - TOD t _ <- getClockTime - let req = makeReq t (fbSession,fb_config) a resp - print "REQ=" - print req - res <- spost fbserver req - let body = HTTP.rspBody $ snd res - print (body::String) - print "body printed" - let resp = runIdentity $ fromString Flexible body - print resp - print "resp returned" - return resp - -fbserver :: Network.URI.URI -fbserver=suri $ fromJust $ parse "http://api.facebook.com/restserver.php" - - -toUid :: Fb_sig_user -> Uid -toUid (Fb_sig_user u_id) = Uid u_id -toFriends :: Fb_sig_friends -> Friends -toFriends (Fb_sig_friends fs) = Friends fs -toSesKey :: Fb_sig_session_key -> Session_key -toSesKey (Fb_sig_session_key s) = Session_key s - -makeReq :: (Xml b, - Show b, - Data b, - Eq b, - Show a, - Data t, - Default t, - Data a1) => - a -> a1 -> b -> t -> [([Char], [Char])] -makeReq t fbInfo a resp= req - where - [example,_] = [defaultValue,resp] - cons = first toLower $ - show $ toConstr example - fbCmd' = map (\x->if x=='_' then '.' else x) $ "facebook."++ cons - meth = Method $ if ".response" `isSuffixOf` fbCmd' - then take (length fbCmd'- (length "_response")) fbCmd' - else fbCmd' - sesKey = (fmap toSesKey (gFind fbInfo::Maybe Fb_sig_session_key)) - args = ("v","1.0"):("call_id",show t): - (toPairs $ apikey .&. meth .&. sesKey .&. a) - s_args = sort args - Secret secret = fromJust $ gFind fbInfo - (apikey::Api_key) = fromJust $ gFind fbInfo - raw = concatMap (\(x,y)->x++'=':y) s_args ++ (secret) - sig = stringMD5 (md5 (L.pack raw)) - req = s_args++[("sig",sig)] - -spost :: URI -> [(String,String)] -> IO (URI, HTTP.Response String) -spost u q = Browser.browse $ Browser.request $ Browser.formToRequest $ - Browser.Form HTTP.POST u q - - -consIf :: Bool -> a -> [a] -> [a] -consIf False _ list = list -consIf _ x list = x:list - -fbApp :: (MonadIO m, ToMessage r) => - XSLTCmd - -> XSLPath - -> (FBSession -> [ServerPartT m r]) - -> ServerPartT m Response -fbApp xslproc stylesheet app -- api_key secret app - = - xslt xslproc stylesheet [ withData fun] - where - fun (fbSes::FBSession) = app $ gSet (Just (xslproc,stylesheet)) fbSes - -onlyInstalled :: (?fbSession::FBSession, MonadIO m) => - [ServerPartT m [Char]] -> [ServerPartT m [Char]] -onlyInstalled app = - if isAppAdded then app else - [uriRest $ \uri -> - anyRequest $ fbSeeOther . gFind' =<< liftIO (getInstallURL uri) - ] - -postAdd :: Monad m => [ServerPartT m String] -postAdd = [uriRest $ \uri -> anyRequest $ fbSeeOther uri] --- = - -fbSeeOther :: (Monad m) => [Char] -> WebT m [Char] -fbSeeOther s = ok $ "" - ---can make it typesafe. now we just need to deal with response -class HasArgs a b | a -> b -instance (HasT args Uid,HasT args Title) => HasArgs Friends_get_response args -f::(Default r,HasArgs r args) => args -> r -f _ = defaultValue -tf :: [Uid] -Friends_get_response tf = f (Uid 123 .&. Title "abc" .&. Secret "abc") diff --git a/src/HAppS/Store/FlashMsgs.hs b/src/HAppS/Store/FlashMsgs.hs deleted file mode 100644 --- a/src/HAppS/Store/FlashMsgs.hs +++ /dev/null @@ -1,111 +0,0 @@ -{-# LANGUAGE CPP, TemplateHaskell, FlexibleInstances, DeriveDataTypeable, FlexibleContexts, - MultiParamTypeClasses, TypeFamilies, TypeSynonymInstances, UndecidableInstances #-} - -module HAppS.Store.FlashMsgs where - -import Control.Monad.State hiding (State) -import Control.Monad.Reader - - -import HAppS.Data -import Data.Generics.Basics -import HAppS.Data.Atom -import HAppS.Data.IxSet -import HAppS.State -import HAppS.Server.Facebook as FB - - - -{-- - Use FashMsgs to send one off messages to the user. Think of it as single use sessions. - Note: we don't have Sessions here yet because we need a nicer expose function - that lets us have multiple sessions in state and parametrize by session value - Also not sure that sessions are useful in this infrastructure - - It would also be nice to be able to parametrize on the Uid, but for now we treat the - facebook Uid type as the universal Id - - 1. Put a FlashMsgs somewhere in your state - 2. Make state an instance of class HasFlash - - instance HasFlash State where - withFlashMsgs = State.withFlashMsgs - flashMsgs = State.flashMsgs - - 3. put commmands in your getInterface function in State - - Now you can use insFlashMsg and extFlashMsg from your app. - If we wanted a cleanup cycle we could add a periodic handler to stdMain - stdMain () $ simpleHTTP impl $ periodic 10 impl $ - -Improvements: - * get rid of HasFlash and use syb/generic haskell for this stuff - * infer state getinterface rather than manual addition ---} - - ---Types -$( deriveAll [''Read,''Show,''Default,''Eq,''Ord] - [d| - - -- we are also going to want to issue flash msgs - data FlashMsg msg = FlashMsg FB.Uid Published msg -- FlashContent - newtype FlashContent = FlashContent [Element] - - |] - ) - -instance Version (FlashMsg msg) -instance Version FlashContent - -$(deriveSerialize ''FlashMsg) -$(deriveSerialize ''FlashContent) - -$(inferIxSet "FlashMsgs" ''FlashMsg 'noCalcs [''FB.Uid,''Published]) - ---Command Functions -setFlashMsg :: (Ord msg,Data msg) => Uid -> msg -> Update (FlashMsgs msg) () -setFlashMsg u_id msg = - do - t <- getTime - let aux = FlashMsg u_id (Published t) msg - modify (updateIx u_id aux) - --delete old messages - expired <-gets (toList . (@< (Updated $ t-maxAge))) - mapM (modify . delete) expired - return () - where maxAge = 3600 - - -getFlashMsg :: (Ord msg, Data msg) => Uid -> Query (FlashMsgs msg) (Maybe msg) -getFlashMsg u_id = - (return . gFind . getOne . (@=u_id)) =<< ask - -delFlashMsg :: (Ord msg, Data msg) => Uid -> Proxy (FlashMsgs msg) -> Update (FlashMsgs msg) () -delFlashMsg u_id _ = do - mbMsg <- gets (getOne . (@=u_id) ) - maybe (return ()) (modify . delete) mbMsg - -$(mkMethods ''FlashMsgs [ 'setFlashMsg - , 'getFlashMsg - , 'delFlashMsg ]) - -instance (Serialize (FlashMsgs a), Ord a, Data a) => Component (FlashMsgs a) where - initialValue = error "No initialValue for Component (FlashMsgs a) " - type Dependencies (FlashMsgs a) = End - --- Controls -insFlashMsg :: (Xml a, MonadIO m) => Uid -> a -> m () -insFlashMsg u_id msg = update $ SetFlashMsg u_id $ toXml msg -extFlashMsg :: (Data msg, - Serialize msg, - Ord msg, - MonadIO m) => - Uid -> m (Maybe msg) -extFlashMsg u_id = do - msg <- query $ GetFlashMsg u_id - let mkProxy :: Maybe msg -> Proxy (FlashMsgs msg) - mkProxy _ = Proxy - update $ DelFlashMsg u_id (mkProxy msg) - return msg - diff --git a/src/HAppS/Store/HelpReqs.hs b/src/HAppS/Store/HelpReqs.hs deleted file mode 100644 --- a/src/HAppS/Store/HelpReqs.hs +++ /dev/null @@ -1,105 +0,0 @@ -{-# LANGUAGE TemplateHaskell, FlexibleInstances, DeriveDataTypeable, - ImplicitParams, TypeSynonymInstances, TypeFamilies, - MultiParamTypeClasses, TypeOperators, FlexibleContexts, - UndecidableInstances #-} - -module HAppS.Store.HelpReqs where - -import Control.Monad.State hiding (State) -import Control.Monad.Reader - -import HAppS.Data -import HAppS.Data.Atom -import HAppS.Data.IxSet -import HAppS.State -import HAppS.Server.Facebook as FB - (Uid,uid,FBSession,fbSeeOther,getIsAdmin - ,getAdmins,notifications_send ) -import HAppS.Store.Util -import HAppS.Server.SimpleHTTP -import HAppS.Store.FlashMsgs -import HAppS.Server.HTTP.Types (Response) -{-- - - Use HelpReqs to track help requests on your app. The concept is that the - user just fills out a form describing their needs and you get back to them. - - See FlashMsgs for the cannonical info, but.. - ---} -$( deriveAll [''Show,''Default,''Read,''Eq,''Ord] - [d| - -- the data for the help system - data HelpReqForm = HelpReqForm --get the form - data HelpReq = HelpReq FB.Uid Published Title HelpText Status--post the help - newtype HelpText = HelpText String - data Status = Open | Closed Published - newtype HelpFeed = HelpFeed [HelpReq] -- provide a help feed - data HelpMsgReceived = HelpMsgReceived - - |]) - -instance Version HelpReq -instance Version Status -instance Version HelpFeed -instance Version HelpText -instance Version HelpMsgReceived -$(deriveSerialize ''HelpReq) -$(deriveSerialize ''Status) -$(deriveSerialize ''HelpFeed) -$(deriveSerialize ''HelpText) -$(deriveSerialize ''HelpMsgReceived) - -$(inferIxSet "HelpReqs" ''HelpReq 'noCalcs [''FB.Uid,''Published,''Status] ) - ---Command functions -addHelpReq :: HelpReq -> Update HelpReqs () -addHelpReq helpReq - = do seconds <- liftM (`div` 1000) getTime - modify $ insert (gSet (Published seconds) helpReq) - -getHelpReqs :: Query HelpReqs [HelpReq] -getHelpReqs = liftM byRevTime ask - -$(mkMethods ''HelpReqs ['addHelpReq,'getHelpReqs]) -instance Component HelpReqs where - initialValue = error "initialValue not defined for Component HelpReqs" - type Dependencies HelpReqs = FlashMsgs HelpMsgReceived :+: End - - - --- http stuff -http::( ?fbSession::FBSession - , MonadIO m - ) => [ServerPartT m Response] -http = - [ - dir "help" [ method () $ ok $ toResponse HelpReqForm] - - ,dir "addHelp" - [withData $ \helpReq -> - [method () $ do - webUpdate $ AddHelpReq helpReq - liftIO $ insFlashMsg uid HelpMsgReceived - admins <- liftIO $ getAdmins - unless (null admins) $ - do - liftIO $ notifications_send admins - (Title "helpreq") - () - return () - liftM toResponse $ fbSeeOther "side-nav" - ]] - - ,dir "helps" [method () $ do - isAdmin <- liftIO $ getIsAdmin - if not isAdmin then forbidden (toResponse "not admin!") else do - flashMsg <- liftIO $ (extFlashMsg uid :: IO (Maybe HelpMsgReceived)) - helpReqs <- webQuery $ GetHelpReqs - (ok . toResponse . - insEl (Attr "context" "helpfeed") . - insEl flashMsg . - HelpFeed . - take 1000) helpReqs - ] - ] diff --git a/src/Happstack/Contrib/Atom.hs b/src/Happstack/Contrib/Atom.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Contrib/Atom.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE CPP, TemplateHaskell, UndecidableInstances, DeriveDataTypeable #-} +module Happstack.Contrib.Atom + ( + Entry(..) + ,Feed(..) + ,Author(..) + ,Contributor(..) + ,Category(..) + ,Id(..) + ,Title(..) + ,Published(..) + ,Updated(..) + ,Summary(..) + ,Content(..) + ,Word(..) + ,Email(..) + + +) + where + +import Happstack.Data +import Happstack.Contrib.HList + + +$( deriveAll [''Ord,''Eq,''Read,''Show,''Default] + [d| + data Feed = Feed [Entry] + + data Entry = + Entry + [Author] + [Category] + (Maybe Content ) + [Contributor] + Id + + -- Link is a computed value + (Maybe Published) + -- ignoring stuff I don't care about + (Maybe Summary) + Title + Updated + + {-- + + Entry + + --stuff not in the spec but commonly useful for management + --a -- sometime you want to stick other data in here + --(Maybe Owner) -- not in spec but useful for actual management + --(Maybe Refs) -- for use when Entry is actually a comment on another + + Author -- we will have only one author + [Contributor] -- author can credit contributors + [Category] -- allow user to select categories + Id + -- Link is a computed value + Title + Updated + Maybe Published + -- (Maybe Rights) + Maybe Summary -- We choose to always have a summary + Maybe Content -- We choose to always have content + --} + + type PersonConstruct = (Name, Maybe Uri, Maybe Email) + data Author = Author PersonConstruct + data Contributor = Contributor PersonConstruct + newtype Name = Name Text + + data Category = Category Term (Maybe Scheme) (Maybe Label) + newtype Term = Term String + newtype Scheme = Scheme String + newtype Label = Label String + + newtype Id = Id Integer + + type DateConstruct = Integer + + data Title = Title TextConstruct + data Subtitle = Subtitle TextConstruct + newtype Summary = Summary TextConstruct + newtype Content = Content TextConstruct + + newtype Uri = Uri String + newtype Email = Email String + newtype Updated = Updated DateConstruct + newtype Published = Published DateConstruct + + type Text = String + type TextConstruct = Text + + newtype Word = Word String + |] ) + +#define V(x) instance Version x +V(Uri);V(Email);V(Updated);V(Published);V(Title);V(Subtitle) +V(Summary);V(Content);V(Author);V(Contributor);V(Name);V(Category) +V(Term);V(Scheme);V(Label);V(Id) +$(deriveSerializeFor [''Uri, ''Email, ''Updated, ''Published + ,''Title, ''Subtitle, ''Summary, ''Content + ,''Author, ''Contributor, ''Name, ''Category + ,''Term, ''Scheme, ''Label, ''Id]) + diff --git a/src/Happstack/Contrib/HList.hs b/src/Happstack/Contrib/HList.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Contrib/HList.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE TemplateHaskell, FlexibleInstances, + UndecidableInstances, OverlappingInstances, + MultiParamTypeClasses, CPP, FunctionalDependencies #-} + +module Happstack.Contrib.HList (HasT, hlextract, hlupdate, (.&.), + (:&:), + Couple(..),Nil(..),CoupleClass,hMap,trans) where +-- HList useful with generic + +import Happstack.Data.Xml +import Happstack.Data.Pairs +import Data.Generics as G +import Happstack.Contrib.HListBase + +infixr 6 .&. +(.&.) :: a -> b -> Couple a b +(.&.) = Couple + +type a :&: b = Couple b a + + + +class CoupleClass a where + toPairs' :: a -> Pairs + fromPairs' :: Pairs -> Maybe a + +instance (Eq a,Xml a, Show a, G.Data a,CoupleClass b) => CoupleClass (Couple a b) where + toPairs' (Couple a b) = (toPairs a) ++ (toPairs' b) + fromPairs' = const Nothing --doesn't make sense to unmix to make toPairs' . fromPairs' an identity + +instance CoupleClass Nil where + toPairs' _ = [] + fromPairs' _ = return Nil + +instance (Xml a, Xml b) => Xml (Couple a b) where + toXml (Couple a b) = (toXml a) ++ (toXml b) + readXml r xml = do + (xml', a) <- readXml r xml + (xml'', b) <- readXml r xml' + return (xml'', Couple a b) + +hlextract :: HasT a b => a -> b +hlextract = x + +hlupdate :: HasT a b => a -> b -> a +hlupdate = u + +class HasT a b where + x :: a -> b + u :: a -> b -> a + +instance HasT (Couple a b) a where + x (Couple a _) = a + u (Couple _ b) a = Couple a b + +instance HasT (Couple a b) b where + x (Couple _ b) = b + u (Couple a _) b = Couple a b + +-- Oleg's trick http://www.haskell.org/pipermail/haskell/2004-June/014176.html +class HasT' a b where + x' :: a -> b + u' :: a -> b -> a + +instance HasT' a b => HasT a b where + x = x' + u = u' + +instance (HasT c a) => HasT' (Couple b c) a where + x' (Couple _ b) = x b + u' (Couple a b) c = Couple a (u b c) + +class Trans ft a where + trans :: ft -> a -> a + +instance Trans (a->a) (Couple a b) where + trans f (Couple a b) = Couple (f a) b + +instance Trans (b->b) (Couple a b) where + trans f (Couple a b) = Couple a (f b) + +class Trans' ft a where + trans' :: ft -> a ->a + +instance Trans' ft a => Trans ft a where + trans = trans' + +instance (Trans ft b) => Trans' ft (Couple a b) where + trans' f (Couple a b) = Couple a (trans f b) + +class HMap a b | a -> b where + hMap::a->b + +instance (HMap b d,CoupleClass b) => HMap (Couple a b) (Couple [a] d) where + hMap (Couple a b) = Couple [a] $ hMap b + +instance HMap (Couple a Nil) (Couple [a] Nil) where + hMap (Couple a Nil) = Couple [a] Nil diff --git a/src/Happstack/Contrib/HListBase.hs b/src/Happstack/Contrib/HListBase.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Contrib/HListBase.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE TemplateHaskell, FlexibleInstances, + UndecidableInstances, OverlappingInstances, + MultiParamTypeClasses, CPP, DeriveDataTypeable #-} +module Happstack.Contrib.HListBase where +import Happstack.Data.DeriveAll +import Happstack.Data.Default +import Data.Typeable + +$( deriveAll [''Show,''Default,''Eq,''Read,''Ord] + [d| + data Couple a b = Couple a b + data Nil = Nil + |] + ) + +nil::Nil +nil=Nil diff --git a/src/Happstack/Server/Facebook.hs b/src/Happstack/Server/Facebook.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Server/Facebook.hs @@ -0,0 +1,434 @@ +{-# OPTIONS -fcontext-stack=25 #-} +{-# LANGUAGE TemplateHaskell, FlexibleInstances, CPP, ImplicitParams, RecursiveDo, DeriveDataTypeable, PatternSignatures, + ScopedTypeVariables, MultiParamTypeClasses, FunctionalDependencies, OverlappingInstances, UndecidableInstances, FlexibleContexts #-} +module Happstack.Server.Facebook where +import Control.Monad.Reader + +import Data.Char +import Data.List +import Data.Maybe + +import Happstack.Data +import Happstack.Contrib.Atom (Email(..)) +import Happstack.Contrib.HList +import Happstack.Server.SURI +import Network.URI (URI) +import Happstack.Server.SimpleHTTP hiding (escape,Method) + +import Happstack.Crypto.MD5 ( md5, stringMD5) +import System.Directory + +import Data.Generics + +import qualified Network.Browser as Browser +import qualified Network.HTTP as HTTP +import Control.Monad.Identity + +import Happstack.Server.XSLT +import Happstack.Server.HTTP.Types (Response,rsBody) +import qualified Data.ByteString.Lazy.Char8 as L +import System.Time +{-- +Conceptually the demo app should expose functionality in website and facebook at once + +1. facebook wrapper should take an fbconf and a require app added parameter +2. ServerParts that are depended on fb_Ses@(FB_Ses uid sessionId appadded) + can we make them implicit parameters so the user doesn't have to see it? +3. if we get the parameters in a post then check valid and assign. +4. if we get parameters in a cookie then check valid and assign. +5. set cookie on initial login +6. calling API functions by typename before _response of returned XML + Friends_get_response [uid] <- fb $ Fields fs .&. Title t + +* make the response types be instances of HasArgs so fb can enforce +* define InCouple class that enforces that a type is inside the couple somewhere. +* enhance xml lib to allow matching if the constructor prefix matches. Then we get + modify fb to drop _response in element name before converting. + + Friends_get_response [uid] <- fb $ Fields fs .&. Title t -- and it all typechecks! + +also need to get pairs to drop the constructor names if present. +careful to only do so if they are present! e.g. UserName "alex" should become +userName=alex. But UserInfo (UserName "alex") should become userName=alex + + + + +uids fields title markup +uids1 uids2 + +so use heterogenous list of things that are convertible +--} + +$(deriveAll [''Show,''Read,''Default, ''Eq, ''Ord] + [d| + + + data Friends_getAppUsers_response = Friends_getAppUsers_response [Uid] + data Friends_get_response = Friends_get_response [Uid] + + newtype Uid = Uid Integer + newtype Friends = Friends [Integer] + newtype Uids1 = Uids1 [Integer] + newtype Uids2 = Uids2 [Integer] + newtype Uids = Uids [Integer] + + -- used in array posted from multi-friend-input + newtype Requested = Requested [Ids] + newtype Ids = Ids Integer + + newtype Fields = Fields [String] + newtype Title = Title String + newtype Method = Method String + + + + data Fb_config = Fb_config Api_key Secret App_id Canvas_id Admins + newtype Secret = Secret String + newtype Api_key = Api_key String + newtype App_id = App_id Int + newtype Canvas_id = Canvas_id String + newtype Admins = Admins [Uid] + + + newtype Session_key=Session_key String + newtype Fb_sig_expires=Fb_sig_expires Int + + data FBSession = FBSession + Fb_sig_in_canvas + Fb_sig_added + Fb_sig_time + Fb_sig_api_key + Fb_sig + ---optional fields + Fb_sig_user + Fb_sig_friends + Fb_sig_session_key + Fb_sig_expires + Fb_sig_profile_update_time + --stuff that is just carried here + (Maybe (XSLTCmd,XSLPath)) + + newtype Tbool = Tbool Bool + newtype Tlist = Tlist [Int] + data Friend_info = Friend_info Uid Uid Are_friends + newtype Are_friends = Are_friends Bool + data Friends_areFriends_response = Friends_areFriends_response [Friend_info] + newtype Users_getInfo_response = Users_getInfo_response [User] + data Profile_setFBML_response = Profile_setFBML_response Bool + data Profile_getFBML_response = Profile_getFBML_response String + + newtype Notifications_send_response = Notifications_send_response String + newtype To_ids = To_ids [Integer] + newtype Notification = Notification String + data Error_response = Error_response Error_code + newtype Error_code=Error_code Int + + newtype Fb_sig_in_canvas = Fb_sig_in_canvas Bool + newtype Fb_sig_added = Fb_sig_added Bool + newtype Fb_sig_time = Fb_sig_time Integer + newtype Fb_sig_api_key = Fb_sig_api_key String + newtype Fb_sig = Fb_sig String + newtype Fb_sig_user = Fb_sig_user Integer + newtype Fb_sig_friends = Fb_sig_friends [Integer] -- add automatic comma sep parse + newtype Fb_sig_session_key= Fb_sig_session_key String + newtype Fb_sig_profile_update_time = Fb_sig_profile_update_time Integer + + data User = User Uid (Maybe About_me) Affiliations -- we may need more lets see + newtype About_me = About_me String + newtype Affiliations = Affiliations [Affiliation] + data Affiliation = Affiliation Nid Name Type Status Year + newtype Nid = Nid Integer + newtype Name = Name String + newtype Type = Type String -- should be fixed later to enumeration + newtype Status = Status String -- not sure what is here + newtype Year = Year Int + + newtype AppUsers = AppUsers [Uid] + data InviteInfo = InviteInfo Uid AppUsers BaseURL --- used for producing invites + data NoFriends = NoFriends + newtype InstallURL = InstallURL String + newtype BaseURL = BaseURL String + |] + ) + +instance Version Uid +instance Version Element + +$(deriveSerializeFor [ ''Uid + , ''Element ]) + + +(.$) :: a -> (a -> b) -> b +a .$ b = b a +fb'::(?fb::Int)=>Int +fb' = ?fb +type FBInfo = (Api_key,Secret,FBSession) + +friends_getAppUsers::(?fbSession::FBSession) => IO AppUsers +friends_getAppUsers = + do + Friends_getAppUsers_response uids <- fb (?fbSession::FBSession) () + return $ AppUsers $ gFind uids + +users_getInfo :: (?fbSession::FBSession, Data a) => a -> [String] -> IO [User] +users_getInfo uids fields = + do + Users_getInfo_response users <- fb (?fbSession::FBSession) $ (Uids $ gFind uids) .&. (Fields fields) + return users + +getNetworks::(?fbSession::FBSession)=>IO (Maybe Affiliations) +getNetworks = return . gFind =<< users_getInfo [uid] ["affiliations"] + + +--now we want to shift this so that the stuff is rendered in the present layer +notifications_send :: (ToMessage b, + Xml b, + ToMessage c, + Xml c, + ?fbSession::FBSession, + Data a, + Show a) => + a -> b -> c -> IO String +notifications_send uids notifObj emailObj = + do + print "UIDS=" + print uids + let (xsltcmd::XSLTCmd + ,xslpath::XSLPath) = gFind' (?fbSession::FBSession) + aux x = do + let els = toPublicXml x + if null els then return "" else do + let res = toResponse els + xres <- doXslt xsltcmd xslpath res + (return . L.unpack . rsBody) xres + + aux :: (ToMessage a,Xml a)=> a -> IO String + (notification::String) <- aux notifObj + (email::String) <- aux emailObj + Notifications_send_response confirm <- + fb (?fbSession::FBSession) $ + (To_ids $ gFind uids) .&. + (Notification notification) + -- .&. (Email email) + .&. (if null email then Nothing else Just $ Email email) + print "CONFIRM" + print confirm + return confirm + +profile_setFBML :: (?fbSession::FBSession, + Xml a, + Xml b, + Show a, + Show b, + Data a, + Data b, + Eq a, + Eq b) => + a -> b -> IO Bool +profile_setFBML u_id markup = + do + --can markup be passed as straight string of fbml? + --how do we call out to xsl for this? + Profile_setFBML_response x <- fb (?fbSession::FBSession) $ u_id .&. markup + return x + +profile_getFBML :: (?fbSession::FBSession, + Xml a, + Show a, + Data a, + Eq a) => + a -> IO String +profile_getFBML u_id = + do + Profile_getFBML_response markup <- fb (?fbSession::FBSession) $ u_id + --does this need decoding? + return markup + +friends_areFriends :: (?fbInfo::FBInfo, Data a, Data b) => + a -> b -> IO [Friend_info] +friends_areFriends uids1 uids2 = + do + Friends_areFriends_response friendInfos <- + fb (?fbInfo::FBInfo) $ (Uids1 $ gFind uids1) .&. (Uids2 $ gFind uids2) + return friendInfos + +getMbUid :: (?fbSession::FBSession, Monad m) => () -> m (Maybe Uid) +getMbUid () = return mbUid +getUid :: (?fbSession::FBSession, Monad m) => () -> m Uid +getUid () = getMbUid () >>= return . fromJust +mbUid::(?fbSession::FBSession) => (Maybe Uid) +mbUid = fmap toUid $ gFind ?fbSession +uid::(?fbSession::FBSession) => (Uid) +uid = fromJust mbUid +friends::(?fbSession::FBSession) => (Friends) +friends = fromJust $ fmap toFriends $ gFind (?fbSession::FBSession) +numFriends::(?fbSession::FBSession) => Int +numFriends = let (Friends fs) = friends in length fs + +getAppURLs :: IO (BaseURL, InstallURL) +getAppURLs = + do + config <- getConfig + let Api_key key = gFind' config + Canvas_id cid = gFind' config + installURL = InstallURL $ + "http://www.facebook.com/install.php?api_key="++key + baseURL = BaseURL $ "http://apps.facebook/com/"++cid + return (baseURL,installURL) + +getInstallURL::(?fbSession::FBSession) => String -> IO InstallURL +getInstallURL (next) = + do + config <- getConfig + let Api_key key = gFind' config + return $ InstallURL $ "http://www.facebook.com/install.php?api_key="++key++ + if null next then "" else "&next="++escape next + +getBaseURL :: IO BaseURL +getBaseURL = do + config <- getConfig + let (Canvas_id cid) = gFind' config + return $ BaseURL $ "http://apps.facebook/com/"++cid++"/" + +--there is no invite info if all user's friends are app users +getInviteInfo::(?fbSession::FBSession) => IO (Maybe InviteInfo) +getInviteInfo = do + appUsers@(AppUsers apps) <-friends_getAppUsers + -- let (Friends fs) = friends + if numFriends == length apps then return Nothing else do + return . Just . InviteInfo uid appUsers =<< getBaseURL + + +isAppAdded::(?fbSession::FBSession) => Bool +isAppAdded = maybe (error "no fb_sig_added") (const appAdded) mbAdded + where + mbAdded = gFind ?fbSession + Fb_sig_added appAdded = fromJust mbAdded + +getConfig :: IO Fb_config +getConfig = --yes reading a file is bad but roundtripping to fb sucks too + do + let configPath = "config/facebook.xml" + fe <- doesFileExist configPath + when (not fe) $ error $ "you need a "++configPath++ "file of type fb_config" + configData <- readFile configPath -- need error message if this fails + print configData + let (fb_config::Fb_config) = runIdentity $ fromString Flexible configData + return fb_config + + +getAdmins::IO [Uid] +getAdmins = getConfig >>= return . gFind + +getIsAdmin::(?fbSession::FBSession) => IO Bool +getIsAdmin = getAdmins >>= return . elem uid + + +fb :: (Show a, + FromString a, + Xml b, + Show b, + Data b, + Eq b, + Data a, + Default a, + Data t) => + t -> b -> IO a +fb fbSession a = + mdo + fb_config <- getConfig + TOD t _ <- getClockTime + let req = makeReq t (fbSession,fb_config) a resp + print "REQ=" + print req + res <- spost fbserver req + let body = HTTP.rspBody $ snd res + print (body::String) + print "body printed" + let resp = runIdentity $ fromString Flexible body + print resp + print "resp returned" + return resp + +fbserver :: Network.URI.URI +fbserver=suri $ fromJust $ parse "http://api.facebook.com/restserver.php" + + +toUid :: Fb_sig_user -> Uid +toUid (Fb_sig_user u_id) = Uid u_id +toFriends :: Fb_sig_friends -> Friends +toFriends (Fb_sig_friends fs) = Friends fs +toSesKey :: Fb_sig_session_key -> Session_key +toSesKey (Fb_sig_session_key s) = Session_key s + +makeReq :: (Xml b, + Show b, + Data b, + Eq b, + Show a, + Data t, + Default t, + Data a1) => + a -> a1 -> b -> t -> [([Char], [Char])] +makeReq t fbInfo a resp= req + where + [example,_] = [defaultValue,resp] + cons = first toLower $ + show $ toConstr example + fbCmd' = map (\x->if x=='_' then '.' else x) $ "facebook."++ cons + meth = Method $ if ".response" `isSuffixOf` fbCmd' + then take (length fbCmd'- (length "_response")) fbCmd' + else fbCmd' + sesKey = (fmap toSesKey (gFind fbInfo::Maybe Fb_sig_session_key)) + args = ("v","1.0"):("call_id",show t): + (toPairs $ apikey .&. meth .&. sesKey .&. a) + s_args = sort args + Secret secret = fromJust $ gFind fbInfo + (apikey::Api_key) = fromJust $ gFind fbInfo + raw = concatMap (\(x,y)->x++'=':y) s_args ++ (secret) + sig = stringMD5 (md5 (L.pack raw)) + req = s_args++[("sig",sig)] + +spost :: URI -> [(String,String)] -> IO (URI, HTTP.Response String) +spost u q = Browser.browse $ Browser.request $ Browser.formToRequest $ + Browser.Form HTTP.POST u q + + +consIf :: Bool -> a -> [a] -> [a] +consIf False _ list = list +consIf _ x list = x:list + +fbApp :: (MonadIO m, ToMessage r, ServerMonad m, MonadPlus m) => + XSLTCmd + -> XSLPath + -> (FBSession -> m r) + -> m Response +fbApp xslproc stylesheet app -- api_key secret app + = + xslt xslproc stylesheet $ withData fun + where + fun (fbSes::FBSession) = app $ gSet (Just (xslproc,stylesheet)) fbSes + +onlyInstalled :: (?fbSession::FBSession, MonadIO m, FilterMonad Response m, ServerMonad m) => + [m [Char]] -> [m [Char]] +onlyInstalled app = + if isAppAdded then app else + [uriRest $ \uri -> + fbSeeOther . gFind' =<< liftIO (getInstallURL uri) + ] + +postAdd :: (Monad m, ServerMonad m, FilterMonad Response m) => [m String] +postAdd = [uriRest $ \uri -> fbSeeOther uri] +-- = + +fbSeeOther :: (Monad m, FilterMonad Response m) => [Char] -> m [Char] +fbSeeOther s = ok $ "" + +--can make it typesafe. now we just need to deal with response +class HasArgs a b | a -> b +instance (HasT args Uid,HasT args Title) => HasArgs Friends_get_response args +f::(Default r,HasArgs r args) => args -> r +f _ = defaultValue +tf :: [Uid] +Friends_get_response tf = f (Uid 123 .&. Title "abc" .&. Secret "abc") diff --git a/src/Happstack/Store/FlashMsgs.hs b/src/Happstack/Store/FlashMsgs.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Store/FlashMsgs.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE CPP, TemplateHaskell, FlexibleInstances, DeriveDataTypeable, FlexibleContexts, + MultiParamTypeClasses, TypeFamilies, TypeSynonymInstances, UndecidableInstances #-} + +module Happstack.Store.FlashMsgs where + +import Control.Monad.State hiding (State) +import Control.Monad.Reader + + +import Happstack.Data +import Happstack.Contrib.Atom +import Data.Generics.Basics +import Happstack.Data.IxSet +import Happstack.State +import Happstack.Server.Facebook as FB + + + +{-- + Use FashMsgs to send one off messages to the user. Think of it as single use sessions. + Note: we don't have Sessions here yet because we need a nicer expose function + that lets us have multiple sessions in state and parametrize by session value + Also not sure that sessions are useful in this infrastructure + + It would also be nice to be able to parametrize on the Uid, but for now we treat the + facebook Uid type as the universal Id + + 1. Put a FlashMsgs somewhere in your state + 2. Make state an instance of class HasFlash + + instance HasFlash State where + withFlashMsgs = State.withFlashMsgs + flashMsgs = State.flashMsgs + + 3. put commmands in your getInterface function in State + + Now you can use insFlashMsg and extFlashMsg from your app. + If we wanted a cleanup cycle we could add a periodic handler to stdMain + stdMain () $ simpleHTTP impl $ periodic 10 impl $ + +Improvements: + * get rid of HasFlash and use syb/generic haskell for this stuff + * infer state getinterface rather than manual addition +--} + + +--Types +$( deriveAll [''Read,''Show,''Default,''Eq,''Ord] + [d| + + -- we are also going to want to issue flash msgs + data FlashMsg msg = FlashMsg FB.Uid Published msg -- FlashContent + newtype FlashContent = FlashContent [Element] + + |] + ) + +instance Version (FlashMsg msg) +instance Version FlashContent + +$(deriveSerialize ''FlashMsg) +$(deriveSerialize ''FlashContent) + +$(inferIxSet "FlashMsgs" ''FlashMsg 'noCalcs [''FB.Uid,''Published]) + +--Command Functions +setFlashMsg :: (Ord msg,Data msg) => Uid -> msg -> Update (FlashMsgs msg) () +setFlashMsg u_id msg = + do + t <- getTime + let aux = FlashMsg u_id (Published t) msg + modify (updateIx u_id aux) + --delete old messages + expired <-gets (toList . (@< (Updated $ t-maxAge))) + mapM (modify . delete) expired + return () + where maxAge = 3600 + + +getFlashMsg :: (Ord msg, Data msg) => Uid -> Query (FlashMsgs msg) (Maybe msg) +getFlashMsg u_id = + (return . gFind . getOne . (@=u_id)) =<< ask + +delFlashMsg :: (Ord msg, Data msg) => Uid -> Proxy (FlashMsgs msg) -> Update (FlashMsgs msg) () +delFlashMsg u_id _ = do + mbMsg <- gets (getOne . (@=u_id) ) + maybe (return ()) (modify . delete) mbMsg + +$(mkMethods ''FlashMsgs [ 'setFlashMsg + , 'getFlashMsg + , 'delFlashMsg ]) + +instance (Serialize (FlashMsgs a), Ord a, Data a) => Component (FlashMsgs a) where + initialValue = error "No initialValue for Component (FlashMsgs a) " + type Dependencies (FlashMsgs a) = End + +-- Controls +insFlashMsg :: (Xml a, MonadIO m) => Uid -> a -> m () +insFlashMsg u_id msg = update $ SetFlashMsg u_id $ toXml msg +extFlashMsg :: (Data msg, + Serialize msg, + Ord msg, + MonadIO m) => + Uid -> m (Maybe msg) +extFlashMsg u_id = do + msg <- query $ GetFlashMsg u_id + let mkProxy :: Maybe msg -> Proxy (FlashMsgs msg) + mkProxy _ = Proxy + update $ DelFlashMsg u_id (mkProxy msg) + return msg + diff --git a/src/Happstack/Store/HelpReqs.hs b/src/Happstack/Store/HelpReqs.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Store/HelpReqs.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE TemplateHaskell, FlexibleInstances, DeriveDataTypeable, + ImplicitParams, TypeSynonymInstances, TypeFamilies, + MultiParamTypeClasses, TypeOperators, FlexibleContexts, + UndecidableInstances #-} + +module Happstack.Store.HelpReqs where + +import Control.Monad.State hiding (State) +import Control.Monad.Reader + +import Happstack.Data +import Happstack.Data.IxSet +import Happstack.Contrib.Atom +import Happstack.State +import Happstack.Server.Facebook as FB + (Uid,uid,FBSession,fbSeeOther,getIsAdmin + ,getAdmins,notifications_send ) +import Happstack.Server.SimpleHTTP +import Happstack.Store.FlashMsgs +import Happstack.Server.HTTP.Types (Response) + +-- Kept from old Happstack.Store.Util +byTime::(Typeable a) => IxSet a -> [a] +byTime = concatMap (\(Published _,es)->es) . groupBy +byRevTime::(Typeable a) => IxSet a -> [a] +byRevTime = concatMap (\(Published _,es)->es) . rGroupBy + + +{-- + + Use HelpReqs to track help requests on your app. The concept is that the + user just fills out a form describing their needs and you get back to them. + + See FlashMsgs for the cannonical info, but.. + +--} +$( deriveAll [''Show,''Default,''Read,''Eq,''Ord] + [d| + -- the data for the help system + data HelpReqForm = HelpReqForm --get the form + data HelpReq = HelpReq FB.Uid Published Title HelpText Status--post the help + newtype HelpText = HelpText String + data Status = Open | Closed Published + newtype HelpFeed = HelpFeed [HelpReq] -- provide a help feed + data HelpMsgReceived = HelpMsgReceived + + |]) + +instance Version HelpReq +instance Version Status +instance Version HelpFeed +instance Version HelpText +instance Version HelpMsgReceived +$(deriveSerialize ''HelpReq) +$(deriveSerialize ''Status) +$(deriveSerialize ''HelpFeed) +$(deriveSerialize ''HelpText) +$(deriveSerialize ''HelpMsgReceived) + +$(inferIxSet "HelpReqs" ''HelpReq 'noCalcs [''FB.Uid,''Published,''Status] ) + +--Command functions +addHelpReq :: HelpReq -> Update HelpReqs () +addHelpReq helpReq + = do seconds <- liftM (`div` 1000) getTime + modify $ insert (gSet (Published seconds) helpReq) + +getHelpReqs :: Query HelpReqs [HelpReq] +getHelpReqs = liftM byRevTime ask + +$(mkMethods ''HelpReqs ['addHelpReq,'getHelpReqs]) +instance Component HelpReqs where + initialValue = error "initialValue not defined for Component HelpReqs" + type Dependencies HelpReqs = FlashMsgs HelpMsgReceived :+: End + + + +-- http stuff +http::( ?fbSession::FBSession + , MonadIO m + , ServerMonad m + , FilterMonad Response m + , MonadPlus m + ) => [m Response] +http = + [ + dir "help" $ ok $ toResponse HelpReqForm + ,dir "addHelp" $ do + mbHelpReq <- getData + helpReq <- maybe mzero return mbHelpReq + liftIO $ update $ AddHelpReq helpReq + liftIO $ insFlashMsg uid HelpMsgReceived + admins <- liftIO $ getAdmins + unless (null admins) $ + do + liftIO $ notifications_send admins + (Title "helpreq") + () + return () + liftM toResponse $ fbSeeOther "side-nav" + + ,dir "helps" $ do + isAdmin <- liftIO $ getIsAdmin + if not isAdmin then forbidden (toResponse "not admin!") else do + flashMsg <- liftIO $ (extFlashMsg uid :: IO (Maybe HelpMsgReceived)) + helpReqs <- liftIO $ query $ GetHelpReqs + (ok . toResponse . + insEl (Attr "context" "helpfeed") . + insEl flashMsg . + HelpFeed . + take 1000) helpReqs + + ] diff --git a/tests/HAppS/Contrib/Tests.hs b/tests/HAppS/Contrib/Tests.hs deleted file mode 100644 --- a/tests/HAppS/Contrib/Tests.hs +++ /dev/null @@ -1,12 +0,0 @@ --- |HUnit tests and QuickQuick properties for HAppS-Contrib -module HAppS.Contrib.Tests (allTests) where - -import Test.HUnit as HU (Test(..),(~:),(~?)) - --- |All of the tests for happstack-util should be listed here. -allTests :: Test -allTests = - "happstack-server tests" ~: [dummyTest] - -dummyTest :: Test -dummyTest = "dummyTest" ~: True ~? "True" diff --git a/tests/Happstack/Contrib/Tests.hs b/tests/Happstack/Contrib/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Happstack/Contrib/Tests.hs @@ -0,0 +1,14 @@ +-- |HUnit tests and QuickQuick properties for Happstack-Contrib +module Happstack.Contrib.Tests (allTests) where + +import Happstack.Contrib.Tests.HList001 (hlist001) +import Happstack.Contrib.Tests.HList002 (hlist002) +import Happstack.Contrib.Tests.HasT001 (hasT001) + +import Test.HUnit as HU (Test(..),(~:),(~?)) + +-- |All of the tests for happstack-contrib should be listed here. +allTests :: Test +allTests = + "happstack-contrib tests" ~: [hlist001, hlist002, hasT001] + diff --git a/tests/Happstack/Contrib/Tests/HList001.hs b/tests/Happstack/Contrib/Tests/HList001.hs new file mode 100644 --- /dev/null +++ b/tests/Happstack/Contrib/Tests/HList001.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE TemplateHaskell, DeriveDataTypeable, + FlexibleInstances, MultiParamTypeClasses, + OverlappingInstances, UndecidableInstances #-} +module Happstack.Contrib.Tests.HList001 (hlist001, t10, t10_2, t11) where + +import Language.Haskell.TH +import Happstack.Data +import Happstack.Contrib.HList +import Test.HUnit + +$( deriveAll [''Show,''Eq, ''Default] + [d| + data UserInfo = UserInfo User Pass + newtype User = User String + newtype Pass = Pass String + newtype Age = Age Int + |] + ) + +t10, t10_2, t11 :: Test + +t10 = "t10" ~: hlextract (User "alex" .&. "abc") @?= "abc" +t10_2 = "t10_2" ~: hlextract (User "alex" .&. Pass "pass" .&. "abc") @?= "abc" +t11 = "t11" ~: + let hl = User "alex" .&. Pass "pass" + in Pass "pass2" @?= (hlextract $ hlupdate hl (Pass "pass2")) + +hlist001 :: Test +hlist001 = "hlextract" ~: [t10, t10_2, t11] diff --git a/tests/Happstack/Contrib/Tests/HList002.hs b/tests/Happstack/Contrib/Tests/HList002.hs new file mode 100644 --- /dev/null +++ b/tests/Happstack/Contrib/Tests/HList002.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE TemplateHaskell, DeriveDataTypeable, + FlexibleInstances, MultiParamTypeClasses, + OverlappingInstances, UndecidableInstances #-} +module Happstack.Contrib.Tests.HList002 (hlist002, t15) where + +import Language.Haskell.TH +import Happstack.Data +import Happstack.Contrib.HList +import Test.HUnit + +$( deriveAll [''Show,''Eq, ''Default] + [d| + data UserInfo = UserInfo User Pass + newtype User = User String + newtype Pass = Pass String + newtype Age = Age Int + |] + ) +t12 :: Couple User (Couple Pass Age) +t12 = (User "ales" .&. Pass "pass" .&. Age 55 ) + +t13 :: Pairs +t13 = toPairs t12 + +t14 :: Maybe (Couple User (Couple Pass Age)) +t14 = fromPairs t13 + +t15 :: Test +t15 = "t15" ~: (Just t12) @?= t14 + +hlist002 :: Test +hlist002 = "toPairs/fromPairs" ~: [ t15 ] diff --git a/tests/Happstack/Contrib/Tests/HasT001.hs b/tests/Happstack/Contrib/Tests/HasT001.hs new file mode 100644 --- /dev/null +++ b/tests/Happstack/Contrib/Tests/HasT001.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE TemplateHaskell, DeriveDataTypeable, + FlexibleInstances, MultiParamTypeClasses, + OverlappingInstances, UndecidableInstances #-} +module Happstack.Contrib.Tests.HasT001 (hasT001, t8, t9) where + +import Language.Haskell.TH +import Happstack.Data +import Happstack.Contrib.HList +import Test.HUnit (Test,(@?=), (~:)) + +$( deriveAll [''Show,''Eq, ''Default] + [d| newtype User = User String |] + ) + +tHasT :: HasT hlist y => hlist -> y -> (y, y) +tHasT hlist v = (hlextract hlist, v) + +t8 :: Test +t8 = "t8" ~: tHasT (User "alex" .&. "asad") (User "alex2") @?= (User "alex",User "alex2") + +t9 :: Test +t9 = "t9" ~: tHasT (User "alex" .&. "asad" ) "abc" @?= ("asad","abc") + +hasT001 :: Test +hasT001 = "hasT001" ~: [t8, t9] diff --git a/tests/Test.hs b/tests/Test.hs --- a/tests/Test.hs +++ b/tests/Test.hs @@ -1,6 +1,6 @@ module Main where -import HAppS.Contrib.Tests (allTests) +import Happstack.Contrib.Tests (allTests) import Test.HUnit (errors, failures, putTextToShowS,runTestText, runTestTT) import System.Exit (exitFailure) import System.IO (hIsTerminalDevice, stdout)