implementation module Newsgroups // In this example newsgroups are created and maintained // User 0 is the manager of the newsgroup who can create new newgroups // All other users can subscribe to such a newsgroup, commit a message or read news // (c) mjp 2007 import StdList, StdOrdList, StdTuple, StdMisc import iTasks import CommonDomain :: NewsGroupNames:== [GroupName] // list of newsgroup names :: GroupName :== String // Name of the newsgroup :: NewsGroup :== [NewsItem] // News stored in a news group :: NewsItem :== (Subscriber,Name,Message) // id, name, and message of the publisher :: Subscriber :== UserName // the id of the publisher :: Name :== String // the login name of the publisher :: Message :== String // the message :: Subscriptions:== [Subscription] // newsgroup subscriptions of user :: Subscription :== (GroupName,Index) // last message read in corresponding group :: Index :== Int // 0 <= index < length newsgroup :: EMail = { to :: !String , mailFrom :: !String , subject :: !String , message :: !Note } derive gPrint EMail, EMail2 derive gParse EMail, EMail2 derive gVisualize EMail, EMail2 derive gUpdate EMail, EMail2 derive bimap Maybe, (,) nmessage = 2 newsgroupsExample :: [Workflow] newsgroupsExample = [ { name = "Examples/Miscellaneous/Newsgroups/Groups/Add" , label = "Add news group" , roles = [] , mainTask = addNewsGroup }, { name = "Examples/Miscellaneous/Newsgroups/Groups/Show" , label = "Show news groups" , roles = [] , mainTask = showNewsGroups }, { name = "Examples/Miscellaneous/Newsgroups/Groups/Subscribe" , label = "Subscribe to news group" , roles = [] , mainTask = subscribeNewsGroup }, { name = "Examples/Miscellaneous/Newsgroups/Mail/Simple" , label = "internal email" , roles = [] , mainTask = internalEmail2 }, { name = "Examples/Miscellaneous/Newsgroups/Mail/With answers" , label = "internal emails with answers" , roles = [] , mainTask = internalEmailResponse } ] :: EMail2 = { to` :: !UserName , subject` :: !String , message` :: !Note } internalEmail2 :: (Task Void) internalEmail2 = enterInformation "Type your email message ..." >>= \msg -> msg.to` @: (msg.EMail2.subject`, showMessageAbout "You have received the following message:" msg) >>| showMessage "Mail has been read." internalEmailResponse :: (Task Void) internalEmailResponse = cancel internalEmailResponse` where internalEmailResponse` = getCurrentUser >>= \me -> getToNames >>= \tos -> updateInformation "Type your message ..." (initMsg (foldl (\s1 s2 -> s1 +++ "; " +++ s2) "" (map snd tos)) me.User.displayName "" "") >>= \msg -> myAndTasks [Text "Mail send to:"] [ ("For: " <+++ toname <+++ "; Subject: " <+++ msg.subject , MailAndReply msg (me.User.userName,me.User.displayName) (to,toname)) \\ (to,toname) <- tos ] where MailAndReply msg (me,myname) (to,toname) = to @: ( msg.subject , enterInformationAbout "Please draft a reply to the following message:" msg ) >>= \(Note reply) -> me @: ( "Reply from: " <+++ toname <+++ "; Subject: " <+++ msg.subject , showMessageAbout "" (initMsg myname toname ("RE: " <+++ msg.subject) reply) ) internalEmail :: (Task Void) internalEmail = getCurrentUser >>= \me -> getToName >>= \(to,toname) -> updateInformation "Type your message ..." (initMsg toname me.User.displayName "" "") >>= \msg -> (showMessageAbout "" msg) -&&- (to @: (msg.subject, showMessageAbout "" msg)) >>| return Void initMsg to for subject msg = {to = to, mailFrom = for, subject = subject , message = Note msg} showCurrentGroups :: NewsGroupNames -> Task Void showCurrentGroups groups = showStickyMessageAbout "Current groups:" groups addNewsGroup :: (Task Void) addNewsGroup = cancel addNewsGroup` where addNewsGroup` = readNewsGroups >>= \groups -> showCurrentGroups groups ||- enterInformation "Enter new news group name to add:" >>= \newName -> readNewsGroups >>= \groups -> writeNewsGroups (removeDup (sort [newName:groups])) >>= \groups -> showCurrentGroups groups ||- requestConfirmation "Do you want to add more?" >>= \yn -> if yn addNewsGroup` (return Void) showNewsGroups :: (Task Void) showNewsGroups = readNewsGroups >>= \groups -> if (length groups == 0) (showMessage "No names in catalogue yet !") (showMessageAbout "Current names in catalogue: " groups) subscribeNewsGroup :: (Task Void) subscribeNewsGroup = getCurrentUser >>= \user -> readNewsGroups >>= subscribe user.User.userName user.User.displayName where subscribe me myname [] = showMessage "No newsgroups in catalogue yet:" subscribe me myname groups = enterChoice "Choose a group:" groups >>= \group -> addSubscription me (group,0) >>| spawnProcess me True (readNews me group 0 <<@ group <+++ " news group subscription") >>| return Void readNews :: UserName String Int -> Task Void readNews me group index = orTasks2 [Text ("Welcome to newsgroup " +++ group)] [("Read next news items from newsgroup " <+++ group, readMore) ,("Commit new message to newsgroup " <+++ group, commitItem group >>| return index) ,("Unsubscribe from newsgroup " <+++ group, unsubscribe) ,("Message list of newsgroup " <+++ group, messageList index >>| return index) ] >>= \index -> if (index >= 0) (spawnProcess me True (readNews me group index <<@ group <+++ " news group subscription" ) >>| return Void) // CODE GENERATION BUG WHEN REPLACE BY >>| (return Void) where unsubscribe = requestConfirmation "Do you realy want to unsubscribe ?" >>= \yn -> return (if yn -1 index) readMore = (enterChoice "Browse through messagelist..." [ readMoreNews (~nmessage) <<@ ("Previous " <+++ nmessage) , readMoreNews nmessage <<@ ("Next " <+++ nmessage) ] >>= \task -> task) where readMoreNews offset = readIndex me group >>= \index -> readNewsGroup group >>= \news -> readNextNewsItems index offset (length news) where readNextNewsItems index offset length # nix = index + offset # nix = if (nix < 0) 0 (if (length <= nix) index nix) = addSubscription me (group,nix) >>| return nix messageList index = readNewsGroup group >>= \newsItems -> allTasks [show i newsItem <<@ ("Message " <+++ i) \\ newsItem <- newsItems%(index,index+nmessage-1) & i <- [index..]] >>| showMessage "Refresh list" show :: Int NewsItem -> Task Void show i (who, name, message) = showMessageAbout [Text ("Message: " <+++ i), BrTag [], Text ("From: " <+++ name)] message commitItem :: String -> Task Void commitItem group = getCurrentUser >>= \user -> commit user.User.userName user.User.displayName group where commit me name group = enterInformation [Text "Type your message ..."] >>= \(Note val) -> readNewsGroup group >>= \news -> writeNewsGroup group (news ++ [(me,name,val)]) >>| showMessage [Text "Message commited to news group ",BTag [] [Text group], BrTag [],BrTag []] getToNames = getToNames` [] where getToNames` names = showCurrentNames (map snd names) ||- getToName >>= \(id,name) -> let newnames = [(id,name):names] in showCurrentNames (map snd newnames) ||- requestConfirmation "Add more names?" >>= \yn -> if yn (getToNames` newnames) (return newnames) showCurrentNames :: [String] -> Task Void showCurrentNames names = showStickyMessageAbout "Current names:" names getToName :: (Task (UserName,String)) getToName = getUsers >>= \users -> enterChoice "Select user to mail a message to: " users >>= \user -> return (user.User.userName,user.User.displayName) cancel :: (Task a) -> Task a | iTask a cancel task = task -||- (showMessage "Cancel this task" >>| getDefaultValue) orTasks2 :: [HtmlTag] [LabeledTask a] -> Task a | iTask a orTasks2 msg tasks = oldParallel "orTasks2" (\list -> length list >= 1) hd undef [t <<@ l \\(l,t) <- tasks] myAndTasks msg tasks = oldParallel "andTask" (\_ -> False) undef hd [t <<@ l \\(l,t) <- tasks] // reading and writing of storages newsGroupsId :: (DBid NewsGroupNames) newsGroupsId = mkDBid "newsGroups" readerId :: UserName -> (DBid Subscriptions) readerId name = mkDBid ("Reader-" <+++ name) groupNameId :: String -> (DBid NewsGroup) groupNameId name = mkDBid ("NewsGroup-" +++ name) readNewsGroups :: Task NewsGroupNames readNewsGroups = readDB newsGroupsId writeNewsGroups :: NewsGroupNames -> Task NewsGroupNames writeNewsGroups newgroups = writeDB newsGroupsId newgroups readSubscriptions :: Subscriber -> Task Subscriptions readSubscriptions me = readDB (readerId me) writeSubscriptions :: Subscriber Subscriptions -> Task Subscriptions writeSubscriptions me subscriptions = writeDB (readerId me) subscriptions addSubscription :: Subscriber Subscription -> Task Subscriptions addSubscription me (groupname,index) # index = if (index < 0) 0 index = readSubscriptions me >>= \subscriptions -> writeSubscriptions me [(groupname,index):[(group,index) \\ (group,index) <- subscriptions | group <> groupname]] readIndex :: Subscriber GroupName -> Task Index readIndex me groupname = readSubscriptions me >>= \subscriptions -> return (hds [index \\ (group,index) <- subscriptions | group == groupname]) where hds [x:xs] = x hds [] = 0 readNewsGroup :: GroupName -> Task NewsGroup readNewsGroup groupname = readDB (groupNameId groupname) writeNewsGroup :: GroupName NewsGroup -> Task NewsGroup writeNewsGroup groupname news = writeDB (groupNameId groupname) news