Commit 216aaba9 authored by Bas Lijnse's avatar Bas Lijnse

First round of cleanup in ad-hoc examples.Moved them to "Extensions" and...

First round of cleanup in ad-hoc examples.Moved them to "Extensions" and updated Groups module to not be linked to roles, but let users create their own groups and invite others.

git-svn-id: https://svn.cs.ru.nl/repos/iTask-system/trunk@1144 63da3aa8-80fd-4f01-9db8-e6ea747a3da2
parent 806cc409
definition module HRM
import iTasks
hrm :: [Workflow]
manageGroups :: Task Void
listGroups :: Task Void
getUserGroups :: Task [String]
\ No newline at end of file
implementation module HRM
import iTasks
hrm :: [Workflow]
hrm = [restrictedWorkflow "Groups/Manage Groups" ["Chair"] manageGroups
,restrictedWorkflow "Groups/List Groups" ["Chair"] listGroups
]
:: Group = { label :: String, members :: (Maybe [User]) }
derive class iTask Group
derive bimap Maybe, (,)
manageGroups :: Task Void
manageGroups = buildGroups
>>= \groups -> updateInformation "Group assignment" "Please assign users to groups" groups
>>= \ngroups -> getUsers
>>= \users -> removeAllGroupsFromUsers users
>>| assignGroupsToUsers ngroups users
removeAllGroupsFromUsers :: [User] -> Task Void
removeAllGroupsFromUsers users = sequence "removeAllGroupsFromUsers" [removeAllGroupsFromUser u \\ u <- users] >>| return Void
where
removeAllGroupsFromUser :: User -> Task Void
removeAllGroupsFromUser user =
getUser (userName user) >>= \mbuser ->
case mbuser of
Just (RegisteredUser details=:{UserDetails | roles})
= updateUser user {UserDetails | details & roles = Nothing} >>| return Void
_
= return Void
assignGroupsToUsers :: [Group] [User] -> Task Void
assignGroupsToUsers groups users = sequence "assignGroupsToUsers" [assignGroupToUsers g users \\ g <- groups] >>| return Void
where
assignGroupToUsers :: Group [User] -> Task Void
assignGroupToUsers group users = sequence "assignGroupToUsers" [assignGroupToUser group u \\ u <- users] >>| return Void
assignGroupToUser :: Group User -> Task Void
assignGroupToUser group=:{label,members} user =
getUser (userName user) >>= \mbuser ->
case mbuser of
Just (RegisteredUser details=:{UserDetails | roles})
# roles = mb2list roles
# members = mb2list members
# details = case isMember user members of
True = {UserDetails | details & roles = list2mb (removeDup [label:roles])}
False = details
= updateUser user details >>| return Void
_
= return Void
listGroups :: Task Void
listGroups = buildGroups
>>= showMessageAbout "Role assignment" "This is the current assignment of roles" >>| return Void
getUserGroups :: Task [String]
getUserGroups = buildGroups
>>= \groups = return [g.Group.label \\ g <- groups]
buildGroups :: Task [Group]
buildGroups = getUsers
>>= \users -> return (foldl buildGroups` [] users)
where
buildGroups` groups user
= case user of
(RegisteredUser details=:{UserDetails | roles}) = foldl (addUserToGroups user) groups (mb2list roles)
_ = groups
addUserToGroups user groups role
| isMember role [g.Group.label \\ g <- groups]
= [if(g.Group.label == role) {Group | g & members = list2mb (removeDup [user:mb2list g.members])} g \\ g <- groups]
| otherwise
= [{Group | label = role, members = Just [user]}:groups]
\ No newline at end of file
definition module ListManagement
import iTasks
lists :: [Workflow]
:: ListDB
getListDB :: DBid ListDB
\ No newline at end of file
definition module Messaging
import iTasks
messaging :: [Workflow]
:: Message
// Messaging
newMessage :: Task Void
newMessageToGroup :: Task Void
sendMessage :: Message -> Task Void
writeMessage :: User String [User] [User] [Message] -> Task Message
readMessage :: Message -> Task Void
broadcast :: [User] String (Maybe a) -> Task Void | iTask a
definition module Toolbox
import iTasks
toolbox :: [Workflow]
// Date Picking
datePicker :: [User] -> Task Date
\ No newline at end of file
module iTaskConf2010 module iTaskConf2010
import iTasks import iTasks
import Toolbox, HRM, ListManagement, Messaging
import Groups, Messaging, Consensus, Lists
Start :: !*World -> *World Start :: !*World -> *World
Start world = startEngine workflows world Start world = startEngine workflows world
where where
workflows = flatten [ messaging, toolbox, hrm, lists ] workflows = [ workflow "Groups" manageGroups
\ No newline at end of file : flatten [ messaging, toolbox, lists ]
]
messaging :: [Workflow]
messaging
= [ workflow "Messaging/Send a new Message" newMessage
, workflow "Messaging/Send a new Group-Message" newMessageToGroup
, workflow "Messaging/View Message Archive" viewArchive
]
toolbox :: [Workflow]
toolbox
= [ workflow "Toolbox/Pick a date" pickADate
]
lists :: [Workflow]
lists = [ workflow "List Management/New List" newList
, workflow "List Management/Edit List" editList
, workflow "List Management/Push List" pushList
]
...@@ -23,6 +23,12 @@ derive gHint GAction, GOnlyAction ...@@ -23,6 +23,12 @@ derive gHint GAction, GOnlyAction
derive JSONEncode GAction, GOnlyAction derive JSONEncode GAction, GOnlyAction
derive JSONDecode GAction, GOnlyAction derive JSONDecode GAction, GOnlyAction
/**
* Transform a value with a custom function
*
*/
transform :: !(a -> b) !a -> Task b | iTask b
/** /**
* Tasks can dynamically add other tasks or stop execution of group. * Tasks can dynamically add other tasks or stop execution of group.
* *
......
...@@ -7,7 +7,7 @@ import StdBool, StdList,StdOrdList, StdTuple, StdGeneric, StdMisc, StdInt, StdCl ...@@ -7,7 +7,7 @@ import StdBool, StdList,StdOrdList, StdTuple, StdGeneric, StdMisc, StdInt, StdCl
from StdFunc import id, const from StdFunc import id, const
from TSt import :: Task(..), :: TSt{..}, :: IWorld(..), :: TaskInfo{..}, :: StaticInfo{..}, :: Workflow, :: ChangeLifeTime,:: HTTPRequest, :: Config from TSt import :: Task(..), :: TSt{..}, :: IWorld(..), :: TaskInfo{..}, :: StaticInfo{..}, :: Workflow, :: ChangeLifeTime,:: HTTPRequest, :: Config
from TSt import applyTask, mkSequenceTask, mkParallelTask from TSt import applyTask, mkSequenceTask, mkParallelTask, mkInstantTask
from Types import :: ProcessId, :: TaskId, :: TaskPriority(..), :: User(..) from Types import :: ProcessId, :: TaskId, :: TaskPriority(..), :: User(..)
from Store import :: Store from Store import :: Store
from SessionDB import :: Session from SessionDB import :: Session
...@@ -29,6 +29,9 @@ derive JSONDecode GAction, GOnlyAction, GroupedBehaviour ...@@ -29,6 +29,9 @@ derive JSONDecode GAction, GOnlyAction, GroupedBehaviour
derive bimap Maybe, (,) derive bimap Maybe, (,)
//Value transformation
transform :: !(a -> b) !a -> Task b | iTask b
transform f x = mkInstantTask "Value transformation" "Value transformation with a custom function" (\tst -> (TaskFinished (f x),tst))
//Grouping combinators //Grouping combinators
emptyGActionL :: [GroupAction a b Void] emptyGActionL :: [GroupAction a b Void]
emptyGActionL = [] emptyGActionL = []
......
definition module Consensus
import iTasks
pickADate :: Task Void
// Date Picking
datePicker :: [User] -> Task Date
\ No newline at end of file
implementation module Toolbox implementation module Consensus
/*
This toolbox contains a number of workflows which can be handle unforseen situations. Or can be used as 'units' in other workflows.
*/
import iTasks, GenEq import iTasks, GenEq
import CommonDomain, Messaging import CommonDomain, Messaging, Groups
from HRM import getUserGroups
derive bimap Maybe, (,) derive bimap Maybe, (,)
toolbox :: [Workflow]
toolbox
= [ workflow "Toolbox/Pick a date" pickADate
]
//======================================================================================================================================================================== //========================================================================================================================================================================
// DatePicker // DatePicker
...@@ -73,6 +64,6 @@ where ...@@ -73,6 +64,6 @@ where
updateCount vc=:{yes,no,maybe} (Editable v) updateCount vc=:{yes,no,maybe} (Editable v)
= case v of = case v of
Yes = {vc & yes = inc yes} Yes = {VoteCount|vc & yes = inc yes}
No = {vc & no = inc no} No = {VoteCount|vc & no = inc no}
Maybe = {vc & maybe = inc maybe} Maybe = {VoteCount|vc & maybe = inc maybe}
definition module Groups
/**
* This extension provides the possibility to create groups of users.
*
* - Users can create new groups (they automatically become member)
* - Group members can invite others to join a group
* - Group members can leave a group (when the last member is removed from a group it is deleted)
*/
import iTasks
:: Group =
{ no :: !Int
, name :: !String
, members :: ![User]
}
derive class iTask Group
instance DB Group
instance toString Group
manageGroups :: Task Void
manageGroup :: Group -> Task Void
createGroup :: !String !User -> Task Group
getAllGroups :: Task [Group]
getMyGroups :: Task [Group]
deleteGroup :: !Group -> Task Group
addMemberToGroup :: !Group !User -> Task Group
removeMemberFromGroup :: !Group !User -> Task Group
inviteUserToGroup :: !User !Group -> Task Group
implementation module Groups
import iTasks
derive class iTask Group
derive bimap Maybe, (,)
instance DB Group
where
databaseId = mkDBid "Groups"
getItemId g = DBRef g.Group.no
setItemId (DBRef no) g = {Group| g & no = no}
instance toString Group where toString g = g.Group.name
createGroup :: !String !User -> Task Group
createGroup name user
= dbCreateItem {Group | no = 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 = 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 :: !User !Group -> Task Group
inviteUserToGroup user group
= getContextWorker
>>= \fromUser ->
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)
>>= dbUpdateItem
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?"]
manageGroups :: Task Void
manageGroups
= Subject "Manage groups" @>>
( getMyGroups
>>= overview
>>= \(action,group) ->
case action of
ActionNew = newGroup >>= manageGroup >>| return False
ActionOpen = manageGroup group >>| return False
ActionQuit = return True
) <! id
>>| return Void
where
overview [] = getDefaultValue >>= showMessageA "My groups" "You have no groups" [aNew,aQuit]
overview list = enterChoiceA "My groups" "Select a group..." [aOpen,aNew,aQuit] list
aOpen = ButtonAction (ActionOpen, IfValid)
aNew = ButtonAction (ActionNew, Always)
aQuit = ButtonAction (ActionQuit, Always)
newGroup = enterInformation "New group" "Please enter a name for the new group"
>>= \name ->
getContextWorker
>>= \user ->
createGroup name user
manageGroup :: Group -> Task Void
manageGroup group
= showMessageAboutA (toString group) "This group contains the following members:" [aBack,aInvite,aLeave] group.Group.members
>>= \(action,_) -> case action of
ActionPrevious = return Void
ActionLabel "Invite a new member" = invite group >>| return Void
ActionLabel "Leave group" = leave group >>| return Void
where
aBack = ButtonAction (ActionPrevious, Always)
aInvite = ButtonAction (ActionLabel "Invite a new member", Always)
aLeave = ButtonAction (ActionLabel "Leave group", Always)
invite group
= enterInformation ("Invite a someone to join " +++ toString group) "Please enter a user to invite to the group"
>>= \user ->
inviteUserToGroup user group
leave group
= getContextWorker
>>= removeMemberFromGroup group
definition module Lists
import iTasks
:: ListDB
getListDB :: DBid ListDB
pushList :: Task Void
editList :: Task Void
newList :: Task Void
\ No newline at end of file
implementation module ListManagement implementation module Lists
import iTasks, CommonDomain import iTasks, CommonDomain
lists :: [Workflow]
lists = [ workflow "List Management/New List" newList
, workflow "List Management/Edit List" editList
, workflow "List Management/Push List" pushList
]
:: ListDB :== [DBid ListDBItem] :: ListDB :== [DBid ListDBItem]
:: ListDBItem = NoteList (List Note) | DateList (List Date) | DocList (List Document) :: ListDBItem = NoteList (List Note) | DateList (List Date) | DocList (List Document)
......
definition module Messaging
import iTasks
:: Message =
{ sender :: HtmlDisplay User
, to :: [User]
, cc :: Maybe [User]
, priority :: TaskPriority
, subject :: String
, message :: Note
, attachments :: Maybe [Document]
, previousMessages :: HtmlDisplay [Message]
}
// Messaging
newMessage :: Task Void
newMessageToGroup :: Task Void
viewArchive :: Task Void
sendMessage :: Message -> Task Void
writeMessage :: User String [User] [User] [Message] -> Task Message
readMessage :: Message -> Task Void
broadcast :: [User] String (Maybe a) -> Task Void | iTask a
...@@ -2,15 +2,9 @@ implementation module Messaging ...@@ -2,15 +2,9 @@ implementation module Messaging
import iTasks import iTasks
import CommonDomain import CommonDomain
import HRM import Groups
import GenEq import GenEq
messaging :: [Workflow]
messaging
= [ workflow "Messaging/Send a new Message" newMessage
, workflow "Messaging/Send a new Group-Message" newMessageToGroup
, workflow "Messaging/View Message Archive" viewArchive
]
//======================================================================================================================================================================== //========================================================================================================================================================================
// Internal mail // Internal mail
...@@ -59,11 +53,12 @@ newMessage = getCurrentUser ...@@ -59,11 +53,12 @@ newMessage = getCurrentUser
newMessageToGroup :: Task Void newMessageToGroup :: Task Void
newMessageToGroup = getCurrentUser newMessageToGroup = getCurrentUser
>>= \me -> getUserGroups >>= \me -> getMyGroups
>>= \groups -> enterChoice "Choose group" "Select group" groups >>= \groups -> case groups of
>>= \role -> getUsersWithRole role [] = showMessage "No groups" "You are not a member of any group" Void
>>= \users -> writeMessage me "" users [] [] _ = enterChoice "Choose group" "Select group" groups
>>= \msg -> sendMessage msg >>= \group -> writeMessage me "" group.members [] []
>>= \msg -> sendMessage msg
sendMessage :: Message -> Task Void sendMessage :: Message -> Task Void
sendMessage msg = allProc [who @>> spawnProcess who True True sendMessage msg = allProc [who @>> spawnProcess who True True
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment