Commit 02e9f6e7 authored by Bas Lijnse's avatar Bas Lijnse

Completely migrated user database to library in the task domain.

git-svn-id: https://svn.cs.ru.nl/repos/iTask-system/trunk@1881 63da3aa8-80fd-4f01-9db8-e6ea747a3da2
parent 3d1e4c4c
......@@ -69,6 +69,7 @@ where
//, rpcExamples
//, ginExamples
, apiDocumentationExamples
, [restrictedWorkflow "Admin/Users" "Manage users" ["admin"] manageUsers]
]
workflowmw = [workflow "Manage workflows" "Manage other workflows and instances" (manageWorkflows workflows)]
implementation module CoreCombinators
import StdList, StdTuple, StdMisc, StdBool, StdOrdList
import Task, TaskContext, TaskStore, Util, HTTP, GenUpdate, UserDB, Store, SystemTypes, Time, Text, Shared, Func
import Task, TaskContext, TaskStore, Util, HTTP, GenUpdate, Store, SystemTypes, Time, Text, Shared, Func
import iTaskClass, InteractionTasks
from Map import qualified get, put, del
from StdFunc import id, const, o, seq
......
......@@ -8,7 +8,6 @@ import SystemTypes, IWorld, Task, TaskContext, Config
import ExceptionCombinators, TuningCombinators
import InteractionTasks
import Shared
import UserDB
from Util import currentTimestampError
from CoreCombinators import >>=, >>|
......
......@@ -4,9 +4,10 @@ definition module SystemData
* a set of shared data structures.
*/
import Maybe
from SharedCombinators import :: ReadOnlyShared, :: Shared, :: ReadWriteShared
from SharedCombinators import :: ReadWriteShared, :: ReadOnlyShared, :: Shared
from SystemTypes import :: DateTime, :: Date, :: Time, :: User, :: Role, :: UserDetails, :: TaskList, :: Tree, :: ProcessId, :: TaskInstanceMeta
from Void import :: Void
from Config import :: Config
// Date & time
currentDateTime :: ReadOnlyShared DateTime
......@@ -26,6 +27,9 @@ currentUser :: ReadOnlyShared User
// Application name
applicationName :: ReadOnlyShared String
// Server config
applicationConfig :: ReadOnlyShared Config
// Random source
randomInt :: ReadOnlyShared Int
......
......@@ -6,9 +6,9 @@ import StdList
from StdFunc import o, seq
from IWorld import :: IWorld(..), :: Control
from Util import qualified currentDate, currentTime, currentDateTime, currentTimestamp
from UserDB import qualified class UserDB(..), instance UserDB IWorld
from WorkflowDB import qualified class WorkflowDB(..), instance WorkflowDB IWorld
from WorkflowDB import :: WorkflowDescription
from Config import :: Config
currentDateTime :: ReadOnlyShared DateTime
currentDateTime = makeReadOnlyShared "SystemData_currentDateTime" 'Util'.currentDateTime 'Util'.currentTimestamp
......@@ -58,6 +58,12 @@ applicationName = makeReadOnlyShared "SystemData_applicationName" appName (\iwor
where
appName iworld=:{IWorld|application} = (application,iworld)
applicationConfig :: ReadOnlyShared Config
applicationConfig = makeReadOnlyShared "SystemData_config" config (\iworld -> (Timestamp 0, iworld))
where
config iworld=:{IWorld|config} = (config,iworld)
// Random source
randomInt :: ReadOnlyShared Int
randomInt = makeReadOnlyShared "SystemData_randomInt" randomInt 'Util'.currentTimestamp
......
......@@ -9,7 +9,6 @@ from Map import :: Map
from Map import qualified get
from HTML import class html
from Time import :: Timestamp
from Config import :: Config
from IWorld import :: IWorld
from TUIDefinition import :: TUISize, :: TUIMargins, :: TUIMinSize
from Task import :: Task
......@@ -33,7 +32,7 @@ derive gUpdate ProcessId, TaskInstanceMeta, ProgressMeta, TaskMeta, TaskStatus
derive gDefaultMask ProcessId, TaskInstanceMeta, ProgressMeta, TaskMeta, TaskStatus
derive gVerify ProcessId, TaskInstanceMeta, ProgressMeta, TaskMeta, TaskStatus
derive class iTask Credentials
derive class iTask Credentials, Config
instance toString Note
......@@ -365,6 +364,23 @@ noMeta :: ManagementMeta
:: Role :== String
//Configuration
:: Config =
{ clientPath :: !String // Where is the client located.
, staticPath :: !String // Additional location where statically served content may be placed
, rootPassword :: !String // Password for the 'root' superuser (default 'root').
, rootEmail :: !String // E-mail address for the 'root' superuser (default root@localhost).
, sessionTime :: !Int // Time (in seconds) before inactive sessions are garbage collected. Default is 3600 (one hour).
, serverPort :: !Int // The TCP port the server runs on. Default is 80.
, serverPath :: !String // The path at which the services are served (default /services)
, debug :: !Bool // Run the server in debug mode (default False).
, smtpServer :: !String // The smtp server to use for sending e-mails
, generalWorkflows :: !Bool // Enable the "general" workflows for managing ad-hoc work
, runAsyncPath :: !String // Path to RunAsync tool for running asynchronous OS tasks and timers.
, curlPath :: !String // Path to Curl needed for RPC tasks.
}
/*
* Gives the unique username of a user
*
......
......@@ -27,7 +27,7 @@ derive gUpdate ProcessId, TaskInstanceMeta, ProgressMeta, TaskMeta, TaskStatus
derive gDefaultMask ProcessId, TaskInstanceMeta, ProgressMeta, TaskMeta, TaskStatus, InteractionTaskType, OutputTaskType
derive gVerify ProcessId, TaskInstanceMeta, ProgressMeta, TaskMeta, TaskStatus, InteractionTaskType, OutputTaskType
derive class iTask Credentials
derive class iTask Credentials, Config
JSONEncode{|Timestamp|} (Timestamp t) = [JSONInt t]
......
......@@ -11,7 +11,7 @@ users :: ReadOnlyShared [User]
//* Users with a specific role
usersWithRole :: !Role -> ReadOnlyShared [User]
//* User details (name,credentials etc)
userDetails :: !User -> Shared UserDetails
userDetails :: !User -> Shared (Maybe UserDetails)
//* Details of the current user
currentUserDetails :: ReadOnlyShared (Maybe UserDetails)
......
implementation module UserAdmin
import iTasks, Text, Time, Tuple, IWorld
import iTasks, Text
from UserDB import qualified class UserDB(..)
from UserDB import qualified instance UserDB IWorld
from Shared import makeReadOnlyShared, :: SharedId, :: ReadWriteShared(..), :: SharedRead, :: SharedWrite, :: SharedGetTimestamp
from Util import mb2error
userStore :: Shared [UserDetails]
userStore = sharedStore "Users" []
users :: ReadOnlyShared [User]
users = makeReadOnlyShared "SystemData_users" 'UserDB'.getUsers 'UserDB'.lastChange
users = mapShared (\users -> map RegisteredUser users, \Void users -> users) userStore
usersWithRole :: !Role -> ReadOnlyShared [User]
usersWithRole role = makeReadOnlyShared ("SystemData_usersWithRole-" +++ toString role) ('UserDB'.getUsersWithRole role) 'UserDB'.lastChange
userDetails :: !User -> Shared UserDetails
userDetails user = ReadWriteShared ["userDetails-" +++ toString user] read write (appFst Ok o 'UserDB'.lastChange)
usersWithRole :: !Role -> ReadOnlyShared [User]
usersWithRole role = mapSharedRead (filter (hasRole role)) users
where
read iworld = appFst (mb2error "user not in database") ('UserDB'.getUserDetails user iworld)
write details iworld
# (_,iworld) = 'UserDB'.updateUser user details iworld
= (Ok Void,iworld)
hasRole role (RegisteredUser details) = maybe False (isMember role) details.UserDetails.roles
hasRole _ _ = False
userDetails :: !User -> Shared (Maybe UserDetails)
userDetails user = mapShared (getDetails user,setDetails) userStore
currentUserDetails :: ReadOnlyShared (Maybe UserDetails)
currentUserDetails = makeReadOnlyShared "SystemData_currentUserDetails" (\iworld=:{currentUser} -> 'UserDB'.getUserDetails currentUser iworld) (\iworld -> (Timestamp 0, iworld))
currentUserDetails = mapSharedRead (\(user,users) -> getDetails user users ) (currentUser |+| userStore)
getDetails :: User [UserDetails] -> Maybe UserDetails
getDetails user users
= case [u \\ u <- users | (RegisteredUser u) == user] of
[details] = Just details
_ = Nothing
setDetails :: (Maybe UserDetails) [UserDetails] -> [UserDetails]
setDetails Nothing users = users
setDetails (Just details) users = map (upd details) users
where
upd n o = if (o.UserDetails.username == n.UserDetails.username) n o
authenticateUser :: !String !String -> Task (Maybe User)
authenticateUser username password = mkInstantTask ("Authenticate user", "Verify if there is a user with the supplied credentials.") eval
where
eval taskNr iworld
# (mbUser,iworld) = 'UserDB'.authenticateUser username password iworld
= (TaskFinished mbUser,iworld)
authenticateUser username password
| username == "root"
= get applicationConfig
>>= \config ->
return (if (config.rootPassword == password) (Just RootUser) Nothing)
| otherwise
= get (userDetails (NamedUser username))
>>= \mbDetails -> case mbDetails of
Just details
= return (if (details.UserDetails.password == Password password) (Just (RegisteredUser details)) Nothing)
Nothing
= return Nothing
createUser :: !UserDetails -> Task User
createUser user = mkInstantTask ("Create user", "Create a new user in the database.") eval
createUser details
= get (userDetails user)
>>= \mbExisting -> case mbExisting of
Nothing
= update (\users -> users ++ [details]) userStore >>| return user
_
= throw ("A user with username '" +++ toString details.UserDetails.username +++ "' already exists.")
where
eval taskNr iworld
# (user,iworld) = 'UserDB'.createUser user iworld
= case user of
(Ok user) = (TaskFinished user,iworld)
(Error e) = (taskException e, iworld)
user = RegisteredUser details
deleteUser :: !User -> Task User
deleteUser user = mkInstantTask ("Delete user", "Delete a user from the database.") eval
deleteUser user = update (filter (exclude user)) userStore >>| return user
where
eval taskNr iworld
# (user,iworld) = 'UserDB'.deleteUser user iworld
= (TaskFinished user,iworld)
exclude user d = user == (RegisteredUser d)
manageUsers :: Task Void
manageUsers =
( enterSharedChoice ("Users","The following users are available") [] users
>?* [ (Action "New", Always (createUserFlow >>| return False))
>?* [ (Action "New", Always (createUserFlow >>| return False))
, (ActionEdit, IfValid (\u -> updateUserFlow u >>| return False))
, (ActionDelete, IfValid (\u -> deleteUserFlow u >>| return False))
, (Action "Import & export/Import CSV file...", Always (importUserFileFlow >>| return False))
......@@ -72,18 +87,21 @@ createUserFlow =
]
updateUserFlow :: User -> Task User
updateUserFlow user =
get sharedDetails
>>= \oldDetails -> updateInformation ("Editing " +++ displayName user,"Please make your changes") [] oldDetails
>?* [ (ActionCancel, Always (return user))
, (ActionOk, IfValid (\newDetails ->
set newDetails sharedDetails
>>= viewInformation "User updated" [DisplayView (GetLocal (\{displayName} -> "Successfully updated " +++ displayName))]
>>| return user
))
]
where
sharedDetails = userDetails user
updateUserFlow user
= get (userDetails user)
>>= \mbOldDetails -> case mbOldDetails of
(Just oldDetails)
= (updateInformation ("Editing " +++ displayName user,"Please make your changes") [] oldDetails
>?* [ (ActionCancel, Always (return user))
, (ActionOk, IfValid (\newDetails ->
set (Just newDetails) (userDetails user)
>>= viewInformation "User updated" [DisplayView (GetLocal (\(Just {displayName}) -> "Successfully updated " +++ displayName))]
>>| return user
))
])
Nothing
= (throw "Could not find user details")
deleteUserFlow :: User -> Task User
deleteUserFlow user =
......
......@@ -4,21 +4,7 @@ definition module Config
* An initial default configuration is written when no config file is found.
*/
from Maybe import ::Maybe
:: Config =
{ clientPath :: !String // Where is the client located.
, staticPath :: !String // Additional location where statically served content may be placed
, rootPassword :: !String // Password for the 'root' superuser (default 'root').
, rootEmail :: !String // E-mail address for the 'root' superuser (default root@localhost).
, sessionTime :: !Int // Time (in seconds) before inactive sessions are garbage collected. Default is 3600 (one hour).
, serverPort :: !Int // The TCP port the server runs on. Default is 80.
, serverPath :: !String // The path at which the services are served (default /services)
, debug :: !Bool // Run the server in debug mode (default False).
, smtpServer :: !String // The smtp server to use for sending e-mails
, generalWorkflows :: !Bool // Enable the "general" workflows for managing ad-hoc work
, runAsyncPath :: !String // Path to RunAsync tool for running asynchronous OS tasks and timers.
, curlPath :: !String // Path to Curl needed for RPC tasks.
}
from SystemTypes import :: Config
/**
* Returns the default configuration
......
implementation module Config
import StdFile, Util, Error, File, FilePath, JSON, OS
import SystemTypes
derive JSONEncode Config
derive JSONDecode Config
derive bimap Maybe, (,)
defaultConfig :: Config
......
definition module UserDB
/**
* This module provides the iTasks user database. It provides
* functions for accessing information about system users.
*/
from Maybe import :: Maybe
from SystemTypes import :: User, :: UserDetails, :: IWorld
from Time import :: Timestamp
from Error import :: MaybeErrorString, :: MaybeError
class UserDB st
where
/**
* Fetches the id and display name from the user database for a given user id.
*
* @param A user id
* @param A unique user database handle
* @return The user if found
* @return The database handle
*/
getUser :: !String !*st -> (!Maybe User , !*st)
/**
* Looks up the details of any user in the database.
*
* @param A user
* @param A unique user database handle
* @return The user-details, if found
* @return The database handle
*/
getUserDetails :: !User !*st -> (!Maybe UserDetails ,!*st)
/**
* Fetches the id and details of all users from the from the user database.
*
* @param A unique user database handle
* @return The list of users
* @return The database handle
*/
getUsers :: !*st -> (![User] , !*st)
/**
* Finds a list of users that have a certain role.
*
* @param The role to look for
* @param A unique user database handle
* @return A list of users
* @return The database handle
*/
getUsersWithRole :: !String !*st -> (![User] , !*st)
/**
* Authenticate a user based on a user name or password
*
* @param A user name
* @param A password
* @param A unique database handle
* @return When successful, A triple of user id/ display name/ list of roles.
* @return The database handle
*/
authenticateUser :: !String !String !*st -> (!Maybe User, !*st)
/**
* Create a new user
*
* @param A new user
* @param A unique database handle
*
* @return A user
* @return The database handle
*/
createUser :: !UserDetails !*st -> (!MaybeErrorString User,!*st)
/**
* Update an existing user
*
* @param An existing user
* @param The new user details to store
* @param A unique database handle
*
* @return The existing user
* @retrun The database handle
*/
updateUser :: !User !UserDetails !*st -> (!User,!*st)
/**
* Delete an existing user
*
* @param An existing user
* @param A unique database handle
*
* @return The existing user
* @retrun The database handle
*/
deleteUser :: !User !*st -> (!User,!*st)
/**
* Gets the timestamp of the last change of the user database.
*
* @param A unique database handle
*
* @return The timestamp
* @retrun The database handle
*/
lastChange :: !*st -> (!Timestamp,!*st)
instance UserDB IWorld
implementation module UserDB
import StdEnv, Maybe
import StdGeneric
import Time, File, Error, Config, Util
import IWorld
from SystemTypes import :: Password(..)
derive bimap (,), Maybe
instance UserDB IWorld
where
getUser :: !String !*IWorld -> (!Maybe User,!*IWorld)
getUser "root" iworld
= (Just RootUser,iworld)
getUser userName iworld
# (details, iworld) = readUserStore iworld
= case filter (\d -> (==) (NamedUser userName) (RegisteredUser d)) details of
[x] = (Just (RegisteredUser x),iworld)
_ = (Nothing,iworld)
getUserDetails :: !User !*IWorld -> (!Maybe UserDetails,!*IWorld)
getUserDetails RootUser iworld=:{IWorld|config}
= (Just {UserDetails
|username = Username "root"
,password = Password config.rootPassword
,displayName = "Root User"
,emailAddress = EmailAddress config.rootEmail
,roles = Nothing},iworld)
getUserDetails (RegisteredUser details) iworld = (Just details,iworld)
getUserDetails (NamedUser username) iworld
# (details, iworld) = readUserStore iworld
= case filter (\d -> (==) (NamedUser username) (RegisteredUser d)) details of
[x] = (Just x,iworld)
_ = (Nothing,iworld)
getUserDetails _ iworld = (Nothing,iworld)
getUsers :: !*IWorld -> (![User], !*IWorld)
getUsers iworld
# (details, iworld) = readUserStore iworld
= (map (\d -> RegisteredUser d) details,iworld) //Do not include the "root" user"
getUsersWithRole :: !String !*IWorld -> (![User], !*IWorld)
getUsersWithRole role iworld
# (details, iworld) = readUserStore iworld
= ([(RegisteredUser d) \\ d <- details | isMember role (mb2list d.UserDetails.roles)], iworld)
authenticateUser :: !String !String !*IWorld -> (!Maybe User, !*IWorld)
authenticateUser username password iworld
| username == "root"
| password == iworld.config.rootPassword
= (Just RootUser, iworld)
| otherwise
= (Nothing, iworld)
| otherwise
# (details, iworld) = readUserStore iworld
= case [(RegisteredUser d) \\ d <- details | d.UserDetails.username == (Username username) && d.UserDetails.password == (Password password)] of
[user] = (Just user, iworld)
_ = (Nothing, iworld)
createUser :: !UserDetails !*IWorld -> (!MaybeErrorString User,!*IWorld)
createUser details iworld
# (store, iworld) = readUserStore iworld
| isMember (details.UserDetails.username) [u.UserDetails.username \\ u <- store]
= (Error ("A user with username '" +++ toString details.UserDetails.username +++ "' already exists."), iworld)
# (store, iworld) = userStore (\_-> store ++ [details]) iworld
= (Ok (RegisteredUser details),iworld)
updateUser :: !User !UserDetails !*IWorld -> (!User,!*IWorld)
updateUser match details iworld
# (store,iworld) = userStore (map (update match details)) iworld
= (RegisteredUser details,iworld)
where
update match details old = if (RegisteredUser old == match) details old
deleteUser :: !User !*IWorld -> (!User,!*IWorld)
deleteUser user iworld
# (store,iworld) = userStore delete iworld
= (user,iworld)
where
delete details = filter (\d -> (RegisteredUser d) <> user) details
lastChange :: !*IWorld -> (!Timestamp,!*IWorld)
lastChange iworld =:{IWorld|application,world}
# ((ts,_),world) = readUserFile application world
= (ts,{iworld & world = world})
//Helper function which finds a property of a certain user
lookupUserProperty :: ![User] !(User -> a) !a !String -> a
lookupUserProperty users selectFunction defaultValue userName
= case [selectFunction user \\ user=:(RegisteredUser d) <- users | toString d.UserDetails.username == userName] of
[x] = x
_ = defaultValue
userStore :: !([UserDetails] -> [UserDetails]) !*IWorld -> (![UserDetails],!*IWorld)
userStore fn iworld=:{IWorld|application,world,timestamp}
# ((_,users),world) = readUserFile application world
# users = fn users
# world = writeUserFile (timestamp,users) application world
= (users,{IWorld|iworld & world = world})
where
writeUserFile users appName world
# (_, world) = writeFile (appName +++ USER_FILE_POSTFIX) (toString (toJSON users)) world
= world
readUserStore :: !*IWorld -> (![UserDetails],!*IWorld)
readUserStore iworld=:{IWorld|application,world}
# ((Timestamp _,users),world) = readUserFile application world
= (users,{IWorld|iworld & world = world})
readUserFile :: !String !*World -> (!(!Timestamp,![UserDetails]),!*World)
readUserFile appName world
# (res,world) = readFile (appName +++ USER_FILE_POSTFIX) world
| isError res = ((Timestamp 0,[]),world)
= case (fromJSON (fromString (fromOk res))) of
Just users = (users,world)
Nothing = ((Timestamp 0,[]),world)
USER_FILE_POSTFIX :== "-users.json"
\ No newline at end of file
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