WorkflowAdmin.icl 17.5 KB
Newer Older
1
implementation module iTasks.Extensions.Admin.WorkflowAdmin
2 3

import iTasks
4
import StdMisc, Data.Tuple, Text, Data.Either, Data.Functor, Data.Func
5 6 7
import iTasks.Internal.SDS
import iTasks.Internal.Serialization
import iTasks.Internal.Store
8
from StdFunc import seq
9
import qualified Data.Map as DM
10
import Data.Map.GenJSON
11
import Data.List, Data.Tuple
12 13
import Text.HTML

14
import iTasks.UI.Definition, iTasks.UI.Editor, iTasks.UI.Editor.Controls, iTasks.UI.Editor.Common, iTasks.UI.Layout.Default, iTasks.UI.Layout.Common
15
import iTasks.Extensions.DateTime
16
// SPECIALIZATIONS
17
derive class iTask Workflow
18

19
gText{|WorkflowTaskContainer|} _ _			            = []
20
gEditor{|WorkflowTaskContainer|} 						= emptyEditorWithDefaultInEnterMode $ WorkflowTask $ return ()
21 22 23
JSONEncode{|WorkflowTaskContainer|} _ c				    = [dynamicJSONEncode c]
JSONDecode{|WorkflowTaskContainer|} _ [c:r]			    = (dynamicJSONDecode c,r)
JSONDecode{|WorkflowTaskContainer|} _ r				    = (Nothing,r)
Bas Lijnse's avatar
Bas Lijnse committed
24
gEq{|WorkflowTaskContainer|} _ _					    = True
25
gDefault{|WorkflowTaskContainer|}					    = WorkflowTask (return ())
26

27 28 29 30 31 32 33 34 35 36 37 38 39 40 41
// Application specific types
:: WorklistRow =
    { taskNr	 :: Maybe String
    , title		 :: Maybe String
	, priority	 :: Maybe String
	, createdBy	 :: Maybe String
	, date		 :: Maybe String
	, deadline	 :: Maybe String
	, createdFor :: Maybe String
	, parentTask :: Maybe String
	}

derive class iTask WorklistRow

// list of active task instances for current user without current one (to avoid work on dependency cycles)
42
myWork :: SDSLens () [(TaskId,WorklistRow)] ()
43 44
myWork = workList taskInstancesForCurrentUser

45
allWork :: SDSLens () [(TaskId,WorklistRow)] ()
46
allWork = workList detachedTaskInstances
47

Haye Böhm's avatar
Haye Böhm committed
48
workList instances = mapRead projection (instances |*| currentTopTask)
49 50 51 52 53 54
where
	projection (instances,ownPid)
		= [(TaskId i.TaskInstance.instanceNo 0, mkRow i) \\ i <- instances | notSelf ownPid i && isActive i]

	notSelf ownPid {TaskInstance|instanceNo} = (TaskId instanceNo 0) <> ownPid
	notSelf ownPid _ = False
Haye Böhm's avatar
Haye Böhm committed
55

56
	isActive {TaskInstance|value} = value === Unstable
57 58 59 60 61 62 63 64 65 66 67 68 69

	mkRow {TaskInstance|instanceNo,attributes,listId} =
		{WorklistRow
		|taskNr		= Just (toString instanceNo)
		,title      = fmap toString ('DM'.get "title"          attributes)
		,priority   = fmap toString ('DM'.get "priority"       attributes)
		,createdBy	= fmap toString ('DM'.get "createdBy"      attributes)
		,date       = fmap toString ('DM'.get "createdAt"      attributes)
		,deadline   = fmap toString ('DM'.get "completeBefore" attributes)
		,createdFor = fmap toString ('DM'.get "createdFor"     attributes)
		,parentTask = if (listId == TaskId 0 0) Nothing (Just (toString listId))
		}

70 71 72
// SHARES
// Available workflows

73
workflows :: SDSLens () [Workflow] [Workflow]
74
workflows = sharedStore "Workflows" []
75

76
workflowByPath :: !String -> SDSLens () Workflow Workflow
Haye Böhm's avatar
Haye Böhm committed
77
workflowByPath path = mapReadWriteError (toPrj,fromPrj) (Just \_ flows -> toPrj flows) workflows
78 79 80
where
	toPrj wfs = case [wf \\ wf <- wfs | wf.Workflow.path == path] of
		[wf:_]	= Ok wf
Bas Lijnse's avatar
Bas Lijnse committed
81
		_		= Error (exception ("Workflow " +++ path +++ " could not be found"))
82

Haye Böhm's avatar
Haye Böhm committed
83
	fromPrj nwf wfs = Ok (Just [if (wf.Workflow.path == path) nwf wf \\ wf <- wfs])
84

85
allowedWorkflows :: SDSLens () [Workflow] ()
Haye Böhm's avatar
Haye Böhm committed
86
allowedWorkflows = mapRead filterAllowed (workflows |*| currentUser)
87
where
88
	filterAllowed (workflows,user) = filter (isAllowedWorkflow user) workflows
89 90

//All tasks that you can do in a session
91
allowedTransientTasks :: SDSLens () [Workflow] ()
92 93
allowedTransientTasks = mapRead (\wfs -> [wf \\ wf=:{Workflow|transient} <- wfs | transient]) allowedWorkflows

94
allowedPersistentWorkflows :: SDSLens () [Workflow] ()
95 96
allowedPersistentWorkflows = mapRead (\wfs -> [wf \\ wf=:{Workflow|transient} <- wfs | not transient]) allowedWorkflows

97
instance Startable WorkflowCollection
98
where
99
	toStartable {WorkflowCollection|name,loginMessage,welcomeMessage,allowGuests,workflows} =
Haye Böhm's avatar
Haye Böhm committed
100
		[onStartup (installWorkflows workflows)
101 102
		,onStartup importDemoUsersFlow
		,onRequest "/" (loginAndManageWork name loginMessage welcomeMessage allowGuests)
103
		]
Bas Lijnse's avatar
Bas Lijnse committed
104

105 106 107
installWorkflows :: ![Workflow] -> Task ()
installWorkflows [] = return ()
installWorkflows iflows
108
	=   try (get workflows) (\(StoreReadBuildVersionError _) -> return [])
109
	>>- \flows -> case flows of
110
		[]	= set iflows workflows @! ()
111
		_	= return ()
Haye Böhm's avatar
Haye Böhm committed
112

113 114
loginAndManageWork :: !String !(Maybe HtmlTag) !(Maybe HtmlTag) !Bool -> Task ()
loginAndManageWork applicationName loginMessage welcomeMessage allowGuests
115
	= forever
116
		(((	identifyApplication applicationName loginMessage
117 118 119 120
			||-
			(anyTask [
	 				enterInformation ("Authenticated access","Enter your credentials and login") [] @ Just
				>>* [OnAction (Action "Login")  (hasValue return)]
121 122 123 124 125
				:if allowGuests
					[viewInformation ("Guest access","Alternatively, you can continue anonymously as guest user") [] ()
					 >>| (return Nothing)
					]
					[]
126
				] <<@ ArrangeHorizontal)
127 128
	 	   )  <<@ ApplyLayout layout
		>>- browse) //Compact layout before login, full screen afterwards
129
		) <<@ Title applicationName
130
where
131
	browse (Just {Credentials|username,password})
132 133
		= authenticateUser username password
		>>= \mbUser -> case mbUser of
134 135
			Just user 	= workAs user (manageWorkOfCurrentUser welcomeMessage)
			Nothing		= (viewInformation (Title "Login failed") [] "Your username or password is incorrect" >>| return ()) <<@ ApplyLayout frameCompact
136
	browse Nothing
137
		= workAs (AuthenticatedUser "guest" ["manager"] (Just "Guest user")) (manageWorkOfCurrentUser welcomeMessage)
Haye Böhm's avatar
Haye Böhm committed
138

139 140 141 142 143
	identifyApplication name welcomeMessage = viewInformation () [] html
	where
		html = DivTag [ClassAttr cssClass] [H1Tag [] [Text name]:maybe [] (\msg -> [msg]) welcomeMessage]
		cssClass = "welcome-" +++ (toLowerCase $ replaceSubString " " "-" name)
	
144
	layout = sequenceLayouts [layoutSubUIs (SelectByType UIAction) (setActionIcon ('DM'.fromList [("Login","login")])) ,frameCompact]
Haye Böhm's avatar
Haye Böhm committed
145

146 147
manageWorkOfCurrentUser :: !(Maybe HtmlTag) -> Task ()
manageWorkOfCurrentUser welcomeMessage
148
	= 	((manageSession -||
149
		  (chooseWhatToDo welcomeMessage >&> withSelection
150 151 152
			(viewInformation () [] "Welcome!")
			(\wf -> unwrapWorkflowTask wf.Workflow.task)
		  )
153
		)
154
	>>* [OnValue (ifStable (const (return ())))]) <<@ ApplyLayout layout
Bas Lijnse's avatar
Bas Lijnse committed
155
where
156
	layout = sequenceLayouts
157
		[unwrapUI //Get rid of the step
158
		,arrangeWithHeader 0
159
		,layoutSubUIs (SelectByPath [0]) layoutManageSession
160
		,layoutSubUIs (SelectByPath [1]) (sequenceLayouts [unwrapUI,layoutWhatToDo])
161 162 163
		//Use maximal screen space
		,setUIAttributes (sizeAttr FlexSize FlexSize)
		]
164

165
	layoutManageSession = sequenceLayouts
166
		[layoutSubUIs SelectChildren actionToButton
167 168
		,layoutSubUIs (SelectByPath [0]) (setUIType UIContainer)
		,setUIType UIContainer
169
		,addCSSClass "manage-work-header"
Bas Lijnse's avatar
Bas Lijnse committed
170
		]
171
	layoutWhatToDo = sequenceLayouts [arrangeWithSideBar 0 LeftSide True, layoutSubUIs (SelectByPath [1]) unwrapUI]
172

173 174
manageSession :: Task ()
manageSession =
Haye Böhm's avatar
Haye Böhm committed
175
		(viewSharedInformation () [ViewAs view] currentUser
176 177
	>>* [OnAction (Action "Log out") (always (return ()))])
		 <<@ ApplyLayout (layoutSubUIs (SelectByType UIAction) (setActionIcon ('DM'.fromList [("Log out","logout")])))
178
where
Haye Böhm's avatar
Haye Böhm committed
179
	view user	= "Welcome " +++ toString user
180

181
chooseWhatToDo welcomeMessage = updateChoiceWithShared (Title "Menu") [ChooseFromList workflowTitle] (mapRead addManageWork allowedTransientTasks) manageWorkWf
182 183
where
	addManageWork wfs = [manageWorkWf:wfs]
184
	manageWorkWf = transientWorkflow "My Tasks" "Manage your worklist"  (manageWork welcomeMessage)
Haye Böhm's avatar
Haye Böhm committed
185

186 187
manageWork :: (Maybe HtmlTag) -> Task ()
manageWork welcomeMessage = parallel [(Embedded, manageList):maybe [] (\html -> [(Embedded, const (viewWelcomeMessage html))]) welcomeMessage] [] <<@ ApplyLayout layoutManageWork @! ()
188
where
189
	manageList taskList
190
		= get currentUser @ userRoles
Haye Böhm's avatar
Haye Böhm committed
191
		>>- \roles ->
192
			forever
193 194
			(	enterChoiceWithSharedAs () [ChooseFromGrid snd] (worklist roles) (appSnd (\{WorklistRow|parentTask} -> isNothing parentTask))
				>>* (continuations roles taskList)
195 196
			)

197
	worklist roles = if (isMember "admin" roles) allWork  myWork
198 199
	continuations roles taskList = if (isMember "manager" roles) [new,open,delete] [open]
	where
200
		new = OnAction (Action "New") (always (appendTask Embedded (removeWhenStable (addNewTask taskList <<@ InWindow <<@ AddCSSClass "new-work-window")) taskList @! () ))
201
		open = OnAction (Action "Open") (hasValue (\(taskId,_) -> openTask taskList taskId @! ()))
202
		delete = OnAction (Action "Delete") (ifValue (\x -> snd x || isMember "admin" roles) (\(taskId,_) -> removeTask taskId topLevelTasks @! ()))
203 204 205 206

	userRoles (AuthenticatedUser _ roles _)  = roles
	userRoles _ = []

207
	layoutManageWork = sequenceLayouts
208
		//Split the screen space
209
		[ arrangeWithSideBar 0 TopSide True
210
		  //Layout all dynamically added tasks as tabs
211
		, layoutSubUIs (SelectByPath [1]) (arrangeWithTabs True)
212 213
		, layoutSubUIs (SelectByPath [1]) $
			layoutSubUIs (SelectByDepth 1) (setUIAttributes $ 'DM'.put "fullscreenable" (JSONBool True) 'DM'.newMap)
214 215
		]

216 217 218
viewWelcomeMessage :: HtmlTag -> Task ()
viewWelcomeMessage html = viewInformation (Title "Welcome") [] html @! ()
	
219
addNewTask :: !(SharedTaskList ()) -> Task ()
Haye Böhm's avatar
Haye Böhm committed
220
addNewTask list
221
	=   ((chooseWorkflow >&> viewWorkflowDetails) <<@ ArrangeHorizontal
222 223
	>>* [OnAction (Action "Start task") (hasValue (\wf -> startWorkflow list wf @! ()))
		,OnAction ActionCancel (always (return ()))
224
		] ) <<@ Title "New task..."
225

226
chooseWorkflow :: Task Workflow
227
chooseWorkflow
228
	=  editSelectionWithShared [Att (Title "Tasks"), Att IconEdit] False (SelectInTree toTree fromTree) allowedPersistentWorkflows (const []) 
Haye Böhm's avatar
Haye Böhm committed
229
	@? tvHd
230
where
231 232
	//We assign unique negative id's to each folder and unique positive id's to each workflow in the list
	toTree workflows = snd (seq (map add (zip ([0..],workflows))) (-1,[]))
233
	where
234
	    add (i,wf=:{Workflow|path}) (folderId,nodeList) = add` path (split "/" path) (folderId,nodeList)
235
        where
236 237 238 239 240 241 242 243 244 245 246 247
    	    add` wfpath [] (folderId,nodeList) = (folderId,nodeList)
		    add` wfpath [title] (folderId,nodeList) = (folderId,nodeList ++ [{ChoiceNode|id=i,label=workflowTitle wf,icon=Nothing,children=[],expanded=False}])
		    add` wfpath path=:[nodeP:pathR] (folderId,[node=:{ChoiceNode|label=nodeL}:nodesR])
		    	| nodeP == nodeL
					# (folderId,children) = add` wfpath pathR (folderId,node.ChoiceNode.children)
					= (folderId,[{ChoiceNode|node & children = children,expanded=False}:nodesR])
		    	| otherwise
					# (folderId,rest) = add` wfpath path (folderId,nodesR)
					= (folderId,[node:rest])
		    add` wfpath path=:[nodeP:pathR] (folderId,[])
				# (folderId`,children) = add` wfpath pathR (folderId - 1,[])
                = (folderId`,[{ChoiceNode|id = folderId, label=nodeP, icon=Nothing, children=children,expanded=False}])
Haye Böhm's avatar
Haye Böhm committed
248
		    add` wfpath path (folderId,[node:nodesR])
249 250
				# (folderId,rest) = add` wfpath path (folderId,nodesR)
				= (folderId,[node:rest])
251 252 253 254 255 256 257

 	fromTree workflows [idx]
      | idx >= 0 && idx < length workflows = [workflows !! idx]
											 = []
	fromTree _ _                             = []
	result (Value [x] s) = Value x s
	result _ = NoValue
258

259
viewWorkflowDetails :: !(sds () (Maybe Workflow) ()) -> Task Workflow | RWShared sds
260
viewWorkflowDetails sel
261
	= viewSharedInformation [Att (Title "Task description"), Att IconView] [ViewUsing view textView] sel
262 263
	@? onlyJust
where
264
	view = maybe "" (\wf -> wf.Workflow.description)
Haye Böhm's avatar
Haye Böhm committed
265

266 267 268
	onlyJust (Value (Just v) s) = Value v s
	onlyJust _					= NoValue

269
startWorkflow :: !(SharedTaskList ()) !Workflow -> Task Workflow
270
startWorkflow list wf
271 272
	= 	get currentUser -&&- get currentDateTime
	>>=	\(user,now) ->
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
273 274 275 276 277
		appendTopLevelTask ('DM'.fromList [ ("title",      workflowTitle wf)
                                          , ("catalogId",  wf.Workflow.path)
                                          , ("createdBy",  toString (toUserConstraint user))
                                          , ("createdAt",  toString now)
                                          , ("createdFor", toString (toUserConstraint user))
278
                                          , ("priority",   toString 5):userAttr user]) False (unwrapWorkflowTask wf.Workflow.task)
279 280 281
	>>= \procId ->
		openTask list procId
	@	const wf
282
where
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
283 284
    userAttr (AuthenticatedUser uid _ _) = [("user", uid)]
    userAttr _                           = []
285

286
unwrapWorkflowTask (WorkflowTask t) = t @! ()
Haye Böhm's avatar
Haye Böhm committed
287
unwrapWorkflowTask (ParamWorkflowTask tf) = (enterInformation "Enter parameters" [] >>= tf @! ())
288

289
openTask :: !(SharedTaskList ()) !TaskId -> Task ()
290
openTask taskList taskId
291
	=	appendOnce taskId (workOnTask taskId) taskList @! ()
292

293
workOnTask :: !TaskId -> Task ()
294
workOnTask taskId
295
    =   (workOn taskId <<@ ApplyLayout (setUIAttributes (heightAttr FlexSize))
Haye Böhm's avatar
Haye Böhm committed
296
    >>* [OnValue    (ifValue (\v. case v of (ASExcepted _) = True; _ = False) (\(ASExcepted excs) -> viewInformation (Title "Error: An exception occurred in this task") [] excs >>| return ()))
297
        ,OnValue    (ifValue ((===) ASIncompatible) (\_ -> dealWithIncompatibleTask))
298 299 300
        ,OnValue    (ifValue ((===) ASDeleted) (\_ -> return ()))
        ,OnValue    (ifValue ((===) (ASAttached True)) (\_ -> return ())) //If the task is stable, there is no need to work on it anymore
        ,OnAction ActionClose   (always (return ()))
301
        ] ) <<@ ApplyLayout (copySubUIAttributes (SelectKeys ["title"]) [0] []) //Use the title from the workOn for the composition
302 303 304 305
where
    dealWithIncompatibleTask
        =   viewInformation (Title "Error") [] "This this task is incompatible with the current application version. Restart?"
        >>* [OnAction ActionYes (always restartTask)
306
            ,OnAction ActionNo (always (return ()))
307 308 309 310 311 312 313
            ]

    restartTask
        =   findReplacement taskId
        >>- \mbReplacement -> case mbReplacement of
            Nothing
                =   viewInformation (Title "Error") [] "Sorry, this task is no longer available in the workflow catalog"
314
                >>| return ()
315
            Just replacement
Bas Lijnse's avatar
Bas Lijnse committed
316
                =   replaceTask taskId (const (unwrapWorkflowTask replacement.Workflow.task)) topLevelTasks
317 318 319 320 321
                >>| workOnTask taskId

    //Look in the catalog for an entry that has the same path as
    //the 'catalogId' that is stored in the incompatible task instance's properties
    findReplacement taskId
Haye Böhm's avatar
Haye Böhm committed
322
        =  get ((sdsFocus taskId (taskListEntryMeta topLevelTasks)) |*| workflows)
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
323
        @  \(taskListEntry,catalog) -> maybe Nothing (lookup catalog) ('DM'.get "catalogId" taskListEntry.TaskListItem.attributes)
324
    where
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
325
        lookup [wf=:{Workflow|path}:wfs] cid = if (path == cid) (Just wf) (lookup wfs cid)
326
        lookup [] _ = Nothing
327

328
appendOnce :: TaskId (Task a) (SharedTaskList a) -> Task () | iTask a
329 330
appendOnce identity task slist
    =   get (taskListMeta slist)
331
    >>- \items -> if (checkItems name items)
332 333
        (return ())
	    (appendTask (NamedEmbedded name) (removeWhenStable task) slist @! ())
334 335
where
    name = toString identity
336 337
    checkItems name [] = False
    checkItems name [{TaskListItem|attributes}:is]
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
338
        | maybe False ((==) name) ('DM'.get "name" attributes)  = True //Item with name exists!
339
                                                                = checkItems name is
340

341
removeWhenStable :: (Task a) (SharedTaskList a) -> Task a | iTask a
342
removeWhenStable task slist
343
    =   (task
344
    >>* [OnValue (ifStable (\_ -> get (taskListSelfId slist) >>- \selfId -> removeTask selfId slist))]
345 346
    @?  const NoValue)
	<<@ ApplyLayout unwrapUI
347

348 349
addWorkflows :: ![Workflow] -> Task [Workflow]
addWorkflows additional
350
	=	upd (\flows -> flows ++ additional) workflows
351

352 353
// UTIL FUNCTIONS
workflow :: String String w -> Workflow | toWorkflow w
354
workflow path description task = toWorkflow path description [] False task
355

356 357 358
transientWorkflow :: String String w -> Workflow | toWorkflow w
transientWorkflow path description task = toWorkflow path description [] True task

359
restrictedWorkflow :: String String [Role] w -> Workflow | toWorkflow w
360
restrictedWorkflow path description roles task = toWorkflow path description roles False task
Bas Lijnse's avatar
Bas Lijnse committed
361

362 363 364
restrictedTransientWorkflow :: String String [Role] w -> Workflow | toWorkflow w
restrictedTransientWorkflow path description roles task = toWorkflow path description roles True task

Bas Lijnse's avatar
Bas Lijnse committed
365 366
inputWorkflow :: String String String (a -> Task b) -> Workflow | iTask a & iTask b
inputWorkflow name desc inputdesc tfun
Haye Böhm's avatar
Haye Böhm committed
367 368
	= workflow name desc (enterInformation inputdesc [] >>= tfun)

369 370
instance toWorkflow (Task a) | iTask a
where
371
	toWorkflow path description roles transient task = toWorkflow path description roles transient (Workflow defaultValue task)
Haye Böhm's avatar
Haye Böhm committed
372

373 374
instance toWorkflow (WorkflowContainer a) | iTask a
where
375
	toWorkflow path description roles transient (Workflow managerP task) = mkWorkflow path description roles transient (WorkflowTask task) managerP
376 377 378

instance toWorkflow (a -> Task b) | iTask a & iTask b
where
379
	toWorkflow path description roles transient paramTask = toWorkflow path description roles transient (ParamWorkflow defaultValue paramTask)
Haye Böhm's avatar
Haye Böhm committed
380

381 382
instance toWorkflow (ParamWorkflowContainer a b) | iTask a & iTask b
where
383
	toWorkflow path description roles transient (ParamWorkflow managerP paramTask) = mkWorkflow path description roles transient (ParamWorkflowTask paramTask) managerP
Haye Böhm's avatar
Haye Böhm committed
384

385
mkWorkflow path description roles transient taskContainer managerProps =
386 387 388
	{ Workflow
	| path	= path
	, roles	= roles
389
	, transient = transient
390 391 392 393 394
	, task = taskContainer
	, description = description
	, managerProperties = managerProps
	}

395 396 397
workflowTitle :: Workflow -> String
workflowTitle {Workflow|path} = last (split "/" path)

398 399 400 401 402
isAllowedWorkflow :: !User !Workflow -> Bool
isAllowedWorkflow _ {Workflow|roles=[]}		= True								//Allow workflows without required roles
isAllowedWorkflow (AuthenticatedUser _ hasRoles _) {Workflow|roles=needsRoles}	//Allow workflows for which the user has permission
	= or [isMember r hasRoles \\ r <- needsRoles]
isAllowedWorkflow _ _ 						= False								//Don't allow workflows in other cases