implementation module UserAdmin import iTasks, Text, Tuple userStore :: Shared [UserDetails] userStore = sharedStore "Users" [] users :: ReadOnlyShared [User] users = mapReadWrite (\users -> map RegisteredUser users, \Void users -> Just users) userStore usersWithRole :: !Role -> ReadOnlyShared [User] usersWithRole role = mapRead (filter (hasRole role)) users where hasRole role (RegisteredUser details) = maybe False (isMember role) details.UserDetails.roles hasRole _ _ = False userDetails :: !User -> Shared (Maybe UserDetails) userDetails user = mapReadWrite (getDetails user,\w r -> Just (setDetails w r)) userStore currentUserDetails :: ReadOnlyShared (Maybe UserDetails) currentUserDetails = mapRead (\(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 :: !Username !Password -> Task (Maybe User) authenticateUser (Username username) (Password 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 doAuthenticated :: (Task a) -> Task a | iTask a doAuthenticated task = doAuthenticateWith verify task where verify {Credentials|username,password} = authenticateUser username password doAuthenticateWith :: (Credentials -> Task (Maybe User)) (Task a) -> Task a | iTask a doAuthenticateWith verifyCredentials task = enterInformation ("Log in","Please enter your credentials") [] <<@ loginForm >>! verifyCredentials >>= \mbUser -> case mbUser of Nothing = throw "Authentication failed" Just user = workAs user task where //Layout tweak loginForm = AfterLayout (tweakTUI (setTopMargin 100 o appDeep [1,0,1,0] (fixedWidth 180) o appDeep [1,1,1,0] (fixedWidth 180) o wrapWidth)) createUser :: !UserDetails -> Task User 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 user = RegisteredUser details deleteUser :: !User -> Task User deleteUser user = update (filter (exclude user)) userStore >>| return user where exclude user d = user == (RegisteredUser d) manageUsers :: Task Void manageUsers = ( enterSharedChoice ("Users","The following users are available") [] users >>* [ AnyTime (Action "New") (\_ -> createUserFlow @ const False) , WithResult (ActionEdit) (const True) (\u -> updateUserFlow u @ const False) , WithResult (ActionDelete) (const True) (\u -> deleteUserFlow u @ const False) , AnyTime (Action "Import & export/Import CSV file...") (\_ -> importUserFileFlow @ const False) , AnyTime (Action "Import & export/Export CSV file...") (\_ -> exportUserFileFlow @ const False) , AnyTime (Action "Import & export/Import demo users") (\_ -> importDemoUsersFlow @ const False) , AnyTime (ActionQuit) (\_ -> return True) ] ) >| return Void createUserFlow :: Task Void createUserFlow = enterInformation ("Create user","Enter user information") [] >>* [ AnyTime ActionCancel (\_ -> return Void) , WithResult ActionOk (const True) (\user -> createUser user >>| viewInformation "User created" [] "Successfully added new user" >>| return Void ) ] updateUserFlow :: User -> Task User updateUserFlow user = get (userDetails user) >>= \mbOldDetails -> case mbOldDetails of (Just oldDetails) = (updateInformation ("Editing " +++ displayName user,"Please make your changes") [] oldDetails >>* [ AnyTime ActionCancel (\_ -> return user) , WithResult ActionOk (const True)(\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 = viewInformation "Delete user" [] ("Are you sure you want to delete " +++ displayName user +++ "? This cannot be undone.") >>* [ AnyTime ActionNo (\_ -> return user) , AnyTime ActionYes (\_ -> deleteUser user >>= viewInformation "User deleted" [DisplayView (GetLocal (\user -> "Successfully deleted " +++ displayName user +++ "."))] ) ] importUserFileFlow :: Task Void importUserFileFlow = viewInformation "Not implemented" [] Void exportUserFileFlow :: Task Document exportUserFileFlow = get users -&&- get applicationName >>= \(list,app) -> createCSVFile (app +++ "-users.csv") [toRow u \\ (RegisteredUser u) <- list] >>= viewInformation ("Export users file","A CSV file containing the users of this application has been created for you to download.") [] where toRow {username = (Username username), password = (Password password), displayName, emailAddress = (EmailAddress email), roles} = [displayName,username,password,email: fromMaybe [] roles] importDemoUsersFlow :: Task [User] importDemoUsersFlow = allTasks [catchAll (createUser (demoUser n)) (\_ -> return (RegisteredUser (demoUser n))) \\ n <- names] where demoUser name = {UserDetails | username = Username (toLowerCase name) , password = Password (toLowerCase name) , displayName = name , emailAddress = EmailAddress (name +++ "@example.com") , roles = Nothing } names = ["Alice","Bob","Carol","Dave","Eve","Fred"]