implementation module Messages import iTasks import Groups derive class iTask Message derive bimap Maybe, (,) :: Message = { messageId :: Hidden Int , subject :: String , sender :: Display User , recipients :: [User] , priority :: TaskPriority , needsReply :: Bool , message :: Note , attachments :: Maybe [Document] , thread :: Display [Message] } instance DB Message where databaseId = mkDBId "Messages" getItemId m = DBRef (fromHidden m.Message.messageId) setItemId (DBRef i) m = {Message|m & messageId = toHidden i} mkMsg :: User -> Message mkMsg me = { Message | messageId = toHidden 0 , sender = toDisplay me , subject = "New message" , recipients = [] , priority = NormalPriority , needsReply = False , message = Note "" , attachments = Nothing , thread = Display [] } manageMessages :: Task Void manageMessages = ( getMyMessages >>= overview >>= \(action,message) -> case fst action of ActionOpen = manageMessage message >>| return False Action "new-msg" _ = newMessage >>| return False Action "new-group-msg" _ = newGroupMessage >>| return False ActionQuit = return True ) >| stop where overview :: [Message] -> Task (ActionEvent,Message) overview [] = getDefaultValue >>= showMessageA "My messages" "You have no messages" [aNew,aNewGroup,aQuit] overview msgs = enterChoiceA "My messages" "Your messages:" [aOpen,aNew,aNewGroup,aQuit] msgs aOpen = (ActionOpen,ifvalid) aNew = (Action "new-msg" "New message", always) aNewGroup = (Action "new-group-msg" "New group message", always) aQuit = (ActionQuit,always) manageMessage :: Message -> Task Bool manageMessage msg=:{Message |subject} = showMessageAboutA subject "You received a message" [aClose,aReply,aReplyAll,aForward,aDelete] msg >>= \act -> case act of ((ActionClose,_),_) = return False ((Action "reply" _,_),message) = getCurrentUser >>= \me -> writeMessage me ("Re: "+++msg.Message.subject) [(fromDisplay msg.sender)] (Just msg) >>= \msg -> sendMessage msg >>| return True ((Action "reply-all" _,_),_) = getCurrentUser >>= \me -> writeMessage me ("Re: "+++msg.Message.subject) [(fromDisplay msg.sender):[u \\ u <- msg.recipients | u <> me]] (Just msg) >>= \msg -> sendMessage msg >>| return True ((Action "forward" _,_),_) = getCurrentUser >>= \me -> writeMessage me ("Fw: " +++ msg.Message.subject) [] (Just msg) >>= \msg -> sendMessage msg >>| return False ((ActionDelete,_),msg) = dbDeleteItem (getItemId msg) >>| showMessage "Deleted" "Message deleted" False where aReply = (Action "reply" "Reply",always) aReplyAll = (Action "reply-all" "Reply All",always) aForward = (Action "forward" "Forward",always) aDelete = (ActionDelete, always) aClose = (ActionClose, always) newMessage :: Task Void newMessage = getCurrentUser >>= \me -> writeMessage me "" [] Nothing >>= \msg -> sendMessage msg newGroupMessage :: Task Void newGroupMessage = getCurrentUser >>= \me -> getMyGroups >>= \groups -> case groups of [] = showMessage "No groups" "You are not a member of any group" Void _ = enterChoice "Choose group" "Select group" groups >>= \group -> writeMessage me "" group.members Nothing >>= \msg -> sendMessage msg sendMessage :: Message -> Task Void sendMessage msg = dbCreateItem msg >>= \msg -> case msg.needsReply of False = allTasks [spawnProcess True True (notifyTask rcp msg) \\ rcp <- msg.Message.recipients] >>| stop True = spawnProcess True True (awaitReplies msg) >>| stop >>| showMessageAbout "Message sent" "The following message has been sent:" msg >>| stop where notifyTask user msg = user @>> subject msg @>> msg.Message.priority @>> (manageMessage msg) awaitReplies msg = Subject ("Waiting for reply on " +++ msg.Message.subject) @>> case msg.Message.recipients of [recipient] = assign recipient (askReplyTask recipient msg) >>= \answer -> notifyNoReplies [recipient] [answer] recipients = allProc [askReplyTask rcp msg \\ rcp <- recipients] Closed >>= notifyNoReplies recipients askReplyTask user msg = user @>> subject msg @>> msg.Message.priority @>> (showStickyMessage "Reply requested" "The sender would like to receive a reply to this message." False ||- manageMessage msg ) subject msg = Subject ("Message from " +++ toString (fromDisplay msg.Message.sender)+++ ": "+++msg.Message.subject) notifyNoReplies recipients answers = case [rcp \\ rcp <- recipients & ans <- answers | not ans] of [] = stop users = showMessageAbout "Reply request ignored" "The following users ignored your request for a reply:" users >>| stop writeMessage :: User String [User] (Maybe Message) -> Task Message writeMessage sender subj recipients mbThread = updateInformation "Compose" "Enter your message" {Message | (mkMsg sender) & subject = subj, recipients = recipients,thread = updateThread mbThread} where updateThread :: (Maybe Message) -> Display [Message] updateThread Nothing = Display [] updateThread (Just msg) = Display [{Message|msg & thread = Display []}:fromDisplay msg.Message.thread] getMyMessages :: Task [Message] getMyMessages = getContextWorker >>= \user -> dbReadAll >>= transform (filter (isRecipient user)) where isRecipient user msg = isMember user msg.Message.recipients getAllMessages ::Task [Message] getAllMessages = dbReadAll