Commit 097eb1ae authored by Bas Lijnse's avatar Bas Lijnse

Added a 'real' user database mechanism with combinators for retrieving...

Added a 'real' user database mechanism with combinators for retrieving information about users of the system.

git-svn-id: https://svn.cs.ru.nl/repos/iTask-system/branches/fancyTasks@361 63da3aa8-80fd-4f01-9db8-e6ea747a3da2
parent 32f48a80
......@@ -47,7 +47,7 @@ itasks.LoginWindow = Ext.extend(Ext.Window, {
//Construct the login window
Ext.apply(this, {
title: 'Login to iTasks',
title: 'iTasks',
y: 150,
width: 350,
height: 165,
......
......@@ -23,10 +23,10 @@ itasks.WorkListPanel = Ext.extend(Ext.ux.grid.livegrid.GridPanel, {
successProperty: 'success'
},[
{name: 'taskid'},
{name: 'priority'},
{name: 'processname'},
{name: 'subject'},
{name: 'delegator'},
{name: 'processname'},
{name: 'delegatorName'},
{name: 'priority'},
{name: 'timestamp'},
{name: 'tree_path'},
{name: 'tree_last'},
......@@ -76,10 +76,10 @@ itasks.WorkListPanel = Ext.extend(Ext.ux.grid.livegrid.GridPanel, {
selModel: new Ext.ux.grid.livegrid.RowSelectionModel(),
columns: [
{id: 'taskid', header: 'Task', dataindex: 'taskid', renderer: treeRenderer, width: 200 },
{id: 'priority', header: 'Priority', dataindex: 'priority', renderer: itasks.util.formatPriority, width: 100 },
{id: 'processname', header: 'Process', dataindex: 'processname', width: 100},
{id: 'subject', header: 'Subject', dataIndex: 'subject', width: 100},
{id: 'delegator', header: 'From', dataIndex: 'delegator', width: 100 },
{id: 'processname', header: 'Process', dataindex: 'processname', width: 100},
{id: 'delegatorName', header: 'From', dataIndex: 'delegatorName', width: 100 },
{id: 'priority', header: 'Priority', dataindex: 'priority', renderer: itasks.util.formatPriority, width: 100 },
{id: 'timestamp', header: 'Date', dataIndex: 'timestamp', renderer: itasks.util.formatDate, width: 100}
],
viewConfig: {
......
......@@ -114,7 +114,7 @@ itasks.WorkTabPanel = Ext.extend(Ext.Panel, {
return "<div class=\"worktab-header-table\"><table>"
+ "<tr><th>Subject:</th><td>" + this.taskinfo.subject + "</td><th>Date:</th><td>" + itasks.util.formatDate(this.taskinfo.timestamp) + "</td></tr>"
+ "<tr><th>TaskID:</th><td>" + this.taskinfo.taskid + "</td><th>Process:</th><td>" + this.taskinfo.processname + "</td></tr>"
+ "<tr><th>From:</th><td>" + this.taskinfo.delegator + "</td><th>Priority:</th><td>" + itasks.util.formatPriority(this.taskinfo.priority) + "</td></tr>"
+ "<tr><th>From:</th><td>" + this.taskinfo.delegatorName + "</td><th>Priority:</th><td>" + itasks.util.formatPriority(this.taskinfo.priority) + "</td></tr>"
+ "</table></div><div class=\"worktab-header-indicator\"></div>";
},
makeFinishedMessage: function() {
......
......@@ -18,10 +18,13 @@ from StdFile import class FileSystem
}
// Definitions on HSt
instance FileSystem HSt // enabling file IO on HSt
instance FileSystem HSt // enabling file IO on HSt
appWorldHSt :: !.(*World -> *World) !*HSt -> *HSt // enabling World operations on HSt
accWorldHSt :: !.(*World -> *(.a,*World)) !*HSt -> (.a,!*HSt) // enabling World operations on HSt
appNWorldHSt :: !.(*NWorld -> *NWorld) !*HSt -> *HSt // enabling NWorld operations on HSt
accNWorldHSt :: !.(*NWorld -> *(.a,*NWorld)) !*HSt -> (.a,!*HSt) // enabling NWorld operations on HSt
appWorldHSt :: !.(*World -> *World) !*HSt -> *HSt // enabling World operations on HSt
accWorldHSt :: !.(*World -> *(.a,*World)) !*HSt -> (.a,!*HSt) // enabling World operations on HSt
// Create a new HSt
mkHSt :: String HTTPRequest *FormStates *NWorld -> *HSt
......
implementation module HSt
import StdInt, StdFile
import StdInt, StdFile, StdFunc
import Http
import NWorld
import iDataState
......@@ -24,15 +24,23 @@ instance FileSystem HSt where
# (bool,file,world) = sfopen string int world
= (bool,file,{hst & world = world})
//Access to the NWorld state embedded in the HSt
appNWorldHSt :: !.(*NWorld -> *NWorld) !*HSt -> *HSt
appNWorldHSt f hst=:{world}
= {hst & world = f world}
accNWorldHSt :: !.(*NWorld -> *(.a,*NWorld)) !*HSt -> (.a,!*HSt)
accNWorldHSt f hst=:{world}
# (a, world) = f world
= (a, {hst & world = world})
// General access to the World environment on HSt:
appWorldHSt :: !.(*World -> *World) !*HSt -> *HSt
appWorldHSt f hst=:{world}
= {hst & world=appWorldNWorld f world}
appWorldHSt f hst = (appNWorldHSt o appWorldNWorld) f hst
accWorldHSt :: !.(*World -> *(.a,*World)) !*HSt -> (.a,!*HSt)
accWorldHSt f hst=:{world}
# (a,world) = accWorldNWorld f world
= (a,{hst & world=world})
accWorldHSt f hst = (accNWorldHSt o accWorldNWorld) f hst
// Create a new HSt
mkHSt :: String HTTPRequest *FormStates *NWorld -> *HSt
......
......@@ -7,16 +7,20 @@ from StdFile import class FileSystem
from Gerda import :: Gerda
from DataFile import :: DataFile
from UserDB import :: UserDB
:: *NWorld = { worldC :: *World // world for any io
, gerda :: *Gerda // to read and write to a relational database
, datafile :: *DataFile // to read and write to a Clean database in a file
, userdb :: *UserDB // to retrieve identity information
}
instance FileSystem NWorld
mkNWorld :: *World *DataFile *Gerda -> *NWorld
mkNWorld :: *World *DataFile *Gerda *UserDB -> *NWorld
appWorldNWorld :: !.(*World -> *World) !*NWorld -> *NWorld
accWorldNWorld :: !.(*World -> *(.a,*World)) !*NWorld -> (.a,!*NWorld)
\ No newline at end of file
appWorldNWorld :: !.(*World -> *World) !*NWorld -> *NWorld
accWorldNWorld :: !.(*World -> *(.a,*World)) !*NWorld -> (.a,!*NWorld)
appUserDBNWorld :: !.(*UserDB -> *UserDB) !*NWorld -> *NWorld
accUserDBNWorld :: !.(*UserDB -> *(.a,*UserDB)) !*NWorld -> (.a,!*NWorld)
\ No newline at end of file
......@@ -3,6 +3,7 @@ implementation module NWorld
import StdFile
from Gerda import :: Gerda
from DataFile import :: DataFile
from UserDB import :: UserDB
instance FileSystem NWorld where
fopen string int nworld=:{worldC}
......@@ -21,8 +22,8 @@ instance FileSystem NWorld where
# (bool,file,worldC) = sfopen string int worldC
= (bool,file,{nworld & worldC = worldC})
mkNWorld :: *World *DataFile *Gerda -> *NWorld
mkNWorld world datafile gerda = {worldC = world, gerda = gerda, datafile = datafile}
mkNWorld :: *World *DataFile *Gerda *UserDB -> *NWorld
mkNWorld world datafile gerda userdb = {worldC = world, gerda = gerda, datafile = datafile, userdb = userdb}
appWorldNWorld :: !.(*World -> *World) !*NWorld -> *NWorld
......@@ -33,3 +34,13 @@ accWorldNWorld :: !.(*World -> *(.a,*World)) !*NWorld -> (.a,!*NWorld)
accWorldNWorld f nw=:{worldC}
# (a,worldC) = f worldC
= (a,{nw & worldC=worldC})
appUserDBNWorld :: !.(*UserDB -> *UserDB) !*NWorld -> *NWorld
appUserDBNWorld f nw=:{userdb}
= {nw & userdb = f userdb}
accUserDBNWorld :: !.(*UserDB -> *(.a,*UserDB)) !*NWorld -> (.a,!*NWorld)
accUserDBNWorld f nw=:{userdb}
# (a,userdb) = f userdb
= (a,{nw & userdb = userdb})
\ No newline at end of file
......@@ -490,6 +490,7 @@ where
dummy = { worldC = abort "dummy world for toHtml!\n"
, gerda = abort "dummy gerda for toHtml!\n"
, datafile = abort "dummy datafile for toHtml!\n"
, userdb = abort "dummy userdb for toHtml!\n"
}
toHtmlForm :: !(*HSt -> *(Form a,*HSt)) -> [HtmlTag] | gForm{|*|}, gUpd{|*|}, gPrint{|*|}, gParse{|*|}, TC a
......@@ -500,6 +501,7 @@ where
dummy = { worldC = abort "dummy world for toHtmlForm!\n"
, gerda = abort "dummy gerda for toHtmlForm!\n"
, datafile = abort "dummy datafile for toHtmlForm!\n"
, userdb = abort "dummy userdb for toHtmlForm!\n"
}
createDefault :: a | gUpd{|*|} a
......
......@@ -40,7 +40,7 @@ definePurchase =
selectSuppliers :: Task [(Int,String)]
selectSuppliers
= getUsersWithRole "supplier" =>> \suppliers ->
= getUsersWithRoleTask "supplier" =>> \suppliers ->
( mchoiceAndTasks
[Text "Select the suppliers from which you want to receive a bid", HrTag []]
[(label, return_V supplier) \\ supplier =: (uid, label) <- suppliers]
......@@ -81,8 +81,4 @@ confirmBid purchase bid =: ((uid,label),price)
[Text "Your bid of ", Text (toString price),Text " for the product ",ITag [] [Text purchase], Text " has been accepted."]
?>> editTask "Ok" Void
)
//Hardcoded users
getUsersWithRole :: String -> Task [(Int,String)]
getUsersWithRole role =
return_V [(UID_SUPPLIER1,"Mega Store"),(UID_SUPPLIER2,"Local shop"),(UID_SUPPLIER3,"Webshop.com")]
\ No newline at end of file
definition module UserTasks
/**
* This modules provides tasks to retrieve information about other the users
* of the iTask system. These tasks are useful when work is to be delegated to
* other users.
*/
from TSt import :: Task
/**
* Looks up the corresponding display names for a list of user ids
*/
getDisplayNamesTask :: ![Int] -> Task [String]
/**
* Looks up the corresponding user names for a list of user ids
*/
getUserNamesTask :: ![Int] -> Task [String]
/**
* Looks up the corresponding roles for a list of user ids
*/
getRolesTask :: ![Int] -> Task [[String]]
/**
* Finds all users (user id + display name) who have the given role
*/
getUsersWithRoleTask :: !String -> Task [(Int,String)]
\ No newline at end of file
implementation module UserTasks
//accNWorldHSt (accUserDBNWorld (authenticateUser username password)) hst
import TSt
import UserDB
import LiftingCombinators
import StdEnv
import StdBimap
derive gForm []
derive gUpd []
getDisplayNamesTask :: ![Int] -> Task [String]
getDisplayNamesTask uids
= appHStOnce "getDisplayNamesTask" (accNWorldHSt (accUserDBNWorld (getDisplayNames uids)))
getUserNamesTask :: ![Int] -> Task [String]
getUserNamesTask uids
= appHStOnce "getUserNamesTask" (accNWorldHSt (accUserDBNWorld (getUserNames uids)))
getRolesTask :: ![Int] -> Task [[String]]
getRolesTask uids
= appHStOnce "getRolesTask" (accNWorldHSt (accUserDBNWorld (getRoles uids)))
getUsersWithRoleTask :: !String -> Task [(Int,String)]
getUsersWithRoleTask role
= appHStOnce "getUsersWithRoleTask" (accNWorldHSt (accUserDBNWorld (getUsersWithRole role)))
\ No newline at end of file
......@@ -2,44 +2,23 @@ implementation module AuthenticationHandler
import Http
import HSt
import Session
import Session, UserDB
import StdEnv
import StdMaybe
handleAuthenticationRequest :: !HTTPRequest *HSt -> (!HTTPResponse, !*HSt)
handleAuthenticationRequest req hst
= case getUserInfo (get "username" req.arg_post) (get "password" req.arg_post) of
Just (uid, roles, displayName)
# (mbCredentials, hst) = accNWorldHSt (accUserDBNWorld (authenticateUser username password)) hst
= case mbCredentials of
Just (uid,displayName,roles)
# (session, hst) = createSession uid roles hst
# hst = storeStates hst
= ({http_emptyResponse & rsp_data = encodeSuccess session.sessionId displayName},hst)
Nothing
= ({http_emptyResponse & rsp_data = encodeFailure},hst)
where
get key [] = Nothing
get key [(x1,x2):xs]
| key == x1 = Just x2
= get key xs
username = http_getValue "username" req.arg_post ""
password = http_getValue "password" req.arg_post ""
encodeFailure = "{\"success\": false, \"error\": \"Incorrect username or password\"}"
encodeSuccess sid displayName = "{\"success\": true, \"displayName\": \"" +++ displayName +++ "\", sessionId: \"" +++ sid +++ "\"}"
//Hardcoded users
getUserInfo (Just username) (Just password) = getUserInfo` username password
getUserInfo _ _ = Nothing
getUserInfo` "root" _ = Just (0, ["president","manager","worker"], "Root")
getUserInfo` "president" _ = Just (1, ["president"], "Organization President")
getUserInfo` "manager" _ = Just (2, ["manager"], "Middle Manager")
getUserInfo` "worker1" _ = Just (3, ["worker"], "Office Worker 1")
getUserInfo` "worker2" _ = Just (4, ["worker"], "Office Worker 2")
//Additional hardcoded users for the webshop example
getUserInfo` "customer" _ = Just (10, [], "Webshop customer")
getUserInfo` "bank" _ = Just (11, [], "Bank authorization")
getUserInfo` "storage" _ = Just (12, [], "Webshop storage")
getUserInfo` "creditcard" _ = Just (13, [], "Credit Card authorization")
getUserInfo` _ _ = Nothing
\ No newline at end of file
encodeSuccess sid displayName = "{\"success\": true, \"displayName\": \"" +++ displayName +++ "\", sessionId: \"" +++ sid +++ "\"}"
\ No newline at end of file
implementation module WorkListHandler
import StdEnv
import Http, Session
import Http, Session, UserDB
import Text
import JSON
import Time
......@@ -14,7 +14,8 @@ import TaskTree, TaskTreeFilters, InternaliTasksCommon
}
:: WorkListItem = { taskid :: String // Task id of the work item
, delegator :: String // Id of the user who issued the work
, delegatorId :: Int // Id of the user who issued the work
, delegatorName :: String // Display name of the user who issued the work
, processname :: String // Name given to the work process the task belongs to
, subject :: String // Name give to the task, which can be a short description of the work to do
, priority :: TaskPriority // Priority of the task
......@@ -23,8 +24,9 @@ import TaskTree, TaskTreeFilters, InternaliTasksCommon
, tree_last :: Bool // Is this item the last of a set of siblings
, tree_icon :: String // An icon name. The actual icon image is defined in the css.
// Current possible values: editTask, orTask, andTask, conditionTask, timeTask, systemTask, finishedTask
} // And also: andTaskMU, maybeTask
}
// And also: andTaskMU, maybeTask
derive JSONEncode WorkList, WorkListItem, TaskPriority
handleWorkListRequest :: !(LabeledTask a) !Int !HTTPRequest !Session *HSt -> (!HTTPResponse, !*HSt) | iData a
......@@ -33,10 +35,11 @@ handleWorkListRequest mainTask mainUser request session hst
# (toServer, htmlTree, maybeError, maybeProcessTable, maybeThreadTable,hst)
= calculateTaskTree uid False False False mainTask mainUser hst // Calculate the TaskTree given the id of the current user
# workitems = determineWorkItems uid htmlTree
# worklist = { success = True
, total = length workitems
, worklist = workitems
}
# (workitems,hst) = addDelegatorNames workitems hst
# worklist = { success = True
, total = length workitems
, worklist = workitems
}
= ({http_emptyResponse & rsp_data = toJSON worklist}, hst)
......@@ -47,8 +50,10 @@ where
determineWorkItems` uid path pdesc (desc @@: tree)
# rest = determineWorkItems` uid path desc tree
| desc.taskWorkerId == uid
# newitem = { taskid = desc.taskNrId
, delegator = toString desc.delegatorId
# newitem = { WorkListItem
| taskid = desc.taskNrId
, delegatorId = desc.TaskDescription.delegatorId
, delegatorName = ""
, processname = desc.workflowLabel
, subject = desc.taskLabel
, priority = desc.taskPriority
......@@ -63,7 +68,7 @@ where
[x:xs]
| x.taskid == desc.taskNrId //'Merge' direct subnode when taskid is the same (e.g. a directly nested CondAnd node)
= [ { x
& delegator = toString desc.delegatorId
& delegatorId = desc.TaskDescription.delegatorId
, processname = desc.workflowLabel
, subject = desc.taskLabel
, priority = desc.taskPriority
......@@ -79,7 +84,8 @@ where
# subpath = path ++ [False]
# rest = markLast (flatten [[mkCondItem pdesc desc subpath: determineWorkItems` uid subpath pdesc tree] \\ (desc,tree) <- trees])
= [ { taskid = pdesc.taskNrId
, delegator = toString pdesc.delegatorId
, delegatorId = pdesc.TaskDescription.delegatorId
, delegatorName = ""
, processname = pdesc.workflowLabel
, subject = pdesc.workflowLabel
, priority = pdesc.taskPriority
......@@ -117,7 +123,8 @@ where
mkCondItem :: TaskDescription CondAndDescription [Bool] -> WorkListItem
mkCondItem pdesc cdesc path
= { taskid = cdesc.caTaskNrId
, delegator = toString pdesc.delegatorId
, delegatorId = pdesc.TaskDescription.delegatorId
, delegatorName = ""
, processname = pdesc.workflowLabel
, subject = cdesc.caTaskLabel
, priority = pdesc.taskPriority
......@@ -138,4 +145,9 @@ where
, timeCreated = Time 0
, taskPriority = LowPriority
, curStatus = True
}
\ No newline at end of file
}
addDelegatorNames :: [WorkListItem] *HSt -> ([WorkListItem], *HSt)
addDelegatorNames items hst
# (names, hst) = accNWorldHSt (accUserDBNWorld (getDisplayNames [i.WorkListItem.delegatorId \\ i <- items])) hst
= ([{i & delegatorName = name} \\ i <- items & name <- names], hst)
\ No newline at end of file
......@@ -9,6 +9,7 @@ implementation module Startup
//
import StdEnv
import iDataSettings, iDataForms, iDataWidgets, iDataFormlib, iDataTrivial
import UserDB
import iTasksSettings, InternaliTasksCommon, InternaliTasksThreadHandling
import BasicCombinators, iTasksProcessHandling
......@@ -121,7 +122,8 @@ initHSt :: !HTTPRequest !*World -> *HSt
initHSt request world
# (gerda,world) = openDatabase ODCBDataBaseName world // open the relational database if option chosen
# (datafile,world) = openmDataFile DataFileName world // open the datafile if option chosen
# nworld = mkNWorld world datafile gerda // Wrap all io states in an NWorld state
# (userdb,world) = openUserDB world // open the user database
# nworld = mkNWorld world datafile gerda userdb // Wrap all io states in an NWorld state
# updates = decodeFormUpdates request.arg_post // Get the form updates from the post
# states = decodeHtmlStates request.arg_post // Fetch stored states from the post
# fstates = mkFormStates states updates
......
definition module UserDB
import StdMaybe
:: UserDB
openUserDB :: !*World -> (!*UserDB , !*World)
getDisplayNames :: ![Int] !*UserDB -> (![String] , !*UserDB)
getUserNames :: ![Int] !*UserDB -> (![String] , !*UserDB)
getRoles :: ![Int] !*UserDB -> (![[String]] , !*UserDB)
getUsersWithRole :: !String !*UserDB -> (![(Int,String)] , !*UserDB)
authenticateUser :: !String !String !*UserDB -> (!Maybe (Int,String,[String]) , !*UserDB)
\ No newline at end of file
implementation module UserDB
import StdEnv
import StdMaybe
:: User = { uid :: Int
, username :: String
, password :: String
, displayname :: String
, roles :: [String]
}
:: UserDB = { cache :: [User] //Cache must be ordered on ascending uids
}
//Dummy database with users used in some examples
dummyCache = [ {User | uid = 0, username = "root", displayname = "Root", password = "", roles = ["president","manager","worker"]}
, {User | uid = 1, username = "president", displayname = "President", password = "", roles = ["president"]}
, {User | uid = 2, username = "manager", displayname = "Middle manager", password = "", roles = ["manager"]}
, {User | uid = 3, username = "worker1", displayname = "Office worker 1", password = "", roles = ["worker"]}
, {User | uid = 10, username = "customer", displayname = "Customer", password = "", roles = ["customer"]}
, {User | uid = 11, username = "bank", displayname = "Bank authorization", password = "", roles = ["bank"]}
, {User | uid = 12, username = "storage", displayname = "Webshop storage", password = "", roles = ["storage"]}
, {User | uid = 13, username = "creditcard", displayname = "Creditcard authorization", password = "", roles = ["creditcard"]}
, {User | uid = 20, username = "megastore", displayname = "Megastore", password = "", roles = ["supplier"]}
, {User | uid = 21, username = "localshop", displayname = "Local shop", password = "", roles = ["supplier"]}
, {User | uid = 22, username = "webshop", displayname = "Webshop.com", password = "", roles = ["supplier"]}
]
openUserDB :: !*World -> (!*UserDB, !*World)
openUserDB world = ({UserDB | cache = dummyCache }, world)
getDisplayNames :: ![Int] !*UserDB -> (![String], !*UserDB)
getDisplayNames uids db=:{cache}
= (map (lookupUserProperty cache (\u -> u.displayname) "Unknown user") uids, {db & cache = cache})
getUserNames :: ![Int] !*UserDB -> (![String], !*UserDB)
getUserNames uids db=:{cache}
= (map (lookupUserProperty cache (\u -> u.username) "") uids, {db & cache = cache})
getRoles :: ![Int] !*UserDB -> (![[String]], !*UserDB)
getRoles uids db=:{cache}
= (map (lookupUserProperty cache (\u -> u.roles) []) uids, {db & cache = cache})
//Helper function which finds a property of a certain user
lookupUserProperty :: ![User] !(User -> a) !a !Int -> a
lookupUserProperty users selectFunction defaultValue userId
= case [selectFunction user \\ user <- users | user.uid == userId] of
[x] = x
_ = defaultValue
getUsersWithRole :: !String !*UserDB -> (![(Int,String)], !*UserDB)
getUsersWithRole role db=:{cache}
= ([(user.uid,user.displayname) \\ user <- cache | isMember role user.roles], {db & cache = cache})
authenticateUser :: !String !String !*UserDB -> (!Maybe (Int,String,[String]), !*UserDB)
authenticateUser username password db =:{cache}
= case [u \\ u <- cache | u.username == username && u.password == password] of
[user] = (Just (user.uid, user.displayname, user.roles), {db & cache = cache})
_ = (Nothing, {db & cache = cache})
......@@ -14,13 +14,15 @@ import
, iTasksProcessHandling // creation of iTask Workflow Processes
, iTasksEditors // basic html editors for any type
, UserTasks // tasks for accessing the user database
, BasicCombinators // basic iTask combinators
, Combinators // handy set of additional iTask combinators
, PromptingCombinators // html prompting
, LiftingCombinators // lifting other domains (e.g. iData) to the iTask domain
, iTasksTimeAndDateHandling // iTasks triggered by time and date
, iTasksExceptionHandling // for handling exceptional situations
......
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