implementation module Groups import iTasks derive class iTask Group derive bimap Maybe, (,) instance DB Group where databaseId = mkDBId "Groups" getItemId g = DBRef (fromHidden g.Group.groupId) setItemId (DBRef groupId) g = {Group| g & groupId = toHidden groupId} instance toString Group where toString g = g.Group.name manageGroups :: Task Void manageGroups = Subject "Manage groups" @>> ( getMyGroups >>= overview >>= \(action,group) -> case fst action of ActionNew = newGroup >>= manageGroup >>| return False ActionOpen = manageGroup group >>| return False ActionQuit = return True ) >| return Void where overview [] = getDefaultValue >>= showMessageA "My groups" startMsg [aNew,aQuit] overview list = enterChoiceA "My groups" listMsg [aOpen,aNew,aQuit] list aOpen = (ActionOpen, ifvalid) aNew = (ActionNew, always) aQuit = (ActionQuit, always) newGroup = enterInformation "New group" "Please enter a name for the new group" >>= \name -> getContextWorker >>= \user -> createGroup name user startMsg = [Text "You have no groups yet.",BrTag [], BrTag [] ,Text "You can create your own user groups to which you can invite other users", BrTag [] ,Text "Members of a group can easily send each other messages " ,Text "or ask each others opinions." ] listMsg = [Text "You are a member of the groups listed below.", BrTag [], BrTag [] ,Text "You may select one to view it or create a new group." ] manageGroup :: Group -> Task Void manageGroup igroup = ( justdo (dbReadItem (getItemId igroup)) >>= \group -> showMessageAboutA (toString group) "This group contains the following members:" [aBack,aInvite,aLeave] group.Group.members >>= \(action,_) -> case fst action of ActionClose = return True Action "invite" _ = invite group >>| return False Action "leave" _ = leave group >>| return False ) >| stop where aBack = (ActionClose, always) aInvite = (Action "invite" "Invite new member", always) aLeave = (Action "leave" "Leave group", always) invite group = enterInformation ("Invite a someone to join " +++ toString group) "Please enter a user to invite to the group" >>= inviteUserToGroup group leave group = getContextWorker >>= removeMemberFromGroup group createGroup :: !String !User -> Task Group createGroup name user = dbCreateItem {Group | groupId = Hidden 0, name = name, members = [user]} getAllGroups :: Task [Group] getAllGroups = dbReadAll getMyGroups :: Task [Group] getMyGroups = getContextWorker >>= \user -> dbReadAll >>= transform (filter (groupMember user)) where groupMember user {Group|members} = isMember user members deleteGroup :: !Group -> Task Group deleteGroup group = dbDeleteItem (getItemId group) >>| return group addMemberToGroup :: !Group !User -> Task Group addMemberToGroup group user = dbReadItem (getItemId group) >>= \mbGroup -> case mbGroup of Just group = dbUpdateItem {Group|group & members = removeDup (group.members ++ [user])} Nothing = return group removeMemberFromGroup :: !Group !User -> Task Group removeMemberFromGroup group user = dbReadItem (getItemId group) >>= \mbGroup -> case mbGroup of //If the current user is the last user, delete the group Just group=:{members=[user]} = deleteGroup group //Remove the user from the group Just group=:{members} = dbUpdateItem {Group|group & members = removeMember user members} Nothing = return group inviteUserToGroup :: !Group !User -> Task Group inviteUserToGroup group user = getContextWorker >>= \fromUser -> spawnProcess True True ( assign user (invite fromUser group) >>= \accept -> if accept (addMemberToGroup group user >>= showMessage "Invitation accepted" (toString user +++ " accepted your invitation to join the group " +++ toString group) ) (showMessage "Invitation declined" (toString user +++ " declined your invitation to join the group " +++ toString group) group) ) >>| showMessage "Invitation sent" ("An invitation to join the group has been sent to " +++ toString user) group where invite user group = requestConfirmation ("Invitation to join group " +++ toString group) [Text (toString user +++ " invites you to join the group " +++ toString group +++ "."),BrTag [], Text "Do you accept this invitation?"]