happstack-contrib 0.1 → 0.2.1
raw patch · 16 files changed
+1006/−671 lines, 16 filesdep +template-haskelldep ~happstack-datadep ~happstack-ixsetdep ~happstack-server
Dependencies added: template-haskell
Dependency ranges changed: happstack-data, happstack-ixset, happstack-server, happstack-state, happstack-util
Files
- happstack-contrib.cabal +27/−9
- src/HAppS/Server/Facebook.hs +0/−433
- src/HAppS/Store/FlashMsgs.hs +0/−111
- src/HAppS/Store/HelpReqs.hs +0/−105
- src/Happstack/Contrib/Atom.hs +105/−0
- src/Happstack/Contrib/HList.hs +98/−0
- src/Happstack/Contrib/HListBase.hs +17/−0
- src/Happstack/Server/Facebook.hs +434/−0
- src/Happstack/Store/FlashMsgs.hs +111/−0
- src/Happstack/Store/HelpReqs.hs +113/−0
- tests/HAppS/Contrib/Tests.hs +0/−12
- tests/Happstack/Contrib/Tests.hs +14/−0
- tests/Happstack/Contrib/Tests/HList001.hs +29/−0
- tests/Happstack/Contrib/Tests/HList002.hs +32/−0
- tests/Happstack/Contrib/Tests/HasT001.hs +25/−0
- tests/Test.hs +1/−1
happstack-contrib.cabal view
@@ -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
− src/HAppS/Server/Facebook.hs
@@ -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 $ "<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
@@ -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-
− src/HAppS/Store/HelpReqs.hs
@@ -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 - ]- ]
+ src/Happstack/Contrib/Atom.hs view
@@ -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])+
+ src/Happstack/Contrib/HList.hs view
@@ -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
+ src/Happstack/Contrib/HListBase.hs view
@@ -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
+ src/Happstack/Server/Facebook.hs view
@@ -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 $ "<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/Happstack/Store/FlashMsgs.hs view
@@ -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+
+ src/Happstack/Store/HelpReqs.hs view
@@ -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 + + ]
− tests/HAppS/Contrib/Tests.hs
@@ -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"
+ tests/Happstack/Contrib/Tests.hs view
@@ -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]+
+ tests/Happstack/Contrib/Tests/HList001.hs view
@@ -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]
+ tests/Happstack/Contrib/Tests/HList002.hs view
@@ -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 ]
+ tests/Happstack/Contrib/Tests/HasT001.hs view
@@ -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]
tests/Test.hs view
@@ -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)