happstack-contrib (empty) → 0.1
raw patch · 8 files changed
+777/−0 lines, 8 filesdep +HTTPdep +HUnitdep +basesetup-changed
Dependencies added: HTTP, HUnit, base, bytestring, directory, happstack-data, happstack-ixset, happstack-server, happstack-state, happstack-util, mtl, network, old-time, syb, unix
Files
- COPYING +29/−0
- Setup.hs +3/−0
- happstack-contrib.cabal +65/−0
- src/HAppS/Server/Facebook.hs +433/−0
- src/HAppS/Store/FlashMsgs.hs +111/−0
- src/HAppS/Store/HelpReqs.hs +105/−0
- tests/HAppS/Contrib/Tests.hs +12/−0
- tests/Test.hs +19/−0
+ COPYING view
@@ -0,0 +1,29 @@+Copyright (c) 2006, HAppS.org+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++Redistributions of source code must retain the above copyright+notice, this list of conditions and the following disclaimer.++Redistributions in binary form must reproduce the above copyright+notice, this list of conditions and the following disclaimer in the+documentation and/or other materials provided with the distribution.++Neither the name of the HAppS.org; nor the names of its contributors+may be used to endorse or promote products derived from this software+without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR+CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,+EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMain
+ happstack-contrib.cabal view
@@ -0,0 +1,65 @@+Name: happstack-contrib+Version: 0.1+Synopsis: Web related tools and services.+Description: Collection of standalone applications+License: BSD3+License-file: COPYING+Author: Happstack team, HAppS LLC+Maintainer: Happstack Team <happs@googlegroups.com>+homepage: http://happstack.com+Category: Web, Distributed Computing+Build-Type: Simple+Cabal-Version: >= 1.2.3++Flag base4+ Description: Choose the even newer, even smaller, split-up base package.++Flag tests+ Description: Build the testsuite, and include the tests in the library+ Default: True++Library++ Exposed-modules:+ HAppS.Server.Facebook+ HAppS.Store.FlashMsgs+ HAppS.Store.HelpReqs+ if flag(tests)+ Exposed-modules: + HAppS.Contrib.Tests++ Build-Depends: base, network, old-time, bytestring, happstack-server,+ mtl, HTTP >= 4000.0.2, directory, happstack-util, happstack-data,+ happstack-state, happstack-ixset++ hs-source-dirs: src++ if !os(windows)+ Build-Depends: unix+ cpp-options: -DUNIX+ if flag(base4)+ Build-Depends: base >= 4 && < 5, syb+ if flag(tests)+ Build-Depends: HUnit++ if flag(tests)+ hs-source-dirs: tests++ -- Should have ", DeriveDataTypeable, PatternSignatures" but Cabal complains+ Extensions: CPP, TemplateHaskell, FlexibleInstances,+ DeriveDataTypeable, MultiParamTypeClasses, TypeFamilies,+ TypeSynonymInstances, ImplicitParams, TypeOperators,+ UndecidableInstances+ ghc-options: -Wall+ GHC-Prof-Options: -auto-all+++Executable happstack-contrib-tests+ Main-Is: Test.hs+ GHC-Options: -threaded+ Build-depends: HUnit+ hs-source-dirs: tests, src+ if flag(tests)+ Buildable: True+ else+ Buildable: False
+ src/HAppS/Server/Facebook.hs view
@@ -0,0 +1,433 @@+{-# 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 $ "<fb:redirect url=\""++s++"\"/>"++--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")
+ src/HAppS/Store/FlashMsgs.hs view
@@ -0,0 +1,111 @@+{-# 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+
+ src/HAppS/Store/HelpReqs.hs view
@@ -0,0 +1,105 @@+{-# 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 + ]+ ]
+ tests/HAppS/Contrib/Tests.hs view
@@ -0,0 +1,12 @@+-- |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"
+ tests/Test.hs view
@@ -0,0 +1,19 @@+module Main where++import HAppS.Contrib.Tests (allTests)+import Test.HUnit (errors, failures, putTextToShowS,runTestText, runTestTT)+import System.Exit (exitFailure)+import System.IO (hIsTerminalDevice, stdout)++-- |A simple driver for running the local test suite.+main :: IO ()+main =+ do c <- do istty <- hIsTerminalDevice stdout+ if istty+ then runTestTT allTests+ else do (c,st) <- runTestText putTextToShowS allTests+ putStrLn (st "")+ return c+ case (failures c) + (errors c) of+ 0 -> return ()+ n -> exitFailure