diff --git a/COPYING b/COPYING new file mode 100644 --- /dev/null +++ b/COPYING @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMain diff --git a/happstack-contrib.cabal b/happstack-contrib.cabal new file mode 100644 --- /dev/null +++ b/happstack-contrib.cabal @@ -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 +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 diff --git a/src/HAppS/Server/Facebook.hs b/src/HAppS/Server/Facebook.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/Server/Facebook.hs @@ -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 $ "" + +--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 new file mode 100644 --- /dev/null +++ b/src/HAppS/Store/FlashMsgs.hs @@ -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 + diff --git a/src/HAppS/Store/HelpReqs.hs b/src/HAppS/Store/HelpReqs.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/Store/HelpReqs.hs @@ -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 + ] + ] diff --git a/tests/HAppS/Contrib/Tests.hs b/tests/HAppS/Contrib/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/HAppS/Contrib/Tests.hs @@ -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" diff --git a/tests/Test.hs b/tests/Test.hs new file mode 100644 --- /dev/null +++ b/tests/Test.hs @@ -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