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

Examples/src/ITaskConf 2010/HRM.dcl

-definition module HRM
-
-import iTasks
-
-hrm :: [Workflow]
-
-manageGroups :: Task Void
-listGroups :: Task Void
-
-getUserGroups :: Task [String]
\ No newline at end of file

Examples/src/ITaskConf 2010/HRM.icl

-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

Examples/src/ITaskConf 2010/ListManagement.dcl

-definition module ListManagement
-
-import iTasks
-
-lists :: [Workflow]
-
-:: ListDB
-getListDB :: DBid ListDB
\ No newline at end of file

Examples/src/ITaskConf 2010/Messaging.dcl

-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

Examples/src/ITaskConf 2010/Toolbox.dcl

-definition module Toolbox
-
-import iTasks
-
-toolbox :: [Workflow]
-
-// Date Picking
-datePicker 		:: [User] 								-> Task Date
\ No newline at end of file

Examples/src/ITaskConf 2010/iTaskConf2010.icl

 module iTaskConf2010
 
 import iTasks
-import Toolbox, HRM, ListManagement, Messaging
+
+import Groups, Messaging, Consensus, Lists
+
 
 Start :: !*World -> *World
 Start world = startEngine workflows world
 where
-	workflows = flatten [ messaging, toolbox, hrm, lists ]	
\ No newline at end of file
+	workflows = [ workflow "Groups" manageGroups
+				: 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
+		]

Language/src/Core/TaskCombinators/CommonCombinators.dcl

@@ -23,6 +23,12 @@ derive gHint		GAction, GOnlyAction
 derive JSONEncode	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.
 *

Language/src/Core/TaskCombinators/CommonCombinators.icl

@@ -7,7 +7,7 @@ import StdBool, StdList,StdOrdList, StdTuple, StdGeneric, StdMisc, StdInt, StdCl
 
 from StdFunc	import id, const
 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 Store		import :: Store
 from SessionDB	import :: Session
@@ -29,6 +29,9 @@ derive JSONDecode	GAction, GOnlyAction, GroupedBehaviour
 
 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
 emptyGActionL :: [GroupAction a b Void]
 emptyGActionL = []

Language/src/Extensions/Consensus.dcl

+definition module Consensus
+
+import iTasks
+
+pickADate :: Task Void
+
+// Date Picking
+datePicker 		:: [User] 								-> Task Date
\ No newline at end of file

Examples/src/ITaskConf 2010/Toolbox.icl → Language/src/Extensions/Consensus.icl

-implementation module Toolbox
-
-/*
-	This toolbox contains a number of workflows which can be handle unforseen situations. Or can be used as 'units' in other workflows.
-*/
+implementation module Consensus
 
 import iTasks, GenEq
-import CommonDomain, Messaging
-
-from HRM import getUserGroups
+import CommonDomain, Messaging, Groups
 
 derive bimap Maybe, (,)
 
-toolbox :: [Workflow]
-toolbox 
-	= [ workflow "Toolbox/Pick a date" pickADate
-	  ]
+
 
 //========================================================================================================================================================================
 // DatePicker
@@ -73,6 +64,6 @@ where
 			
 		updateCount vc=:{yes,no,maybe} (Editable v)
 			= case v of
-				Yes 	= {vc & yes 	= inc yes}
-				No  	= {vc & no  	= inc no}
-				Maybe	= {vc & maybe 	= inc maybe}
+				Yes 	= {VoteCount|vc & yes 		= inc yes}
+				No  	= {VoteCount|vc & no  		= inc no}
+				Maybe	= {VoteCount|vc & maybe 	= inc maybe}

Language/src/Extensions/Groups.dcl

+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
+

Language/src/Extensions/Groups.icl

+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
+			
+

Language/src/Extensions/Lists.dcl

+definition module Lists
+
+import iTasks
+
+:: ListDB
+getListDB :: DBid ListDB
+
+pushList :: Task Void
+
+editList :: Task Void
+
+newList :: Task Void
\ No newline at end of file

Examples/src/ITaskConf 2010/ListManagement.icl → Language/src/Extensions/Lists.icl

-implementation module ListManagement
+implementation module Lists
 
 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]
 :: ListDBItem = NoteList (List Note) | DateList (List Date) | DocList (List Document)

Language/src/Extensions/Messaging.dcl

+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

Examples/src/ITaskConf 2010/Messaging.icl → Language/src/Extensions/Messaging.icl

@@ -2,15 +2,9 @@ implementation module Messaging
 
 import iTasks
 import CommonDomain
-import HRM
+import Groups
 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
@@ -59,11 +53,12 @@ newMessage = getCurrentUser
 
 newMessageToGroup :: Task Void
 newMessageToGroup = getCurrentUser
-	>>= \me ->		getUserGroups
-	>>= \groups ->	enterChoice "Choose group" "Select group" groups
-	>>= \role ->	getUsersWithRole role
-	>>= \users ->	writeMessage me "" users [] []
-	>>= \msg ->		sendMessage msg
+	>>= \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 [] []
+			>>= \msg ->		sendMessage msg
 	
 sendMessage :: Message -> Task Void
 sendMessage msg = allProc [who @>> spawnProcess who True True