fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'master' into 455-datepicker-interagieren-schlecht-mit-modals

Browse Source
This commit is contained in:
Sarah Vaupel 2019-10-09 13:38:37 +02:00
commit bd97587ee5
283 changed files with 9691 additions and 2983 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

391
CHANGELOG.md
View File

@ -2,6 +2,397 @@
All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
## [7.10.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.9.1...v7.10.0) (2019-10-09)
### Bug Fixes
* hlint ([c19f427](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/c19f427))
* **tooltips:** add dark variants of theme independent colors ([e5c7aa0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/e5c7aa0))
### Features
* **course:** csv export of course participants ([9a28dc8](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/9a28dc8))
* **courses:** add NotificationCourseRegistered ([3750da8](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/3750da8))
* **info-lecturer:** add expiry time for newFeat ([fa9e6b5](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/fa9e6b5))
* **info-lecturer:** add inline newU2W icons ([5a49feb](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/5a49feb))
* **info-lecturer:** add newU2W icons on info page ([9f02ef0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/9f02ef0))
* **info-lecturer:** minor adjustments ([64b391a](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/64b391a))
* **info-lecturer:** more bullhorns ([4a5e7d9](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/4a5e7d9))
* **info-lecturer:** remove "news" section ([cb1e3a6](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/cb1e3a6))
* **lecturer-info:** add planned features icon; update info ([a4068b4](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/a4068b4))
* **lecturer-info:** fix typos, add info (adding tutorial participants) ([5139825](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/5139825))
* **lecturer-info:** replaced icons with icon-tooltips; edited text ([2ca7085](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/2ca7085))
* **tooltip:** added test warning to admin test page ([885efd3](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/885efd3))
* **tooltips:** add auto unzip and multiFileField tooltips ([276dcb6](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/276dcb6))
* **tooltips:** add option for inline tooltips ([0b2e931](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/0b2e931))
* **tooltips:** replace tooltips ([3b0e1d5](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/3b0e1d5))
* **tooltips:** tooltips from messages ([f85ab69](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/f85ab69))
### [7.9.1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.9.0...v7.9.1) (2019-10-07)
### Bug Fixes
* allow deregistering from full courses ([d7e1e67](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/d7e1e67))
## [7.9.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.8.5...v7.9.0) (2019-10-05)
### Features
* **allocations:** show more information ([b7c54df](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/b7c54df))
### [7.8.5](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.8.4...v7.8.5) (2019-10-05)
### Bug Fixes
* fix form-notification styling ([0226593](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/0226593))
### [7.8.4](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.8.3...v7.8.4) (2019-10-05)
### Bug Fixes
* **course-user:** handle allocations when deregistering single users ([ef5bb70](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/ef5bb70))
### [7.8.3](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.8.2...v7.8.3) (2019-10-05)
### Bug Fixes
* typo ([a6e40f1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/a6e40f1))
### [7.8.2](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.8.1...v7.8.2) (2019-10-04)
### Bug Fixes
* **favourites:** always move current course up ([56d89d7](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/56d89d7))
### [7.8.1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.8.0...v7.8.1) (2019-10-04)
### Bug Fixes
* **allocation:** fix allocation-results notifications ([ed700a3](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/ed700a3))
## [7.8.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.7.0...v7.8.0) (2019-10-04)
### Bug Fixes
* ordinalPriorities ([d4ab6f6](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/d4ab6f6))
### Features
* **course:** show direct registration dates ([8f284ac](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/8f284ac))
## [7.7.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.6.0...v7.7.0) (2019-10-04)
### Features
* **allocations:** fingerprints & ordinal ratings ([60603cb](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/60603cb))
## [7.6.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.5.0...v7.6.0) (2019-10-04)
### Features
* **allocations:** notification about finished allocation ([9323220](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/9323220))
* **allocations:** properly save allocation-relevant course-deregs ([7a759b1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/7a759b1))
* **favourites:** usability improvements ([fccc2ea](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/fccc2ea))
## [7.5.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.4.2...v7.5.0) (2019-10-03)
### Features
* **allocations:** auxilliaries for allocation-algo ([47bfd8d](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/47bfd8d))
* **allocations:** prototype assignment-algorithm ([0fcf48c](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/0fcf48c))
### [7.4.2](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.4.1...v7.4.2) (2019-10-01)
### Bug Fixes
* **course-news:** prevent display of edit-functions unless auth'ed ([89cc9ad](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/89cc9ad))
### [7.4.1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.4.0...v7.4.1) (2019-10-01)
### Bug Fixes
* **course-news:** fix permissions ([9e5fde9](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/9e5fde9))
## [7.4.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.3.2...v7.4.0) (2019-10-01)
### Features
* **course:** introduce CourseNews ([aa93b75](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/aa93b75))
### [7.3.2](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.3.1...v7.3.2) (2019-10-01)
### Bug Fixes
* **exam-users:** make csv import much more lenient ([2ddb566](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/2ddb566))
* **mail:** honor userCsvOptions and userDisplayEmail ([89adf7f](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/89adf7f))
### [7.3.1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.3.0...v7.3.1) (2019-09-30)
### Bug Fixes
* **course-edit:** edit courses without being school-wide lecturer ([d7d1f27](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/d7d1f27)), closes [#464](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/issues/464)
## [7.3.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.2.2...v7.3.0) (2019-09-30)
### Bug Fixes
* **course-application:** better display of priorities ([64f7715](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/64f7715))
### Features
* **csv:** allow customisation of csv-export-options ([95ceedd](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/95ceedd))
### [7.2.2](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.2.1...v7.2.2) (2019-09-30)
### Bug Fixes
* **authorisation:** keep showing allocations (ro) to lecturers ([c8e1d51](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/c8e1d51))
### [7.2.1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.2.0...v7.2.1) (2019-09-28)
### Bug Fixes
* fix build ([69f4a80](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/69f4a80))
* fix tutorial registration group applying globally ([d2ba173](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/d2ba173))
## [7.2.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.1.2...v7.2.0) (2019-09-27)
### Bug Fixes
* bump changelog ([60a7bb2](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/60a7bb2))
* don't treat ExamBonusManual as override ([16abcd2](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/16abcd2))
### Features
* **course-applications:** automatic acceptance of direct applicants ([620950d](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/620950d))
### [7.1.2](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.1.1...v7.1.2) (2019-09-26)
### Bug Fixes
* **exams:** include bonus points in sum for exam participants ([2bc6894](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/2bc6894))
### [7.1.1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.1.0...v7.1.1) (2019-09-26)
### Bug Fixes
* fix build ([d13ace4](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/d13ace4))
## [7.1.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.0.0...v7.1.0) (2019-09-26)
### Bug Fixes
* **datepicker:** select time from preselected date on edit ([d3375bb](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/d3375bb))
* **jobs:** cleaner shutdown of job-pool-manager ([adc8d46](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/adc8d46))
### Features
* **exams:** re-introduce ExamBonusManual ([54e94a6](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/54e94a6))
## [7.0.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v6.11.1...v7.0.0) (2019-09-25)
### Bug Fixes
* fix startup on unix-socket ([39f1295](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/39f1295))
* improve async behaviour ([cc7a528](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/cc7a528))
* make migration idempotent again ([9778404](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/9778404))
* restore behaviour of waiting asynchronously for job-management ([5ebcd89](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/5ebcd89))
* **communication:** make communication form more intuitive ([7a2b972](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/7a2b972)), closes [#387](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/issues/387)
* fix migration ([d2478a3](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/d2478a3))
* fix migration & tests ([e05ea8e](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/e05ea8e))
* migration ([4383eb1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/4383eb1))
* syntax ([7afd569](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/7afd569))
* **migration:** drop more tables in w.a. for inconsistent 21→22 ([d79dca6](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/d79dca6))
* typo ([fb1e42d](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/fb1e42d))
### chore
* bump versions ([67e3b38](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/67e3b38))
### Features
* **course:** additional crosslinking ([5eaba78](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/5eaba78))
* **exam-users:** document part-* family of columns ([fe07a22](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/fe07a22))
* **exams:** accept/reset computed results ([72342f1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/72342f1))
* **exams:** automatically compute examResults ([ea5a398](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/ea5a398))
* **exams:** better display exam-result-information ([0ebda4d](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/0ebda4d))
* **exams:** csv-import of ExamPartResults ([29f4e28](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/29f4e28))
* **exams:** implement rounding of exambonus ([e97cd56](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/e97cd56))
* **exams:** refine exam form ([014a17a](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/014a17a))
### BREAKING CHANGES
* yesod >=1.6
* **exams:** examPartName no longer required
* **exams:** Introduces ExamPartNumbers
### [6.11.1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v6.11.0...v6.11.1) (2019-09-17)
### Bug Fixes
* **changelog:** update changelog ([fa5358a](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/fa5358a))
## [6.11.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v6.10.0...v6.11.0) (2019-09-16)
### Bug Fixes
* **course:** add links between users & applications ([edaca1b](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/edaca1b))
* **exam-office:** better logic for isSynced ([cb9ff32](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/cb9ff32))
* **exams:** make examClosed a button ([530a8c6](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/530a8c6))
### Features
* **exam-office:** course/user opt-outs ([484fa1c](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/484fa1c))
* **exam-office:** exam-office permissions by courseSchool ([5841a7b](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/5841a7b))
* **exam-office:** exams list ([651f0bc](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/651f0bc))
* **exam-office:** grade export ([72a7f6e](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/72a7f6e))
* **exam-office:** notifications ([52e1844](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/52e1844))
* **exam-office:** show exam(Occurrence) end-time ([b638783](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/b638783))
* **exam-office:** subscription management for users & fields ([f75cc64](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/f75cc64))
* **exam-office:** user invitations ([123970a](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/123970a))
## [6.10.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v6.9.0...v6.10.0) (2019-09-13)
### Features
* **exams:** notifications wrt. registration ([ae27ff0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/ae27ff0))
## [6.9.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v6.8.0...v6.9.0) (2019-09-12)
### Features
* **users:** allow customisation of displayed email address ([2f38278](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/2f38278)), closes [#459](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/issues/459)
* **users:** allow customisation of userDisplayName ([a85f317](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/a85f317)), closes [#346](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/issues/346)
## [6.8.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v6.7.0...v6.8.0) (2019-09-12)
### Bug Fixes
* **allocations:** better explain capped allocation bounds ([a890e34](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/a890e34))
### Features
* **allocations:** allow changing course capacity during allocation ([83e1c94](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/83e1c94))
* **allocations:** show bounds on assignments due to allocation ([91b249e](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/91b249e))
## [6.7.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v6.6.0...v6.7.0) (2019-09-12)
### Bug Fixes
* **datepicker:** increase datepicker z-index in modals ([593a6a7](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/593a6a7))
* **datepicker:** quickfix to fix datepicker position in modals ([3f9454a](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/3f9454a))
* **submission-users:** properly delete old invitations ([91c926b](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/91c926b))
### Features
* **admin-users:** allow adding users ([67f1201](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/67f1201))
* **health:** timeout all health checks ([33338cd](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/33338cd))
* **invitations:** additional explanation for new users ([bb9c34f](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/bb9c34f))
## [6.6.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v6.5.0...v6.6.0) (2019-09-09) ## [6.6.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v6.5.0...v6.6.0) (2019-09-09)

36
README.md
View File

@ -5,6 +5,14 @@ The following description applies to Ubuntu and similar debian based Linux distr
## Prerequisites ## Prerequisites
These are the things you need to do/install before you can get started working on Uni2work. These are the things you need to do/install before you can get started working on Uni2work.
### Install german locale
You will need to install the german locale at compile time.
Install:
- Edit `/etc/locale.gen` as root and uncomment/add the line `de_DE.UTF-8 UTF-8`
- Save the file and run `sudo locale-gen`
### Clone repository ### Clone repository
Clone this repository and navigate into it Clone this repository and navigate into it
```sh ```sh
@ -41,7 +49,7 @@ You'll get a prompt:
```sh ```sh
Enter name of role to add: uniworx Enter name of role to add: uniworx
Shall the new role be a superuser? (y/n) [not exactly sure. Guess not?] Shall the new role be a superuser? (y/n) y [user must be superuser to create extensions]
Password: uniworx Password: uniworx
... ...
``` ```
@ -89,18 +97,6 @@ $ sudo apt-get install pkg-config
$ sudo apt-get install libsodium-dev $ sudo apt-get install libsodium-dev
``` ```
Build the app:
```sh
$ stack build
```
This might take a few minutes... if not hours... be prepared.
install yesod:
```sh
$ stack install yesod-bin --install-ghc
```
### `Node` & `npm` ### `Node` & `npm`
Node and Npm are needed to compile the frontend. Node and Npm are needed to compile the frontend.
@ -110,6 +106,18 @@ $ curl -sL https://deb.nodesource.com/setup_12.x | sudo -E bash -
$ sudo apt-get install -y nodejs $ sudo apt-get install -y nodejs
``` ```
Build the app:
```sh
$ npm run build
```
This might take a few minutes... if not hours... be prepared.
install yesod:
```sh
$ stack install yesod-bin --install-ghc
```
### Add dummy data to the database ### Add dummy data to the database
After building the app you can prepare the database and add some dummy data: After building the app you can prepare the database and add some dummy data:
```sh ```sh
@ -118,7 +126,7 @@ $ ./db.sh -f
## Run Uni2work ## Run Uni2work
```sh ```sh
$ npm start $ npm run start
``` ```
This will compile both frontend and backend and will start Uni2work in development mode (might take a few minutes the first time). It will keep running and will watch any file changes to automatically re-compile the application if necessary. This will compile both frontend and backend and will start Uni2work in development mode (might take a few minutes the first time). It will keep running and will watch any file changes to automatically re-compile the application if necessary.

7
app/DevelMain.hs
View File

@ -67,7 +67,7 @@ update = do
restartAppInNewThread tidStore = modifyStoredIORef tidStore $ \tid -> do restartAppInNewThread tidStore = modifyStoredIORef tidStore $ \tid -> do
killThread tid killThread tid
withStore doneStore takeMVar withStore doneStore takeMVar
readStore doneStore >>= start withStore doneStore start
-- | Start the server in a separate thread. -- | Start the server in a separate thread.
@ -77,10 +77,7 @@ update = do
(port, site, app) <- getApplicationRepl (port, site, app) <- getApplicationRepl
resourceForkIO $ do resourceForkIO $ do
finally (liftIO $ runSettings (setPort port defaultSettings) app) finally (liftIO $ runSettings (setPort port defaultSettings) app)
-- Note that this implies concurrency (liftIO $ shutdownApp site `finally` putMVar done ())
-- between shutdownApp and the next app that is starting.
-- Normally this should be fine
(liftIO $ putMVar done () >> shutdownApp site)
-- | kill the server -- | kill the server
shutdown :: IO () shutdown :: IO ()

13
clean.sh
View File

@ -10,6 +10,8 @@ case $1 in
;; ;;
*) *)
target=".stack-work-${1}" target=".stack-work-${1}"
shift
if [[ ! -d "${target}" ]]; then if [[ ! -d "${target}" ]]; then
printf "%s does not exist or is no directory\n" "${target}" >&2 printf "%s does not exist or is no directory\n" "${target}" >&2
exit 1 exit 1
@ -20,7 +22,11 @@ case $1 in
fi fi
move-back() { move-back() {
mv -v .stack-work "${target}" if [[ -d .stack-work ]]; then
mv -v .stack-work "${target}"
else
mkdir -v "${target}"
fi
[[ -d .stack-work-clean ]] && mv -v .stack-work-clean .stack-work [[ -d .stack-work-clean ]] && mv -v .stack-work-clean .stack-work
} }
@ -28,6 +34,9 @@ case $1 in
mv -v "${target}" .stack-work mv -v "${target}" .stack-work
trap move-back EXIT trap move-back EXIT
stack clean (
set -ex
stack clean $@
)
;; ;;
esac esac

28
config/settings.yml
View File

@ -24,8 +24,8 @@ job-flush-interval: "_env:JOB_FLUSH:30"
job-cron-interval: "_env:CRON_INTERVAL:60" job-cron-interval: "_env:CRON_INTERVAL:60"
job-stale-threshold: 300 job-stale-threshold: 300
notification-rate-limit: 3600 notification-rate-limit: 3600
notification-collate-delay: 300 notification-collate-delay: 7200
notification-expiration: 259201 notification-expiration: 259200
session-timeout: 7200 session-timeout: 7200
jwt-expiration: 604800 jwt-expiration: 604800
jwt-encoding: HS256 jwt-encoding: HS256
@ -122,13 +122,23 @@ widget-memcached:
expiration: "_env:MEMCACHEDEXPIRATION:3600" expiration: "_env:MEMCACHEDEXPIRATION:3600"
user-defaults: user-defaults:
max-favourites: 12 max-favourites: 12
theme: Default max-favourite-terms: 2
date-time-format: "%a %d %b %Y %R" theme: Default
date-format: "%d.%m.%Y" date-time-format: "%a %d %b %Y %R"
time-format: "%R" date-format: "%d.%m.%Y"
download-files: false time-format: "%R"
warning-days: 1209600 download-files: false
warning-days: 1209600
# During central allocations lecturer-given ratings of applications (as
# ExamGrades) are combined with a central priority.
# This encodes the weight of the lecturer ratings on the same scale as the
# centrally supplied priorities.
allocation-grade-scale: 25
# This encodes how many ordinal places lecturer ratings may move students up or
# down when central priorities are supplied as ordered list.
allocation-grade-ordinal-places: 3
instance-id: "_env:INSTANCE_ID:instance" instance-id: "_env:INSTANCE_ID:instance"
ribbon: "_env:RIBBON:" ribbon: "_env:RIBBON:"

2
config/test-settings.yml
View File

@ -8,3 +8,5 @@ log-settings:
destination: "test.log" destination: "test.log"
auth-dummy-login: true auth-dummy-login: true
job-workers: 1

24
frontend/src/utils/asidenav/asidenav.scss
View File

@ -56,6 +56,10 @@
font-size: 18px; font-size: 18px;
padding-left: 10px; padding-left: 10px;
} }
.asidenav__box-subtitle {
display: none;
}
} }
} }
@ -95,6 +99,14 @@
border-bottom: 1px solid var(--color-grey); border-bottom: 1px solid var(--color-grey);
} }
.asidenav__box-subtitle {
color: var(--color-fontsec);
font-size: 0.9rem;
font-weight: 600;
padding: 0 13px;
margin: 3px 0;
}
/* LOGO */ /* LOGO */
.asidenav__logo { .asidenav__logo {
@ -170,7 +182,7 @@
position: absolute; position: absolute;
bottom: -40px; bottom: -40px;
right: 25px; right: 25px;
opacity: 0.2; opacity: 0.1;
> img { > img {
width: 350px; width: 350px;
@ -314,8 +326,16 @@
color: var(--color-lightwhite); color: var(--color-lightwhite);
&:hover { &:hover {
background-color: var(--color-dark); background-color: var(--color-darker);
} }
&::before {
display: none;
}
}
.asidenav__box-subtitle {
display: none;
} }
.asidenav__link-shorthand { .asidenav__link-shorthand {

36
frontend/src/utils/form/datepicker.js
View File

@ -25,17 +25,6 @@ const FORM_DATE_FORMAT_MOMENT = {
'datetime-local': `${FORM_DATE_FORMAT_DATE_MOMENT} ${FORM_DATE_FORMAT_TIME_MOMENT}`, 'datetime-local': `${FORM_DATE_FORMAT_DATE_MOMENT} ${FORM_DATE_FORMAT_TIME_MOMENT}`,
}; };
/**
* Takes a string representation of a date and a format string and parses the given date to a Date object.
* If the date string is not valid (i.e. cannot be parsed with the given format string), returns undefined.
* @param {*} dateStr string representation of a date
* @param {*} dateFormat format string of the date
*/
function parseDateWithFormat(dateStr, dateFormat) {
const parsedMomentDate = moment(dateStr, dateFormat);
if (parsedMomentDate.isValid()) return parsedMomentDate.toDate();
}
/** /**
* Takes a string representation of a date, an input ('previous') format and a desired output format and returns a reformatted date string. * Takes a string representation of a date, an input ('previous') format and a desired output format and returns a reformatted date string.
* If the date string is not valid (i.e. cannot be parsed with the given input format string), returns the original date string; * If the date string is not valid (i.e. cannot be parsed with the given input format string), returns the original date string;
@ -137,6 +126,9 @@ export class Datepicker {
throw new Error('Datepicker utility called on unsupported element!'); throw new Error('Datepicker utility called on unsupported element!');
} }
// format any existing dates to fancy display format on pageload
this.formatElementValue(true);
// initialize tail.datetime (datepicker) instance // initialize tail.datetime (datepicker) instance
this.datepickerInstance = datetime(this._element, { ...datepickerGlobalConfig, ...datepickerConfig }); this.datepickerInstance = datetime(this._element, { ...datepickerGlobalConfig, ...datepickerConfig });
@ -198,9 +190,6 @@ export class Datepicker {
// format the date value of the form input element of this datepicker before form submission // format the date value of the form input element of this datepicker before form submission
this._element.form.addEventListener('submit', () => this.formatElementValue()); this._element.form.addEventListener('submit', () => this.formatElementValue());
// format any existing dates to fancy display format on pageload
this.formatElementValue(true);
} }
destroy() { destroy() {
@ -212,22 +201,21 @@ export class Datepicker {
* @param {*} toFancy optional target format switch (boolean value; default is false). If set to a truthy value, formats the element value to fancy instead of internal date format. * @param {*} toFancy optional target format switch (boolean value; default is false). If set to a truthy value, formats the element value to fancy instead of internal date format.
*/ */
formatElementValue(toFancy) { formatElementValue(toFancy) {
const dp = this.datepickerInstance;
if (this._element.value) { if (this._element.value) {
if (toFancy) { this._element.value = this.unformat(toFancy);
const parsedDate = parseDateWithFormat(this._element.value, FORM_DATE_FORMAT[this.elementType]);
if (parsedDate) dp.selectDate();
} else {
this._element.value = this.unformat();
}
} }
} }
/** /**
* Returns a datestring in internal format from the current state of the input element value. * Returns a datestring in internal format from the current state of the input element value.
* @param {*} toFancy Format date from internal to fancy or vice versa. When omitted, toFancy is falsy and results in fancy -> internal
*/ */
unformat() { unformat(toFancy) {
return reformatDateString(this._element.value, FORM_DATE_FORMAT_MOMENT[this.elementType], FORM_DATE_FORMAT[this.elementType]); const formatIn = toFancy ? FORM_DATE_FORMAT[this.elementType] : FORM_DATE_FORMAT_MOMENT[this.elementType];
const formatOut = toFancy ? FORM_DATE_FORMAT_MOMENT[this.elementType] : FORM_DATE_FORMAT[this.elementType];
return reformatDateString(this._element.value, formatIn, formatOut);
} }
/** /**
@ -256,4 +244,4 @@ export class Datepicker {
// return the (possibly changed) FormData // return the (possibly changed) FormData
return formData; return formData;
} }
} }

8
frontend/src/utils/inputs/inputs.scss
View File

@ -33,11 +33,14 @@
margin: 7px 0; margin: 7px 0;
} }
.form-section-title__hint { .form-group__hint, .form-section-title__hint {
margin-top: 7px;
color: var(--color-fontsec); color: var(--color-fontsec);
font-size: 0.9rem; font-size: 0.9rem;
font-weight: 600; font-weight: 600;
}
.form-section-title__hint {
margin-top: 7px;
+ .form-group { + .form-group {
margin-top: 11px; margin-top: 11px;
@ -58,6 +61,7 @@
.form-group--required .form-group-label__caption::after, .form-group__required-marker::before { .form-group--required .form-group-label__caption::after, .form-group__required-marker::before {
content: ' *'; content: ' *';
color: var(--color-error); color: var(--color-error);
font-weight: 600;
} }
.form-group--optional { .form-group--optional {

46
frontend/src/utils/tooltips/tooltips.scss
View File

@ -1,8 +1,7 @@
.tooltip { .tooltip {
position: relative; position: relative;
display: inline-block; display: inline-block;
height: 1.5rem; vertical-align: middle;
vertical-align: -0.375rem;
&:hover .tooltip__content { &:hover .tooltip__content {
display: inline-block; display: inline-block;
@ -10,13 +9,10 @@
} }
.tooltip__handle { .tooltip__handle {
background-color: var(--color-dark); color: var(--color-light);
border-radius: 50%;
height: 1.5rem; height: 1.5rem;
width: 1.5rem;
line-height: 1.5rem; line-height: 1.5rem;
font-size: 1.2rem; font-size: 1.2rem;
color: white;
display: inline-block; display: inline-block;
text-align: center; text-align: center;
margin: 0 10px; margin: 0 10px;
@ -24,27 +20,45 @@
position: relative; position: relative;
&::before { &::before {
content: '\f128';
position: absolute; position: absolute;
top: 0; top: 0;
left: 0; left: 0;
font-family: 'Font Awesome 5 Free';
top: 50%; top: 50%;
left: 50%; left: 50%;
transform: translate(-50%, -50%); transform: translate(-50%, -50%);
font-size: 15px; font-size: 15px;
} }
&.tooltip__handle--danger::before { &.tooltip__handle.urgency__success {
content: '\f12a'; color: var(--color-success);
} }
&.tooltip__handle.urgency__warning {
&.tooltip__handle--danger { color: var(--color-warning);
background-color: var(--color-warning); }
&.tooltip__handle.urgency__error {
color: var(--color-error);
} }
&:hover { &:hover {
background-color: var(--color-light); color: var(--color-dark);
&.tooltip__handle.urgency__success {
color: var(--color-success-dark);
}
&.tooltip__handle.urgency__warning {
color: var(--color-warning-dark);
}
&.tooltip__handle.urgency__error {
color: var(--color-error-dark);
}
}
}
.tooltip.tooltip__inline {
.tooltip__handle {
height: 1.0rem;
line-height: 1.0rem;
font-size: 1.0rem;
} }
} }
@ -53,7 +67,7 @@
display: none; display: none;
top: -10px; top: -10px;
transform: translateY(-100%); transform: translateY(-100%);
right: 3px; left: 3px;
width: 275px; width: 275px;
z-index: 10; z-index: 10;
background-color: #fafafa; background-color: #fafafa;
@ -68,7 +82,7 @@
background-color: #fafafa; background-color: #fafafa;
transform: rotate(45deg); transform: rotate(45deg);
position: absolute; position: absolute;
right: 10px; left: 10px;
bottom: -8px; bottom: -8px;
} }
} }

2
haddock.sh
View File

@ -15,4 +15,4 @@ if [[ -d .stack-work-doc ]]; then
trap move-back EXIT trap move-back EXIT
fi fi
stack build --fast --flag uniworx:library-only --flag uniworx:dev --haddock --haddock-hyperlink-source --haddock-deps --haddock-internal stack build --fast --flag uniworx:library-only --flag uniworx:dev --haddock --haddock-hyperlink-source --haddock-deps --haddock-internal ${@}

2
is-clean.sh
View File

@ -1,5 +1,7 @@
#!/usr/bin/env bash #!/usr/bin/env bash
[[ -n "${FORCE_RELEASE}" ]] && exit 0
set -e set -e
if [ -n "$(git status --porcelain)" ]; then if [ -n "$(git status --porcelain)" ]; then

333
messages/uniworx/de.msg
View File

@ -36,6 +36,10 @@ RegisterTo: Anmeldungen bis
DeRegUntil: Abmeldungen bis DeRegUntil: Abmeldungen bis
RegisterRetry: Sie wurden noch nicht angemeldet. Drücken Sie dazu den Knopf "Anmelden" RegisterRetry: Sie wurden noch nicht angemeldet. Drücken Sie dazu den Knopf "Anmelden"
CourseRegistrationInterval: Anmeldung
CourseDirectRegistrationInterval: Direkte Anmeldung
CourseDeregisterUntil time@Text: Abmeldung nur bis #{time}
GenericKey: Schlüssel GenericKey: Schlüssel
GenericShort: Kürzel GenericShort: Kürzel
GenericIsNew: Neu GenericIsNew: Neu
@ -173,6 +177,7 @@ CourseApplicationTemplateApplication: Bewerbungsvorlage(n)
CourseApplicationTemplateRegistration: Anmeldungsvorlage(n) CourseApplicationTemplateRegistration: Anmeldungsvorlage(n)
CourseApplicationTemplateArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-bewerbungsvorlagen CourseApplicationTemplateArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-bewerbungsvorlagen
CourseApplication: Bewerbung CourseApplication: Bewerbung
CourseApplicationIsParticipant: Kursteilnehmer
CourseApplicationExists: Sie haben sich bereits für diesen Kurs beworben CourseApplicationExists: Sie haben sich bereits für diesen Kurs beworben
CourseApplicationInvalidAction: Angegeben Aktion kann nicht durchgeführt werden CourseApplicationInvalidAction: Angegeben Aktion kann nicht durchgeführt werden
@ -365,6 +370,8 @@ UnauthorizedToken404: Authorisierungs-Tokens können nicht auf Fehlerseiten ausg
UnauthorizedSiteAdmin: Sie sind kein System-weiter Administrator. UnauthorizedSiteAdmin: Sie sind kein System-weiter Administrator.
UnauthorizedSchoolAdmin: Sie sind nicht als Administrator für dieses Institut eingetragen. UnauthorizedSchoolAdmin: Sie sind nicht als Administrator für dieses Institut eingetragen.
UnauthorizedAdminEscalation: Sie sind nicht Administrator für alle Institute, für die dieser Nutzer Administrator oder Veranstalter ist. UnauthorizedAdminEscalation: Sie sind nicht Administrator für alle Institute, für die dieser Nutzer Administrator oder Veranstalter ist.
UnauthorizedExamOffice: Sie sind nicht Teil eines Prüfungsamts.
UnauthorizedExamExamOffice: Es existieren keine Prüfungsergebnisse für Nutzer, für die Sie Teil eines assoziierten Prüfungsamts sind.
UnauthorizedSchoolLecturer: Sie sind nicht als Veranstalter für dieses Institut eingetragen. UnauthorizedSchoolLecturer: Sie sind nicht als Veranstalter für dieses Institut eingetragen.
UnauthorizedLecturer: Sie sind nicht als Veranstalter für diese Veranstaltung eingetragen. UnauthorizedLecturer: Sie sind nicht als Veranstalter für diese Veranstaltung eingetragen.
UnauthorizedAllocationLecturer: Sie sind nicht als Veranstalter für eine Veranstaltung dieser Zentralanmeldung eingetragen. UnauthorizedAllocationLecturer: Sie sind nicht als Veranstalter für eine Veranstaltung dieser Zentralanmeldung eingetragen.
@ -375,12 +382,14 @@ UnauthorizedRegistered: Sie sind nicht als Teilnehmer für diese Veranstaltung r
UnauthorizedAllocationRegistered: Sie sind nicht als Teilnehmer für diese Zentralanmeldung registriert. UnauthorizedAllocationRegistered: Sie sind nicht als Teilnehmer für diese Zentralanmeldung registriert.
UnauthorizedExamResult: Sie haben keine Ergebnisse in dieser Prüfung. UnauthorizedExamResult: Sie haben keine Ergebnisse in dieser Prüfung.
UnauthorizedParticipant: Angegebener Benutzer ist nicht als Teilnehmer dieser Veranstaltung registriert. UnauthorizedParticipant: Angegebener Benutzer ist nicht als Teilnehmer dieser Veranstaltung registriert.
UnauthorizedCourseNewsParticipant: Sie sind kein Teilnehmer dieser Veranstaltung.
UnauthorizedCourseTime: Dieses Kurs erlaubt momentan keine Anmeldungen. UnauthorizedCourseTime: Dieses Kurs erlaubt momentan keine Anmeldungen.
UnauthorizedAllocationRegisterTime: Diese Zentralanmeldung erlaubt momentan keine Bewerbungen. UnauthorizedAllocationRegisterTime: Diese Zentralanmeldung erlaubt momentan keine Bewerbungen.
UnauthorizedSheetTime: Dieses Übungsblatt ist momentan nicht freigegeben. UnauthorizedSheetTime: Dieses Übungsblatt ist momentan nicht freigegeben.
UnauthorizedApplicationTime: Diese Bewerbung ist momentan nicht freigegeben. UnauthorizedApplicationTime: Diese Bewerbung ist momentan nicht freigegeben.
UnauthorizedMaterialTime: Dieses Material ist momentan nicht freigegeben. UnauthorizedMaterialTime: Dieses Material ist momentan nicht freigegeben.
UnauthorizedTutorialTime: Dieses Tutorium erlaubt momentan keine Anmeldungen. UnauthorizedTutorialTime: Dieses Tutorium erlaubt momentan keine Anmeldungen.
UnauthorizedCourseNewsTime: Diese Nachricht ist momentan nicht freigegeben.
UnauthorizedExamTime: Diese Prüfung ist momentan nicht freigegeben. UnauthorizedExamTime: Diese Prüfung ist momentan nicht freigegeben.
UnauthorizedSubmissionOwner: Sie sind an dieser Abgabe nicht beteiligt. UnauthorizedSubmissionOwner: Sie sind an dieser Abgabe nicht beteiligt.
UnauthorizedSubmissionRated: Diese Abgabe ist noch nicht korrigiert. UnauthorizedSubmissionRated: Diese Abgabe ist noch nicht korrigiert.
@ -471,7 +480,9 @@ LdapSynced: LDAP-Synchronisiert
LdapSyncedBefore: Letzte LDAP-Synchronisation vor LdapSyncedBefore: Letzte LDAP-Synchronisation vor
NoMatrikelKnown: Keine Matrikelnummer NoMatrikelKnown: Keine Matrikelnummer
Theme: Oberflächen Design Theme: Oberflächen Design
Favoriten: Anzahl gespeicherter Favoriten Favourites: Anzahl gespeicherter Favoriten
FavouritesTip: Betrifft nur automatisch angelegte Favoriten („Kürzlich besucht“)
FavouriteSemesters: Maximale Anzahl an Semestern in Seitenleiste
Plugin: Plugin Plugin: Plugin
Ident: Identifikation Ident: Identifikation
LastLogin: Letzter Login LastLogin: Letzter Login
@ -638,6 +649,7 @@ UserSchoolsTip: Sie erhalten nur institutweite Benachrichtigungen für Institute
FormNotifications: Benachrichtigungen FormNotifications: Benachrichtigungen
FormBehaviour: Verhalten FormBehaviour: Verhalten
FormCosmetics: Oberfläche FormCosmetics: Oberfläche
FormPersonalAppearance: Öffentliche Daten
FormFieldRequiredTip: Gekennzeichnete Pflichtfelder sind immer auszufüllen FormFieldRequiredTip: Gekennzeichnete Pflichtfelder sind immer auszufüllen
ActiveAuthTags: Aktivierte Authorisierungsprädikate ActiveAuthTags: Aktivierte Authorisierungsprädikate
@ -688,6 +700,9 @@ UploadModeSpecific: Upload, vorgegebene Dateinamen
UploadModeUnpackZips: Abgabe mehrerer Dateien UploadModeUnpackZips: Abgabe mehrerer Dateien
UploadModeUnpackZipsTip: Wenn die Abgabe mehrerer Dateien erlaubt ist, werden auch unterstützte Archiv-Formate zugelassen. Diese werden nach dann beim Hochladen automatisch entpackt. UploadModeUnpackZipsTip: Wenn die Abgabe mehrerer Dateien erlaubt ist, werden auch unterstützte Archiv-Formate zugelassen. Diese werden nach dann beim Hochladen automatisch entpackt.
AutoUnzip: ZIPs automatisch entpacken
AutoUnzipInfo: Entpackt hochgeladene ZIP-Dateien (*.zip) automatisch und fügt den Inhalt dem Stamm-Verzeichnis hinzu.
UploadModeExtensionRestriction: Zulässige Dateiendungen UploadModeExtensionRestriction: Zulässige Dateiendungen
UploadModeExtensionRestrictionTip: Komma-separiert. Wenn keine Dateiendungen angegeben werden erfolgt keine Einschränkung. UploadModeExtensionRestrictionTip: Komma-separiert. Wenn keine Dateiendungen angegeben werden erfolgt keine Einschränkung.
UploadModeExtensionRestrictionEmpty: Liste von zulässigen Dateiendungen darf nicht leer sein UploadModeExtensionRestrictionEmpty: Liste von zulässigen Dateiendungen darf nicht leer sein
@ -762,9 +777,29 @@ MailSubmissionRatedIntro courseName@Text termDesc@Text: Ihre Abgabe im Kurs #{co
MailSubjectSheetActive csh@CourseShorthand sheetName@SheetName: #{sheetName} in #{csh} wurde herausgegeben MailSubjectSheetActive csh@CourseShorthand sheetName@SheetName: #{sheetName} in #{csh} wurde herausgegeben
MailSheetActiveIntro courseName@Text termDesc@Text sheetName@SheetName: Sie können nun #{sheetName} im Kurs #{courseName} (#{termDesc}) herunterladen. MailSheetActiveIntro courseName@Text termDesc@Text sheetName@SheetName: Sie können nun #{sheetName} im Kurs #{courseName} (#{termDesc}) herunterladen.
MailSubjectCourseRegistered csh@CourseShorthand: Sie wurden zu #{csh} angemeldet
MailSubjectCourseRegisteredOther displayName@Text csh@CourseShorthand: #{displayName} wurde zu #{csh} angemeldet
MailCourseRegisteredIntro courseName@Text termDesc@Text: Sie wurden im Kurs #{courseName} (#{termDesc}) angemeldet.
MailCourseRegisteredIntroOther displayName@Text courseName@Text termDesc@Text: #{displayName} wurde im Kurs #{courseName} (#{termDesc}) angemeldet.
MailSubjectExamResult csh@CourseShorthand examn@ExamName: Ergebnisse für #{examn} in #{csh} wurden herausgegeben MailSubjectExamResult csh@CourseShorthand examn@ExamName: Ergebnisse für #{examn} in #{csh} wurden herausgegeben
MailExamResultIntro courseName@Text termDesc@Text examn@ExamName: Sie können nun Ihr Ergebnis für #{examn} im Kurs #{courseName} (#{termDesc}) einsehen. MailExamResultIntro courseName@Text termDesc@Text examn@ExamName: Sie können nun Ihr Ergebnis für #{examn} im Kurs #{courseName} (#{termDesc}) einsehen.
MailSubjectExamOfficeExamResults csh@CourseShorthand examn@ExamName: Ergebnisse für #{examn} in #{csh} sind fertiggestellt
MailExamOfficeExamResultsIntro courseName@Text termDesc@Text examn@ExamName: Ein Kursverwalter hat die Prüfungsleistungen für #{examn} im Kurs #{courseName} (#{termDesc}) freigegeben.
MailSubjectExamOfficeExamResultsChanged csh@CourseShorthand examn@ExamName: Ergebnisse für #{examn} in #{csh} wurden verändert
MailExamOfficeExamResultsChangedIntro courseName@Text termDesc@Text examn@ExamName: Ein Kursverwalter hat Prüfungsleistungen für #{examn} im Kurs #{courseName} (#{termDesc}) verändert.
MailSubjectExamRegistrationActive csh@CourseShorthand examn@ExamName: Anmeldung für #{examn} in #{csh} ist möglich
MailExamRegistrationActiveIntro courseName@Text termDesc@Text examn@ExamName: Sie können sich nun für #{examn} im Kurs #{courseName} (#{termDesc}) anmelden.
MailSubjectExamRegistrationSoonInactive csh@CourseShorthand examn@ExamName: Anmeldung für #{examn} in #{csh} ist nur noch kurze Zeit möglich
MailExamRegistrationSoonInactiveIntro courseName@Text termDesc@Text examn@ExamName: Sie können sich bald nicht mehr für #{examn} im Kurs #{courseName} (#{termDesc}) anmelden.
MailSubjectExamDeregistrationSoonInactive csh@CourseShorthand examn@ExamName: Abmeldung für #{examn} in #{csh} ist nur noch kurze Zeit möglich
MailExamDeregistrationSoonInactiveIntro courseName@Text termDesc@Text examn@ExamName: Sie können sich bald nicht mehr von #{examn} im Kurs #{courseName} (#{termDesc}) abmelden.
MailSubjectSubmissionsUnassigned csh@CourseShorthand sheetName@SheetName: Abgaben zu #{sheetName} in #{csh} konnten nicht verteilt werden MailSubjectSubmissionsUnassigned csh@CourseShorthand sheetName@SheetName: Abgaben zu #{sheetName} in #{csh} konnten nicht verteilt werden
MailSubmissionsUnassignedIntro n@Int courseName@Text termDesc@Text sheetName@SheetName: #{n} Abgaben zu #{sheetName} im Kurs #{courseName} (#{termDesc}) konnten nicht automatisiert verteilt werden. MailSubmissionsUnassignedIntro n@Int courseName@Text termDesc@Text sheetName@SheetName: #{n} Abgaben zu #{sheetName} im Kurs #{courseName} (#{termDesc}) konnten nicht automatisiert verteilt werden.
@ -781,9 +816,9 @@ MailUserRightsIntro name@Text email@UserEmail: #{name} <#{email}> hat folgende U
MailNoLecturerRights: Sie haben derzeit keine Dozenten-Rechte. MailNoLecturerRights: Sie haben derzeit keine Dozenten-Rechte.
MailLecturerRights n@Int: Als Dozent dürfen Sie Veranstaltungen innerhalb #{pluralDE n "Ihres Instituts" "Ihrer Institute"} anlegen. MailLecturerRights n@Int: Als Dozent dürfen Sie Veranstaltungen innerhalb #{pluralDE n "Ihres Instituts" "Ihrer Institute"} anlegen.
MailSubjectUserAuthModeUpdate: Änderung Ihres Uni2work-Anmeldemodus MailSubjectUserAuthModeUpdate: Ihr Uni2work-Login
UserAuthModePWHashChangedToLDAP: Sie melden sich nun mit Ihrer Campus-Kennung an UserAuthModePWHashChangedToLDAP: Sie können sich nun mit Ihrer Campus-Kennung in Uni2work einloggen
UserAuthModeLDAPChangedToPWHash: Sie melden sich nun mit einer Uni2work-internen Kennung an UserAuthModeLDAPChangedToPWHash: Sie können sich nun mit einer Uni2work-internen Kennung in Uni2work einloggen
NewPasswordLinkTip: Das Passwort Ihrer Uni2work-internen Kennung können Sie auf der folgenden Seite setzen: NewPasswordLinkTip: Das Passwort Ihrer Uni2work-internen Kennung können Sie auf der folgenden Seite setzen:
NewPasswordLink: Neues Passwort setzen NewPasswordLink: Neues Passwort setzen
AuthPWHashTip: Sie müssen nun das mit "Uni2work-Login" beschriftete Login-Formular verwenden. Stellen Sie bitte sicher, dass Sie ein Passwort gesetzt haben, bevor Sie versuchen sich anzumelden. AuthPWHashTip: Sie müssen nun das mit "Uni2work-Login" beschriftete Login-Formular verwenden. Stellen Sie bitte sicher, dass Sie ein Passwort gesetzt haben, bevor Sie versuchen sich anzumelden.
@ -796,8 +831,10 @@ MailSubjectSupportCustom customSubject@Text: [Support] #{customSubject}
CommCourseSubject: Kursmitteilung CommCourseSubject: Kursmitteilung
MailSubjectLecturerInvitation tid@TermId ssh@SchoolId csh@CourseShorthand: [#{tid}-#{ssh}-#{csh}] Einladung zum Kursverwalter MailSubjectLecturerInvitation tid@TermId ssh@SchoolId csh@CourseShorthand: [#{tid}-#{ssh}-#{csh}] Einladung zum Kursverwalter
InvitationAcceptDecline: Einladung annehmen/ablehnen InvitationAcceptDecline: Einladung annehmen/ablehnen
InvitationFromTip displayName@Text: Sie erhalten diese Einladung, weil #{displayName} ihren Versand in Uni2work ausgelöst hat.
InvitationUniWorXTip: Uni2work ist ein webbasiertes Lehrverwaltungssystem der LMU München.
MailSubjectParticipantInvitation tid@TermId ssh@SchoolId csh@CourseShorthand: [#{tid}-#{ssh}-#{csh}] Einladung zum Kursteilname MailSubjectParticipantInvitation tid@TermId ssh@SchoolId csh@CourseShorthand: [#{tid}-#{ssh}-#{csh}] Einladung zur Kursteilnahme
MailSubjectCorrectorInvitation tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName: [#{tid}-#{ssh}-#{csh}] Einladung zum Korrektor für #{shn} MailSubjectCorrectorInvitation tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName: [#{tid}-#{ssh}-#{csh}] Einladung zum Korrektor für #{shn}
@ -809,6 +846,8 @@ MailSubjectExamRegistrationInvitation tid@TermId ssh@SchoolId csh@CourseShorthan
MailSubjectSubmissionUserInvitation tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName: [#{tid}-#{ssh}-#{csh}] Einladung zu einer Abgabe für #{shn} MailSubjectSubmissionUserInvitation tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName: [#{tid}-#{ssh}-#{csh}] Einladung zu einer Abgabe für #{shn}
MailSubjectExamOfficeUserInvitation displayName@Text: Berücksichtigung von Prüfungsleistungen in Uni2work
MailSubjectPasswordReset: Uni2work-Passwort ändern bzw. setzen MailSubjectPasswordReset: Uni2work-Passwort ändern bzw. setzen
SheetGrading: Bewertung SheetGrading: Bewertung
@ -863,22 +902,31 @@ NotificationTriggerCorrectionsAssigned: Mir wurden Abgaben zur Korrektur zugetei
NotificationTriggerCorrectionsNotDistributed: Nicht alle Abgaben eines meiner Übungsblätter konnten einem Korrektor zugeteilt werden NotificationTriggerCorrectionsNotDistributed: Nicht alle Abgaben eines meiner Übungsblätter konnten einem Korrektor zugeteilt werden
NotificationTriggerUserRightsUpdate: Meine Berechtigungen wurden geändert NotificationTriggerUserRightsUpdate: Meine Berechtigungen wurden geändert
NotificationTriggerUserAuthModeUpdate: Mein Anmelde-Modus wurde geändert NotificationTriggerUserAuthModeUpdate: Mein Anmelde-Modus wurde geändert
NotificationTriggerExamRegistrationActive: Ich kann mich für eine Prüfung anmelden
NotificationTriggerExamRegistrationSoonInactive: Ich kann mich bald nicht mehr für eine Prüfung anmelden
NotificationTriggerExamDeregistrationSoonInactive: Ich kann mich bald nicht mehr von einer Prüfung abmelden
NotificationTriggerExamResult: Ich kann ein neues Prüfungsergebnis einsehen NotificationTriggerExamResult: Ich kann ein neues Prüfungsergebnis einsehen
NotificationTriggerAllocationStaffRegister: Ich kann Kurse bei einer neuen Zentralanmeldung eintragen NotificationTriggerAllocationStaffRegister: Ich kann Kurse bei einer neuen Zentralanmeldung eintragen
NotificationTriggerAllocationAllocation: Ich kann Zentralanmeldung-Bewerbungen für einen meiner Kurse bewerten NotificationTriggerAllocationAllocation: Ich kann Zentralanmeldung-Bewerbungen für einen meiner Kurse bewerten
NotificationTriggerAllocationRegister: Ich kann mich bei einer neuen Zentralanmeldung bewerben NotificationTriggerAllocationRegister: Ich kann mich bei einer neuen Zentralanmeldung bewerben
NotificationTriggerAllocationOutdatedRatings: Zentralanmeldung-Bewerbungen für einen meiner Kurse wurden verändert, nachdem sie bewertet wurden NotificationTriggerAllocationOutdatedRatings: Zentralanmeldung-Bewerbungen für einen meiner Kurse wurden verändert, nachdem sie bewertet wurden
NotificationTriggerAllocationUnratedApplications: Bewertungen zu Zentralanmeldung-Bewerbungen für einen meiner Kurse stehen aus NotificationTriggerAllocationUnratedApplications: Bewertungen zu Zentralanmeldung-Bewerbungen für einen meiner Kurse stehen aus
NotificationTriggerAllocationResults: Plätze wurden für eine meiner Zentralanmeldungen verteilt
NotificationTriggerExamOfficeExamResults: Ich kann neue Prüfungsergebnisse einsehen
NotificationTriggerExamOfficeExamResultsChanged: Prüfungsergebnisse wurden verändert
NotificationTriggerCourseRegistered: Ein Kursverwalter hat mich zu einem Kurs angemeldet
NotificationTriggerKindAll: Für alle Benutzer NotificationTriggerKindAll: Für alle Benutzer
NotificationTriggerKindCourseParticipant: Für Kursteilnehmer NotificationTriggerKindCourseParticipant: Für Kursteilnehmer
NotificationTriggerKindExamParticipant: Für Prüfungsteilnehmer NotificationTriggerKindExamParticipant: Für Prüfungsteilnehmer
NotificationTriggerKindCorrector: Für Korrektoren NotificationTriggerKindCorrector: Für Korrektoren
NotificationTriggerKindLecturer: Für Dozenten NotificationTriggerKindLecturer: Für Dozenten
NotificationTriggerKindCourseLecturer: Für Kursverwalter
NotificationTriggerKindAdmin: Für Administratoren NotificationTriggerKindAdmin: Für Administratoren
NotificationTriggerKindExamOffice: Für das Prüfungsamt NotificationTriggerKindExamOffice: Für das Prüfungsamt
NotificationTriggerKindEvaluation: Für Vorlesungsumfragen NotificationTriggerKindEvaluation: Für Vorlesungsumfragen
NotificationTriggerKindAllocationStaff: Für Zentralanmeldungen NotificationTriggerKindAllocationStaff: Für Zentralanmeldungen (Dozenten)
NotificationTriggerKindAllocationParticipant: Für Zentralanmeldungen
CorrCreate: Abgaben erstellen CorrCreate: Abgaben erstellen
UnknownPseudonymWord pseudonymWord@Text: Unbekanntes Pseudonym-Wort "#{pseudonymWord}" UnknownPseudonymWord pseudonymWord@Text: Unbekanntes Pseudonym-Wort "#{pseudonymWord}"
@ -993,11 +1041,13 @@ MenuAllocationList: Zentralanmeldungen
MenuCourseList: Kurse MenuCourseList: Kurse
MenuCourseMembers: Kursteilnehmer MenuCourseMembers: Kursteilnehmer
MenuCourseAddMembers: Kursteilnehmer hinzufügen MenuCourseAddMembers: Kursteilnehmer hinzufügen
MenuCourseCommunication: Kursmitteilung MenuCourseCommunication: Kursmitteilung (E-Mail)
MenuCourseApplications: Bewerbungen MenuCourseApplications: Bewerbungen
MenuCourseExamOffice: Prüfungsämter
MenuTermShow: Semester MenuTermShow: Semester
MenuSubmissionDelete: Abgabe löschen MenuSubmissionDelete: Abgabe löschen
MenuUsers: Benutzer MenuUsers: Benutzer
MenuUserAdd: Benutzer anlegen
MenuUserNotifications: Benachrichtigungs-Einstellungen MenuUserNotifications: Benachrichtigungs-Einstellungen
MenuUserPassword: Passwort MenuUserPassword: Passwort
MenuAdminTest: Admin-Demo MenuAdminTest: Admin-Demo
@ -1045,18 +1095,25 @@ MenuExamList: Prüfungen
MenuExamNew: Neue Prüfung anlegen MenuExamNew: Neue Prüfung anlegen
MenuExamEdit: Bearbeiten MenuExamEdit: Bearbeiten
MenuExamUsers: Teilnehmer MenuExamUsers: Teilnehmer
MenuExamGrades: Prüfungsleistungen
MenuExamAddMembers: Prüfungsteilnehmer hinzufügen MenuExamAddMembers: Prüfungsteilnehmer hinzufügen
MenuExamOfficeExams: Prüfungen
MenuExamOfficeFields: Fächer
MenuExamOfficeUsers: Benutzer
MenuLecturerInvite: Dozenten hinzufügen MenuLecturerInvite: Dozenten hinzufügen
MenuAllocationInfo: Hinweise zum Ablauf einer Zentralanmeldung MenuAllocationInfo: Hinweise zum Ablauf einer Zentralanmeldung
MenuCourseApplicationsFiles: Dateien aller Bewerbungen MenuCourseApplicationsFiles: Dateien aller Bewerbungen
MenuSchoolList: Institute MenuSchoolList: Institute
MenuSchoolNew: Neues Institut anlegen MenuSchoolNew: Neues Institut anlegen
MenuCourseNewsNew: Neue Kursnachricht
MenuCourseNewsEdit: Kursnachricht bearbeiten
AuthPredsInfo: Um eigene Veranstaltungen aus Sicht der Teilnehmer anzusehen, können Veranstalter und Korrektoren hier die Prüfung ihrer erweiterten Berechtigungen temporär deaktivieren. Abgewählte Prädikate schlagen immer fehl. Abgewählte Prädikate werden also nicht geprüft um Zugriffe zu gewähren, welche andernfalls nicht erlaubt wären. Diese Einstellungen gelten nur temporär bis Ihre Sitzung abgelaufen ist, d.h. bis ihr Browser-Cookie abgelaufen ist. Durch Abwahl von Prädikaten kann man sich höchstens temporär aussperren. AuthPredsInfo: Um eigene Veranstaltungen aus Sicht der Teilnehmer anzusehen, können Veranstalter und Korrektoren hier die Prüfung ihrer erweiterten Berechtigungen temporär deaktivieren. Abgewählte Prädikate schlagen immer fehl. Abgewählte Prädikate werden also nicht geprüft um Zugriffe zu gewähren, welche andernfalls nicht erlaubt wären. Diese Einstellungen gelten nur temporär bis Ihre Sitzung abgelaufen ist, d.h. bis ihr Browser-Cookie abgelaufen ist. Durch Abwahl von Prädikaten kann man sich höchstens temporär aussperren.
AuthPredsActive: Aktive Authorisierungsprädikate AuthPredsActive: Aktive Authorisierungsprädikate
AuthPredsActiveChanged: Authorisierungseinstellungen für aktuelle Sitzung gespeichert AuthPredsActiveChanged: Authorisierungseinstellungen für aktuelle Sitzung gespeichert
AuthTagFree: Seite ist universell zugänglich AuthTagFree: Seite ist universell zugänglich
AuthTagAdmin: Nutzer ist Administrator AuthTagAdmin: Nutzer ist Administrator
AuthTagExamOffice: Nutzer ist Teil eines Prüfungsamts
AuthTagToken: Nutzer präsentiert Authorisierungs-Token AuthTagToken: Nutzer präsentiert Authorisierungs-Token
AuthTagNoEscalation: Nutzer-Rechte werden nicht auf fremde Institute ausgeweitet AuthTagNoEscalation: Nutzer-Rechte werden nicht auf fremde Institute ausgeweitet
AuthTagDeprecated: Seite ist nicht überholt AuthTagDeprecated: Seite ist nicht überholt
@ -1089,6 +1146,7 @@ AuthTagRead: Zugriff ist nur lesend
AuthTagWrite: Zugriff ist i.A. schreibend AuthTagWrite: Zugriff ist i.A. schreibend
DeleteCopyStringIfSure n@Int: Wenn Sie sich sicher sind, dass Sie #{pluralDE n "das obige Objekt" "obige Objekte"} unwiderbringlich löschen möchten, schreiben Sie bitte zunächst den angezeigten Text ab. DeleteCopyStringIfSure n@Int: Wenn Sie sich sicher sind, dass Sie #{pluralDE n "das obige Objekt" "obige Objekte"} unwiderbringlich löschen möchten, schreiben Sie bitte zunächst den angezeigten Text ab.
DeletePressButtonIfSure n@Int: Wenn Sie sich sicher sind, dass Sie #{pluralDE n "das obige Objekt" "obige Objekte"} unwiderbringlich löschen möchten, bestätigen Sie dies bitte durch Drücken des untigen Knopfes.
DeleteConfirmation: Bestätigung DeleteConfirmation: Bestätigung
DeleteConfirmationWrong: Bestätigung muss genau dem angezeigten Text entsprechen. DeleteConfirmationWrong: Bestätigung muss genau dem angezeigten Text entsprechen.
@ -1101,10 +1159,14 @@ NavigationFavourites: Favoriten
CommSubject: Betreff CommSubject: Betreff
CommBody: Nachricht CommBody: Nachricht
CommBodyTip: Das Eingabefeld akzeptiert derzeit ausschließlich Html. U.A. Zeilumbrüche werden dementsprechend ignoriert und müssen manuell mit <br> eingefügt werden.
CommRecipients: Empfänger CommRecipients: Empfänger
CommRecipientsTip: Sie selbst erhalten immer eine Kopie der Nachricht CommRecipientsTip: Sie selbst erhalten immer eine Kopie der Nachricht
CommRecipientsList: Die an Sie selbst verschickte Kopie der Nachricht wird, zu Archivierungszwecken, eine vollständige Liste aller Empfänger enthalten. Die Empfängerliste wird im CSV-Format and die E-Mail angehängt. Andere Empfänger erhalten die Liste nicht. Bitte entfernen Sie dementsprechend den Anhang bevor Sie die E-Mail weiterleiten oder anderweitig mit Dritten teilen.
CommDuplicateRecipients n@Int: #{n} #{pluralDE n "doppelter" "doppelte"} Empfänger ignoriert CommDuplicateRecipients n@Int: #{n} #{pluralDE n "doppelter" "doppelte"} Empfänger ignoriert
CommSuccess n@Int: Nachricht wurde an #{n} Empfänger versandt CommSuccess n@Int: Nachricht wurde an #{n} Empfänger versandt
CommUndisclosedRecipients: Verborgene Empfänger
CommAllRecipients: alle-empfaenger
CommCourseHeading: Kursmitteilung CommCourseHeading: Kursmitteilung
CommTutorialHeading: Tutorium-Mitteilung CommTutorialHeading: Tutorium-Mitteilung
@ -1162,6 +1224,10 @@ SubmissionUserInvitationDeclined shn@SheetName: Sie haben die Einladung, Mitabge
SubmissionUserInviteHeading shn@SheetName: Einladung zu einer Abgabe für #{shn} SubmissionUserInviteHeading shn@SheetName: Einladung zu einer Abgabe für #{shn}
SubmissionUserInviteExplanation: Sie wurden eingeladen, Mitabgebende(r) bei einer Abgabe zu sein. SubmissionUserInviteExplanation: Sie wurden eingeladen, Mitabgebende(r) bei einer Abgabe zu sein.
ExamOfficeUserInviteHeading displayName@Text: Zugriff auf Ihre Prüfungsleistungen durch #{displayName}
ExamOfficeUserInviteExplanation: Um Ihre Prüfungsleistungen ordnungsgemäß anrechnen zu können (z.B. im finalen Transcript of Records für Erasmus-Studierende) werden sie eingeladen der hierfür zuständigen Stelle Einsicht zu gewähren.
ExamOfficeUserInvitationAccepted: Einsicht erfolgreich gewährt
InvitationAction: Aktion InvitationAction: Aktion
InvitationActionTip: Abgelehnte Einladungen können nicht mehr angenommen werden InvitationActionTip: Abgelehnte Einladungen können nicht mehr angenommen werden
InvitationMissingRestrictions: Authorisierungs-Token fehlen benötigte Daten InvitationMissingRestrictions: Authorisierungs-Token fehlen benötigte Daten
@ -1246,6 +1312,9 @@ HealthSMTPConnect: SMTP-Server kann erreicht werden
HealthWidgetMemcached: Memcached-Server liefert Widgets korrekt aus HealthWidgetMemcached: Memcached-Server liefert Widgets korrekt aus
HealthActiveJobExecutors: Anteil der job-workers, die neue Befehle annehmen HealthActiveJobExecutors: Anteil der job-workers, die neue Befehle annehmen
CourseParticipantsHeading: Kursteilnehmer
CourseParticipantsCount n@Int: #{n}
CourseParticipantsCountOf n@Int m@Int: #{n} von #{m}
CourseParticipants n@Int: Derzeit #{n} angemeldete Kursteilnehmer CourseParticipants n@Int: Derzeit #{n} angemeldete Kursteilnehmer
CourseParticipantsInvited n@Int: #{n} #{pluralDE n "Einladung" "Einladungen"} per E-Mail verschickt CourseParticipantsInvited n@Int: #{n} #{pluralDE n "Einladung" "Einladungen"} per E-Mail verschickt
CourseParticipantsAlreadyRegistered n@Int: #{n} Teilnehmer #{pluralDE n "ist" "sind"} bereits angemeldet CourseParticipantsAlreadyRegistered n@Int: #{n} Teilnehmer #{pluralDE n "ist" "sind"} bereits angemeldet
@ -1283,35 +1352,48 @@ ExamPublishOccurrenceAssignments: Termin- bzw. Raumzuteilung den Teilnehmern mit
ExamPublishOccurrenceAssignmentsTip: Ab diesem Zeitpunkt Teilnehmer einsehen zu welcher Teilprüfung bzw. welchen Raum sie angemeldet sind ExamPublishOccurrenceAssignmentsTip: Ab diesem Zeitpunkt Teilnehmer einsehen zu welcher Teilprüfung bzw. welchen Raum sie angemeldet sind
ExamPublishOccurrenceAssignmentsParticipant: Termin- bzw. Raumzuteilung einsehbar ab ExamPublishOccurrenceAssignmentsParticipant: Termin- bzw. Raumzuteilung einsehbar ab
ExamFinished: Bewertung abgeschlossen ab ExamFinished: Bewertung abgeschlossen ab
ExamFinishedOffice: Noten bekannt gegeben
ExamFinishedParticipant: Bewertung vorrausichtlich abgeschlossen ExamFinishedParticipant: Bewertung vorrausichtlich abgeschlossen
ExamFinishedTip: Zeitpunkt zu dem Prüfungergebnisse den Teilnehmern gemeldet werden ExamFinishedTip: Zeitpunkt zu dem Prüfungergebnisse den Teilnehmern gemeldet werden
ExamClosed: Noten stehen fest ab ExamClosed: Noten gemeldet
ExamClosedTip: Zeitpunkt ab dem keine Änderungen an den Ergebnissen zulässig sind; Prüfungsämter bekommen Einsicht ExamClosedTip: Prüfungsämter, die im System Noten einsehen, werden zu diesem Zeitpunkt benachrichtigt und danach bei Änderungen informiert
ExamShowGrades: Noten anzeigen ExamShowGrades: Klausur ist benotet
ExamShowGradesTip: Soll den Teilnehmern ihre genaue Note angezeigt werden, oder sollen sie nur informiert werden, ob sie bestanden haben? ExamShowGradesTip: Sollen genaue Noten angezeigt werden, oder sollen Teilnehmer und Prüfungsämter nur informiert werden, ob die Klausur bestanden wurde?
ExamPublicStatistics: Statistik veröffentlichen ExamPublicStatistics: Statistik veröffentlichen
ExamPublicStatisticsTip: Soll die statistische Auswertung auch den Teilnehmer angezeigt werden, sobald diese ihre Noten einsehen können? ExamPublicStatisticsTip: Soll die automatisch berechnete statistische Auswertung auch den Teilnehmern angezeigt werden, sobald diese ihre Noten einsehen können?
ExamAutomaticGrading: Automatische Notenberechnung
ExamAutomaticGradingTip: Sollen die Gesamtleistungen der Teilnehmer automatisch aus den in den einzelnen Teilprüfungen erreichten Leistungen berechnet werden? Etwaige Bonuspunkte werden dabei berücksichtigt. Manuelles Überschreiben der Gesamtleistung ist dennoch möglich.
ExamGradingRule: Notenberechnung ExamGradingRule: Notenberechnung
ExamGradingManual': Keine automatische Berechnung ExamGradingManual': Keine automatische Berechnung
ExamGradingKey': Nach Schlüssel ExamGradingKey': Nach Schlüssel
ExamGradingKey: Notenschlüssel ExamGradingKey: Notenschlüssel
ExamGradingKeyTip: Die Grenzen beziehen sich auf die effektive Maximalpunktzahl, nachdem etwaige Bonuspunkte aus dem Übungsbetrieb angerechnet und die Ergebnise der Teilaufgaben mit ihrem Gewicht multipliziert wurden ExamGradingKeyTip: Die Grenzen beziehen sich auf die effektive Maximalpunktzahl, nachdem etwaige Bonuspunkte aus dem Übungsbetrieb angerechnet und die Ergebnise der Teilprüfungen mit ihrem Gewicht multipliziert wurden
Points: Punkte Points: Punkte
PointsMustBeNonNegative: Punktegrenzen dürfen nicht negativ sein PointsMustBeNonNegative: Punktegrenzen dürfen nicht negativ sein
PointsMustBeMonotonic: Punktegrenzen müssen aufsteigend sein PointsMustBeMonotonic: Punktegrenzen müssen aufsteigend sein
GradingFrom: Ab GradingFrom: Ab
ExamNew: Neue Prüfung ExamNew: Neue Prüfung
ExamBonus: Bonuspunkte-System
ExamBonusRule: Prüfungsbonus aus Übungsbetrieb ExamBonusRule: Prüfungsbonus aus Übungsbetrieb
ExamNoBonus': Kein automatischer Bonus ExamNoBonus': Kein automatischer Bonus
ExamBonusPoints': Umrechnung von Übungspunkten ExamBonusPoints': Umrechnung von Übungspunkten
ExamBonusManual': Manuelle Berechnung
ExamBonusAchieved: Bonuspunkte
ExamEditHeading examn@ExamName: #{examn} bearbeiten ExamEditHeading examn@ExamName: #{examn} bearbeiten
ExamBonusMaxPoints: Maximal erreichbare Prüfungs-Bonuspunkte ExamBonusMaxPoints: Maximal erreichbare Prüfungs-Bonuspunkte
ExamBonusMaxPointsTip: Bonuspunkte werden, anhand der erreichten Übungspunkte bzw. der Anzahl von bestandenen Übungsblättern, linear zwischen null und der angegebenen Schranke interpoliert.
ExamBonusMaxPointsNonPositive: Maximaler Prüfungsbonus muss positiv und größer null sein ExamBonusMaxPointsNonPositive: Maximaler Prüfungsbonus muss positiv und größer null sein
ExamBonusOnlyPassed: Bonus nur nach Bestehen anrechnen ExamBonusOnlyPassed: Bonus nur nach Bestehen anrechnen
ExamBonusRound: Bonus runden auf
ExamBonusRoundNonPositive: Vielfaches, auf das gerundet werden soll, muss positiv und größer null sein
ExamBonusRoundTip: Bonuspunkte werden kaufmännisch auf ein Vielfaches der angegeben Zahl gerundet.
ExamOccurrenceRule: Automatische Termin- bzw. Raumzuteilung ExamAutomaticOccurrenceAssignment: Automatische Termin- bzw. Raumzuteilung
ExamAutomaticOccurrenceAssignmentTip: Sollen Prüfungsteilnehmer zum Zeitpunkt der Bekanntgabe der Raum- bzw. Terminzuteilung automatisch auf die zur Verfügung stehenden Räume bzw. Termine verteilt werden? Manuelle Umverteilung bzw. vorheriges Festlegen von Zuteilungen einzelner Teilnehmer ist trotzdem möglich.
ExamOccurrenceRule: Verfahren
ExamOccurrenceRuleParticipant: Termin- bzw. Raumzuteilungsverfahren ExamOccurrenceRuleParticipant: Termin- bzw. Raumzuteilungsverfahren
ExamRoomManual': Keine automatische Zuteilung ExamRoomManual': Keine automatische Zuteilung
ExamRoomSurname': Nach Nachname ExamRoomSurname': Nach Nachname
@ -1334,6 +1416,8 @@ ExamRoomDescription: Beschreibung
ExamTimeTip: Nur zur Information der Studierenden, die tatsächliche Zeitangabe erfolgt pro Prüfung ExamTimeTip: Nur zur Information der Studierenden, die tatsächliche Zeitangabe erfolgt pro Prüfung
ExamRoomRegistered: Zugeteilt ExamRoomRegistered: Zugeteilt
ExamOccurrenceStart: Prüfungsbeginn
ExamFormTimes: Zeiten ExamFormTimes: Zeiten
ExamFormOccurrences: Prüfungstermine/Räume ExamFormOccurrences: Prüfungstermine/Räume
ExamFormAutomaticFunctions: Automatische Funktionen ExamFormAutomaticFunctions: Automatische Funktionen
@ -1343,12 +1427,17 @@ ExamFormParts: Teile
ExamCorrectors: Korrektoren ExamCorrectors: Korrektoren
ExamCorrectorAlreadyAdded: Ein Korrektor mit dieser E-Mail ist bereits für diese Prüfung eingetragen ExamCorrectorAlreadyAdded: Ein Korrektor mit dieser E-Mail ist bereits für diese Prüfung eingetragen
ExamParts: Teilaufgaben ExamParts: Teilprüfungen/Aufgaben
ExamPartWeightNegative: Gewicht aller Teilaufgaben muss größer oder gleich Null sein ExamPartWeightNegative: Gewicht aller Teilprüfungen muss größer oder gleich Null sein
ExamPartAlreadyExists: Teilaufgabe mit diesem Namen existiert bereits ExamPartAlreadyExists: Teilprüfung mit diesem Namen existiert bereits
ExamPartName: Name ExamPartNumber: Nummer
ExamPartNumbered examPartNumber@ExamPartNumber: Teil #{view _ExamPartNumber examPartNumber}
ExamPartNumberTip: Wird als interne Bezeichnung z.B. bei CSV-Export verwendet
ExamPartName: Titel
ExamPartNameTip: Wird den Studierenden angezeigt
ExamPartMaxPoints: Maximalpunktzahl ExamPartMaxPoints: Maximalpunktzahl
ExamPartWeight: Gewichtung ExamPartWeight: Gewichtung
ExamPartWeightTip: Wird vor Anzeige oder Notenberechnung mit der erreichten Punktzahl und der Maximalpunktzahl multipliziert; Änderungen hier passen auch bestehende Korrekturergebnisse an
ExamPartResultPoints: Erreichte Punkte ExamPartResultPoints: Erreichte Punkte
ExamNameTaken exam@ExamName: Es existiert bereits eine Prüfung mit Namen #{exam} ExamNameTaken exam@ExamName: Es existiert bereits eine Prüfung mit Namen #{exam}
@ -1358,6 +1447,7 @@ ExamEdited exam@ExamName: #{exam} erfolgreich bearbeitet
ExamNoShow: Nicht erschienen ExamNoShow: Nicht erschienen
ExamVoided: Entwertet ExamVoided: Entwertet
ExamBonusManualParticipants: Von den Kursverwaltern manuell berechnet
ExamBonusPoints possible@Points: Maximal #{showFixed True possible} Prüfungspunkte ExamBonusPoints possible@Points: Maximal #{showFixed True possible} Prüfungspunkte
ExamBonusPointsPassed possible@Points: Maximal #{showFixed True possible} Prüfungspunkte, falls die Prüfung auch ohne Bonus bereits bestanden ist ExamBonusPointsPassed possible@Points: Maximal #{showFixed True possible} Prüfungspunkte, falls die Prüfung auch ohne Bonus bereits bestanden ist
@ -1391,11 +1481,30 @@ VersionHistory: Versionsgeschichte
KnownBugs: Bekannte Bugs KnownBugs: Bekannte Bugs
ImplementationDetails: Implementierung ImplementationDetails: Implementierung
ExamSynchronised: Synchronisiert
ExamUsersHeading: Prüfungsteilnehmer ExamUsersHeading: Prüfungsteilnehmer
ExamUserDeregister: Teilnehmer von Prüfung abmelden ExamUserDeregister: Teilnehmer von Prüfung abmelden
ExamUserAssignOccurrence: Termin/Raum zuweisen ExamUserAssignOccurrence: Termin/Raum zuweisen
ExamUserAcceptComputedResult: Berechnetes Prüfungsergebnis übernehmen
ExamUserResetToComputedResult: Prüfungsergebnis zurücksetzen
ExamUserResetBonus: Auch Bonuspunkte zurücksetzen
ExamUsersDeregistered count@Int64: #{show count} Teilnehmer von der Prüfung abgemeldet ExamUsersDeregistered count@Int64: #{show count} Teilnehmer von der Prüfung abgemeldet
ExamUsersOccurrenceUpdated count@Int64: Termin/Raum für #{show count} Teilnehmer gesetzt ExamUsersOccurrenceUpdated count@Int64: Termin/Raum für #{show count} Teilnehmer gesetzt
ExamUsersResultsAccepted count@Int64: Prüfungsergebnis für #{show count} Teilnehmer übernommen
ExamUsersResultsReset count@Int64: Prüfungsergebnis für #{show count} Teilnehmer zurückgesetzt
ExamUserSynchronised: Synchronisiert
ExamUserSyncOfficeName: Name
ExamUserSyncTime: Zeitpunkt
ExamUserSyncSchools: Institute
ExamUserSyncLastChange: Zuletzt geändert
ExamUserMarkSynchronised: Prüfungsleistung als synchronisiert markieren
ExamUserMarkSynchronisedCsv: Prüfungsleistungen beim Export als synchronisiert markieren
ExamUserMarkedSynchronised n@Int: #{n} #{pluralDE n "Prüfungsleistung" "Prüfungsleistungen"} als synchronisiert markiert
ExamOfficeExamUsersHeading: Prüfungsleistungen
CsvFile: CSV-Datei CsvFile: CSV-Datei
CsvModifyExisting: Existierende Einträge angleichen CsvModifyExisting: Existierende Einträge angleichen
@ -1415,8 +1524,12 @@ CsvImportExplanationLabel: Hinweise zum CSV-Import
Proportion c@Text of@Text prop@Rational: #{c}/#{of} (#{rationalToFixed2 (100 * prop)}%) Proportion c@Text of@Text prop@Rational: #{c}/#{of} (#{rationalToFixed2 (100 * prop)}%)
CsvColumnsExplanationsLabel: Spalten CourseUserCsvName tid@TermId ssh@SchoolId csh@CourseShorthand: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-teilnehmer
CsvColumnsExplanationsTip: Bedeutung der in der CSV-Datei enthaltenen Spalten ExamUserCsvName tid@TermId ssh@SchoolId csh@CourseShorthand examn@ExamName: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase examn}-teilnehmer
CourseApplicationsTableCsvName tid@TermId ssh@SchoolId csh@CourseShorthand: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-bewerbungen
CsvColumnsExplanationsLabel: Spalten- & Zellenformat
CsvColumnsExplanationsTip: Bedeutung und Format der in der CSV-Datei enthaltenen Spalten
CsvColumnExamUserSurname: Nachname(n) des Teilnehmers CsvColumnExamUserSurname: Nachname(n) des Teilnehmers
CsvColumnExamUserFirstName: Vorname(n) des Teilnehmers CsvColumnExamUserFirstName: Vorname(n) des Teilnehmers
CsvColumnExamUserName: Voller Name des Teilnehmers (gewöhnlicherweise inkl. Vor- und Nachname(n)) CsvColumnExamUserName: Voller Name des Teilnehmers (gewöhnlicherweise inkl. Vor- und Nachname(n))
@ -1429,8 +1542,22 @@ CsvColumnExamUserExercisePoints: Anzahl von Punkten, die der Teilnehmer im Übun
CsvColumnExamUserExercisePointsMax: Maximale Anzahl von Punkten, die der Teilnehmer im Übungsbetrieb bis zu seinem Prüfungstermin erreichen hätte können CsvColumnExamUserExercisePointsMax: Maximale Anzahl von Punkten, die der Teilnehmer im Übungsbetrieb bis zu seinem Prüfungstermin erreichen hätte können
CsvColumnExamUserExercisePasses: Anzahl von Übungsblättern, die der Teilnehmer bestanden hat CsvColumnExamUserExercisePasses: Anzahl von Übungsblättern, die der Teilnehmer bestanden hat
CsvColumnExamUserExercisePassesMax: Maximale Anzahl von Übungsblättern, die der Teilnehmer bis zu seinem Prüfungstermin bestehen hätte können CsvColumnExamUserExercisePassesMax: Maximale Anzahl von Übungsblättern, die der Teilnehmer bis zu seinem Prüfungstermin bestehen hätte können
CsvColumnExamUserBonus: Anzurechnende Bonuspunkte
CsvColumnExamUserParts: Erreichte Punktezahlen in den Teilprüfungen, sofern vorhanden; eine Spalte pro Teilprüfung
CsvColumnExamUserResult: Erreichte Prüfungsleistung; "passed", "failed", "no-show", "voided", oder eine Note ("1.0", "1.3", "1.7", ..., "4.0", "5.0") CsvColumnExamUserResult: Erreichte Prüfungsleistung; "passed", "failed", "no-show", "voided", oder eine Note ("1.0", "1.3", "1.7", ..., "4.0", "5.0")
CsvColumnExamUserCourseNote: Notizen zum Teilnehmer CsvColumnExamUserCourseNote: Notizen zum Teilnehmer
CsvColumnUserName: Voller Name des Teilnehmers
CsvColumnUserMatriculation: Matrikelnummer des Teilnehmers
CsvColumnUserEmail: E-Mail Addresse des Teilnehmers
CsvColumnUserField: Studienfach, mit dem der Teilnehmer seine Kursanmeldung assoziiert hat
CsvColumnUserDegree: Abschluss, den der Teilnehmer im assoziierten Studienfach anstrebt
CsvColumnUserSemester: Fachsemester des Teilnehmers im assoziierten Studienfach
CsvColumnUserRegistration: Zeitpunkt der Anmeldung zum Kurs (ISO 8601)
CsvColumnUserNote: Notizen zum Teilnehmer
CsvColumnExamOfficeExamUserOccurrenceStart: Prüfungstermin (ISO 8601)
CsvColumnApplicationsAllocation: Zentralanmeldung über die die Bewerbung eingegangen ist CsvColumnApplicationsAllocation: Zentralanmeldung über die die Bewerbung eingegangen ist
CsvColumnApplicationsApplication: Eindeutige Nummer der Bewerbung (zur Zuordnung im ZIP-Archiv aller Bewerbungsdateien) CsvColumnApplicationsApplication: Eindeutige Nummer der Bewerbung (zur Zuordnung im ZIP-Archiv aller Bewerbungsdateien)
CsvColumnApplicationsName: Voller Name des Bewerbers CsvColumnApplicationsName: Voller Name des Bewerbers
@ -1441,7 +1568,7 @@ CsvColumnApplicationsSemester: Fachsemester des Bewerbes im assoziierten Studien
CsvColumnApplicationsText: Text-Bewerbung CsvColumnApplicationsText: Text-Bewerbung
CsvColumnApplicationsHasFiles: Hat der Bewerber Dateien zu seiner Bewerbung eingereicht (siehe ZIP-Archiv aller Bewerbungsdateien)? CsvColumnApplicationsHasFiles: Hat der Bewerber Dateien zu seiner Bewerbung eingereicht (siehe ZIP-Archiv aller Bewerbungsdateien)?
CsvColumnApplicationsVeto: Bewerber mit Veto werden garantiert nicht dem Kurs zugeteilt; "veto" oder leer CsvColumnApplicationsVeto: Bewerber mit Veto werden garantiert nicht dem Kurs zugeteilt; "veto" oder leer
CsvColumnApplicationsRating: Bewertung der Bewerbung; "1.0", "1.3", "1.7", ..., "4.0", "5.0" CsvColumnApplicationsRating: Bewertung der Bewerbung; "1.0", "1.3", "1.7", ..., "4.0", "5.0" (Leer wird behandelt wie eine Note zwischen 2.3 und 2.7)
CsvColumnApplicationsComment: Kommentar zur Bewerbung; je nach Kurs-Einstellungen entweder nur als Notiz für die Kursverwalter oder Feedback für den Bewerber CsvColumnApplicationsComment: Kommentar zur Bewerbung; je nach Kurs-Einstellungen entweder nur als Notiz für die Kursverwalter oder Feedback für den Bewerber
Action: Aktion Action: Aktion
@ -1457,8 +1584,13 @@ ExamUserCsvRegister: Kursteilnehmer zur Prüfung anmelden
ExamUserCsvAssignOccurrence: Teilnehmern einen anderen Termin/Raum zuweisen ExamUserCsvAssignOccurrence: Teilnehmern einen anderen Termin/Raum zuweisen
ExamUserCsvDeregister: Teilnehmer von der Prüfung abmelden ExamUserCsvDeregister: Teilnehmer von der Prüfung abmelden
ExamUserCsvSetCourseField: Kurs-assoziiertes Studienfach ändern ExamUserCsvSetCourseField: Kurs-assoziiertes Studienfach ändern
ExamUserCsvOverrideBonus: Bonuspunkte entgegen Bonusregelung überschreiben
ExamUserCsvOverrideResult: Ergebnis entgegen automatischer Notenberechnung überschreiben
ExamUserCsvSetBonus: Bonuspunkte eintragen
ExamUserCsvSetResult: Ergebnis eintragen ExamUserCsvSetResult: Ergebnis eintragen
ExamUserCsvSetPartResult: Ergebnis einer Teilprüfung eintragen
ExamUserCsvSetCourseNote: Teilnehmer-Notizen anpassen ExamUserCsvSetCourseNote: Teilnehmer-Notizen anpassen
ExamBonusNone: Keine Bonuspunkte
ExamUserCsvCourseNoteDeleted: Notiz wird gelöscht ExamUserCsvCourseNoteDeleted: Notiz wird gelöscht
@ -1530,7 +1662,10 @@ AllocationAppliedCourses: Bewerbungen
AllocationNumCoursesAvailableApplied available@Int applied@Int: Sie haben sich bisher für #{applied}/#{available} #{pluralDE applied "Kurs" "Kursen"} beworben AllocationNumCoursesAvailableApplied available@Int applied@Int: Sie haben sich bisher für #{applied}/#{available} #{pluralDE applied "Kurs" "Kursen"} beworben
AllocationTitle termText@Text ssh'@SchoolShorthand allocation@AllocationName: #{termText} - #{ssh'}: #{allocation} AllocationTitle termText@Text ssh'@SchoolShorthand allocation@AllocationName: #{termText} - #{ssh'}: #{allocation}
AllocationShortTitle termText@Text ssh'@SchoolShorthand ash@AllocationShorthand: #{termText} - #{ssh'} - #{ash} AllocationShortTitle termText@Text ssh'@SchoolShorthand ash@AllocationShorthand: #{termText} - #{ssh'} - #{ash}
AllocationSchool: Institut
AllocationSemester: Semester
AllocationDescription: Beschreibung AllocationDescription: Beschreibung
AllocationStaffDescription: Beschreibung für Dozenten
AllocationStaffRegisterFrom: Eintragung der Kurse ab AllocationStaffRegisterFrom: Eintragung der Kurse ab
AllocationStaffRegister: Eintragung der Kurse AllocationStaffRegister: Eintragung der Kurse
AllocationRegisterFrom: Bewerbung ab AllocationRegisterFrom: Bewerbung ab
@ -1539,6 +1674,13 @@ AllocationRegisterClosed: Die Zentralanmeldung ist aktuell geschlossen.
AllocationRegisterOpensIn difftime@Text: Die Zentralanmeldung öffnet voraussichtlich in #{difftime} AllocationRegisterOpensIn difftime@Text: Die Zentralanmeldung öffnet voraussichtlich in #{difftime}
AllocationStaffAllocationFrom: Bewertung der Bewerbungen ab AllocationStaffAllocationFrom: Bewertung der Bewerbungen ab
AllocationStaffAllocation: Bewertung der Bewerbungen AllocationStaffAllocation: Bewertung der Bewerbungen
AllocationRegisterByStaff: An- und Abmeldung durch Kursverwalter
AllocationRegisterByStaffFrom: An- und Abmeldung durch Kursverwalter ab
AllocationRegisterByStaffTip: In diesem Zeitraum können Kursverwalter Teilnehmer zu und von ihren Kursen an- und abmelden.
AllocationRegisterByStaffFromTip: Ab diesem Zeitpunkt können Kursverwalter Teilnehmer zu und von ihren Kursen an- und abmelden.
AllocationRegisterByCourseFrom: Direkte An- und Abmeldung ab
AllocationRegisterByCourseFromTip: Frühestens ab diesem Zeitpunkt ist die eigentständige An- und Abmeldung zu und von den Kursen, die an der Zentralanmeldung teilnehmen, möglich. Kontrolle über die genauen Fristen haben die Kursverwalter.
AllocationOverrideDeregister: Abmeldung von den Kursen nur bis
AllocationProcess: Platzvergabe AllocationProcess: Platzvergabe
AllocationNoApplication: Keine Bewerbung AllocationNoApplication: Keine Bewerbung
AllocationPriority: Priorität AllocationPriority: Priorität
@ -1586,9 +1728,16 @@ CourseApplicationNoVeto: Kein Veto
CourseApplicationNoRatingPoints: Keine Bewertung CourseApplicationNoRatingPoints: Keine Bewertung
CourseApplicationNoRatingComment: Kein Kommentar CourseApplicationNoRatingComment: Kein Kommentar
UserDisplayName: Voller Name UserDisplayName: Angezeigter Name
UserDisplayNameInvalid: Angezeigter Name erfüllt nicht die Vorgaben
UserDisplayNameRules: Vorgaben für den angezeigten Namen
UserDisplayNameRulesBelow: Vorgaben für den angezeigten Namen finden sich weiter unten auf der Seite
UserMatriculation: Matrikelnummer UserMatriculation: Matrikelnummer
UserDisplayEmail: Angezeigte E-Mail Adresse
UserDisplayEmailTip: Diese Adresse wird in öffentlich zugänglichen Teilen des Systems im Zusammenhang mit Ihrem Namen angezeigt. Benachrichtigungen und andere Kommunikation von Uni2work und Nutzern mit erweiterten Rechten erhalten sie stets, unabhängig von dieser Einstellung, an die in Ihren Persönlichen Daten hinterlegte primäre Adresse.
UserDisplayEmailChangeSent displayEmail@UserEmail: Anweisungen zum Ändern der angezeigten E-Mail Adresse wurden an „#{displayEmail}” versandt
SchoolShort: Kürzel SchoolShort: Kürzel
SchoolName: Name SchoolName: Name
SchoolLdapOrganisations: Assoziierte LDAP-Fragmente SchoolLdapOrganisations: Assoziierte LDAP-Fragmente
@ -1629,4 +1778,142 @@ MailAllocationUnratedApplications: Für die unten aufgeführten Kurse liegen Bew
MailSubjectAllocationOutdatedRatings allocation@AllocationName: Bereits bewertete Bewerbungen für ihre Kurse in der Zentralanmeldung „#{allocation}“ haben sich geändert MailSubjectAllocationOutdatedRatings allocation@AllocationName: Bereits bewertete Bewerbungen für ihre Kurse in der Zentralanmeldung „#{allocation}“ haben sich geändert
MailAllocationOutdatedRatings: Für die unten aufgeführten Kurse liegen Bewerbungen vor, die im Rahmen der Zentralanmeldung an den jeweiligen Kurs gestellt wurden, die sich verändert haben, seit sie zuletzt bewertet wurden. MailAllocationOutdatedRatings: Für die unten aufgeführten Kurse liegen Bewerbungen vor, die im Rahmen der Zentralanmeldung an den jeweiligen Kurs gestellt wurden, die sich verändert haben, seit sie zuletzt bewertet wurden.
MailAllocationOutdatedRatingsWarning: Bewerbungen deren Bewertung veraltet ist (d.h. die Bewerbung wurde nach der Bewertung verändert) zählen als nicht bewertet. MailAllocationOutdatedRatingsWarning: Bewerbungen deren Bewertung veraltet ist (d.h. die Bewerbung wurde nach der Bewertung verändert) zählen als nicht bewertet.
ExamOfficeSubscribedUsers: Benutzer
ExamOfficeSubscribedUsersTip: Sie können mehrere Matrikelnummern mit Komma separieren
ExamOfficeSubscribedUsersExplanation: Für hier angegebene Benutzer können Sie (ungeachtet der Fächer des Studierenden) stets sämtliche Prüfungsergebnisse einsehen.
ExamOfficeSubscribedFieldsExplanation: Sie können für alle Benutzer, die mindestens eines der angegeben Studienfächer studieren, sämtliche Prüfungsergebnisse einsehen. Sie haben zusätzlich die Möglichkeit anzugeben, ob es den Benutzern gestattet sein soll, dieser Einsicht im Einzelfall (pro Kurs) zu widersprechen.
UserMatriculationNotFound matriculation@Text: Es existiert kein Uni2work-Benutzer mit Matrikelnummer „#{matriculation}“
UserMatriculationAmbiguous matriculation@Text: Matrikelnummer „#{matriculation}“ ist nicht eindeutig
TransactionExamOfficeUsersUpdated nDeleted@Int nAdded@Int: #{nAdded} Benutzer hinzugefügt, #{nDeleted} Benutzer gelöscht
TransactionExamOfficeFieldsUpdated nUpdates@Int: #{nUpdates} #{pluralDE nUpdates "Studienfach" "Studienfächer"} angepasst
ExamOfficeFieldNotSubscribed: —
ExamOfficeFieldSubscribed: Einsicht
ExamOfficeFieldForced: Forcierte Einsicht
InvalidExamOfficeFieldMode parseErr@Text: Konnte „#{parseErr}“ nicht interpretieren
LdapIdentification: Campus-Kennung
LdapIdentificationOrEmail: Campus-Kennung/E-Mail Addresse
AdminUserTitle: Titel
AdminUserFirstName: Vorname
AdminUserSurname: Nachname
AdminUserDisplayName: Anzeige-Name
AdminUserEmail: E-Mail Addresse
AdminUserDisplayEmail: Anzeige-E-Mail
AdminUserIdent: Identifikation
AdminUserAuth: Authentifizierung
AdminUserMatriculation: Matrikelnummer
AuthKindLDAP: Campus-Kennung
AuthKindPWHash: Uni2work-Kennung
UserAdded: Benutzer erfolgreich angelegt
UserCollision: Benutzer konnte wegen Eindeutigkeit nicht angelegt werden
CourseAllocationsBounds n@Int: Voraussichtliche Zuteilungen durch #{pluralDE n "Zentralanmeldung" "Zentralanmeldungen"}
CourseAllocationsBoundCoincide numFirstChoice@Int: Vstl. #{numFirstChoice} Teilnehmer
CourseAllocationsBound numApps@Int numFirstChoice@Int: Vstl. zwischen #{numFirstChoice} und #{numApps} Teilnehmer
CourseAllocationsBoundCapped: Die obige Anzeige wurde durch die aktuell angegebene Kurskapazität reduziert.
CourseAllocationsBoundWarningOpen: Diese Informationen entsprechen nur dem aktuellen Stand der Bewerbungen und können sich noch ändern.
BtnSetDisplayEmail: E-Mail Adresse setzen
UserDisplayEmailChanged: Öffentliche E-Mail Adresse erfolgreich gesetzt
TitleChangeUserDisplayEmail: Öffentliche E-Mail Adresse setzen
MailSubjectChangeUserDisplayEmail: Diese E-Mail Adresse in Uni2work veröffentlichen
MailIntroChangeUserDisplayEmail displayEmail@UserEmail: Der oben genannte Benutzer möchte „#{displayEmail}“ als öffentliche Adresse, assoziiert mit sich selbst, angeben. Wenn Sie diese Aktion nicht selbst ausgelöst haben, ignorieren Sie diese Mitteilung bitte!
MailTitleChangeUserDisplayEmail displayName@Text: #{displayName} möchte diese E-Mail Adresse in Uni2work veröffentlichen
ExamOfficeOptOutsChanged: Zuständige Prüfungsämter erfolgreich angepasst
BtnCloseExam: Klausur abschließen
ExamCloseTip: Wenn eine Klausur abgeschlossen wird, werden Prüfungsämter, die im System Noten einsehen, benachrichtigt und danach bei Änderungen informiert.
ExamCloseReminder: Bitte schließen Sie die Klausur frühstmöglich, sobald die Prüfungsleistungen sich voraussichtlich nicht mehr ändern werden. Z.B. direkt nach der Klausureinsicht.
ExamDidClose: Klausur erfolgreich abgeschlossen
ExamClosedSince time@Text: Klausur abgeschlossen seit #{time}
LecturerInfoTooltipNew: Neues Feature
LecturerInfoTooltipProblem: Feature mit bekannten Problemen
LecturerInfoTooltipPlanned: Geplantes Feature
LecturerInfoTooltipNewU2W: Unterschied zu UniWorX
BtnAcceptApplications: Bewerbungen akzeptieren
BtnAcceptApplicationsTip: Mit dem untigen Knopf können Sie den Kurs (höchstens bis zur angegeben Maximalkapazität, falls eingestellt) mit Bewerbern auffüllen. Die Bewertungen der Bewerbungen werden dabei berücksichtigt (Unbewertet wird behandelt wie eine Note zwischen 2.3 und 2.7). Bewerber mit Veto oder 5.0 werden nicht angemeldet.
AcceptApplicationsMode: Bewerbungen akzeptieren
AcceptApplicationsModeTip: Sollen akzeptierte Bewerber direkt als Teilnehmer im Kurs eingetragen werden oder sollen Einladungen per E-Mail verschickt werden?
AcceptApplicationsDirect: Direkt anmelden
AcceptApplicationsInvite: Einladungen verschicken
AcceptApplicationsSecondary: Gleichstände auflösen
AcceptApplicationsSecondaryTip: Wenn es im Laufe des Verfahrens mehrere Bewerber mit der selben Bewertung für den selben Platz gibt, wie soll der Gleichstand aufgelöst werden?
AcceptApplicationsSecondaryRandom: Zufällig
AcceptApplicationsSecondaryTime: Nach Zeitpunkt der Bewerbung
CsvOptions: CSV-Optionen
CsvOptionsTip: Diese Einstellungen betreffen nur den CSV-Export; beim Import werden die verwendeten Einstellungen automatisch ermittelt.
CsvPresetRFC: Standard-Konform (RFC 4180)
CsvPresetExcel: Excel-Kompatibel
CsvCustom: Benutzerdefiniert
CsvDelimiter: Trennzeichen
CsvUseCrLf: Zeilenumbrüche
CsvQuoting: Quoting
CsvQuotingTip: Wann sollen Anführungszeichen (") um Felder platziert werden, um Interpretation von im Feld enthaltenen Zeichen als Trennzeichen zu verhindern?
CsvDelimiterNull: Null-Byte
CsvDelimiterTab: Tabulator
CsvDelimiterComma: Komma
CsvDelimiterColon: Doppelpunkt
CsvDelimiterBar: Senkrechter Strich
CsvDelimiterSpace: Leerzeichen
CsvDelimiterUnitSep: Teilgruppentrennzeichen
CsvCrLf: DOS (CRLF)
CsvLf: Unix (LF)
CsvQuoteNone: Nie
CsvQuoteMinimal: Nur wenn nötig
CsvQuoteAll: Immer
CsvOptionsUpdated: CSV-Optionen erfolgreich angepasst
CsvChangeOptionsLabel: Export-Optionen
CourseNews: Aktuelles
CourseNewsArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand newsTitle@Text: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldCase newsTitle}
CourseNewsFiles: Dateien
CourseNewsLastEdited time@Text: Zuletzt verändert: #{time}
CourseNewsActionEdit: Bearbeiten
CourseNewsActionDelete: Löschen
CourseNewsActionCreate: Neue Nachricht
CourseMaterial: Material
CourseMaterialFree: Das Kursmaterial ist ohne Anmeldung frei zugänglich
CourseMaterialNotFree: Eine Anmeldung zum Kurs ist Voraussetzung zum Zugang zu Kursmaterial
CourseNewsVisibleFromEditWarning: Das Datum der Veröffentlichung liegt in der Vergangenheit und sollte nicht mehr verändert werden, da dies die Teilnehmer verwirren könnte.
CourseNewsVisibleFromTip: Ohne Datum nie sichtbar für Teilnehmer; leer lassen ist nur sinnvoll für noch unfertige Nachrichten
CourseNewsTitle: Titel
CourseNewsSummary: Zusammenfassung
CourseNewsSummaryTip: Wenn angegeben, wird auf der Kursübersichtsseite, platzsparend, nur die Zusammenfassung angezeigt und der Inhalt in ein Popup ausgelagert
CourseNewsContent: Inhalt
CourseNewsParticipantsOnly: Nur für Kursteilnehmer
CourseNewsVisibleFrom: Sichtbar ab
CourseNewsCreated: Kursnachricht erfolgreich angelegt
CourseNewsEdited: Kursnachricht erfolgreich editiert
CourseNewsDeleteQuestion: Wollen Sie die unten aufgeführte Nachricht wirklich löschen?
CourseNewsDeleted: Kursnachricht erfolgreich gelöscht
CourseDeregistrationAllocationLog: Ihr Platz in diesem Kurs stammt aus einer Zentralanmeldung. Wenn Sie sich vom Kurs abmelden wird dieser Umstand permanent im System gespeichert und kann Sie u.U. bei zukünftigen Zentralanmeldungen benachteiligen. Wenn Sie gute Gründe vorzuweisen haben, warum Ihre Abmeldung nicht selbstverschuldet ist, kontaktieren Sie bitte einen Kursverwalter. Diese haben die Möglichkeit Sie ohne permanente Eintragung im System abzumelden.
CourseDeregistrationAllocationReason: Grund
CourseDeregistrationAllocationReasonTip: Der angegebene Grund wird permanent im System hinterlegt und ist i.A. einziger Anhaltspunkt zur Schlichtung etwaiger Konflikte
CourseDeregistrationAllocationShouldLog: Selbstverschuldet
CourseDeregistrationAllocationShouldLogTip: Falls der Platz des Studierenden, der abgemeldet wird, aus einer Zentralanmeldung stammt, ist vorgesehen einen permanenten Eintrag im System zu speichern, der den Studierenden u.U. bei zukünftigen Zentralanmeldungen benachteiligt. Als Kursverwalter haben Sie die Möglichkeit dies zu unterbinden, wenn der Studierende gute Gründe vorweisen kann, warum seine Abmeldung nicht selbstverschuldet ist.
MailSubjectAllocationResults allocation@AllocationName: Plätze für Zentralanmeldung „#{allocation}“ wurden verteilt
AllocationResultsLecturer: Es wurden Plätze zugewiesen, wie folgt:
AllocationResultLecturer csh@CourseShorthand count@Int64: #{count} Teilnehmer für #{csh}
AllocationResultsStudent: Sie haben Plätze erhalten in:
AllocationNoResultsStudent: Sie haben leider keine Plätze erhalten.
AllocationResultStudent csh@CourseShorthand: Sie haben einen Platz in #{csh} erhalten.
FavouriteVisited: Kürzlich besucht
FavouriteParticipant: Ihre Kurse
FavouriteManual: Favoriten
FavouriteCurrent: Aktueller Kurs

3
models/allocations → models/allocations.model
View File

@ -21,6 +21,8 @@ Allocation -- attributes with prefix staff- affect lecturers only, but are invis
registerByCourse UTCTime Maybe -- course registration dates are ignored until this day has passed or always prohibited registerByCourse UTCTime Maybe -- course registration dates are ignored until this day has passed or always prohibited
overrideDeregister UTCTime Maybe -- course deregistration enforced to be this date, i.e. students may disenrol from course after or never overrideDeregister UTCTime Maybe -- course deregistration enforced to be this date, i.e. students may disenrol from course after or never
-- overrideVisible not needed, since courses are always visible -- overrideVisible not needed, since courses are always visible
fingerprint AllocationFingerprint Maybe
matchingLog FileId Maybe
TermSchoolAllocationShort term school shorthand -- shorthand must be unique within school and semester TermSchoolAllocationShort term school shorthand -- shorthand must be unique within school and semester
TermSchoolAllocationName term school name -- name must be unique within school and semester TermSchoolAllocationName term school name -- name must be unique within school and semester
deriving Show Eq Ord Generic deriving Show Eq Ord Generic
@ -35,6 +37,7 @@ AllocationUser
allocation AllocationId allocation AllocationId
user UserId user UserId
totalCourses Natural -- number of total allocated courses for this user must be <= than this number totalCourses Natural -- number of total allocated courses for this user must be <= than this number
priority AllocationPriority Maybe
UniqueAllocationUser allocation user UniqueAllocationUser allocation user
AllocationDeregister -- self-inflicted user-deregistrations from an allocated course AllocationDeregister -- self-inflicted user-deregistrations from an allocated course

0
models/audit → models/audit.model
View File

0
models/config → models/config.model
View File

37
models/courses → models/courses.model
View File

@ -17,11 +17,11 @@ Course -- Information about a single course; contained info is always visible
deregisterUntil UTCTime Maybe -- unenrolement may be prohibited from a given date onwards deregisterUntil UTCTime Maybe -- unenrolement may be prohibited from a given date onwards
registerSecret Text Maybe -- enrolement maybe protected by a simple common passphrase registerSecret Text Maybe -- enrolement maybe protected by a simple common passphrase
materialFree Bool -- False: only enrolled users may see course materials not stored in this table materialFree Bool -- False: only enrolled users may see course materials not stored in this table
applicationsRequired Bool applicationsRequired Bool default=false
applicationsInstructions Html Maybe applicationsInstructions Html Maybe
applicationsText Bool applicationsText Bool default=false
applicationsFiles UploadMode applicationsFiles UploadMode "default='{\"mode\": \"no-upload\"}'::jsonb"
applicationsRatingsVisible Bool applicationsRatingsVisible Bool default=false
TermSchoolCourseShort term school shorthand -- shorthand must be unique within school and semester TermSchoolCourseShort term school shorthand -- shorthand must be unique within school and semester
TermSchoolCourseName term school name -- name must be unique within school and semester TermSchoolCourseName term school name -- name must be unique within school and semester
deriving Generic deriving Generic
@ -35,12 +35,6 @@ CourseEdit -- who edited when a row in table "Course", kept indef
user UserId user UserId
time UTCTime time UTCTime
course CourseId course CourseId
CourseFavourite -- which user accessed which course when, only displayed to user for convenience;
user UserId -- max number of rows kept per user is user-defined by column 'maxFavourites' in table "User"
time UTCTime -- oldest is removed first
course CourseId
UniqueCourseFavourite user course
deriving Show
Lecturer -- course ownership Lecturer -- course ownership
user UserId user UserId
course CourseId course CourseId
@ -51,7 +45,7 @@ CourseParticipant -- course enrolement
user UserId user UserId
registration UTCTime -- time of last enrolement for this course registration UTCTime -- time of last enrolement for this course
field StudyFeaturesId Maybe -- associated degree course, user-defined; required for communicating grades field StudyFeaturesId Maybe -- associated degree course, user-defined; required for communicating grades
allocated Bool default=false -- participant was centrally allocated allocated AllocationId Maybe -- participant was centrally allocated
UniqueParticipant user course UniqueParticipant user course
-- Replace the last two by the following, once an audit log is available -- Replace the last two by the following, once an audit log is available
-- CourseUserNote -- lecturers of a specific course may share a text note on each enrolled student -- CourseUserNote -- lecturers of a specific course may share a text note on each enrolled student
@ -71,19 +65,8 @@ CourseUserNoteEdit -- who edited a participants course note when
time UTCTime time UTCTime
note CourseUserNoteId -- PROBLEM: deleted notes have no modification date any more note CourseUserNoteId -- PROBLEM: deleted notes have no modification date any more
CourseApplication CourseUserExamOfficeOptOut
course CourseId course CourseId
user UserId user UserId
field StudyFeaturesId Maybe -- associated degree course, user-defined; required for communicating grades school SchoolId
text Text Maybe -- free text entered by user UniqueCourseUserExamOfficeOptOut course user school
ratingVeto Bool default=false
ratingPoints ExamGrade Maybe
ratingComment Text Maybe
allocation AllocationId Maybe
allocationPriority Natural Maybe
time UTCTime default=now()
ratingTime UTCTime Maybe
CourseApplicationFile
application CourseApplicationId
file FileId
UniqueApplicationFile application file

16
models/courses/applications.model Normal file
View File

@ -0,0 +1,16 @@
CourseApplication
course CourseId
user UserId
field StudyFeaturesId Maybe -- associated degree course, user-defined; required for communicating grades
text Text Maybe -- free text entered by user
ratingVeto Bool default=false
ratingPoints ExamGrade Maybe
ratingComment Text Maybe
allocation AllocationId Maybe
allocationPriority Natural Maybe
time UTCTime default=now()
ratingTime UTCTime Maybe
CourseApplicationFile
application CourseApplicationId
file FileId
UniqueApplicationFile application file

10
models/courses/favourite.model Normal file
View File

@ -0,0 +1,10 @@
CourseFavourite -- which user accessed which course when, only displayed to user for convenience;
user UserId
course CourseId
reason FavouriteReason
lastVisit UTCTime
UniqueCourseFavourite user course
CourseNoFavourite
user UserId
course CourseId
UniqueCourseNoFavourite user course

3
models/materials → models/courses/materials.model
View File

@ -9,4 +9,5 @@ Material -- course material for disemination to course participants
deriving Generic deriving Generic
MaterialFile -- a file that is part of a material distribution MaterialFile -- a file that is part of a material distribution
material MaterialId material MaterialId
file FileId file FileId
UniqueMaterialFile material file

12
models/courses/news.model Normal file
View File

@ -0,0 +1,12 @@
CourseNews
course CourseId
visibleFrom UTCTime Maybe
participantsOnly Bool
title Text Maybe
content Html
summary Html Maybe
lastEdit UTCTime
CourseNewsFile
news CourseNewsId
file FileId
UniqueCourseNewsFile news file

14
models/exam-office.model Normal file
View File

@ -0,0 +1,14 @@
ExamOfficeField
office UserId
field StudyTermsId
forced Bool
UniqueExamOfficeField office field
ExamOfficeUser
office UserId
user UserId
UniqueExamOfficeUser office user
ExamOfficeResultSynced
school SchoolId Maybe
office UserId
result ExamResultId
time UTCTime

19
models/exams → models/exams.model
View File

@ -1,9 +1,9 @@
Exam Exam
course CourseId course CourseId
name ExamName name ExamName
gradingRule ExamGradingRule gradingRule ExamGradingRule Maybe
bonusRule ExamBonusRule bonusRule ExamBonusRule Maybe
occurrenceRule ExamOccurrenceRule occurrenceRule ExamOccurrenceRule Maybe
visibleFrom UTCTime Maybe visibleFrom UTCTime Maybe
registerFrom UTCTime Maybe registerFrom UTCTime Maybe
registerTo UTCTime Maybe registerTo UTCTime Maybe
@ -19,10 +19,12 @@ Exam
UniqueExam course name UniqueExam course name
ExamPart ExamPart
exam ExamId exam ExamId
name (CI Text) number ExamPartNumber
name ExamPartName Maybe
maxPoints Points Maybe maxPoints Points Maybe
weight Rational weight Rational
UniqueExamPart exam name UniqueExamPartNumber exam number
UniqueExamPartName exam name !force
ExamOccurrence ExamOccurrence
exam ExamId exam ExamId
name ExamOccurrenceName name ExamOccurrenceName
@ -42,7 +44,14 @@ ExamPartResult
examPart ExamPartId examPart ExamPartId
user UserId user UserId
result ExamResultPoints result ExamResultPoints
lastChanged UTCTime default=now()
UniqueExamPartResult examPart user UniqueExamPartResult examPart user
ExamBonus
exam ExamId
user UserId
bonus Points
lastChanged UTCTime default=now()
UniqueExamBonus exam user
ExamResult ExamResult
exam ExamId exam ExamId
user UserId user UserId

0
models/files → models/files.model
View File

0
models/invitations → models/invitations.model
View File

0
models/jobs → models/jobs.model
View File

3
models/schools → models/schools.model
View File

@ -13,4 +13,5 @@ SchoolLdap
UniqueOrgUnit orgUnit UniqueOrgUnit orgUnit
SchoolTerms SchoolTerms
school SchoolId school SchoolId
terms StudyTermsId terms StudyTermsId
UniqueSchoolTerms school terms

0
models/sheets → models/sheets.model
View File

0
models/submissions → models/submissions.model
View File

0
models/system-messages → models/system-messages.model
View File

0
models/terms → models/terms.model
View File

0
models/tutorials → models/tutorials.model
View File

11
models/users → models/users.model
View File

@ -9,9 +9,10 @@
-- --
User json -- Each Uni2work user has a corresponding row in this table; created upon first login. User json -- Each Uni2work user has a corresponding row in this table; created upon first login.
surname UserSurname -- Display user names always through 'nameWidget displayName surname' surname UserSurname -- Display user names always through 'nameWidget displayName surname'
displayName UserDisplayName -- we only show LDAP-DisplayName, and highlight LDAP-Surname within (appended if not contained) displayName UserDisplayName
email (CI Text) -- Case-insensitive eMail address displayEmail UserEmail
ident (CI Text) -- Case-insensitive user-identifier email UserEmail -- Case-insensitive eMail address
ident UserIdent -- Case-insensitive user-identifier
authentication AuthenticationMode -- 'AuthLDAP' or ('AuthPWHash'+password-hash) authentication AuthenticationMode -- 'AuthLDAP' or ('AuthPWHash'+password-hash)
lastAuthentication UTCTime Maybe -- last login date lastAuthentication UTCTime Maybe -- last login date
created UTCTime default=now() created UTCTime default=now()
@ -20,7 +21,8 @@ User json -- Each Uni2work user has a corresponding row in this table; create
matrikelnummer UserMatriculation Maybe -- optional immatriculation-string; usually a number, but not always (e.g. lecturers, pupils, guests,...) matrikelnummer UserMatriculation Maybe -- optional immatriculation-string; usually a number, but not always (e.g. lecturers, pupils, guests,...)
firstName Text -- For export in tables, pre-split firstName from displayName firstName Text -- For export in tables, pre-split firstName from displayName
title Text Maybe -- For upcoming name customisation title Text Maybe -- For upcoming name customisation
maxFavourites Int default=12 -- max number of rows with this userId in table "CourseFavourite"; for convenience links; user-defined maxFavourites Int default=12 -- max number of non-manual entries in favourites bar (pruned only if below a set importance threshold)
maxFavouriteTerms Int default=2 -- max number of term-sections in favourites bar
theme Theme default='Default' -- Color-theme of the frontend; user-defined theme Theme default='Default' -- Color-theme of the frontend; user-defined
dateTimeFormat DateTimeFormat "default='%a %d %b %Y %R'" -- preferred Date+Time display format for user; user-defined dateTimeFormat DateTimeFormat "default='%a %d %b %Y %R'" -- preferred Date+Time display format for user; user-defined
dateFormat DateTimeFormat "default='%d.%m.%Y'" -- preferred Date-only display format for user; user-defined dateFormat DateTimeFormat "default='%d.%m.%Y'" -- preferred Date-only display format for user; user-defined
@ -29,6 +31,7 @@ User json -- Each Uni2work user has a corresponding row in this table; create
mailLanguages MailLanguages "default='[]'::jsonb" -- Preferred language for eMail; i18n not yet implemented; user-defined mailLanguages MailLanguages "default='[]'::jsonb" -- Preferred language for eMail; i18n not yet implemented; user-defined
notificationSettings NotificationSettings -- Bit-array for which events email notifications are requested by user; user-defined notificationSettings NotificationSettings -- Bit-array for which events email notifications are requested by user; user-defined
warningDays NominalDiffTime default=1209600 -- timedistance to pending deadlines for homepage infos warningDays NominalDiffTime default=1209600 -- timedistance to pending deadlines for homepage infos
csvOptions CsvOptions "default='{}'::jsonb"
UniqueAuthentication ident -- Column 'ident' can be used as a row-key in this table UniqueAuthentication ident -- Column 'ident' can be used as a row-key in this table
UniqueEmail email -- Column 'email' can be used as a row-key in this table UniqueEmail email -- Column 'email' can be used as a row-key in this table
deriving Show Eq Ord Generic -- Haskell-specific settings for runtime-value representing a row in memory deriving Show Eq Ord Generic -- Haskell-specific settings for runtime-value representing a row in memory

4
nixpkgs.nix
View File

@ -4,6 +4,6 @@
import ((nixpkgs {}).fetchFromGitHub { import ((nixpkgs {}).fetchFromGitHub {
owner = "NixOS"; owner = "NixOS";
repo = "nixpkgs"; repo = "nixpkgs";
rev = "19.03"; rev = "10e61bf5be57736035ec7a804cb0bf3d083bf2cf";
sha256 = "0q2m2qhyga9yq29yz90ywgjbn9hdahs7i8wwlq7b55rdbyiwa5dy"; sha256 = "0fplfm2zx4vk7gs8bdcxnvzkdmpx2w0llqwf8475z9dz9cl132rm";
}) })

14
package-lock.json generated
View File

@ -1,6 +1,6 @@
{ {
"name": "uni2work", "name": "uni2work",
"version": "6.6.0", "version": "7.10.0",
"lockfileVersion": 1, "lockfileVersion": 1,
"requires": true, "requires": true,
"dependencies": { "dependencies": {
@ -7702,9 +7702,9 @@
"dev": true "dev": true
}, },
"handlebars": { "handlebars": {
"version": "4.1.2", "version": "4.3.1",
"resolved": "https://registry.npmjs.org/handlebars/-/handlebars-4.1.2.tgz", "resolved": "https://registry.npmjs.org/handlebars/-/handlebars-4.3.1.tgz",
"integrity": "sha512-nvfrjqvt9xQ8Z/w0ijewdD/vvWDTOweBUm96NTr66Wfvo1mJenBLwcYmPs3TIBP5ruzYGD7Hx/DaM9RmhroGPw==", "integrity": "sha512-c0HoNHzDiHpBt4Kqe99N8tdLPKAnGCQ73gYMPWtAYM4PwGnf7xl8PBUHJqh9ijlzt2uQKaSRxbXRt+rZ7M2/kA==",
"dev": true, "dev": true,
"requires": { "requires": {
"neo-async": "^2.6.0", "neo-async": "^2.6.0",
@ -15623,9 +15623,9 @@
"dev": true "dev": true
}, },
"uglify-js": { "uglify-js": {
"version": "3.5.15", "version": "3.6.0",
"resolved": "https://registry.npmjs.org/uglify-js/-/uglify-js-3.5.15.tgz", "resolved": "https://registry.npmjs.org/uglify-js/-/uglify-js-3.6.0.tgz",
"integrity": "sha512-fe7aYFotptIddkwcm6YuA0HmknBZ52ZzOsUxZEdhhkSsz7RfjHDX2QDxwKTiv4JQ5t5NhfmpgAK+J7LiDhKSqg==", "integrity": "sha512-W+jrUHJr3DXKhrsS7NUVxn3zqMOFn0hL/Ei6v0anCIMoKC93TjcflTagwIHLW7SfMFfiQuktQyFVCFHGUE0+yg==",
"dev": true, "dev": true,
"optional": true, "optional": true,
"requires": { "requires": {

4
package.json
View File

@ -1,6 +1,6 @@
{ {
"name": "uni2work", "name": "uni2work",
"version": "6.6.0", "version": "7.10.0",
"description": "", "description": "",
"keywords": [], "keywords": [],
"author": "", "author": "",
@ -14,7 +14,9 @@
"yesod:start": "./start.sh", "yesod:start": "./start.sh",
"yesod:lint": "./hlint.sh", "yesod:lint": "./hlint.sh",
"yesod:test": "./test.sh", "yesod:test": "./test.sh",
"yesod:test:watch": "./test.sh --file-watch",
"yesod:build": "./build.sh", "yesod:build": "./build.sh",
"yesod:build:watch": "./build.sh --file-watch",
"frontend:lint": "eslint frontend/src", "frontend:lint": "eslint frontend/src",
"frontend:test": "karma start --conf karma.conf.js", "frontend:test": "karma start --conf karma.conf.js",
"frontend:test:watch": "karma start --conf karma.conf.js --single-run false", "frontend:test:watch": "karma start --conf karma.conf.js --single-run false",

60
package.yaml
View File

@ -1,41 +1,39 @@
name: uniworx name: uniworx
version: 6.6.0 version: 7.10.0
dependencies: dependencies:
# Due to a bug in GHC 8.0.1, we block its usage - base >=4.9.1.0 && <5
# See: https://ghc.haskell.org/trac/ghc/ticket/12130 - yesod >=1.6 && <1.7
- base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5 - yesod-core >=1.6 && <1.7
# version 1.0 had a bug in reexporting Handler, causing trouble - yesod-auth >=1.6 && <1.7
- classy-prelude-yesod >=0.10.2 && <1.0 || >=1.1 - yesod-static >=1.6 && <1.7
- foreign-store - yesod-form >=1.6 && <1.7
- yesod >=1.4.3 && <1.5 - classy-prelude >=1.5 && <1.6
- yesod-core >=1.4.30 && <1.5 - classy-prelude-conduit >=1.5 && <1.6
- yesod-auth >=1.4.0 && <1.5 - classy-prelude-yesod >=1.5 && <1.6
- yesod-static >=1.4.0.3 && <1.6 - bytestring >=0.10 && <0.11
- yesod-form >=1.4.0 && <1.5
- classy-prelude >=0.10.2
- classy-prelude-conduit >=0.10.2
- bytestring >=0.9 && <0.11
- text >=0.11 && <2.0 - text >=0.11 && <2.0
- persistent >=2.7.2 && <2.8 - persistent >=2.9 && <2.10
- persistent-postgresql >=2.1.1 && <2.8 - persistent-postgresql >=2.9 && <2.10
- persistent-template >=2.0 && <2.8 - persistent-template >=2.5 && <2.9
- persistent-qq >=2.9 && <2.10
- template-haskell - template-haskell
- shakespeare >=2.0 && <2.1 - shakespeare >=2.0 && <2.1
- hjsmin >=0.1 && <0.3 - hjsmin >=0.1 && <0.3
- monad-control >=0.3 && <1.1 - monad-control >=0.3 && <1.1
- wai-extra >=3.0 && <3.1 - wai-extra >=3.0 && <3.1
- yaml >=0.8 && <0.9 - yaml >=0.11 && <0.12
- http-conduit >=2.1 && <2.3 - http-conduit >=2.3 && <2.4
- directory >=1.1 && <1.4 - directory >=1.1 && <1.4
- warp >=3.0 && <3.3 - warp >=3.0 && <3.3
- data-default - data-default
- aeson >=0.6 && <1.3 - aeson >=1.4 && <1.5
- conduit >=1.0 && <2.0 - conduit >=1.0 && <2.0
- conduit-combinators - conduit-combinators
- monad-logger >=0.3 && <0.4 - monad-logger >=0.3 && <0.4
- fast-logger >=2.2 && <2.5 - fast-logger >=2.2 && <2.5
- wai-logger >=2.2 && <2.4 - wai-logger >=2.2 && <2.4
- foreign-store
- file-embed - file-embed
- safe - safe
- unordered-containers - unordered-containers
@ -52,11 +50,12 @@ dependencies:
- http-api-data - http-api-data
- profunctors - profunctors
- colonnade >=1.1.1 - colonnade >=1.1.1
- yesod-colonnade >=1.1.0
- blaze-markup - blaze-markup
- zip-stream - zip-stream
- encoding
- filepath - filepath
- transformers - transformers
- transformers-base
- wl-pprint-text - wl-pprint-text
- uuid-types - uuid-types
- path-pieces - path-pieces
@ -100,8 +99,10 @@ dependencies:
- th-abstraction - th-abstraction
- HaskellNet - HaskellNet
- HaskellNet-SSL - HaskellNet-SSL
- network - network >=3
- resource-pool - network-bsd
- unliftio
- unliftio-pool
- mime-mail - mime-mail
- hashable - hashable
- aeson-pretty - aeson-pretty
@ -116,7 +117,6 @@ dependencies:
- pkcs7 - pkcs7
- memcached-binary - memcached-binary
- directory-tree - directory-tree
- lifted-base
- lattices - lattices
- hsass - hsass
- semigroupoids - semigroupoids
@ -126,7 +126,6 @@ dependencies:
- mono-traversable - mono-traversable
- lens-aeson - lens-aeson
- systemd - systemd
- lifted-async
- streaming-commons - streaming-commons
- hourglass - hourglass
- unix - unix
@ -137,6 +136,10 @@ dependencies:
- memory - memory
- pqueue - pqueue
- deepseq - deepseq
- multiset
- retry
- generic-lens
- array
other-extensions: other-extensions:
- GeneralizedNewtypeDeriving - GeneralizedNewtypeDeriving
@ -182,6 +185,7 @@ default-extensions:
- DeriveLift - DeriveLift
- DeriveFunctor - DeriveFunctor
- DerivingStrategies - DerivingStrategies
- DerivingVia
- DataKinds - DataKinds
- BinaryLiterals - BinaryLiterals
- PolyKinds - PolyKinds
@ -189,14 +193,18 @@ default-extensions:
- TypeApplications - TypeApplications
- RecursiveDo - RecursiveDo
- TypeFamilyDependencies - TypeFamilyDependencies
- QuantifiedConstraints
ghc-options: ghc-options:
- -Wall - -Wall
- -Wmissing-home-modules
- -Wredundant-constraints
- -fno-warn-type-defaults - -fno-warn-type-defaults
- -fno-warn-unrecognised-pragmas - -fno-warn-unrecognised-pragmas
- -fno-warn-partial-type-signatures - -fno-warn-partial-type-signatures
- -fno-max-relevant-binds - -fno-max-relevant-binds
- -j - -j
- -freduction-depth=0
when: when:
- condition: flag(pedantic) - condition: flag(pedantic)

23
routes
View File

@ -51,6 +51,7 @@
/users/#CryptoUUIDUser/password UserPasswordR GET POST !selfANDis-pw-hash /users/#CryptoUUIDUser/password UserPasswordR GET POST !selfANDis-pw-hash
!/users/functionary-invite/new AdminNewFunctionaryInviteR GET POST !/users/functionary-invite/new AdminNewFunctionaryInviteR GET POST
!/users/functionary-invite AdminFunctionaryInviteR GET POST !/users/functionary-invite AdminFunctionaryInviteR GET POST
!/users/add AdminUserAddR GET POST
/admin AdminR GET /admin AdminR GET
/admin/features AdminFeaturesR GET POST /admin/features AdminFeaturesR GET POST
/admin/test AdminTestR GET POST /admin/test AdminTestR GET POST
@ -70,6 +71,14 @@
/user ProfileR GET POST !free /user ProfileR GET POST !free
/user/profile ProfileDataR GET !free /user/profile ProfileDataR GET !free
/user/authpreds AuthPredsR GET POST !free /user/authpreds AuthPredsR GET POST !free
/user/set-display-email SetDisplayEmailR GET POST !free
/user/csv-options CsvOptionsR GET POST !free
/exam-office ExamOfficeR !exam-office:
/ EOExamsR GET
/fields EOFieldsR GET POST
/users EOUsersR GET POST
/users/invite EOUsersInviteR GET POST
/term TermShowR GET !free /term TermShowR GET !free
/term/current TermCurrentR GET !free /term/current TermCurrentR GET !free
@ -95,7 +104,8 @@
!/course/new CourseNewR GET POST !lecturer !/course/new CourseNewR GET POST !lecturer
/course/#TermId/#SchoolId/#CourseShorthand CourseR !lecturer: /course/#TermId/#SchoolId/#CourseShorthand CourseR !lecturer:
/ CShowR GET !free / CShowR GET !free
/register CRegisterR GET POST !timeANDcapacityANDallocation-timeAND¬exam-result !lecturerANDallocation-time /favourite CFavouriteR POST
/register CRegisterR GET POST !timeANDcapacityANDallocation-timeAND¬course-registered !timeANDallocation-timeAND¬exam-resultANDcourse-registered !lecturerANDallocation-time
/register-template CRegisterTemplateR GET !free /register-template CRegisterTemplateR GET !free
/edit CEditR GET POST /edit CEditR GET POST
/lecturer-invite CLecInviteR GET POST /lecturer-invite CLecInviteR GET POST
@ -107,6 +117,7 @@
/correctors CHiWisR GET /correctors CHiWisR GET
/communication CCommR GET POST /communication CCommR GET POST
/notes CNotesR GET POST !corrector -- THIS route is used to check for overall course corrector access! /notes CNotesR GET POST !corrector -- THIS route is used to check for overall course corrector access!
/exam-office CExamOfficeR GET POST !course-registered
/subs CCorrectionsR GET POST /subs CCorrectionsR GET POST
/subs/assigned CAssignR GET POST /subs/assigned CAssignR GET POST
/sheet SheetListR GET !course-registered !materials !corrector /sheet SheetListR GET !course-registered !materials !corrector
@ -156,18 +167,26 @@
/exams CExamListR GET !free /exams CExamListR GET !free
/exams/new CExamNewR GET POST /exams/new CExamNewR GET POST
/exams/#ExamName ExamR: /exams/#ExamName ExamR:
/show EShowR GET !time /show EShowR GET !time !exam-office
/edit EEditR GET POST /edit EEditR GET POST
/corrector-invite ECInviteR GET POST /corrector-invite ECInviteR GET POST
/users EUsersR GET POST /users EUsersR GET POST
/users/new EAddUserR GET POST /users/new EAddUserR GET POST
/users/invite EInviteR GET POST /users/invite EInviteR GET POST
/register ERegisterR POST !timeANDcourse-registeredAND¬exam-registered !timeANDexam-registeredAND¬exam-result /register ERegisterR POST !timeANDcourse-registeredAND¬exam-registered !timeANDexam-registeredAND¬exam-result
/grades EGradesR GET POST !exam-office
/apps CApplicationsR GET POST /apps CApplicationsR GET POST
!/apps/files CAppsFilesR GET !/apps/files CAppsFilesR GET
/apps/#CryptoFileNameCourseApplication CourseApplicationR: /apps/#CryptoFileNameCourseApplication CourseApplicationR:
/ CAEditR GET POST !timeANDself !lecturerANDstaff-time !selfANDread / CAEditR GET POST !timeANDself !lecturerANDstaff-time !selfANDread
/files CAFilesR GET !self !lecturerANDstaff-time /files CAFilesR GET !self !lecturerANDstaff-time
!/news/add CNewsNewR GET POST
/news/#CryptoUUIDCourseNews CourseNewsR:
/ CNShowR GET !timeANDparticipant
/edit CNEditR GET POST
/delete CNDeleteR GET POST
!/download CNArchiveR GET !timeANDparticipant
!/download/*FilePath CNFileR GET !timeANDparticipant
/subs CorrectionsR GET POST !corrector !lecturer /subs CorrectionsR GET POST !corrector !lecturer
/subs/upload CorrectionsUploadR GET POST !corrector !lecturer /subs/upload CorrectionsUploadR GET POST !corrector !lecturer

8
shell.nix
View File

@ -19,7 +19,7 @@ let
''; '';
override = oldAttrs: { override = oldAttrs: {
nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ nodejs-8_x postgresql pgadmin openldap ]) ++ (with haskellPackages; [ stack yesod-bin hlint cabal-install ]); nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ nodejs-12_x postgresql openldap ]) ++ (with haskellPackages; [ stack yesod-bin hlint cabal-install ]);
shellHook = '' shellHook = ''
export PROMPT_INFO="${oldAttrs.name}" export PROMPT_INFO="${oldAttrs.name}"
@ -47,6 +47,12 @@ let
set +xe set +xe
fi fi
if [ -n "$ZSH_VERSION" ]; then
autoload -U +X compinit && compinit
autoload -U +X bashcompinit && bashcompinit
fi
eval "$(stack --bash-completion-script stack)"
${oldAttrs.shellHook} ${oldAttrs.shellHook}
''; '';
}; };

45
src/Application.hs
View File

@ -24,7 +24,7 @@ import Language.Haskell.TH.Syntax (qLocation)
import Network.Wai (Middleware) import Network.Wai (Middleware)
import Network.Wai.Handler.Warp (Settings, defaultSettings, import Network.Wai.Handler.Warp (Settings, defaultSettings,
defaultShouldDisplayException, defaultShouldDisplayException,
runSettingsSocket, setHost, runSettings, runSettingsSocket, setHost,
setBeforeMainLoop, setBeforeMainLoop,
setOnException, setPort, getPort) setOnException, setPort, getPort)
import Data.Streaming.Network (bindPortTCP) import Data.Streaming.Network (bindPortTCP)
@ -44,7 +44,6 @@ import qualified Data.UUID as UUID
import qualified Data.UUID.V4 as UUID import qualified Data.UUID.V4 as UUID
import System.Directory import System.Directory
import System.FilePath
import Jobs import Jobs
@ -55,7 +54,9 @@ import qualified Data.ByteString.Lazy as LBS
import Network.HaskellNet.SSL hiding (Settings) import Network.HaskellNet.SSL hiding (Settings)
import Network.HaskellNet.SMTP.SSL as SMTP hiding (Settings) import Network.HaskellNet.SMTP.SSL as SMTP hiding (Settings)
import Data.Pool
import UnliftIO.Concurrent
import UnliftIO.Pool
import Control.Monad.Trans.Resource import Control.Monad.Trans.Resource
@ -71,17 +72,17 @@ import System.Exit
import qualified Database.Memcached.Binary.IO as Memcached import qualified Database.Memcached.Binary.IO as Memcached
import qualified System.Systemd.Daemon as Systemd import qualified System.Systemd.Daemon as Systemd
import Control.Concurrent.Async.Lifted.Safe
import System.Environment (lookupEnv) import System.Environment (lookupEnv)
import System.Posix.Process (getProcessID) import System.Posix.Process (getProcessID)
import System.Posix.Signals (SignalInfo(..), installHandler, sigTERM) import System.Posix.Signals (SignalInfo(..), installHandler, sigTERM, sigINT)
import qualified System.Posix.Signals as Signals (Handler(..)) import qualified System.Posix.Signals as Signals (Handler(..))
import Network (socketPort) import Network.Socket (socketPort, Socket, PortNumber)
import qualified Network.Socket as Socket (close) import qualified Network.Socket as Socket (close)
import Control.Concurrent.STM.Delay import Control.Concurrent.STM.Delay
import Control.Monad.STM (retry) import Control.Monad.STM (retry)
import Control.Monad.Trans.Cont (runContT, callCC)
import qualified Data.Set as Set import qualified Data.Set as Set
@ -109,6 +110,7 @@ import Handler.SystemMessage
import Handler.Health import Handler.Health
import Handler.Exam import Handler.Exam
import Handler.Allocation import Handler.Allocation
import Handler.ExamOffice
-- This line actually creates our YesodDispatch instance. It is the second half -- This line actually creates our YesodDispatch instance. It is the second half
@ -120,7 +122,7 @@ mkYesodDispatch "UniWorX" resourcesUniWorX
-- performs initialization and returns a foundation datatype value. This is also -- performs initialization and returns a foundation datatype value. This is also
-- the place to put your migrate statements to have automatic database -- the place to put your migrate statements to have automatic database
-- migrations handled by Yesod. -- migrations handled by Yesod.
makeFoundation :: (MonadResource m, MonadBaseControl IO m) => AppSettings -> m UniWorX makeFoundation :: (MonadResource m, MonadUnliftIO m) => AppSettings -> m UniWorX
makeFoundation appSettings'@AppSettings{..} = do makeFoundation appSettings'@AppSettings{..} = do
-- Some basic initializations: HTTP connection manager, logger, and static -- Some basic initializations: HTTP connection manager, logger, and static
-- subsite. -- subsite.
@ -146,7 +148,7 @@ makeFoundation appSettings'@AppSettings{..} = do
oldLogger <- atomically . swapTVar tVar =<< mkLogger newSettings oldLogger <- atomically . swapTVar tVar =<< mkLogger newSettings
rmLoggerSet $ loggerSet oldLogger rmLoggerSet $ loggerSet oldLogger
updateLogger newSettings updateLogger newSettings
(tVar, ) <$> fork (updateLogger initialSettings) (tVar, ) <$> forkIO (updateLogger initialSettings)
appLogger <- over _2 fst <$> allocate mkLogger' (\(tVar, tId) -> killThread tId >> (readTVarIO tVar >>= rmLoggerSet . loggerSet)) appLogger <- over _2 fst <$> allocate mkLogger' (\(tVar, tId) -> killThread tId >> (readTVarIO tVar >>= rmLoggerSet . loggerSet))
let appStatic = embeddedStatic let appStatic = embeddedStatic
@ -250,7 +252,7 @@ readInstanceIDFile idFile = liftIO . handle generateInstead $ LBS.readFile idFil
instanceId <- UUID.nextRandom instanceId <- UUID.nextRandom
LBS.writeFile idFile $ UUID.toByteString instanceId LBS.writeFile idFile $ UUID.toByteString instanceId
return instanceId return instanceId
| otherwise = throw e | otherwise = throwIO e
createSmtpPool :: MonadLoggerIO m => SmtpConf -> m SMTPPool createSmtpPool :: MonadLoggerIO m => SmtpConf -> m SMTPPool
createSmtpPool SmtpConf{ smtpPool = ResourcePoolConf{..}, .. } = do createSmtpPool SmtpConf{ smtpPool = ResourcePoolConf{..}, .. } = do
@ -327,7 +329,7 @@ warpSettings foundation = defaultSettings
void $ liftIO Systemd.notifyReady void $ liftIO Systemd.notifyReady
if if
| foundation ^. _appHealthCheckDelayNotify | foundation ^. _appHealthCheckDelayNotify
-> void . fork $ do -> void . forkIO $ do
let activeChecks = Set.fromList universeF let activeChecks = Set.fromList universeF
& Set.filter (is _Just . (foundation ^. _appHealthCheckInterval)) & Set.filter (is _Just . (foundation ^. _appHealthCheckInterval))
atomically $ do atomically $ do
@ -365,11 +367,20 @@ develMain = runResourceT $ do
wsettings <- liftIO . getDevSettings $ warpSettings foundation wsettings <- liftIO . getDevSettings $ warpSettings foundation
app <- makeApplication foundation app <- makeApplication foundation
let
awaitTermination :: IO ()
awaitTermination
= flip runContT return . forever $ do
lift $ threadDelay 100e3
whenM (lift $ doesFileExist "yesod-devel/devel-terminate") $
callCC ($ ())
void . liftIO $ installHandler sigINT (Signals.Catch $ return ()) Nothing
runAppLoggingT foundation $ handleJobs foundation runAppLoggingT foundation $ handleJobs foundation
liftIO . develMainHelper $ return (wsettings, app) void . liftIO $ awaitTermination `race` runSettings wsettings app
-- | The @main@ function for an executable running this site. -- | The @main@ function for an executable running this site.
appMain :: MonadResourceBase m => m () appMain :: forall m. (MonadUnliftIO m, MonadMask m) => m ()
appMain = runResourceT $ do appMain = runResourceT $ do
settings <- getAppSettings settings <- getAppSettings
@ -397,7 +408,7 @@ appMain = runResourceT $ do
$logInfoS "bind" [st|Listening on #{tshow host} port #{tshow port} as per configuration|] $logInfoS "bind" [st|Listening on #{tshow host} port #{tshow port} as per configuration|]
liftIO $ pure <$> bindPortTCP port host liftIO $ pure <$> bindPortTCP port host
$logDebugS "bind" . tshow =<< mapM (liftIO . socketPort) sockets $logDebugS "bind" . tshow =<< mapM (liftIO . try . socketPort :: Socket -> _ (Either SomeException PortNumber)) sockets
mainThreadId <- myThreadId mainThreadId <- myThreadId
liftIO . void . flip (installHandler sigTERM) Nothing . Signals.CatchInfo $ \SignalInfo{..} -> runAppLoggingT foundation $ do liftIO . void . flip (installHandler sigTERM) Nothing . Signals.CatchInfo $ \SignalInfo{..} -> runAppLoggingT foundation $ do
@ -445,7 +456,7 @@ appMain = runResourceT $ do
_other -> return () _other -> return ()
go status go status
in void $ allocate (async notifyWatchdog >>= \a -> a <$ link a) cancel in void $ allocateLinkedAsync notifyWatchdog
_other -> return () _other -> return ()
let runWarp socket = runSettingsSocket (warpSettings foundation) socket app let runWarp socket = runSettingsSocket (warpSettings foundation) socket app
@ -461,7 +472,7 @@ appMain = runResourceT $ do
foundationStoreNum :: Word32 foundationStoreNum :: Word32
foundationStoreNum = 2 foundationStoreNum = 2
getApplicationRepl :: (MonadResource m, MonadBaseControl IO m) => m (Int, UniWorX, Application) getApplicationRepl :: (MonadResource m, MonadUnliftIO m, MonadMask m) => m (Int, UniWorX, Application)
getApplicationRepl = do getApplicationRepl = do
settings <- getAppDevSettings settings <- getAppDevSettings
foundation <- makeFoundation settings foundation <- makeFoundation settings
@ -475,7 +486,7 @@ getApplicationRepl = do
return (getPort wsettings, foundation, app1) return (getPort wsettings, foundation, app1)
shutdownApp :: (MonadIO m, MonadBaseControl IO m) => UniWorX -> m () shutdownApp :: (MonadIO m, MonadUnliftIO m) => UniWorX -> m ()
shutdownApp app = do shutdownApp app = do
stopJobCtl app stopJobCtl app
liftIO $ do liftIO $ do
@ -494,7 +505,7 @@ handler :: Handler a -> IO a
handler h = runResourceT $ getAppDevSettings >>= makeFoundation >>= liftIO . flip unsafeHandler h handler h = runResourceT $ getAppDevSettings >>= makeFoundation >>= liftIO . flip unsafeHandler h
-- | Run DB queries -- | Run DB queries
db :: ReaderT SqlBackend (HandlerT UniWorX IO) a -> IO a db :: DB a -> IO a
db = handler . runDB db = handler . runDB
addPWEntry :: User addPWEntry :: User

5
src/Audit.hs
View File

@ -22,7 +22,7 @@ import qualified Network.Socket as Wai
import qualified Net.IP as IP import qualified Net.IP as IP
import qualified Net.IPv6 as IPv6 import qualified Net.IPv6 as IPv6
import Control.Exception (ErrorCall(..), evaluate) import Control.Exception (ErrorCall(..))
{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-} {-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}
@ -79,7 +79,6 @@ instance Exception AuditException
audit :: ( AuthId (HandlerSite m) ~ Key User audit :: ( AuthId (HandlerSite m) ~ Key User
, AuthEntity (HandlerSite m) ~ User
, IsSqlBackend (YesodPersistBackend (HandlerSite m)) , IsSqlBackend (YesodPersistBackend (HandlerSite m))
, SqlBackendCanWrite (YesodPersistBackend (HandlerSite m)) , SqlBackendCanWrite (YesodPersistBackend (HandlerSite m))
, HasInstanceID (HandlerSite m) InstanceId , HasInstanceID (HandlerSite m) InstanceId
@ -99,7 +98,7 @@ audit (toJSON -> transactionLogInfo) = do
transactionLogTime <- liftIO getCurrentTime transactionLogTime <- liftIO getCurrentTime
transactionLogInstance <- getsYesod $ view instanceID transactionLogInstance <- getsYesod $ view instanceID
transactionLogInitiator <- liftHandlerT maybeAuthId transactionLogInitiator <- liftHandler maybeAuthId
transactionLogRemote <- handle (throwM . AuditRemoteException) $ Just <$> getRemote transactionLogRemote <- handle (throwM . AuditRemoteException) $ Just <$> getRemote
insert_ TransactionLog{..} insert_ TransactionLog{..}

35
src/Audit/Types.hs
View File

@ -23,6 +23,24 @@ data Transaction
{ transactionExam :: ExamId { transactionExam :: ExamId
, transactionUser :: UserId , transactionUser :: UserId
} }
| TransactionExamPartResultEdit
{ transactionExamPart :: ExamPartId
, transactionUser :: UserId
}
| TransactionExamPartResultDeleted
{ transactionExamPart :: ExamPartId
, transactionUser :: UserId
}
| TransactionExamBonusEdit
{ transactionExam :: ExamId
, transactionUser :: UserId
}
| TransactionExamBonusDeleted
{ transactionExam :: ExamId
, transactionUser :: UserId
}
| TransactionExamResultEdit | TransactionExamResultEdit
{ transactionExam :: ExamId { transactionExam :: ExamId
@ -98,6 +116,23 @@ data Transaction
{ transactionFile :: FileId { transactionFile :: FileId
} }
| TransactionExamOfficeUserAdd
{ transactionOffice :: UserId
, transactionUser :: UserId
}
| TransactionExamOfficeUserDelete
{ transactionOffice :: UserId
, transactionUser :: UserId
}
| TransactionExamOfficeFieldEdit
{ transactionOffice :: UserId
, transactionField :: StudyTermsId
}
| TransactionExamOfficeFieldDelete
{ transactionOffice :: UserId
, transactionField :: StudyTermsId
}
deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriveJSON defaultOptions deriveJSON defaultOptions

40
src/Auth/Dummy.hs
View File

@ -17,41 +17,47 @@ data DummyMessage = MsgDummyIdent
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
dummyForm :: ( RenderMessage site FormMessage dummyForm :: ( RenderMessage (HandlerSite m) FormMessage
, RenderMessage site DummyMessage , RenderMessage (HandlerSite m) DummyMessage
, YesodPersist site , YesodPersist (HandlerSite m)
, SqlBackendCanRead (YesodPersistBackend site) , SqlBackendCanRead (YesodPersistBackend (HandlerSite m))
, Button site ButtonSubmit , Button (HandlerSite m) ButtonSubmit
) => AForm (HandlerT site IO) (CI Text) , MonadHandler m
) => AForm m (CI Text)
dummyForm = areq (ciField & addDatalist userList) (fslI MsgDummyIdent & noAutocomplete) Nothing dummyForm = areq (ciField & addDatalist userList) (fslI MsgDummyIdent & noAutocomplete) Nothing
where where
userList = fmap mkOptionList . runDB $ map toOption <$> selectList [] [Asc UserIdent] userList = fmap mkOptionList . runDB $ withReaderT projectBackend (map toOption <$> selectList [] [Asc UserIdent] :: ReaderT SqlBackend _ [Option UserIdent])
toOption (Entity _ User{..}) = Option userDisplayName userIdent (CI.original userIdent) toOption (Entity _ User{..}) = Option userDisplayName userIdent (CI.original userIdent)
dummyLogin :: ( YesodAuth site dummyLogin :: forall site.
( YesodAuth site
, YesodPersist site , YesodPersist site
, SqlBackendCanRead (YesodPersistBackend site) , SqlBackendCanRead (YesodPersistBackend site)
, RenderMessage site FormMessage
, RenderMessage site AFormMessage , RenderMessage site AFormMessage
, RenderMessage site DummyMessage , RenderMessage site DummyMessage
, Button site ButtonSubmit , Button site ButtonSubmit
) => AuthPlugin site ) => AuthPlugin site
dummyLogin = AuthPlugin{..} dummyLogin = AuthPlugin{..}
where where
apName :: Text
apName = "dummy" apName = "dummy"
-- apDispatch :: Text -> [Text] -> HandlerT Auth (HandlerT site IO) TypedContent
apDispatch "POST" [] = do apDispatch :: forall m. MonadAuthHandler site m => Text -> [Text] -> m TypedContent
((loginRes, _), _) <- lift . runFormPost $ renderAForm FormStandard dummyForm apDispatch "POST" [] = liftSubHandler $ do
((loginRes, _), _) <- runFormPost $ renderAForm FormStandard dummyForm
tp <- getRouteToParent
case loginRes of case loginRes of
FormFailure errs -> do FormFailure errs -> do
lift . forM_ errs $ addMessage Error . toHtml forM_ errs $ addMessage Error . toHtml
redirect LoginR redirect $ tp LoginR
FormMissing -> do FormMissing -> do
lift $ addMessageI Warning MsgDummyNoFormData addMessageI Warning MsgDummyNoFormData
redirect LoginR redirect $ tp LoginR
FormSuccess ident -> FormSuccess ident ->
lift . setCredsRedirect $ Creds "dummy" (CI.original ident) [] setCredsRedirect $ Creds "dummy" (CI.original ident) []
apDispatch _ _ = notFound apDispatch _ _ = notFound
apLogin :: (Route Auth -> Route site) -> WidgetFor site ()
apLogin toMaster = do apLogin toMaster = do
(login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard dummyForm (login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard dummyForm
let loginForm = wrapForm login FormSettings let loginForm = wrapForm login FormSettings

32
src/Auth/LDAP.hs
View File

@ -84,7 +84,7 @@ instance Exception CampusUserException
makePrisms ''CampusUserException makePrisms ''CampusUserException
campusUser :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) => LdapConf -> LdapPool -> Creds site -> m (Ldap.AttrList []) campusUser :: MonadUnliftIO m => LdapConf -> LdapPool -> Creds site -> m (Ldap.AttrList [])
campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdap pool $ \ldap -> do campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdap pool $ \ldap -> do
Ldap.bind ldap ldapDn ldapPassword Ldap.bind ldap ldapDn ldapPassword
results <- case lookup "DN" credsExtra of results <- case lookup "DN" credsExtra of
@ -109,15 +109,15 @@ campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $
, Exc.Handler $ \(HostCannotConnect host excs) -> throwM $ CampusUserHostCannotConnect host excs , Exc.Handler $ \(HostCannotConnect host excs) -> throwM $ CampusUserHostCannotConnect host excs
] ]
campusUser' :: (MonadBaseControl IO m, MonadCatch m, MonadIO m) => LdapConf -> LdapPool -> User -> m (Maybe (Ldap.AttrList [])) campusUser' :: (MonadCatch m, MonadUnliftIO m) => LdapConf -> LdapPool -> User -> m (Maybe (Ldap.AttrList []))
campusUser' conf pool User{userIdent} campusUser' conf pool User{userIdent}
= runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUser conf pool (Creds apLdap (CI.original userIdent) []) = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUser conf pool (Creds apLdap (CI.original userIdent) [])
campusForm :: ( RenderMessage site FormMessage campusForm :: ( RenderMessage (HandlerSite m) FormMessage
, RenderMessage site CampusMessage , RenderMessage (HandlerSite m) CampusMessage
, Button site ButtonSubmit , MonadHandler m
) => WForm (HandlerT site IO) (FormResult CampusLogin) ) => WForm m (FormResult CampusLogin)
campusForm = do campusForm = do
MsgRenderer mr <- getMsgRenderer MsgRenderer mr <- getMsgRenderer
@ -133,24 +133,26 @@ apLdap = "LDAP"
campusLogin :: forall site. campusLogin :: forall site.
( YesodAuth site ( YesodAuth site
, RenderMessage site FormMessage
, RenderMessage site CampusMessage , RenderMessage site CampusMessage
, RenderMessage site AFormMessage , RenderMessage site AFormMessage
, Button site ButtonSubmit , Button site ButtonSubmit
) => LdapConf -> LdapPool -> AuthPlugin site ) => LdapConf -> LdapPool -> AuthPlugin site
campusLogin conf@LdapConf{..} pool = AuthPlugin{..} campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
where where
apName :: Text
apName = apLdap apName = apLdap
apDispatch :: Text -> [Text] -> HandlerT Auth (HandlerT site IO) TypedContent
apDispatch "POST" [] = do apDispatch :: forall m. MonadAuthHandler site m => Text -> [Text] -> m TypedContent
((loginRes, _), _) <- lift . runFormPost $ renderWForm FormStandard campusForm apDispatch "POST" [] = liftSubHandler $ do
((loginRes, _), _) <- runFormPost $ renderWForm FormStandard campusForm
tp <- getRouteToParent
case loginRes of case loginRes of
FormFailure errs -> do FormFailure errs -> do
forM_ errs $ addMessage Error . toHtml forM_ errs $ addMessage Error . toHtml
redirect LoginR redirect $ tp LoginR
FormMissing -> redirect LoginR FormMissing -> redirect $ tp LoginR
FormSuccess CampusLogin{ campusIdent = CI.original -> campusIdent, ..} -> do FormSuccess CampusLogin{ campusIdent = CI.original -> campusIdent, ..} -> do
ldapResult <- withLdap pool $ \ldap -> do ldapResult <- withLdap pool $ \ldap -> liftIO $ do
Ldap.bind ldap ldapDn ldapPassword Ldap.bind ldap ldapDn ldapPassword
searchResults <- findUser conf ldap campusIdent [ldapUserPrincipalName] searchResults <- findUser conf ldap campusIdent [ldapUserPrincipalName]
case searchResults of case searchResults of
@ -169,11 +171,13 @@ campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
$logErrorS "LDAP" $ "Error during login: " <> tshow err $logErrorS "LDAP" $ "Error during login: " <> tshow err
loginErrorMessageI LoginR Msg.AuthError loginErrorMessageI LoginR Msg.AuthError
Right (Right (userDN, credsIdent)) -> Right (Right (userDN, credsIdent)) ->
lift . setCredsRedirect $ Creds apName credsIdent [("DN", userDN)] setCredsRedirect $ Creds apName credsIdent [("DN", userDN)]
Right (Left searchResults) -> do Right (Left searchResults) -> do
$logWarnS "LDAP" $ "Could not extract principal name: " <> tshow searchResults $logWarnS "LDAP" $ "Could not extract principal name: " <> tshow searchResults
loginErrorMessageI LoginR Msg.AuthError loginErrorMessageI LoginR Msg.AuthError
apDispatch _ _ = notFound apDispatch _ _ = notFound
apLogin :: (Route Auth -> Route site) -> WidgetFor site ()
apLogin toMaster = do apLogin toMaster = do
(login, loginEnctype) <- handlerToWidget . generateFormPost $ renderWForm FormStandard campusForm (login, loginEnctype) <- handlerToWidget . generateFormPost $ renderWForm FormStandard campusForm
let loginForm = wrapForm login FormSettings let loginForm = wrapForm login FormSettings

56
src/Auth/PWHash.hs
View File

@ -26,68 +26,50 @@ data PWHashMessage = MsgPWHashIdent
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
hashForm :: ( RenderMessage site FormMessage hashForm :: ( RenderMessage (HandlerSite m) FormMessage
, RenderMessage site PWHashMessage , RenderMessage (HandlerSite m) PWHashMessage
, Button site ButtonSubmit , MonadHandler m
) => AForm (HandlerT site IO) HashLogin ) => AForm m HashLogin
hashForm = HashLogin hashForm = HashLogin
<$> areq ciField (fslpI MsgPWHashIdent "Identifikation") Nothing <$> areq ciField (fslpI MsgPWHashIdent "Identifikation") Nothing
<*> areq passwordField (fslpI MsgPWHashPassword "Passwort") Nothing <*> areq passwordField (fslpI MsgPWHashPassword "Passwort") Nothing
hashLogin :: ( YesodAuth site hashLogin :: forall site.
( YesodAuth site
, YesodPersist site , YesodPersist site
, SqlBackendCanRead (YesodPersistBackend site) , SqlBackendCanRead (YesodPersistBackend site)
, RenderMessage site FormMessage , PersistRecordBackend User (YesodPersistBackend site)
, RenderMessage site PWHashMessage , RenderMessage site PWHashMessage
, RenderMessage site AFormMessage , RenderMessage site AFormMessage
, Button site ButtonSubmit , Button site ButtonSubmit
) => PWHashAlgorithm -> AuthPlugin site ) => PWHashAlgorithm -> AuthPlugin site
hashLogin pwHashAlgo = AuthPlugin{..} hashLogin pwHashAlgo = AuthPlugin{..}
where where
apName :: Text
apName = "PWHash" apName = "PWHash"
apDispatch "POST" [] = do
((loginRes, _), _) <- lift . runFormPost $ renderAForm FormStandard hashForm apDispatch :: forall m. MonadAuthHandler site m => Text -> [Text] -> m TypedContent
apDispatch "POST" [] = liftSubHandler $ do
((loginRes, _), _) <- runFormPost $ renderAForm FormStandard hashForm
tp <- getRouteToParent
case loginRes of case loginRes of
FormFailure errs -> do FormFailure errs -> do
forM_ errs $ addMessage Error . toHtml forM_ errs $ addMessage Error . toHtml
redirect LoginR redirect $ tp LoginR
FormMissing -> redirect LoginR FormMissing -> redirect $ tp LoginR
FormSuccess HashLogin{..} -> do FormSuccess HashLogin{..} -> do
user <- lift . runDB . getBy $ UniqueAuthentication hashIdent user <- liftHandler . runDB . getBy $ UniqueAuthentication hashIdent
case user of case user of
Just (Entity _ User{ userAuthentication = AuthPWHash{..}, userIdent = CI.original -> userIdent }) Just (Entity _ User{ userAuthentication = AuthPWHash{..}, userIdent = CI.original -> userIdent })
| verifyPasswordWith pwHashAlgo (2^) (encodeUtf8 hashPassword) (encodeUtf8 authPWHash) -> -- (2^) is magic. | verifyPasswordWith pwHashAlgo (2^) (encodeUtf8 hashPassword) (encodeUtf8 authPWHash) -> -- (2^) is magic.
lift . setCredsRedirect $ Creds apName userIdent [] setCredsRedirect $ Creds apName userIdent []
other -> do other -> do
$logDebugS "PWHash" $ tshow other $logDebugS "PWHash" $ tshow other
loginErrorMessageI LoginR Msg.InvalidLogin loginErrorMessageI LoginR Msg.InvalidLogin
-- apDispatch "GET" [] = do
-- authData <- lookupBasicAuth
-- pwdata <- liftIO $ Yaml.decodeFileEither fp
-- addHeader "WWW-Authenticate" [st|Basic realm="uni2work maintenance auth" charset="UTF-8"|]
-- case pwdata of
-- Left err -> $logDebugS "Auth" $ tshow err
-- Right pws -> $logDebugS "Auth" $ tshow (length pws) <> " pw entries"
-- case (authData, pwdata) of
-- (Nothing, _) -> do
-- notAuthenticated
-- (Just (usr, (Text.encodeUtf8 -> pw)), Right pwdata')
-- | [ PWEntry{ pwUser = pwUser@(User{..}), pwHash = (Text.encodeUtf8 -> pwHash) } ]
-- <- [ pwe | pwe@PWEntry{..} <- pwdata'
-- , let User{..} = pwUser
-- , userIdent == usr
-- , userPlugin == apName
-- ]
-- , verifyPassword pw pwHash
-- -> lift $ do
-- runDB . void $ insertUnique pwUser
-- setCredsRedirect $ Creds apName userIdent []
-- _ -> permissionDenied "Invalid auth"
apDispatch _ _ = notFound apDispatch _ _ = notFound
apLogin :: (Route Auth -> Route site) -> WidgetFor site ()
apLogin toMaster = do apLogin toMaster = do
(login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard hashForm (login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard hashForm
let loginForm = wrapForm login FormSettings let loginForm = wrapForm login FormSettings

17
src/Control/Concurrent/Async/Lifted/Safe/Utils.hs
View File

@ -1,17 +0,0 @@
module Control.Concurrent.Async.Lifted.Safe.Utils
( allocateAsync, allocateLinkedAsync
) where
import ClassyPrelude hiding (cancel)
import Control.Lens
import Control.Concurrent.Async.Lifted.Safe
import Control.Monad.Trans.Resource
allocateLinkedAsync, allocateAsync :: forall m a.
MonadResource m
=> IO a -> m (Async a)
allocateAsync = fmap (view _2) . flip allocate cancel . async
allocateLinkedAsync = uncurry (<$) . (id &&& link) <=< allocateAsync

9
src/CryptoID.hs
View File

@ -8,11 +8,12 @@ module CryptoID
, module System.FilePath.Cryptographic.ImplicitNamespace , module System.FilePath.Cryptographic.ImplicitNamespace
) where ) where
import CryptoID.TH
import ClassyPrelude import Import.NoModel
import Model import Model
import CryptoID.TH
import qualified Data.CryptoID as E import qualified Data.CryptoID as E
import Data.CryptoID.Poly.ImplicitNamespace import Data.CryptoID.Poly.ImplicitNamespace
import Data.UUID.Cryptographic.ImplicitNamespace import Data.UUID.Cryptographic.ImplicitNamespace
@ -20,9 +21,6 @@ import System.FilePath.Cryptographic.ImplicitNamespace
import qualified Data.Text as Text import qualified Data.Text as Text
-- import Data.UUID.Types
import Web.PathPieces
import Data.CaseInsensitive (CI) import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
@ -50,6 +48,7 @@ decCryptoIDs [ ''SubmissionId
, ''AllocationId , ''AllocationId
, ''CourseApplicationId , ''CourseApplicationId
, ''CourseId , ''CourseId
, ''CourseNewsId
] ]
-- CryptoIDNamespace (CI FilePath) SubmissionId ~ "Submission" -- CryptoIDNamespace (CI FilePath) SubmissionId ~ "Submission"

1
src/Data/CaseInsensitive/Instances.hs
View File

@ -1,5 +1,6 @@
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
module Data.CaseInsensitive.Instances module Data.CaseInsensitive.Instances
( (

2
src/Data/CryptoID/Instances.hs
View File

@ -43,5 +43,5 @@ instance Csv.FromField s => Csv.FromField (CID.CryptoID c s) where
instance Csv.ToField s => Csv.ToField (CID.CryptoID c s) where instance Csv.ToField s => Csv.ToField (CID.CryptoID c s) where
toField = Csv.toField . CID.ciphertext toField = Csv.toField . CID.ciphertext
instance {-# OVERLAPS #-} (Csv.ToField s, CI.FoldCase s) => Csv.ToField (CID.CryptoID c (CI s)) where instance {-# OVERLAPS #-} Csv.ToField s => Csv.ToField (CID.CryptoID c (CI s)) where
toField = Csv.toField . CI.foldedCase . CID.ciphertext toField = Csv.toField . CI.foldedCase . CID.ciphertext

12
src/Data/List/NonEmpty/Instances.hs
View File

@ -1,12 +0,0 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.List.NonEmpty.Instances
(
) where
import Data.List.NonEmpty
import Language.Haskell.TH.Syntax (Lift(..))
instance Lift a => Lift (NonEmpty a) where
lift (toList -> xs) = [e|fromList xs|]

19
src/Data/Time/Clock/Instances.hs
View File

@ -1,7 +1,7 @@
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.Time.Clock.Instances module Data.Time.Clock.Instances
( ( iso8601OutputFormat, iso8601ParseFormat
) where ) where
import ClassyPrelude import ClassyPrelude
@ -17,6 +17,8 @@ import Data.Time.Clock
import Data.Time.Calendar.Instances () import Data.Time.Calendar.Instances ()
import Web.PathPieces import Web.PathPieces
import qualified Data.Csv as Csv
instance Hashable DiffTime where instance Hashable DiffTime where
hashWithSalt s = hashWithSalt s . toRational hashWithSalt s = hashWithSalt s . toRational
@ -29,12 +31,23 @@ instance PersistFieldSql NominalDiffTime where
sqlType _ = sqlType (Proxy @Rational) sqlType _ = sqlType (Proxy @Rational)
iso8601OutputFormat, iso8601ParseFormat :: String
iso8601OutputFormat = "%0Y-%m-%dT%H:%M:%S%Q%z"
iso8601ParseFormat = "%Y-%m-%dT%H:%M:%S%Q%z"
deriving instance Generic UTCTime deriving instance Generic UTCTime
instance Hashable UTCTime instance Hashable UTCTime
instance PathPiece UTCTime where instance PathPiece UTCTime where
toPathPiece = pack . formatTime defaultTimeLocale "%0Y-%m-%dT%H:%M:%S%Q%z" toPathPiece = pack . formatTime defaultTimeLocale iso8601OutputFormat
fromPathPiece = parseTimeM False defaultTimeLocale "%Y-%m-%dT%H:%M:%S%Q%z" . unpack fromPathPiece = parseTimeM False defaultTimeLocale iso8601ParseFormat . unpack
instance Csv.ToField UTCTime where
toField = Csv.toField . formatTime defaultTimeLocale iso8601OutputFormat
instance Csv.FromField UTCTime where
parseField = parseTimeM False defaultTimeLocale iso8601ParseFormat <=< Csv.parseField
instance Binary DiffTime where instance Binary DiffTime where

12
src/Data/Time/LocalTime/Instances.hs
View File

@ -12,6 +12,12 @@ import Data.Binary (Binary)
import qualified Language.Haskell.TH.Syntax as TH import qualified Language.Haskell.TH.Syntax as TH
import qualified Data.Csv as Csv
import Data.Time.Clock.Instances
( iso8601OutputFormat, iso8601ParseFormat
)
deriving instance Generic TimeOfDay deriving instance Generic TimeOfDay
deriving instance Typeable TimeOfDay deriving instance Typeable TimeOfDay
@ -21,3 +27,9 @@ instance Binary TimeOfDay
deriving instance TH.Lift TimeZone deriving instance TH.Lift TimeZone
instance Csv.ToField ZonedTime where
toField = Csv.toField . formatTime defaultTimeLocale iso8601OutputFormat
instance Csv.FromField ZonedTime where
parseField = parseTimeM False defaultTimeLocale iso8601ParseFormat <=< Csv.parseField

20
src/Database/Esqueleto/Utils.hs
View File

@ -1,4 +1,5 @@
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
module Database.Esqueleto.Utils module Database.Esqueleto.Utils
( true, false ( true, false
@ -6,19 +7,19 @@ module Database.Esqueleto.Utils
, isInfixOf, hasInfix , isInfixOf, hasInfix
, or, and , or, and
, any, all , any, all
, SqlIn(..)
, mkExactFilter, mkExactFilterWith , mkExactFilter, mkExactFilterWith
, mkContainsFilter, mkContainsFilterWith , mkContainsFilter, mkContainsFilterWith
, mkExistsFilter , mkExistsFilter
, anyFilter, allFilter , anyFilter, allFilter
, orderByList , orderByList
, orderByOrd, orderByEnum , orderByOrd, orderByEnum
, lower, ciEq , strip, lower, ciEq
, selectExists , selectExists
, SqlHashable , SqlHashable
, sha256 , sha256
, maybe , maybe
, SqlProject(..) , SqlProject(..)
, module Database.Esqueleto.Utils.TH
) where ) where
@ -61,24 +62,22 @@ false :: E.SqlExpr (E.Value Bool)
false = E.val False false = E.val False
-- | Negation of `isNothing` which is missing -- | Negation of `isNothing` which is missing
isJust :: (E.Esqueleto query expr backend, PersistField typ) => expr (E.Value (Maybe typ)) -> expr (E.Value Bool) isJust :: PersistField typ => E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool)
isJust = E.not_ . E.isNothing isJust = E.not_ . E.isNothing
infix 4 `isInfixOf`, `hasInfix` infix 4 `isInfixOf`, `hasInfix`
-- | Check if the first string is contained in the text derived from the second argument -- | Check if the first string is contained in the text derived from the second argument
isInfixOf :: ( E.Esqueleto query expr backend isInfixOf :: ( E.SqlString s1
, E.SqlString s1
, E.SqlString s2 , E.SqlString s2
) )
=> expr (E.Value s1) -> expr (E.Value s2) -> expr (E.Value Bool) => E.SqlExpr (E.Value s1) -> E.SqlExpr (E.Value s2) -> E.SqlExpr (E.Value Bool)
isInfixOf needle strExpr = E.castString strExpr `E.ilike` (E.%) E.++. needle E.++. (E.%) isInfixOf needle strExpr = E.castString strExpr `E.ilike` (E.%) E.++. needle E.++. (E.%)
hasInfix :: ( E.Esqueleto query expr backend hasInfix :: ( E.SqlString s1
, E.SqlString s1
, E.SqlString s2 , E.SqlString s2
) )
=> expr (E.Value s2) -> expr (E.Value s1) -> expr (E.Value Bool) => E.SqlExpr (E.Value s2) -> E.SqlExpr (E.Value s1) -> E.SqlExpr (E.Value Bool)
hasInfix = flip isInfixOf hasInfix = flip isInfixOf
and, or :: Foldable f => f (E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool) and, or :: Foldable f => f (E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool)
@ -194,6 +193,9 @@ orderByEnum = orderByList $ List.sortOn fromEnum universeF
lower :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) lower :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s)
lower = E.unsafeSqlFunction "LOWER" lower = E.unsafeSqlFunction "LOWER"
strip :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s)
strip = E.unsafeSqlFunction "TRIM"
ciEq :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value Bool) ciEq :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value Bool)
ciEq a b = lower a E.==. lower b ciEq a b = lower a E.==. lower b

13
src/Database/Persist/Class/Instances.hs
View File

@ -8,11 +8,14 @@ module Database.Persist.Class.Instances
import ClassyPrelude import ClassyPrelude
import Database.Persist.Class import Database.Persist.Class
import Database.Persist.Types (HaskellName, DBName, PersistValue)
import Database.Persist.Types.Instances () import Database.Persist.Types.Instances ()
import Data.Binary (Binary) import Data.Binary (Binary)
import qualified Data.Binary as Binary import qualified Data.Binary as Binary
import qualified Data.Map as Map
instance PersistEntity record => Hashable (Key record) where instance PersistEntity record => Hashable (Key record) where
hashWithSalt s = hashWithSalt s . toPersistValue hashWithSalt s = hashWithSalt s . toPersistValue
@ -24,3 +27,13 @@ instance PersistEntity record => Binary (Key record) where
instance PersistEntity record => NFData (Key record) where instance PersistEntity record => NFData (Key record) where
rnf = rnf . keyToValues rnf = rnf . keyToValues
uniqueToMap :: PersistEntity record => Unique record -> Map (HaskellName, DBName) PersistValue
uniqueToMap = fmap Map.fromList $ zip <$> persistUniqueToFieldNames <*> persistUniqueToValues
instance PersistEntity record => Eq (Unique record) where
(==) = (==) `on` uniqueToMap
instance PersistEntity record => Show (Unique record) where
showsPrec p = showsPrec p . uniqueToMap

649
src/Foundation.hs
View File

File diff suppressed because it is too large Load Diff

18
src/Handler/Admin.hs
View File

@ -21,7 +21,6 @@ import Database.Persist.Sql (fromSqlKey)
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
import Database.Esqueleto.Utils (mkExactFilter, mkContainsFilter) import Database.Esqueleto.Utils (mkExactFilter, mkContainsFilter)
import Handler.Utils.Table.Cells
import qualified Handler.Utils.TermCandidates as Candidates import qualified Handler.Utils.TermCandidates as Candidates
-- import Colonnade hiding (fromMaybe) -- import Colonnade hiding (fromMaybe)
@ -55,7 +54,7 @@ instance Button UniWorX ButtonCreate where
btnClasses CreateInf = [BCIsButton, BCPrimary] btnClasses CreateInf = [BCIsButton, BCPrimary]
-- END Button needed only here -- END Button needed only here
emailTestForm :: AForm (HandlerT UniWorX IO) (Email, MailContext) emailTestForm :: AForm (HandlerFor UniWorX) (Email, MailContext)
emailTestForm = (,) emailTestForm = (,)
<$> areq emailField (fslI MsgMailTestFormEmail) Nothing <$> areq emailField (fslI MsgMailTestFormEmail) Nothing
<*> ( MailContext <*> ( MailContext
@ -113,7 +112,7 @@ postAdminTestR = do
jId <- queueJob $ JobSendTestEmail email ls jId <- queueJob $ JobSendTestEmail email ls
tell . pure $ Message Success [shamlet|Email-test gestartet (Job ##{tshow (fromSqlKey jId)})|] (Just IconEmail) tell . pure $ Message Success [shamlet|Email-test gestartet (Job ##{tshow (fromSqlKey jId)})|] (Just IconEmail)
return jId return jId
writeJobCtl $ JobCtlPerform jId runReaderT (writeJobCtl $ JobCtlPerform jId) =<< getYesod
addMessage Warning [shamlet|Inkorrekt ausgegebener Alert|] -- For testing alert handling when short circuiting; for proper (not fallback-solution) handling always use `tell` within `formResultModal` addMessage Warning [shamlet|Inkorrekt ausgegebener Alert|] -- For testing alert handling when short circuiting; for proper (not fallback-solution) handling always use `tell` within `formResultModal`
let emailWidget' = wrapForm emailWidget def let emailWidget' = wrapForm emailWidget def
@ -147,7 +146,14 @@ postAdminTestR = do
$forall m <- msgs $forall m <- msgs
<li>#{m} <li>#{m}
|] |]
let testTooltipMsg = toWidget [whamlet| So sehen aktuell Tooltips via iconTooltip aus. |] :: WidgetFor UniWorX ()
msgInfoTooltip <- messageI Info ("Info-Tooltip via messageI" :: Text)
msgSuccessTooltip <- messageI Success ("Success-Tooltip via messageI" :: Text)
msgWarningTooltip <- messageI Warning ("Warning-Tooltip via messageI" :: Text)
msgErrorTooltip <- messageI Error ("Error-Tooltip via messageI" :: Text)
msgNonDefaultIconTooltip <- messageIconI Info IconEmail ("Info-Tooltip mit lustigem Icon" :: Text)
{- The following demonstrates the use of @massInput@. {- The following demonstrates the use of @massInput@.
@ -190,7 +196,7 @@ postAdminTestR = do
-- | How does the shape (`ListLength`) change if a certain cell is deleted? -- | How does the shape (`ListLength`) change if a certain cell is deleted?
deleteCell :: Map ListPosition Int -- ^ Current shape, including initialisation data deleteCell :: Map ListPosition Int -- ^ Current shape, including initialisation data
-> ListPosition -- ^ Coordinate to delete -> ListPosition -- ^ Coordinate to delete
-> MaybeT (MForm (HandlerT UniWorX IO)) (Map ListPosition ListPosition) -- ^ Monadically compute a set of new positions and their associated old positions -> MaybeT (MForm (HandlerFor UniWorX)) (Map ListPosition ListPosition) -- ^ Monadically compute a set of new positions and their associated old positions
deleteCell = miDeleteList deleteCell = miDeleteList
-- | Make a decision on whether an add widget should be allowed to further cells, given the current @liveliness@ (i.e. before performing the addition) -- | Make a decision on whether an add widget should be allowed to further cells, given the current @liveliness@ (i.e. before performing the addition)
allowAdd :: ListPosition -> Natural -> ListLength -> Bool allowAdd :: ListPosition -> Natural -> ListLength -> Bool
@ -375,7 +381,7 @@ postAdminFeaturesR = do
-> Getter (DBRow r) (Maybe Text) -> Getter (DBRow r) (Maybe Text)
-> Getter (DBRow r) i -> Getter (DBRow r) i
-> DBRow r -> DBRow r
-> DBCell (MForm (HandlerT UniWorX IO)) (FormResult (DBFormResult i a (DBRow r))) -> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r)))
textInputCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex) textInputCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
(\row _mkUnique -> (\(res,fieldView) -> (set lensRes . assertM (not . Text.null) <$> res, fvInput fieldView)) (\row _mkUnique -> (\(res,fieldView) -> (set lensRes . assertM (not . Text.null) <$> res, fvInput fieldView))
<$> mopt textField "" (Just $ row ^. lensDefault) <$> mopt textField "" (Just $ row ^. lensDefault)
@ -386,7 +392,7 @@ postAdminFeaturesR = do
-> Getter (DBRow r) Bool -> Getter (DBRow r) Bool
-> Getter (DBRow r) i -> Getter (DBRow r) i
-> DBRow r -> DBRow r
-> DBCell (MForm (HandlerT UniWorX IO)) (FormResult (DBFormResult i a (DBRow r))) -> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r)))
checkboxCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex) checkboxCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
( \row _mkUnique -> (\(res, fieldView) -> (set lensRes <$> res, fvInput fieldView)) ( \row _mkUnique -> (\(res, fieldView) -> (set lensRes <$> res, fvInput fieldView))
<$> mpopt checkBoxField "" (Just $ row ^. lensDefault) <$> mpopt checkBoxField "" (Just $ row ^. lensDefault)

15
src/Handler/Allocation/Application.hs
View File

@ -52,7 +52,7 @@ data ApplicationForm = ApplicationForm
{ afPriority :: Maybe Natural { afPriority :: Maybe Natural
, afField :: Maybe StudyFeaturesId , afField :: Maybe StudyFeaturesId
, afText :: Maybe Text , afText :: Maybe Text
, afFiles :: Maybe (Source Handler File) , afFiles :: Maybe (ConduitT () File Handler ())
, afRatingVeto :: Bool , afRatingVeto :: Bool
, afRatingPoints :: Maybe ExamGrade , afRatingPoints :: Maybe ExamGrade
, afRatingComment :: Maybe Text , afRatingComment :: Maybe Text
@ -77,13 +77,12 @@ applicationForm :: (Maybe AllocationId)
-> Html -> MForm Handler (FormResult ApplicationForm, ApplicationFormView) -> Html -> MForm Handler (FormResult ApplicationForm, ApplicationFormView)
applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf = do applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf = do
(mApp, coursesNum, Course{..}, maxPrio) <- liftHandlerT . runDB $ do (mApp, coursesNum, Course{..}, maxPrio) <- liftHandler . runDB $ do
mApplication <- listToMaybe <$> selectList [CourseApplicationAllocation ==. maId, CourseApplicationUser ==. uid, CourseApplicationCourse ==. cid] [LimitTo 1] mApplication <- listToMaybe <$> selectList [CourseApplicationAllocation ==. maId, CourseApplicationUser ==. uid, CourseApplicationCourse ==. cid] [LimitTo 1]
coursesNum <- fromIntegral . fromMaybe 1 <$> for maId (\aId -> count [AllocationCourseAllocation ==. aId]) coursesNum <- fromIntegral . fromMaybe 1 <$> for maId (\aId -> count [AllocationCourseAllocation ==. aId])
course <- getJust cid course <- getJust cid
[E.Value (fromMaybe 0 -> maxPrio)] <- E.select . E.from $ \courseApplication -> do (fromMaybe 0 -> maxPrio) <- fmap ((>>= E.unValue) . listToMaybe) . E.select . E.from $ \courseApplication -> do
E.where_ $ courseApplication E.^. CourseApplicationCourse E.==. E.val cid E.where_ $ courseApplication E.^. CourseApplicationUser E.==. E.val uid
E.&&. courseApplication E.^. CourseApplicationUser E.==. E.val uid
E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.val maId E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.val maId
E.&&. E.not_ (E.isNothing $ courseApplication E.^. CourseApplicationAllocationPriority) E.&&. E.not_ (E.isNothing $ courseApplication E.^. CourseApplicationAllocationPriority)
return . E.joinV . E.max_ $ courseApplication E.^. CourseApplicationAllocationPriority return . E.joinV . E.max_ $ courseApplication E.^. CourseApplicationAllocationPriority
@ -146,7 +145,7 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
-> over _2 Just . over (_1 . _FormSuccess) (assertM $ not . Text.null) <$> mopt textField' textFs (Just $ mApp >>= courseApplicationText . entityVal) -> over _2 Just . over (_1 . _FormSuccess) (assertM $ not . Text.null) <$> mopt textField' textFs (Just $ mApp >>= courseApplicationText . entityVal)
hasFiles <- for mApp $ \(Entity appId _) hasFiles <- for mApp $ \(Entity appId _)
-> fmap (not . null) . liftHandlerT . runDB $ selectKeysList [ CourseApplicationFileApplication ==. appId ] [ LimitTo 1 ] -> fmap (not . null) . liftHandler . runDB $ selectKeysList [ CourseApplicationFileApplication ==. appId ] [ LimitTo 1 ]
appCID <- for mApp $ encrypt . entityKey appCID <- for mApp $ encrypt . entityKey
let appFilesInfo = (,) <$> hasFiles <*> appCID let appFilesInfo = (,) <$> hasFiles <*> appCID
@ -296,7 +295,7 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do
fId <- insert file fId <- insert file
insert_ $ CourseApplicationFile appId fId insert_ $ CourseApplicationFile appId fId
forM_ afFiles $ \afFiles' -> forM_ afFiles $ \afFiles' ->
runConduit $ transPipe liftHandlerT afFiles' .| C.mapM_ sinkFile' runConduit $ transPipe liftHandler afFiles' .| C.mapM_ sinkFile'
audit $ TransactionCourseApplicationEdit cid uid appId audit $ TransactionCourseApplicationEdit cid uid appId
addMessageI Success $ MsgCourseApplicationCreated courseShorthand addMessageI Success $ MsgCourseApplicationCreated courseShorthand
| is _BtnAllocationApplicationEdit afAction || is _BtnAllocationApplicationRate afAction | is _BtnAllocationApplicationEdit afAction || is _BtnAllocationApplicationRate afAction
@ -327,7 +326,7 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do
fId <- lift $ insert file fId <- lift $ insert file
lift . insert_ $ CourseApplicationFile appId fId lift . insert_ $ CourseApplicationFile appId fId
modify $ Set.insert fId modify $ Set.insert fId
in runConduit $ transPipe liftHandlerT afFiles' .| C.mapM_ sinkFile' in runConduit $ transPipe liftHandler afFiles' .| C.mapM_ sinkFile'
deleteCascadeWhere [ FileId <-. Set.toList (oldFiles `Set.intersection` changes) ] deleteCascadeWhere [ FileId <-. Set.toList (oldFiles `Set.intersection` changes) ]
return changes return changes
| otherwise | otherwise

2
src/Handler/Allocation/List.hs
View File

@ -1,3 +1,5 @@
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
module Handler.Allocation.List module Handler.Allocation.List
( getAllocationListR ( getAllocationListR
) where ) where

1
src/Handler/Allocation/Register.hs
View File

@ -50,6 +50,7 @@ postARegisterR tid ssh ash = do
{ allocationUserAllocation = aId { allocationUserAllocation = aId
, allocationUserUser = uid , allocationUserUser = uid
, allocationUserTotalCourses = arfTotalCourses , allocationUserTotalCourses = arfTotalCourses
, allocationUserPriority = Nothing
} }
[ AllocationUserTotalCourses =. arfTotalCourses [ AllocationUserTotalCourses =. arfTotalCourses
] ]

22
src/Handler/Allocation/Show.hs
View File

@ -23,11 +23,16 @@ getAShowR tid ssh ash = do
resultCourseApplication = _2 . _Just resultCourseApplication = _2 . _Just
resultHasTemplate :: Simple Field3 a (E.Value Bool) => Lens' a Bool resultHasTemplate :: Simple Field3 a (E.Value Bool) => Lens' a Bool
resultHasTemplate = _3 . _Value resultHasTemplate = _3 . _Value
resultIsRegistered :: Simple Field4 a (E.Value Bool) => Lens' a Bool
resultIsRegistered = _4 . _Value
(Entity aId Allocation{..}, courses, registration) <- runDB $ do (Entity aId Allocation{..}, School{..}, isAnyLecturer, courses, registration) <- runDB $ do
alloc@(Entity aId _) <- getBy404 $ TermSchoolAllocationShort tid ssh ash alloc@(Entity aId Allocation{allocationSchool}) <- getBy404 $ TermSchoolAllocationShort tid ssh ash
school <- getJust allocationSchool
courses <- E.select . E.from $ \((allocationCourse `E.InnerJoin` course) `E.LeftOuterJoin` courseApplication) -> do courses <- E.select . E.from $ \((allocationCourse `E.InnerJoin` course) `E.LeftOuterJoin` courseApplication `E.LeftOuterJoin` registration) -> do
E.on $ registration E.?. CourseParticipantCourse E.==. E.just (course E.^. CourseId)
E.&&. registration E.?. CourseParticipantUser E.==. E.val muid
E.on $ courseApplication E.?. CourseApplicationCourse E.==. E.just (course E.^. CourseId) E.on $ courseApplication E.?. CourseApplicationCourse E.==. E.just (course E.^. CourseId)
E.&&. courseApplication E.?. CourseApplicationUser E.==. E.val muid E.&&. courseApplication E.?. CourseApplicationUser E.==. E.val muid
E.&&. courseApplication E.?. CourseApplicationAllocation E.==. E.just (E.just $ E.val aId) E.&&. courseApplication E.?. CourseApplicationAllocation E.==. E.just (E.just $ E.val aId)
@ -36,11 +41,13 @@ getAShowR tid ssh ash = do
E.orderBy [E.asc $ course E.^. CourseName] E.orderBy [E.asc $ course E.^. CourseName]
let hasTemplate = E.exists . E.from $ \courseAppInstructionFile -> let hasTemplate = E.exists . E.from $ \courseAppInstructionFile ->
E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. course E.^. CourseId E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. course E.^. CourseId
return (course, courseApplication, hasTemplate) return (course, courseApplication, hasTemplate, E.not_ . E.isNothing $ registration E.?. CourseParticipantId)
registration <- fmap join . for muid $ getBy . UniqueAllocationUser aId registration <- fmap join . for muid $ getBy . UniqueAllocationUser aId
return (alloc, nubOn (view $ resultCourse . _entityKey) courses, registration) isAnyLecturer <- hasWriteAccessTo CourseNewR
return (alloc, school, isAnyLecturer, nubOn (view $ resultCourse . _entityKey) courses, registration)
MsgRenderer mr <- getMsgRenderer MsgRenderer mr <- getMsgRenderer
let title = MsgAllocationTitle (mr . ShortTermIdentifier $ unTermKey allocationTerm) (unSchoolKey allocationSchool) allocationName let title = MsgAllocationTitle (mr . ShortTermIdentifier $ unTermKey allocationTerm) (unSchoolKey allocationSchool) allocationName
@ -68,10 +75,11 @@ getAShowR tid ssh ash = do
let Entity cid Course{..} = cEntry ^. resultCourse let Entity cid Course{..} = cEntry ^. resultCourse
hasApplicationTemplate = cEntry ^. resultHasTemplate hasApplicationTemplate = cEntry ^. resultHasTemplate
mApp = cEntry ^? resultCourseApplication mApp = cEntry ^? resultCourseApplication
cID <- encrypt cid :: WidgetT UniWorX IO CryptoUUIDCourse isRegistered = cEntry ^. resultIsRegistered
cID <- encrypt cid :: WidgetFor UniWorX CryptoUUIDCourse
mayApply <- hasWriteAccessTo . AllocationR tid ssh ash $ AApplyR cID mayApply <- hasWriteAccessTo . AllocationR tid ssh ash $ AApplyR cID
isLecturer <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR isLecturer <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR
mApplyFormView <- liftHandlerT . for muid $ \uid -> generateFormPost . applicationForm (Just aId) cid uid $ ApplicationFormMode True mayApply isLecturer mApplyFormView <- liftHandler . for muid $ \uid -> generateFormPost . applicationForm (Just aId) cid uid $ ApplicationFormMode True mayApply isLecturer
tRoute <- case mApp of tRoute <- case mApp of
Nothing -> return . AllocationR tid ssh ash $ AApplyR cID Nothing -> return . AllocationR tid ssh ash $ AApplyR cID
Just (Entity appId _) -> CApplicationR courseTerm courseSchool courseShorthand <$> encrypt appId <*> pure CAEditR Just (Entity appId _) -> CApplicationR courseTerm courseSchool courseShorthand <$> encrypt appId <*> pure CAEditR

37
src/Handler/Corrections.hs
View File

@ -1,13 +1,12 @@
module Handler.Corrections where module Handler.Corrections where
import Import import Import hiding (link)
-- import System.FilePath (takeFileName) -- import System.FilePath (takeFileName)
import Jobs import Jobs
import Handler.Utils import Handler.Utils hiding (colSchool)
import Handler.Utils.Corrections import Handler.Utils.Corrections
import Handler.Utils.Submission import Handler.Utils.Submission
import Handler.Utils.Table.Cells
import Handler.Utils.SheetType import Handler.Utils.SheetType
import Handler.Utils.Delete import Handler.Utils.Delete
-- import Handler.Utils.Zip -- import Handler.Utils.Zip
@ -72,8 +71,8 @@ correctionsTableQuery whereClause returnStatement t@((course `E.InnerJoin` sheet
E.where_ $ whereClause t E.where_ $ whereClause t
return $ returnStatement t return $ returnStatement t
lastEditQuery :: Database.Esqueleto.Internal.Language.From query expr backend (expr (Entity SubmissionEdit)) lastEditQuery :: Database.Esqueleto.Internal.Language.From (E.SqlExpr (Entity SubmissionEdit))
=> expr (Entity Submission) -> expr (E.Value (Maybe UTCTime)) => E.SqlExpr (Entity Submission) -> E.SqlExpr (E.Value (Maybe UTCTime))
lastEditQuery submission = E.sub_select $ E.from $ \edit -> do lastEditQuery submission = E.sub_select $ E.from $ \edit -> do
E.where_ $ edit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId E.where_ $ edit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId
return $ E.max_ $ edit E.^. SubmissionEditTime return $ E.max_ $ edit E.^. SubmissionEditTime
@ -217,7 +216,7 @@ colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ for
) )
colCommentField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, b, Maybe Text) CorrectionTableData))) colCommentField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, b, Maybe Text) CorrectionTableData)))
colCommentField = sortable (Just "comment") (i18nCell MsgRatingComment) $ fmap (addCellAttrs [("style","width:60%")]) $ formCell id colCommentField = sortable (Just "comment") (i18nCell MsgRatingComment) $ fmap (cellAttrs <>~ [("style","width:60%")]) $ formCell id
(\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _) } -> return subId) (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _) } -> return subId)
(\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _, _) } mkUnique -> over (_1.mapped) ((_3 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvInput <$> mopt textareaField (fsUniq mkUnique "comment") (Just $ Textarea <$> submissionRatingComment)) (\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _, _) } mkUnique -> over (_1.mapped) ((_3 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvInput <$> mopt textareaField (fsUniq mkUnique "comment") (Just $ Textarea <$> submissionRatingComment))
@ -239,7 +238,7 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d
) )
in (submission, sheet, crse, corrector, lastEditQuery submission) in (submission, sheet, crse, corrector, lastEditQuery submission)
) )
dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CorrectionTableData dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerFor UniWorX)) CorrectionTableData
dbtProj = traverse $ \(submission@(Entity sId _), sheet@(Entity shId _), (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector, E.Value mbLastEdit) -> do dbtProj = traverse $ \(submission@(Entity sId _), sheet@(Entity shId _), (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector, E.Value mbLastEdit) -> do
submittors <- lift . E.select . E.from $ \((submissionUser `E.InnerJoin` user) `E.LeftOuterJoin` pseudonym) -> do submittors <- lift . E.select . E.from $ \((submissionUser `E.InnerJoin` user) `E.LeftOuterJoin` pseudonym) -> do
E.on $ pseudonym E.?. SheetPseudonymUser E.==. E.just (user E.^. UserId) E.on $ pseudonym E.?. SheetPseudonymUser E.==. E.just (user E.^. UserId)
@ -399,9 +398,9 @@ data ActionCorrectionsData = CorrDownloadData
| CorrAutoSetCorrectorData SheetId | CorrAutoSetCorrectorData SheetId
| CorrDeleteData | CorrDeleteData
correctionsR :: _ -> _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerT UniWorX IO) ActionCorrectionsData) -> Handler TypedContent correctionsR :: _ -> _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerFor UniWorX) ActionCorrectionsData) -> Handler TypedContent
correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do
Just currentRoute <- getCurrentRoute -- This should never be called from a 404 handler currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler
postDeleteR $ \drRecords -> (submissionDeleteRoute drRecords) postDeleteR $ \drRecords -> (submissionDeleteRoute drRecords)
{ drAbort = SomeRoute currentRoute { drAbort = SomeRoute currentRoute
@ -417,7 +416,7 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do
, dbParamsFormAdditional = \frag -> do , dbParamsFormAdditional = \frag -> do
(actionRes, action) <- multiActionM actions "" Nothing mempty (actionRes, action) <- multiActionM actions "" Nothing mempty
return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action) return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action)
, dbParamsFormEvaluate = liftHandlerT . runFormPost , dbParamsFormEvaluate = liftHandler . runFormPost
, dbParamsFormResult = _1 , dbParamsFormResult = _1
, dbParamsFormIdent = def , dbParamsFormIdent = def
} }
@ -467,7 +466,7 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do
] ]
addMessageI Success $ MsgUpdatedAssignedCorrectorSingle num addMessageI Success $ MsgUpdatedAssignedCorrectorSingle num
auditAllSubEdit sIds auditAllSubEdit sIds
(E.Value selfCorrectors:_) <- E.select . E.from $ \(submission `E.InnerJoin` subuser) -> do selfCorrectors <- fmap (maybe 0 (max 0 . E.unValue) . listToMaybe) . E.select . E.from $ \(submission `E.InnerJoin` subuser) -> do
E.on $ submission E.^. SubmissionId E.==. subuser E.^. SubmissionUserSubmission E.on $ submission E.^. SubmissionId E.==. subuser E.^. SubmissionUserSubmission
E.where_ $ submission E.^. SubmissionId `E.in_` E.valList subs E.where_ $ submission E.^. SubmissionId `E.in_` E.valList subs
E.&&. submission E.^. SubmissionRatingBy E.==. E.just (subuser E.^. SubmissionUserUser) E.&&. submission E.^. SubmissionRatingBy E.==. E.just (subuser E.^. SubmissionUserUser)
@ -538,7 +537,7 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do
where where
authorizedToAssign :: SubmissionId -> DB Bool authorizedToAssign :: SubmissionId -> DB Bool
authorizedToAssign sId = do authorizedToAssign sId = do
[(E.Value tid, E.Value ssh, E.Value csh, E.Value shn)] <- (E.Value tid, E.Value ssh, E.Value csh, E.Value shn) <- maybe notFound return . listToMaybe <=<
E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission ) -> do E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission ) -> do
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
@ -548,7 +547,7 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do
let route = CSubmissionR tid ssh csh shn cID SubAssignR let route = CSubmissionR tid ssh csh shn cID SubAssignR
(== Authorized) <$> evalAccessDB route True (== Authorized) <$> evalAccessDB route True
type ActionCorrections' = (ActionCorrections, AForm (HandlerT UniWorX IO) ActionCorrectionsData) type ActionCorrections' = (ActionCorrections, AForm (HandlerFor UniWorX) ActionCorrectionsData)
downloadAction, deleteAction :: ActionCorrections' downloadAction, deleteAction :: ActionCorrections'
downloadAction = ( CorrDownload downloadAction = ( CorrDownload
@ -561,7 +560,7 @@ deleteAction = ( CorrDelete
assignAction :: Either CourseId SheetId -> ActionCorrections' assignAction :: Either CourseId SheetId -> ActionCorrections'
assignAction selId = ( CorrSetCorrector assignAction selId = ( CorrSetCorrector
, wFormToAForm $ do , wFormToAForm $ do
correctors <- liftHandlerT . runDB . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector `E.InnerJoin` user) -> do correctors <- liftHandler . runDB . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector `E.InnerJoin` user) -> do
E.on $ user E.^. UserId E.==. sheetCorrector E.^. SheetCorrectorUser E.on $ user E.^. UserId E.==. sheetCorrector E.^. SheetCorrectorUser
E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
@ -574,7 +573,7 @@ assignAction selId = ( CorrSetCorrector
correctors' <- forM correctors $ \Entity{ entityKey, entityVal = User{..} } -> (SomeMessage userDisplayName, ) <$> encrypt entityKey correctors' <- forM correctors $ \Entity{ entityKey, entityVal = User{..} } -> (SomeMessage userDisplayName, ) <$> encrypt entityKey
cId <- wopt (selectFieldList correctors' :: Field (HandlerT UniWorX IO) CryptoUUIDUser) (fslI MsgCorrector & setTooltip MsgCorrSetCorrectorTooltip) Nothing cId <- wopt (selectFieldList correctors' :: Field (HandlerFor UniWorX) CryptoUUIDUser) (fslI MsgCorrector & setTooltip MsgCorrSetCorrectorTooltip) Nothing
fmap CorrSetCorrectorData <$> (traverse.traverse) decrypt cId fmap CorrSetCorrectorData <$> (traverse.traverse) decrypt cId
) )
@ -741,7 +740,7 @@ postCorrectionR tid ssh csh shn cid = do
} }
formResult corrResult $ \(rated, ratingPoints', ratingComment') -> do formResult corrResult $ \(rated, ratingPoints', ratingComment') -> do
uid <- liftHandlerT requireAuthId uid <- liftHandler requireAuthId
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
if if
@ -1014,7 +1013,7 @@ postCorrectionsGradeR = do
, colCommentField , colCommentField
] -- Continue here ] -- Continue here
psValidator = def psValidator = def
& defaultSorting [SortDescBy "ratingtime"] :: PSValidator (MForm (HandlerT UniWorX IO)) (FormResult (DBFormResult SubmissionId (Bool, Maybe Points, Maybe Text) CorrectionTableData)) & defaultSorting [SortDescBy "ratingtime"] :: PSValidator (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult SubmissionId (Bool, Maybe Points, Maybe Text) CorrectionTableData))
unFormResult = getDBFormResult $ \DBRow{ dbrOutput = (Entity _ sub@Submission{..}, _, _, _, _, _) } -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment) unFormResult = getDBFormResult $ \DBRow{ dbrOutput = (Entity _ sub@Submission{..}, _, _, _, _, _) } -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment)
dbtProj' i@(Entity subId _, Entity _ Sheet{ sheetName = shn }, (_, csh, tid, ssh), _, _, _) = do dbtProj' i@(Entity subId _, Entity _ Sheet{ sheetName = shn }, (_, csh, tid, ssh), _, _, _) = do
cID <- encrypt subId cID <- encrypt subId
@ -1266,10 +1265,6 @@ assignHandler tid ssh csh cid assignSids = do
showAvgsDays :: Maybe NominalDiffTime -> Integer -> Text showAvgsDays :: Maybe NominalDiffTime -> Integer -> Text
showAvgsDays Nothing _ = mempty showAvgsDays Nothing _ = mempty
showAvgsDays (Just dt) n = formatDiffDays $ dt / fromIntegral n showAvgsDays (Just dt) n = formatDiffDays $ dt / fromIntegral n
heat :: Integer -> Integer -> Double
heat = heat' 0.3
heat' :: Double -> Integer -> Integer -> Double
heat' cut full achieved = roundToDigits 3 $ cutOffPercent cut (fromIntegral full^2) (fromIntegral achieved^2)
let headingShort let headingShort
| 0 < Map.size assignment = MsgMenuCorrectionsAssignSheet $ Text.intercalate ", " $ fmap CI.original $ Map.keys assignment | 0 < Map.size assignment = MsgMenuCorrectionsAssignSheet $ Text.intercalate ", " $ fmap CI.original $ Map.keys assignment
| otherwise = MsgMenuCorrectionsAssign | otherwise = MsgMenuCorrectionsAssign

5
src/Handler/Course.hs
View File

@ -16,6 +16,8 @@ import Handler.Course.Show as Handler.Course
import Handler.Course.User as Handler.Course import Handler.Course.User as Handler.Course
import Handler.Course.Users as Handler.Course import Handler.Course.Users as Handler.Course
import Handler.Course.Application as Handler.Course import Handler.Course.Application as Handler.Course
import Handler.ExamOffice.Course as Handler.Course
import Handler.Course.News as Handler.Course
getCHiWisR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCHiWisR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
@ -27,3 +29,6 @@ getCNotesR, postCNotesR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
-- If they are shared, adjust MsgCourseUserNoteTooltip -- If they are shared, adjust MsgCourseUserNoteTooltip
getCNotesR = postCNotesR getCNotesR = postCNotesR
postCNotesR _ _ _ = defaultLayout [whamlet|You have corrector access to this course.|] postCNotesR _ _ _ = defaultLayout [whamlet|You have corrector access to this course.|]
postCFavouriteR :: TermId -> SchoolId -> CourseShorthand -> Handler ()
postCFavouriteR _ _ _ = error "not implemented"

4
src/Handler/Course/Application/Files.hs
View File

@ -1,3 +1,5 @@
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
module Handler.Course.Application.Files module Handler.Course.Application.Files
( getCAFilesR ( getCAFilesR
, getCAppsFilesR , getCAppsFilesR
@ -47,7 +49,7 @@ getCAppsFilesR tid ssh csh = do
archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ MsgCourseAllApplicationsArchiveName tid ssh csh archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ MsgCourseAllApplicationsArchiveName tid ssh csh
let let
fsSource :: Source DB File fsSource :: ConduitT () File DB ()
fsSource = do fsSource = do
apps <- lift . E.select . E.from $ \((course `E.InnerJoin` courseApplication `E.InnerJoin` user) `E.LeftOuterJoin` allocation) -> do apps <- lift . E.select . E.from $ \((course `E.InnerJoin` courseApplication `E.InnerJoin` user) `E.LeftOuterJoin` allocation) -> do
E.on $ allocation E.?. AllocationId E.==. courseApplication E.^. CourseApplicationAllocation E.on $ allocation E.?. AllocationId E.==. courseApplication E.^. CourseApplicationAllocation

199
src/Handler/Course/Application/List.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
module Handler.Course.Application.List module Handler.Course.Application.List
( getCApplicationsR, postCApplicationsR ( getCApplicationsR, postCApplicationsR
@ -7,7 +8,6 @@ module Handler.Course.Application.List
import Import import Import
import Handler.Utils import Handler.Utils
import Handler.Utils.Table.Columns
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Utils as E
@ -25,6 +25,10 @@ import qualified Data.Map as Map
import qualified Data.Conduit.List as C import qualified Data.Conduit.List as C
import Handler.Course.ParticipantInvite
import Jobs.Queue
type CourseApplicationsTableExpr = ( E.SqlExpr (Entity CourseApplication) type CourseApplicationsTableExpr = ( E.SqlExpr (Entity CourseApplication)
`E.InnerJoin` E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity User)
@ -34,41 +38,49 @@ type CourseApplicationsTableExpr = ( E.SqlExpr (Entity CourseApplic
`E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms))
`E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree))
) )
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseParticipant))
type CourseApplicationsTableData = DBRow ( Entity CourseApplication type CourseApplicationsTableData = DBRow ( Entity CourseApplication
, Entity User , Entity User
, E.Value Bool -- hasFiles , Bool -- hasFiles
, Maybe (Entity Allocation) , Maybe (Entity Allocation)
, Maybe (Entity StudyFeatures) , Maybe (Entity StudyFeatures)
, Maybe (Entity StudyTerms) , Maybe (Entity StudyTerms)
, Maybe (Entity StudyDegree) , Maybe (Entity StudyDegree)
, Bool -- isParticipant
) )
courseApplicationsIdent :: Text courseApplicationsIdent :: Text
courseApplicationsIdent = "applications" courseApplicationsIdent = "applications"
queryCourseApplication :: Getter CourseApplicationsTableExpr (E.SqlExpr (Entity CourseApplication)) queryCourseApplication :: Getter CourseApplicationsTableExpr (E.SqlExpr (Entity CourseApplication))
queryCourseApplication = to $ $(sqlIJproj 2 1) . $(sqlLOJproj 3 1) queryCourseApplication = to $ $(sqlIJproj 2 1) . $(sqlLOJproj 4 1)
queryUser :: Getter CourseApplicationsTableExpr (E.SqlExpr (Entity User)) queryUser :: Getter CourseApplicationsTableExpr (E.SqlExpr (Entity User))
queryUser = to $ $(sqlIJproj 2 2) . $(sqlLOJproj 3 1) queryUser = to $ $(sqlIJproj 2 2) . $(sqlLOJproj 4 1)
queryHasFiles :: Getter CourseApplicationsTableExpr (E.SqlExpr (E.Value Bool)) queryHasFiles :: Getter CourseApplicationsTableExpr (E.SqlExpr (E.Value Bool))
queryHasFiles = to $ hasFiles . $(sqlIJproj 2 1) . $(sqlLOJproj 3 1) queryHasFiles = to $ hasFiles . $(sqlIJproj 2 1) . $(sqlLOJproj 4 1)
where where
hasFiles appl = E.exists . E.from $ \courseApplicationFile -> hasFiles appl = E.exists . E.from $ \courseApplicationFile ->
E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. appl E.^. CourseApplicationId E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. appl E.^. CourseApplicationId
queryAllocation :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity Allocation))) queryAllocation :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity Allocation)))
queryAllocation = to $(sqlLOJproj 3 2) queryAllocation = to $(sqlLOJproj 4 2)
queryStudyFeatures :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity StudyFeatures))) queryStudyFeatures :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity StudyFeatures)))
queryStudyFeatures = to $ $(sqlIJproj 3 1) . $(sqlLOJproj 3 3) queryStudyFeatures = to $ $(sqlIJproj 3 1) . $(sqlLOJproj 4 3)
queryStudyTerms :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity StudyTerms))) queryStudyTerms :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity StudyTerms)))
queryStudyTerms = to $ $(sqlIJproj 3 2) . $(sqlLOJproj 3 3) queryStudyTerms = to $ $(sqlIJproj 3 2) . $(sqlLOJproj 4 3)
queryStudyDegree :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity StudyDegree))) queryStudyDegree :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity StudyDegree)))
queryStudyDegree = to $ $(sqlIJproj 3 3) . $(sqlLOJproj 3 3) queryStudyDegree = to $ $(sqlIJproj 3 3) . $(sqlLOJproj 4 3)
queryCourseParticipant :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity CourseParticipant)))
queryCourseParticipant = to $(sqlLOJproj 4 4)
queryIsParticipant :: Getter CourseApplicationsTableExpr (E.SqlExpr (E.Value Bool))
queryIsParticipant = to $ E.not_ . E.isNothing . (E.?. CourseParticipantId) . $(sqlLOJproj 4 4)
resultCourseApplication :: Lens' CourseApplicationsTableData (Entity CourseApplication) resultCourseApplication :: Lens' CourseApplicationsTableData (Entity CourseApplication)
resultCourseApplication = _dbrOutput . _1 resultCourseApplication = _dbrOutput . _1
@ -77,7 +89,7 @@ resultUser :: Lens' CourseApplicationsTableData (Entity User)
resultUser = _dbrOutput . _2 resultUser = _dbrOutput . _2
resultHasFiles :: Lens' CourseApplicationsTableData Bool resultHasFiles :: Lens' CourseApplicationsTableData Bool
resultHasFiles = _dbrOutput . _3 . _Value resultHasFiles = _dbrOutput . _3
resultAllocation :: Traversal' CourseApplicationsTableData (Entity Allocation) resultAllocation :: Traversal' CourseApplicationsTableData (Entity Allocation)
resultAllocation = _dbrOutput . _4 . _Just resultAllocation = _dbrOutput . _4 . _Just
@ -91,6 +103,9 @@ resultStudyTerms = _dbrOutput . _6 . _Just
resultStudyDegree :: Traversal' CourseApplicationsTableData (Entity StudyDegree) resultStudyDegree :: Traversal' CourseApplicationsTableData (Entity StudyDegree)
resultStudyDegree = _dbrOutput . _7 . _Just resultStudyDegree = _dbrOutput . _7 . _Just
resultIsParticipant :: Lens' CourseApplicationsTableData Bool
resultIsParticipant = _dbrOutput . _8
newtype CourseApplicationsTableVeto = CourseApplicationsTableVeto Bool newtype CourseApplicationsTableVeto = CourseApplicationsTableVeto Bool
deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving (Eq, Ord, Read, Show, Generic, Typeable)
@ -104,7 +119,7 @@ instance Csv.ToField CourseApplicationsTableVeto where
instance Csv.FromField CourseApplicationsTableVeto where instance Csv.FromField CourseApplicationsTableVeto where
parseField f = do parseField f = do
(CI.map Text.strip -> t :: CI Text) <- Csv.parseField f (CI.map Text.strip -> t :: CI Text) <- Csv.parseField f
return . CourseApplicationsTableVeto $ any (== t) return . CourseApplicationsTableVeto $ elem t
[ "veto", "v", "yes", "y", "ja", "j", "wahr", "w", "true", "t", "1" ] [ "veto", "v", "yes", "y", "ja", "j", "wahr", "w", "true", "t", "1" ]
data CourseApplicationsTableCsv = CourseApplicationsTableCsv data CourseApplicationsTableCsv = CourseApplicationsTableCsv
@ -205,14 +220,47 @@ data CourseApplicationsTableCsvException
instance Exception CourseApplicationsTableCsvException instance Exception CourseApplicationsTableCsvException
embedRenderMessage ''UniWorX ''CourseApplicationsTableCsvException id embedRenderMessage ''UniWorX ''CourseApplicationsTableCsvException id
data ButtonAcceptApplications = BtnAcceptApplications
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
instance Universe ButtonAcceptApplications
instance Finite ButtonAcceptApplications
nullaryPathPiece ''ButtonAcceptApplications $ camelToPathPiece' 1
embedRenderMessage ''UniWorX ''ButtonAcceptApplications id
instance Button UniWorX ButtonAcceptApplications where
btnClasses BtnAcceptApplications = [BCIsButton]
data AcceptApplicationsMode = AcceptApplicationsInvite
| AcceptApplicationsDirect
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
instance Universe AcceptApplicationsMode
instance Finite AcceptApplicationsMode
nullaryPathPiece ''AcceptApplicationsMode $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''AcceptApplicationsMode id
data AcceptApplicationsSecondary = AcceptApplicationsSecondaryRandom
| AcceptApplicationsSecondaryTime
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
instance Universe AcceptApplicationsSecondary
instance Finite AcceptApplicationsSecondary
nullaryPathPiece ''AcceptApplicationsSecondary $ camelToPathPiece' 3
embedRenderMessage ''UniWorX ''AcceptApplicationsSecondary id
getCApplicationsR, postCApplicationsR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCApplicationsR, postCApplicationsR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCApplicationsR = postCApplicationsR getCApplicationsR = postCApplicationsR
postCApplicationsR tid ssh csh = do postCApplicationsR tid ssh csh = do
table <- runDB $ do (table, allocationsBounds, mayAccept) <- runDB $ do
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh Entity cid Course{..} <- getBy404 $ TermSchoolCourseShort tid ssh csh
csvName <- getMessageRender <*> pure (MsgCourseApplicationsTableCsvName tid ssh csh)
let let
allocationLink :: Allocation -> SomeRoute UniWorX allocationLink :: Allocation -> SomeRoute UniWorX
allocationLink Allocation{..} = SomeRoute $ AllocationR allocationTerm allocationSchool allocationShorthand AShowR allocationLink Allocation{..} = SomeRoute $ AllocationR allocationTerm allocationSchool allocationShorthand AShowR
@ -236,31 +284,43 @@ postCApplicationsR tid ssh csh = do
studyFeatures <- view queryStudyFeatures studyFeatures <- view queryStudyFeatures
studyTerms <- view queryStudyTerms studyTerms <- view queryStudyTerms
studyDegree <- view queryStudyDegree studyDegree <- view queryStudyDegree
courseParticipant <- view queryCourseParticipant
lift $ do lift $ do
E.on $ E.just (user E.^. UserId) E.==. courseParticipant E.?. CourseParticipantUser
E.&&. courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val cid)
E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree
E.on $ studyTerms E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField E.on $ studyTerms E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField
E.on $ studyFeatures E.?. StudyFeaturesId E.==. courseApplication E.^. CourseApplicationField E.on $ studyFeatures E.?. StudyFeaturesId E.==. courseApplication E.^. CourseApplicationField
E.on $ courseApplication E.^. CourseApplicationAllocation E.==. allocation E.?. AllocationId E.on $ courseApplication E.^. CourseApplicationAllocation E.==. allocation E.?. AllocationId
E.on $ user E.^. UserId E.==. courseApplication E.^. CourseApplicationUser E.on $ user E.^. UserId E.==. courseApplication E.^. CourseApplicationUser
E.where_ $ courseApplication E.^. CourseApplicationCourse E.==. E.val cid E.&&. courseApplication E.^. CourseApplicationCourse E.==. E.val cid
return (courseApplication, user, hasFiles, allocation, studyFeatures, studyTerms, studyDegree) return ( courseApplication
, user
, hasFiles
, allocation
, studyFeatures
, studyTerms
, studyDegree
, E.not_ . E.isNothing $ courseParticipant E.?. CourseParticipantId
)
dbtProj :: DBRow _ -> MaybeT (YesodDB UniWorX) CourseApplicationsTableData dbtProj :: DBRow _ -> MaybeT (YesodDB UniWorX) CourseApplicationsTableData
dbtProj = runReaderT $ do dbtProj = runReaderT $ do
appId <- view $ resultCourseApplication . _entityKey appId <- view $ _dbrOutput . _1 . _entityKey
cID <- encrypt appId cID <- encrypt appId
guardM . hasReadAccessTo $ CApplicationR tid ssh csh cID CAEditR guardM . hasReadAccessTo $ CApplicationR tid ssh csh cID CAEditR
view id asks $ over (_dbrOutput . _3) E.unValue . over (_dbrOutput . _8) E.unValue
dbtRowKey = view $ queryCourseApplication . to (E.^. CourseApplicationId) dbtRowKey = view $ queryCourseApplication . to (E.^. CourseApplicationId)
dbtColonnade :: Colonnade Sortable _ _ dbtColonnade :: Colonnade Sortable _ _
dbtColonnade = mconcat dbtColonnade = mconcat
[ emptyOpticColonnade (resultAllocation . _entityVal) $ \l -> anchorColonnade (views l allocationLink) $ colAllocationShorthand (l . _allocationShorthand) [ sortable (Just "participant") (i18nCell MsgCourseApplicationIsParticipant) $ bool mempty (cell $ toWidget iconOK) . view resultIsParticipant
, emptyOpticColonnade (resultAllocation . _entityVal) $ \l -> anchorColonnade (views l allocationLink) $ colAllocationShorthand (l . _allocationShorthand)
, anchorColonnadeM (views (resultCourseApplication . _entityKey) applicationLink) $ colApplicationId (resultCourseApplication . _entityKey) , anchorColonnadeM (views (resultCourseApplication . _entityKey) applicationLink) $ colApplicationId (resultCourseApplication . _entityKey)
, anchorColonnadeM (views (resultUser . _entityKey) participantLink) $ colUserDisplayName (resultUser . _entityVal . $(multifocusL 2) _userDisplayName _userSurname) , anchorColonnadeM (views (resultUser . _entityKey) participantLink) $ colUserDisplayName (resultUser . _entityVal . $(multifocusL 2) _userDisplayName _userSurname)
, colUserMatriculation (resultUser . _entityVal . _userMatrikelnummer) , colUserMatriculation (resultUser . _entityVal . _userMatrikelnummer)
@ -268,14 +328,15 @@ postCApplicationsR tid ssh csh = do
, emptyOpticColonnade (resultStudyDegree . _entityVal) colStudyDegree , emptyOpticColonnade (resultStudyDegree . _entityVal) colStudyDegree
, emptyOpticColonnade (resultStudyFeatures . _entityVal . _studyFeaturesSemester) colStudyFeaturesSemester , emptyOpticColonnade (resultStudyFeatures . _entityVal . _studyFeaturesSemester) colStudyFeaturesSemester
, colApplicationText (resultCourseApplication . _entityVal . _courseApplicationText) , colApplicationText (resultCourseApplication . _entityVal . _courseApplicationText)
, lmap ((tid, ssh, csh), ) $ colApplicationFiles ($(multifocusL 5) (_1 . _1) (_1 . _2) (_1 . _3) (_2 . resultCourseApplication . _entityKey) (_2 . resultHasFiles)) , lmap ((tid, ssh, csh), ) $ colApplicationFiles ($(multifocusG 5) (_1 . _1) (_1 . _2) (_1 . _3) (_2 . resultCourseApplication . _entityKey) (_2 . resultHasFiles))
, colApplicationVeto (resultCourseApplication . _entityVal . _courseApplicationRatingVeto) , colApplicationVeto (resultCourseApplication . _entityVal . _courseApplicationRatingVeto)
, colApplicationRatingPoints (resultCourseApplication . _entityVal . _courseApplicationRatingPoints) , colApplicationRatingPoints (resultCourseApplication . _entityVal . _courseApplicationRatingPoints)
, colApplicationRatingComment (resultCourseApplication . _entityVal . _courseApplicationRatingComment) , colApplicationRatingComment (resultCourseApplication . _entityVal . _courseApplicationRatingComment)
] ]
dbtSorting = mconcat dbtSorting = mconcat
[ sortAllocationShorthand $ queryAllocation . to (E.?. AllocationShorthand) [ singletonMap "participant" . SortColumn $ view queryIsParticipant
, sortAllocationShorthand $ queryAllocation . to (E.?. AllocationShorthand)
, sortUserName' $ $(multifocusG 2) (queryUser . to (E.^. UserDisplayName)) (queryUser . to (E.^. UserSurname)) , sortUserName' $ $(multifocusG 2) (queryUser . to (E.^. UserDisplayName)) (queryUser . to (E.^. UserSurname))
, sortUserMatriculation $ queryUser . to (E.^. UserMatrikelnummer) , sortUserMatriculation $ queryUser . to (E.^. UserMatrikelnummer)
, sortStudyTerms queryStudyTerms , sortStudyTerms queryStudyTerms
@ -320,8 +381,7 @@ postCApplicationsR tid ssh csh = do
} }
dbtParams = def dbtParams = def
dbtCsvEncode :: DBTCsvEncode CourseApplicationsTableData CourseApplicationsTableCsv dbtCsvEncode = simpleCsvEncodeM csvName $ CourseApplicationsTableCsv
dbtCsvEncode = DictJust . C.mapM . runReaderT $ CourseApplicationsTableCsv
<$> preview (resultAllocation . _entityVal . _allocationShorthand) <$> preview (resultAllocation . _entityVal . _allocationShorthand)
<*> (preview (resultCourseApplication . _entityKey) >>= traverse encrypt) <*> (preview (resultCourseApplication . _entityKey) >>= traverse encrypt)
<*> preview (resultUser . _entityVal . _userDisplayName) <*> preview (resultUser . _entityVal . _userDisplayName)
@ -532,10 +592,101 @@ postCApplicationsR tid ssh csh = do
psValidator = def psValidator = def
& defaultSorting [SortAscBy "user-name"] & defaultSorting [SortAscBy "user-name"]
dbTableWidget' psValidator DBTable{..} participants <- count [ CourseParticipantCourse ==. cid ]
let remainingCapacity = subtract participants <$> courseCapacity
allocationsBounds' <- E.select . E.from $ \(allocation `E.InnerJoin` allocationCourse) -> do
E.on $ allocation E.^. AllocationId E.==. allocationCourse E.^. AllocationCourseAllocation
E.&&. allocationCourse E.^. AllocationCourseCourse E.==. E.val cid
let numApps addWhere = E.sub_select . E.from $ \courseApplication -> do
E.where_ $ courseApplication E.^. CourseApplicationCourse E.==. E.val cid
E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.just (allocationCourse E.^. AllocationCourseAllocation)
addWhere courseApplication
return E.countRows
numApps' = numApps . const $ return ()
numFirstChoice = numApps $ \courseApplication ->
E.where_ . E.not_ . E.exists . E.from $ \courseApplication' -> do
E.where_ $ courseApplication E.^. CourseApplicationAllocation E.==. courseApplication' E.^. CourseApplicationAllocation
E.&&. courseApplication E.^. CourseApplicationUser E.==. courseApplication' E.^. CourseApplicationUser
E.where_ . E.not_ $ E.isNothing (courseApplication E.^. CourseApplicationAllocationPriority)
E.||. E.isNothing (courseApplication' E.^. CourseApplicationAllocationPriority)
E.where_ $ courseApplication' E.^. CourseApplicationAllocationPriority E.>. courseApplication E.^. CourseApplicationAllocationPriority
return (allocation, numApps', numFirstChoice)
let
allocationsBounds = [ (allocation, numApps', numFirstChoice', capped)
| (Entity _ allocation, E.Value numApps, E.Value numFirstChoice) <- allocationsBounds'
, let numApps' = max 0 $ maybe id min remainingCapacity numApps
numFirstChoice' = max 0 $ maybe id min remainingCapacity numFirstChoice
capped = numApps' /= numApps
|| numFirstChoice' /= numFirstChoice
]
mayAccept <- hasWriteAccessTo $ CourseR tid ssh csh CAddUserR
(, allocationsBounds, mayAccept) <$> dbTableWidget' psValidator DBTable{..}
now <- liftIO getCurrentTime
let title = prependCourseTitle tid ssh csh MsgCourseApplicationsListTitle let title = prependCourseTitle tid ssh csh MsgCourseApplicationsListTitle
registrationOpen = maybe True (now <)
((acceptRes, acceptWgt'), acceptEnc) <- runFormPost . identifyForm BtnAcceptApplications . renderAForm FormStandard $
(,) <$> apopt (selectField optionsFinite) (fslI MsgAcceptApplicationsMode & setTooltip MsgAcceptApplicationsModeTip) (Just AcceptApplicationsInvite)
<*> apopt (selectField optionsFinite) (fslI MsgAcceptApplicationsSecondary & setTooltip MsgAcceptApplicationsSecondaryTip) (Just AcceptApplicationsSecondaryTime)
let acceptWgt = wrapForm' BtnAcceptApplications acceptWgt' def
{ formSubmit = FormSubmit
, formAction = Just . SomeRoute $ CourseR tid ssh csh CApplicationsR
, formEncoding = acceptEnc
}
when mayAccept $
formResult acceptRes $ \(invMode, appsSecOrder) -> do
runDBJobs $ do
Entity cid Course{..} <- getBy404 $ TermSchoolCourseShort tid ssh csh
participants <- count [ CourseParticipantCourse ==. cid ]
let openCapacity = subtract participants <$> courseCapacity
applications <- E.select . E.from $ \(user `E.InnerJoin` application) -> do
E.on $ user E.^. UserId E.==. application E.^. CourseApplicationUser
E.where_ $ application E.^. CourseApplicationCourse E.==. E.val cid
E.&&. E.isNothing (application E.^. CourseApplicationAllocation)
E.&&. E.not_ (application E.^. CourseApplicationRatingVeto)
E.&&. E.maybe E.true (`E.in_` E.valList (filter (view $ passingGrade . _Wrapped) universeF)) (application E.^. CourseApplicationRatingPoints )
E.where_ . E.not_ . E.exists . E.from $ \participant ->
E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid
E.&&. participant E.^. CourseParticipantUser E.==. user E.^. UserId
return (user, application)
let
ratingL = _2 . _entityVal . _courseApplicationRatingPoints . to (Down . ExamGradeDefCenter)
cmp = case appsSecOrder of
AcceptApplicationsSecondaryTime
-> comparing . view $ $(multifocusG 2) ratingL (_2 . _entityVal . _courseApplicationTime)
AcceptApplicationsSecondaryRandom
-> comparing $ view ratingL
sortedApplications <- unstableSortBy cmp applications
let applicants = sortedApplications
& nubOn (view $ _1 . _entityKey)
& maybe id take openCapacity
& setOf (case invMode of
AcceptApplicationsDirect -> folded . _1 . _entityKey . to Right
AcceptApplicationsInvite -> folded . _1 . _entityVal . _userEmail . to Left
)
mapM_ addMessage' <=< execWriterT $ registerUsers cid applicants
redirect $ CourseR tid ssh csh CUsersR
siteLayoutMsg title $ do siteLayoutMsg title $ do
setTitleI title setTitleI title
table $(widgetFile "course/applications-list")

42
src/Handler/Course/Edit.hs
View File

@ -44,7 +44,7 @@ data CourseForm = CourseForm
, cfAllocation :: Maybe AllocationCourseForm , cfAllocation :: Maybe AllocationCourseForm
, cfAppRequired :: Bool , cfAppRequired :: Bool
, cfAppInstructions :: Maybe Html , cfAppInstructions :: Maybe Html
, cfAppInstructionFiles :: Maybe (Source Handler (Either FileId File)) , cfAppInstructionFiles :: Maybe (ConduitT () (Either FileId File) Handler ())
, cfAppText :: Bool , cfAppText :: Bool
, cfAppFiles :: UploadMode , cfAppFiles :: UploadMode
, cfAppRatingsVisible :: Bool , cfAppRatingsVisible :: Bool
@ -101,22 +101,23 @@ allocationCourseToForm (Entity _ AllocationCourse{..}) = AllocationCourseForm
makeCourseForm :: (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)) -> Maybe CourseForm -> Form CourseForm makeCourseForm :: (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)) -> Maybe CourseForm -> Form CourseForm
makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB validateCourse $ \html -> do makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB validateCourse $ \html -> do
-- TODO: Refactor to avoid the four repeated calls to liftHandlerT and three runDBs -- TODO: Refactor to avoid the four repeated calls to liftHandler and three runDBs
-- let editCid = cfCourseId =<< template -- possible start for refactoring -- let editCid = cfCourseId =<< template -- possible start for refactoring
MsgRenderer mr <- getMsgRenderer MsgRenderer mr <- getMsgRenderer
uid <- liftHandlerT requireAuthId uid <- liftHandler requireAuthId
(lecturerSchools, adminSchools) <- liftHandlerT . runDB $ do (lecturerSchools, adminSchools, oldSchool) <- liftHandler . runDB $ do
lecturerSchools <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolLecturer]] [] lecturerSchools <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolLecturer]] []
protoAdminSchools <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolAdmin]] [] protoAdminSchools <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolAdmin]] []
adminSchools <- filterM (hasWriteAccessTo . flip SchoolR SchoolEditR) protoAdminSchools adminSchools <- filterM (hasWriteAccessTo . flip SchoolR SchoolEditR) protoAdminSchools
return (lecturerSchools, adminSchools) oldSchool <- forM (cfCourseId =<< template) $ fmap courseSchool . getJust
let userSchools = nub $ lecturerSchools ++ adminSchools return (lecturerSchools, adminSchools, oldSchool)
let userSchools = nub . maybe id (:) oldSchool $ lecturerSchools ++ adminSchools
termsField <- case template of termsField <- case template of
-- Change of term is only allowed if user may delete the course (i.e. no participants) or admin -- Change of term is only allowed if user may delete the course (i.e. no participants) or admin
(Just cform) | (Just cid) <- cfCourseId cform -> liftHandlerT $ do -- edit existing course (Just cform) | (Just cid) <- cfCourseId cform -> liftHandler $ do -- edit existing course
_courseOld@Course{..} <- runDB $ get404 cid _courseOld@Course{..} <- runDB $ get404 cid
mayEditTerm <- isAuthorized TermEditR True mayEditTerm <- isAuthorized TermEditR True
mayDelete <- isAuthorized (CourseR courseTerm courseSchool courseShorthand CDeleteR) True mayDelete <- isAuthorized (CourseR courseTerm courseSchool courseShorthand CDeleteR) True
@ -128,7 +129,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
let miAdd :: ListPosition -> Natural -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId)))) let miAdd :: ListPosition -> Natural -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))))
miAdd _ _ nudge btn = Just $ \csrf -> do miAdd _ _ nudge btn = Just $ \csrf -> do
(addRes, addView) <- mpreq emailField ("" & addName (nudge "user")) Nothing (addRes, addView) <- mpreq emailField ("" & addName (nudge "user")) Nothing
addRes' <- for addRes $ liftHandlerT . runDB . getKeyBy . UniqueEmail . CI.mk addRes' <- for addRes $ liftHandler . runDB . getKeyBy . UniqueEmail . CI.mk
let addRes'' = case (,) <$> addRes <*> addRes' of let addRes'' = case (,) <$> addRes <*> addRes' of
FormSuccess (CI.mk -> email, mLid) -> FormSuccess (CI.mk -> email, mLid) ->
let new = maybe (Left email) Right mLid let new = maybe (Left email) Right mLid
@ -143,17 +144,18 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
miCell :: ListPosition -> Either UserEmail UserId -> Maybe (Maybe LecturerType) -> (Text -> Text) -> Form (Maybe LecturerType) miCell :: ListPosition -> Either UserEmail UserId -> Maybe (Maybe LecturerType) -> (Text -> Text) -> Form (Maybe LecturerType)
miCell _ (Right lid) defType nudge = \csrf -> do miCell _ (Right lid) defType nudge = \csrf -> do
(lrwRes,lrwView) <- mreq (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) (join defType) (lrwRes,lrwView) <- mreq (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) (join defType)
User{userEmail, userDisplayName, userSurname} <- liftHandlerT . runDB $ get404 lid User{userEmail, userDisplayName, userSurname} <- liftHandler . runDB $ get404 lid
let lrwView' = $(widgetFile "course/lecturerMassInput/cellKnown") let lrwView' = $(widgetFile "course/lecturerMassInput/cellKnown")
return (Just <$> lrwRes,lrwView') return (Just <$> lrwRes,lrwView')
miCell _ (Left lEmail) defType nudge = \csrf -> do miCell _ (Left lEmail) defType nudge = \csrf -> do
(lrwRes,lrwView) <- mopt (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) defType (lrwRes,lrwView) <- mopt (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) defType
invWarnMsg <- messageI Warning MsgEmailInvitationWarning
let lrwView' = $(widgetFile "course/lecturerMassInput/cellInvitation") let lrwView' = $(widgetFile "course/lecturerMassInput/cellInvitation")
return (lrwRes,lrwView') return (lrwRes,lrwView')
miDelete :: Map ListPosition (Either UserEmail UserId) -- ^ Current shape miDelete :: Map ListPosition (Either UserEmail UserId) -- ^ Current shape
-> ListPosition -- ^ Coordinate to delete -> ListPosition -- ^ Coordinate to delete
-> MaybeT (MForm (HandlerT UniWorX IO)) (Map ListPosition ListPosition) -> MaybeT (MForm (HandlerFor UniWorX)) (Map ListPosition ListPosition)
miDelete = miDeleteList miDelete = miDeleteList
miAllowAdd :: ListPosition -> Natural -> ListLength -> Bool miAllowAdd :: ListPosition -> Natural -> ListLength -> Bool
@ -194,7 +196,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
(newRegFrom,newRegTo,newDeRegUntil) <- case template of (newRegFrom,newRegTo,newDeRegUntil) <- case template of
(Just cform) | (Just _cid) <- cfCourseId cform -> return (Nothing,Nothing,Nothing) (Just cform) | (Just _cid) <- cfCourseId cform -> return (Nothing,Nothing,Nothing)
_allIOtherCases -> do _allIOtherCases -> do
mbLastTerm <- liftHandlerT $ runDB $ selectFirst [TermActive ==. True] [Desc TermName] mbLastTerm <- liftHandler $ runDB $ selectFirst [TermActive ==. True] [Desc TermName]
return ( (Just . toMidnight . termStart . entityVal) <$> mbLastTerm return ( (Just . toMidnight . termStart . entityVal) <$> mbLastTerm
, (Just . beforeMidnight . termEnd . entityVal) <$> mbLastTerm , (Just . beforeMidnight . termEnd . entityVal) <$> mbLastTerm
, (Just . beforeMidnight . termEnd . entityVal) <$> mbLastTerm ) , (Just . beforeMidnight . termEnd . entityVal) <$> mbLastTerm )
@ -202,7 +204,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
let let
allocationForm :: AForm Handler (Maybe AllocationCourseForm) allocationForm :: AForm Handler (Maybe AllocationCourseForm)
allocationForm = wFormToAForm $ do allocationForm = wFormToAForm $ do
availableAllocations' <- liftHandlerT . runDB . E.select . E.from $ \(allocation `E.InnerJoin` term) -> do availableAllocations' <- liftHandler . runDB . E.select . E.from $ \(allocation `E.InnerJoin` term) -> do
E.on $ allocation E.^. AllocationTerm E.==. term E.^. TermId E.on $ allocation E.^. AllocationTerm E.==. term E.^. TermId
let alreadyParticipates = flip (maybe E.false) (template >>= cfCourseId) $ \cid -> let alreadyParticipates = flip (maybe E.false) (template >>= cfCourseId) $ \cid ->
@ -226,7 +228,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
activeAllocations = availableAllocations' ^.. folded . filtered ((&&) <$> (not <$> allocationEnabled . view _1) <*> view (_2 . _Value)) . _1 activeAllocations = availableAllocations' ^.. folded . filtered ((&&) <$> (not <$> allocationEnabled . view _1) <*> view (_2 . _Value)) . _1
mkAllocationOption :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX) => Entity Allocation -> m (Option AllocationId) mkAllocationOption :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX) => Entity Allocation -> m (Option AllocationId)
mkAllocationOption (Entity aId Allocation{..}) = liftHandlerT $ do mkAllocationOption (Entity aId Allocation{..}) = liftHandler $ do
cID <- encrypt aId :: Handler CryptoUUIDAllocation cID <- encrypt aId :: Handler CryptoUUIDAllocation
return . Option (mr . MsgCourseAllocationOption (mr . ShortTermIdentifier $ unTermKey allocationTerm) $ CI.original allocationName) aId $ toPathPiece cID return . Option (mr . MsgCourseAllocationOption (mr . ShortTermIdentifier $ unTermKey allocationTerm) $ CI.original allocationName) aId $ toPathPiece cID
@ -254,6 +256,9 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
optionalActionW' (bool mforcedJust mpopt mayChange) allocationForm' (fslI MsgCourseAllocationParticipate & setTooltip MsgCourseAllocationParticipateTip) (is _Just . cfAllocation <$> template) optionalActionW' (bool mforcedJust mpopt mayChange) allocationForm' (fslI MsgCourseAllocationParticipate & setTooltip MsgCourseAllocationParticipateTip) (is _Just . cfAllocation <$> template)
-- TODO: internationalization
-- let autoUnzipInfo = [|Entpackt hochgeladene Zip-Dateien (*.zip) automatisch und fügt den Inhalt dem Stamm-Verzeichnis der Abgabe hinzu. TODO|]
(result, widget) <- flip (renderAForm FormStandard) html $ CourseForm (result, widget) <- flip (renderAForm FormStandard) html $ CourseForm
<$> pure (cfCourseId =<< template) <$> pure (cfCourseId =<< template)
<*> areq (textField & cfStrip & cfCI) (fslI MsgCourseName) (cfName <$> template) <*> areq (textField & cfStrip & cfCI) (fslI MsgCourseName) (cfName <$> template)
@ -295,7 +300,7 @@ validateCourse = do
CourseForm{..} <- State.get CourseForm{..} <- State.get
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
uid <- liftHandlerT requireAuthId uid <- liftHandler requireAuthId
userAdmin <- hasWriteAccessTo $ SchoolR cfSchool SchoolEditR userAdmin <- hasWriteAccessTo $ SchoolR cfSchool SchoolEditR
allocationTerm <- for (acfAllocation <$> cfAllocation) $ lift . fmap allocationTerm . getJust allocationTerm <- for (acfAllocation <$> cfAllocation) $ lift . fmap allocationTerm . getJust
@ -303,10 +308,11 @@ validateCourse = do
prevAllocationCourse <- getBy $ UniqueAllocationCourse cid prevAllocationCourse <- getBy $ UniqueAllocationCourse cid
prevAllocation <- fmap join . traverse get $ allocationCourseAllocation . entityVal <$> prevAllocationCourse prevAllocation <- fmap join . traverse get $ allocationCourseAllocation . entityVal <$> prevAllocationCourse
fmap join . for prevAllocation $ \Allocation{allocationStaffRegisterTo} -> if fmap join . for prevAllocation $ \Allocation{allocationStaffAllocationTo, allocationRegisterByCourse} -> if
| userAdmin | userAdmin
-> return Nothing -> return Nothing
| NTop allocationStaffRegisterTo <= NTop (Just now) | NTop allocationStaffAllocationTo <= NTop (Just now)
, NTop allocationRegisterByCourse > NTop (Just now)
-> Just . courseCapacity <$> getJust cid -> Just . courseCapacity <$> getJust cid
| otherwise | otherwise
-> return Nothing -> return Nothing
@ -516,7 +522,7 @@ courseEditHandler miButtonAction mbCourseForm = do
tell $ Set.singleton fId tell $ Set.singleton fId
lift $ lift $
void . insertUnique $ CourseAppInstructionFile cid fId void . insertUnique $ CourseAppInstructionFile cid fId
keep <- execWriterT . runConduit $ transPipe liftHandlerT (traverse_ id $ cfAppInstructionFiles res) .| C.mapM_ finsert keep <- execWriterT . runConduit $ transPipe liftHandler (traverse_ id $ cfAppInstructionFiles res) .| C.mapM_ finsert
acfs <- selectList [ CourseAppInstructionFileCourse ==. cid, CourseAppInstructionFileFile /<-. Set.toList keep ] [] acfs <- selectList [ CourseAppInstructionFileCourse ==. cid, CourseAppInstructionFileFile /<-. Set.toList keep ] []
mapM_ deleteCascade $ map (courseAppInstructionFileFile . entityVal) acfs mapM_ deleteCascade $ map (courseAppInstructionFileFile . entityVal) acfs
@ -533,7 +539,7 @@ courseEditHandler miButtonAction mbCourseForm = do
, formEncoding = formEnctype , formEncoding = formEnctype
} }
upsertAllocationCourse :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => CourseId -> Maybe AllocationCourseForm -> ReaderT SqlBackend m () upsertAllocationCourse :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => CourseId -> Maybe AllocationCourseForm -> ReaderT SqlBackend m ()
upsertAllocationCourse cid cfAllocation = do upsertAllocationCourse cid cfAllocation = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
Course{..} <- getJust cid Course{..} <- getJust cid

11
src/Handler/Course/LecturerInvite.hs
View File

@ -57,16 +57,19 @@ lecturerInvitationConfig = InvitationConfig{..}
where where
invitationRoute (Entity _ Course{..}) _ = return . CourseR courseTerm courseSchool courseShorthand $ CLecInviteR invitationRoute (Entity _ Course{..}) _ = return . CourseR courseTerm courseSchool courseShorthand $ CLecInviteR
invitationResolveFor _ = do invitationResolveFor _ = do
Just (CourseR tid csh ssh CLecInviteR) <- getCurrentRoute cRoute <- getCurrentRoute
getKeyBy404 $ TermSchoolCourseShort tid csh ssh case cRoute of
Just (CourseR tid csh ssh CLecInviteR) ->
getKeyBy404 $ TermSchoolCourseShort tid csh ssh
_other -> error "lecturerInvitationConfig called from unsupported route"
invitationSubject (Entity _ Course{..}) _ = return . SomeMessage $ MsgMailSubjectLecturerInvitation courseTerm courseSchool courseShorthand invitationSubject (Entity _ Course{..}) _ = return . SomeMessage $ MsgMailSubjectLecturerInvitation courseTerm courseSchool courseShorthand
invitationHeading (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseLecInviteHeading $ CI.original courseName invitationHeading (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseLecInviteHeading $ CI.original courseName
invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgCourseLecInviteExplanation}|] invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgCourseLecInviteExplanation}|]
invitationTokenConfig _ _ = do invitationTokenConfig _ _ = do
itAuthority <- liftHandlerT requireAuthId itAuthority <- liftHandler requireAuthId
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
invitationRestriction _ _ = return Authorized invitationRestriction _ _ = return Authorized
invitationForm _ (InvDBDataLecturer mlType, _) _ = hoistAForm liftHandlerT $ toJunction <$> case mlType of invitationForm _ (InvDBDataLecturer mlType, _) _ = hoistAForm liftHandler $ toJunction <$> case mlType of
Nothing -> areq (selectField optionsFinite) lFs Nothing Nothing -> areq (selectField optionsFinite) lFs Nothing
Just lType -> aforced (selectField optionsFinite) lFs lType Just lType -> aforced (selectField optionsFinite) lFs lType
where where

5
src/Handler/Course/List.hs
View File

@ -12,8 +12,7 @@ import Data.Maybe (fromJust)
import Utils.Form import Utils.Form
-- import Utils.DB -- import Utils.DB
import Handler.Utils import Handler.Utils hiding (colSchoolShort)
import Handler.Utils.Table.Cells
import Data.Function ((&)) import Data.Function ((&))
@ -87,7 +86,7 @@ makeCourseTable whereClause colChoices psValidator = do
E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser
E.where_ $ cid E.==. lecturer E.^. LecturerCourse E.&&. lecturer E.^. LecturerType E.==. E.val CourseLecturer E.where_ $ cid E.==. lecturer E.^. LecturerCourse E.&&. lecturer E.^. LecturerType E.==. E.val CourseLecturer
return user return user
dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CourseTableData dbtProj :: DBRow _ -> MaybeT DB CourseTableData
dbtProj = traverse $ \(course, E.Value participants, E.Value registered, school) -> do dbtProj = traverse $ \(course, E.Value participants, E.Value registered, school) -> do
lecturerList <- lift $ E.select $ E.from $ lecturerQuery $ E.val $ entityKey course lecturerList <- lift $ E.select $ E.from $ lecturerQuery $ E.val $ entityKey course
courseAlloc <- lift $ getBy (UniqueAllocationCourse $ entityKey course) courseAlloc <- lift $ getBy (UniqueAllocationCourse $ entityKey course)

9
src/Handler/Course/News.hs Normal file
View File

@ -0,0 +1,9 @@
module Handler.Course.News
( module Handler.Course.News
) where
import Handler.Course.News.New as Handler.Course.News
import Handler.Course.News.Edit as Handler.Course.News
import Handler.Course.News.Download as Handler.Course.News
import Handler.Course.News.Show as Handler.Course.News
import Handler.Course.News.Delete as Handler.Course.News

44
src/Handler/Course/News/Delete.hs Normal file
View File

@ -0,0 +1,44 @@
module Handler.Course.News.Delete
( getCNDeleteR, postCNDeleteR
) where
import Import
import Handler.Utils.Delete
import qualified Data.Set as Set
getCNDeleteR, postCNDeleteR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseNews -> Handler Html
getCNDeleteR = postCNDeleteR
postCNDeleteR tid ssh csh cID = do
nId <- decrypt cID
let
drRecords :: Set (Key CourseNews)
drRecords = Set.singleton nId
drGetInfo = return
drUnjoin = id
drRenderRecord :: Entity CourseNews -> DB Widget
drRenderRecord (Entity _ CourseNews{..})
= return . fromMaybe (toWidget courseNewsContent) $ asum
[ toWidget <$> courseNewsTitle
, toWidget <$> courseNewsSummary
]
drRecordConfirmString :: Entity CourseNews -> DB Text
drRecordConfirmString _ = return ""
drCaption, drSuccessMessage :: SomeMessage UniWorX
drCaption = SomeMessage MsgCourseNewsDeleteQuestion
drSuccessMessage = SomeMessage MsgCourseNewsDeleted
drAbort, drSuccess :: SomeRoute UniWorX
drAbort = SomeRoute $ CourseR tid ssh csh CShowR :#: [st|news-#{toPathPiece cID}|]
drSuccess = SomeRoute $ CourseR tid ssh csh CShowR
drDelete :: forall a. CourseNewsId -> DB a -> DB a
drDelete _ = id
deleteR DeleteRoute{..}

41
src/Handler/Course/News/Download.hs Normal file
View File

@ -0,0 +1,41 @@
module Handler.Course.News.Download
( getCNArchiveR
, getCNFileR
) where
import Import
import Handler.Utils
import qualified Database.Esqueleto as E
import qualified Data.Conduit.List as C
getCNArchiveR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseNews -> Handler TypedContent
getCNArchiveR tid ssh csh cID = do
nId <- decrypt cID
CourseNews{..} <- runDB $ get404 nId
archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack). ap getMessageRender . pure $ MsgCourseNewsArchiveName tid ssh csh (fromMaybe (toPathPiece courseNewsLastEdit) courseNewsTitle)
let getFilesQuery = (.| C.map entityVal) . E.selectSource . E.from $
\(newsFile `E.InnerJoin` file) -> do
E.on $ file E.^. FileId E.==. newsFile E.^. CourseNewsFileFile
E.where_ $ newsFile E.^. CourseNewsFileNews E.==. E.val nId
return file
serveSomeFiles archiveName getFilesQuery
getCNFileR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseNews -> FilePath -> Handler TypedContent
getCNFileR _ _ _ cID title = do
nId <- decrypt cID
let
fileQuery = E.selectSource . E.from $ \(newsFile `E.InnerJoin` file) -> do
E.on $ newsFile E.^. CourseNewsFileFile E.==. file E.^. FileId
E.where_ $ newsFile E.^. CourseNewsFileNews E.==. E.val nId
E.&&. file E.^. FileTitle E.==. E.val title
return file
serveOneFile $ fileQuery .| C.map entityVal

54
src/Handler/Course/News/Edit.hs Normal file
View File

@ -0,0 +1,54 @@
module Handler.Course.News.Edit
( getCNEditR, postCNEditR
) where
import Import
import Handler.Utils
import Handler.Course.News.Form
import qualified Data.Set as Set
import qualified Data.Conduit.List as C
getCNEditR, postCNEditR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseNews -> Handler Html
getCNEditR = postCNEditR
postCNEditR tid ssh csh cID = do
nId <- decrypt cID
(courseNews@CourseNews{..}, fids) <- runDB $ do
courseNews <- get404 nId
cnfs <- selectList [CourseNewsFileNews ==. nId] []
return ( courseNews
, setOf (folded . _entityVal . _courseNewsFileFile) cnfs
)
((newsRes, newsWgt'), newsEnctype) <- runFormPost . courseNewsForm . Just $ courseNewsToForm courseNews fids
formResult newsRes $ \CourseNewsForm{..} -> do
now <- liftIO getCurrentTime
runDB $ do
replace nId CourseNews
{ courseNewsCourse
, courseNewsVisibleFrom = cnfVisibleFrom
, courseNewsParticipantsOnly = cnfParticipantsOnly
, courseNewsTitle = cnfTitle
, courseNewsContent = cnfContent
, courseNewsSummary = cnfSummary
, courseNewsLastEdit = now
}
let
insertFile (Left fId) = fId <$ upsertBy (UniqueCourseNewsFile nId fId) (CourseNewsFile nId fId) []
insertFile (Right f ) = insert f >>= \fId -> fId <$ insert_ (CourseNewsFile nId fId)
newFids <- runConduit $ transPipe lift (fromMaybe (return ()) cnfFiles) .| C.mapM insertFile .| C.foldMap Set.singleton
deleteWhere [ CourseNewsFileNews ==. nId, CourseNewsFileFile /<-. Set.toList newFids ]
addMessageI Success MsgCourseNewsEdited
redirect $ CourseR tid ssh csh CShowR :#: [st|news-#{toPathPiece cID}|]
siteLayoutMsg MsgMenuCourseNewsEdit $ do
setTitleI MsgMenuCourseNewsEdit
wrapForm newsWgt' def
{ formAction = Just . SomeRoute $ CNewsR tid ssh csh cID CNEditR
, formEncoding = newsEnctype
}

71
src/Handler/Course/News/Form.hs Normal file
View File

@ -0,0 +1,71 @@
module Handler.Course.News.Form
( CourseNewsForm(..)
, courseNewsForm
, courseNewsToForm
) where
import Import
import Handler.Utils
import Text.Blaze.Renderer.Text (renderMarkup)
import qualified Data.Conduit.List as C
import qualified Data.Set as Set
data CourseNewsForm = CourseNewsForm
{ cnfTitle :: Maybe Text
, cnfSummary :: Maybe Html
, cnfContent :: Html
, cnfParticipantsOnly :: Bool
, cnfVisibleFrom :: Maybe UTCTime
, cnfFiles :: Maybe (ConduitT () (Either FileId File) Handler ())
}
courseNewsForm :: Maybe CourseNewsForm -> Form CourseNewsForm
courseNewsForm template = identifyForm FIDCourseNews . renderWForm FormStandard $ do
now <- liftIO getCurrentTime
let oldFileIds = maybe (return mempty) (\s -> runConduit $ s .| C.foldMap (either opoint $ const mempty)) $ template >>= cnfFiles
cTime = ceilingQuarterHour now
visibleFromTip
| Just vFrom <- template >>= cnfVisibleFrom
, vFrom <= now
= MsgCourseNewsVisibleFromEditWarning
| otherwise
= MsgCourseNewsVisibleFromTip
cnfTitle' <- wopt
(textField & cfStrip & guardField (not . null))
(fslI MsgCourseNewsTitle)
(cnfTitle <$> template)
cnfSummary' <- wopt
(htmlField & guardField (not . null . renderMarkup))
(fslI MsgCourseNewsSummary & setTooltip MsgCourseNewsSummaryTip)
(cnfSummary <$> template)
cnfContent' <- wreq
(htmlField & guardField (not . null . renderMarkup))
(fslI MsgCourseNewsContent)
(cnfContent <$> template)
cnfParticipantsOnly' <- wpopt checkBoxField (fslI MsgCourseNewsParticipantsOnly) (cnfParticipantsOnly <$> template)
cnfVisibleFrom' <- wopt utcTimeField (fslI MsgCourseNewsVisibleFrom & setTooltip visibleFromTip) (cnfVisibleFrom <$> template <|> Just (Just cTime))
cnfFiles' <- wopt (multiFileField oldFileIds) (fslI MsgCourseNewsFiles) (cnfFiles <$> template)
return $ CourseNewsForm
<$> cnfTitle'
<*> cnfSummary'
<*> cnfContent'
<*> cnfParticipantsOnly'
<*> cnfVisibleFrom'
<*> cnfFiles'
courseNewsToForm :: CourseNews -> Set FileId -> CourseNewsForm
courseNewsToForm CourseNews{..} fs = CourseNewsForm
{ cnfTitle = courseNewsTitle
, cnfSummary = courseNewsSummary
, cnfContent = courseNewsContent
, cnfParticipantsOnly = courseNewsParticipantsOnly
, cnfVisibleFrom = courseNewsVisibleFrom
, cnfFiles = guardOn (not $ Set.null fs) $ C.sourceList (Left <$> Set.toList fs)
}

47
src/Handler/Course/News/New.hs Normal file
View File

@ -0,0 +1,47 @@
module Handler.Course.News.New
( getCNewsNewR, postCNewsNewR
) where
import Import
import Handler.Utils
import Handler.Course.News.Form
import qualified Data.Conduit.List as C
getCNewsNewR, postCNewsNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCNewsNewR = postCNewsNewR
postCNewsNewR tid ssh csh = do
cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
((newsRes, newsWgt'), newsEnctype) <- runFormPost $ courseNewsForm Nothing
formResult newsRes $ \CourseNewsForm{..} -> do
now <- liftIO getCurrentTime
cID <- runDB $ do
nId <- insert CourseNews
{ courseNewsCourse = cid
, courseNewsVisibleFrom = cnfVisibleFrom
, courseNewsParticipantsOnly = cnfParticipantsOnly
, courseNewsTitle = cnfTitle
, courseNewsContent = cnfContent
, courseNewsSummary = cnfSummary
, courseNewsLastEdit = now
}
let
insertFile (Left fId) = insert_ $ CourseNewsFile nId fId
insertFile (Right f ) = insert_ . CourseNewsFile nId =<< insert f
forM_ cnfFiles $ \fSource ->
runConduit $ transPipe lift fSource .| C.mapM_ insertFile
encrypt nId :: DB CryptoUUIDCourseNews
addMessageI Success MsgCourseNewsCreated
redirect $ CourseR tid ssh csh CShowR :#: [st|news-#{toPathPiece cID}|]
siteLayoutMsg MsgMenuCourseNewsNew $ do
setTitleI MsgMenuCourseNewsNew
wrapForm newsWgt' def
{ formAction = Just . SomeRoute $ CourseR tid ssh csh CNewsNewR
, formEncoding = newsEnctype
}

17
src/Handler/Course/News/Show.hs Normal file
View File

@ -0,0 +1,17 @@
module Handler.Course.News.Show
( getCNShowR
) where
import Import
import Handler.Utils
getCNShowR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseNews -> Handler Html
getCNShowR tid ssh csh cID = do
nId <- decrypt cID
CourseNews{..} <- runDB $ get404 nId
siteLayout' (toWidget <$> courseNewsTitle) $ do
setTitleI . prependCourseTitle tid ssh csh $ maybe (SomeMessage MsgCourseNews) SomeMessage courseNewsTitle
$(widgetFile "course-news")

131
src/Handler/Course/ParticipantInvite.hs
View File

@ -4,6 +4,9 @@ module Handler.Course.ParticipantInvite
( InvitableJunction(..), InvitationDBData(..), InvitationTokenData(..) ( InvitableJunction(..), InvitationDBData(..), InvitationTokenData(..)
, getCInviteR, postCInviteR , getCInviteR, postCInviteR
, getCAddUserR, postCAddUserR , getCAddUserR, postCAddUserR
, AddParticipantsResult(..)
, addParticipantsResultMessages
, registerUsers, registerUser
) where ) where
import Import import Import
@ -35,7 +38,7 @@ instance IsInvitableJunction CourseParticipant where
data InvitableJunction CourseParticipant = JunctionParticipant data InvitableJunction CourseParticipant = JunctionParticipant
{ jParticipantRegistration :: UTCTime { jParticipantRegistration :: UTCTime
, jParticipantField :: Maybe StudyFeaturesId , jParticipantField :: Maybe StudyFeaturesId
, jParticipantAllocated :: Bool , jParticipantAllocated :: Maybe AllocationId
} deriving (Eq, Ord, Read, Show, Generic, Typeable) } deriving (Eq, Ord, Read, Show, Generic, Typeable)
data InvitationDBData CourseParticipant = InvDBDataParticipant data InvitationDBData CourseParticipant = InvDBDataParticipant
-- no data needed in DB to manage participant invitation -- no data needed in DB to manage participant invitation
@ -70,20 +73,24 @@ participantInvitationConfig = InvitationConfig{..}
where where
invitationRoute (Entity _ Course{..}) _ = return $ CourseR courseTerm courseSchool courseShorthand CInviteR invitationRoute (Entity _ Course{..}) _ = return $ CourseR courseTerm courseSchool courseShorthand CInviteR
invitationResolveFor _ = do invitationResolveFor _ = do
Just (CourseR tid csh ssh CInviteR) <- getCurrentRoute cRoute <- getCurrentRoute
getKeyBy404 $ TermSchoolCourseShort tid csh ssh case cRoute of
Just (CourseR tid csh ssh CInviteR) ->
getKeyBy404 $ TermSchoolCourseShort tid csh ssh
_other ->
error "participantInvitationConfig called from unsupported route"
invitationSubject (Entity _ Course{..}) _ = return . SomeMessage $ MsgMailSubjectParticipantInvitation courseTerm courseSchool courseShorthand invitationSubject (Entity _ Course{..}) _ = return . SomeMessage $ MsgMailSubjectParticipantInvitation courseTerm courseSchool courseShorthand
invitationHeading (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseParticipantInviteHeading $ CI.original courseName invitationHeading (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseParticipantInviteHeading $ CI.original courseName
invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgCourseParticipantInviteExplanation}|] invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgCourseParticipantInviteExplanation}|]
invitationTokenConfig _ _ = do invitationTokenConfig _ _ = do
itAuthority <- liftHandlerT requireAuthId itAuthority <- liftHandler requireAuthId
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
invitationRestriction _ _ = return Authorized invitationRestriction _ _ = return Authorized
invitationForm (Entity _ Course{..}) _ uid = hoistAForm lift . wFormToAForm $ do invitationForm (Entity _ Course{..}) _ uid = hoistAForm lift . wFormToAForm $ do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
studyFeatures <- wreq (studyFeaturesFieldFor Nothing False [] $ Just uid) studyFeatures <- wreq (studyFeaturesFieldFor Nothing False [] $ Just uid)
(fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) Nothing (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) Nothing
return . fmap (, ()) $ JunctionParticipant <$> pure now <*> studyFeatures <*> pure False return . fmap (, ()) $ JunctionParticipant <$> pure now <*> studyFeatures <*> pure Nothing
invitationInsertHook _ _ CourseParticipant{..} _ act = do invitationInsertHook _ _ CourseParticipant{..} _ act = do
res <- act res <- act
audit $ TransactionCourseParticipantEdit courseParticipantCourse courseParticipantUser audit $ TransactionCourseParticipantEdit courseParticipantCourse courseParticipantUser
@ -92,15 +99,18 @@ participantInvitationConfig = InvitationConfig{..}
return . SomeMessage $ MsgCourseParticipantInvitationAccepted (CI.original courseName) return . SomeMessage $ MsgCourseParticipantInvitationAccepted (CI.original courseName)
invitationUltDest (Entity _ Course{..}) _ = return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR invitationUltDest (Entity _ Course{..}) _ = return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR
data AddRecipientsResult = AddRecipientsResult data AddParticipantsResult = AddParticipantsResult
{ aurAlreadyRegistered { aurAlreadyRegistered
, aurNoUniquePrimaryField , aurNoUniquePrimaryField
, aurSuccess :: [UserEmail] , aurSuccess :: Set UserId
} deriving (Read, Show, Generic, Typeable) } deriving (Read, Show, Generic, Typeable)
instance Monoid AddRecipientsResult where instance Semigroup AddParticipantsResult where
(<>) = mappenddefault
instance Monoid AddParticipantsResult where
mempty = memptydefault mempty = memptydefault
mappend = mappenddefault mappend = (<>)
getCAddUserR, postCAddUserR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCAddUserR, postCAddUserR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCAddUserR = postCAddUserR getCAddUserR = postCAddUserR
@ -111,7 +121,9 @@ postCAddUserR tid ssh csh = do
wreq (multiUserField (maybe True not $ formResultToMaybe enlist) Nothing) wreq (multiUserField (maybe True not $ formResultToMaybe enlist) Nothing)
(fslI MsgCourseParticipantInviteField & setTooltip MsgMultiEmailFieldTip) Nothing (fslI MsgCourseParticipantInviteField & setTooltip MsgMultiEmailFieldTip) Nothing
formResultModal usersToEnlist (CourseR tid ssh csh CUsersR) $ processUsers cid formResultModal usersToEnlist (CourseR tid ssh csh CUsersR) $
hoist runDBJobs . registerUsers cid
let heading = prependCourseTitle tid ssh csh MsgCourseParticipantsRegisterHeading let heading = prependCourseTitle tid ssh csh MsgCourseParticipantsRegisterHeading
@ -121,57 +133,74 @@ postCAddUserR tid ssh csh = do
{ formEncoding { formEncoding
, formAction = Just . SomeRoute $ CourseR tid ssh csh CAddUserR , formAction = Just . SomeRoute $ CourseR tid ssh csh CAddUserR
} }
where
processUsers :: CourseId -> Set (Either UserEmail UserId) -> WriterT [Message] Handler ()
processUsers cid users = do
let (emails,uids) = partitionEithers $ Set.toList users
AddRecipientsResult{..} <- lift . runDBJobs $ do
-- send Invitation eMails to unkown users
sinkInvitationsF participantInvitationConfig [(mail,cid,(InvDBDataParticipant,InvTokenDataParticipant)) | mail <- emails]
-- register known users
execWriterT $ mapM (registerUser cid) uids
unless (null emails) $ registerUsers :: CourseId -> Set (Either UserEmail UserId) -> WriterT [Message] (YesodJobDB UniWorX) ()
tell . pure <=< messageI Success . MsgCourseParticipantsInvited $ length emails registerUsers cid users = do
let (emails,uids) = partitionEithers $ Set.toList users
unless (null aurAlreadyRegistered) $ do -- send Invitation eMails to unkown users
let modalTrigger = [whamlet|_{MsgCourseParticipantsAlreadyRegistered (length aurAlreadyRegistered)}|] lift $ sinkInvitationsF participantInvitationConfig [(mail,cid,(InvDBDataParticipant,InvTokenDataParticipant)) | mail <- emails]
modalContent = $(widgetFile "messages/courseInvitationAlreadyRegistered") -- register known users
tell . pure <=< messageWidget Info $ msgModal modalTrigger (Right modalContent) tell <=< lift . addParticipantsResultMessages <=< lift . execWriterT $ mapM_ (registerUser cid) uids
unless (null aurNoUniquePrimaryField) $ do unless (null emails) $
let modalTrigger = [whamlet|_{MsgCourseParticipantsRegisteredWithoutField (length aurNoUniquePrimaryField)}|] tell . pure <=< messageI Success . MsgCourseParticipantsInvited $ length emails
modalContent = $(widgetFile "messages/courseInvitationRegisteredWithoutField")
tell . pure <=< messageWidget Warning $ msgModal modalTrigger (Right modalContent)
unless (null aurSuccess) $
tell . pure <=< messageI Success . MsgCourseParticipantsRegistered $ length aurSuccess
registerUser :: CourseId -> UserId -> WriterT AddRecipientsResult (YesodJobDB UniWorX) () addParticipantsResultMessages :: (MonadHandler m, HandlerSite m ~ UniWorX)
registerUser cid uid = exceptT tell tell $ do => AddParticipantsResult
User{..} <- lift . lift $ getJust uid -> ReaderT (YesodPersistBackend UniWorX) m [Message]
addParticipantsResultMessages AddParticipantsResult{..} = execWriterT $ do
(aurAlreadyRegistered', aurNoUniquePrimaryField') <-
(,) <$> fmap sort (lift . mapM (fmap userEmail . getJust) $ Set.toList aurAlreadyRegistered)
<*> fmap sort (lift . mapM (fmap userEmail . getJust) $ Set.toList aurNoUniquePrimaryField)
whenM (lift . lift . existsBy $ UniqueParticipant uid cid) $ unless (null aurAlreadyRegistered) $ do
throwError $ mempty { aurAlreadyRegistered = pure userEmail } let modalTrigger = [whamlet|_{MsgCourseParticipantsAlreadyRegistered (length aurAlreadyRegistered)}|]
modalContent = $(widgetFile "messages/courseInvitationAlreadyRegistered")
tell . pure <=< messageWidget Info $ msgModal modalTrigger (Right modalContent)
features <- lift . lift $ selectKeysList [ StudyFeaturesUser ==. uid, StudyFeaturesValid ==. True, StudyFeaturesType ==. FieldPrimary ] [] unless (null aurNoUniquePrimaryField) $ do
let modalTrigger = [whamlet|_{MsgCourseParticipantsRegisteredWithoutField (length aurNoUniquePrimaryField)}|]
modalContent = $(widgetFile "messages/courseInvitationRegisteredWithoutField")
tell . pure <=< messageWidget Warning $ msgModal modalTrigger (Right modalContent)
let courseParticipantField unless (null aurSuccess) $
| [f] <- features = Just f tell . pure <=< messageI Success . MsgCourseParticipantsRegistered $ length aurSuccess
| otherwise = Nothing
courseParticipantRegistration <- liftIO getCurrentTime
void . lift . lift . insert $ CourseParticipant
{ courseParticipantCourse = cid
, courseParticipantUser = uid
, courseParticipantAllocated = False
, ..
}
lift . lift . audit $ TransactionCourseParticipantEdit cid uid
return $ case courseParticipantField of registerUser :: CourseId
Nothing -> mempty { aurNoUniquePrimaryField = pure userEmail } -> UserId
Just _ -> mempty { aurSuccess = pure userEmail } -> WriterT AddParticipantsResult (YesodJobDB UniWorX) ()
registerUser cid uid = exceptT tell tell $ do
whenM (lift . lift . existsBy $ UniqueParticipant uid cid) $
throwError $ mempty { aurAlreadyRegistered = Set.singleton uid }
features <- lift . lift $ selectKeysList [ StudyFeaturesUser ==. uid, StudyFeaturesValid ==. True, StudyFeaturesType ==. FieldPrimary ] []
applications <- lift . lift $ selectList [ CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid ] []
let courseParticipantField
| [f] <- features
= Just f
| [f'] <- nub $ mapMaybe (courseApplicationField . entityVal) applications
, f' `elem` features
= Just f'
| otherwise
= Nothing
courseParticipantRegistration <- liftIO getCurrentTime
void . lift . lift . insert $ CourseParticipant
{ courseParticipantCourse = cid
, courseParticipantUser = uid
, courseParticipantAllocated = Nothing
, ..
}
lift . lift . audit $ TransactionCourseParticipantEdit cid uid
lift . lift . queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cid
return $ case courseParticipantField of
Nothing -> mempty { aurNoUniquePrimaryField = Set.singleton uid }
Just _ -> mempty { aurSuccess = Set.singleton uid }
getCInviteR, postCInviteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCInviteR, postCInviteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html

15
src/Handler/Course/Register.hs
View File

@ -41,12 +41,12 @@ instance Button UniWorX ButtonCourseRegister where
data CourseRegisterForm = CourseRegisterForm data CourseRegisterForm = CourseRegisterForm
{ crfStudyFeatures :: Maybe StudyFeaturesId { crfStudyFeatures :: Maybe StudyFeaturesId
, crfApplicationText :: Maybe Text , crfApplicationText :: Maybe Text
, crfApplicationFiles :: Maybe (Source Handler File) , crfApplicationFiles :: Maybe (ConduitT () File Handler ())
} }
courseRegisterForm :: (MonadHandler m, HandlerSite m ~ UniWorX) => Entity Course -> m (AForm Handler CourseRegisterForm, ButtonCourseRegister) courseRegisterForm :: (MonadHandler m, HandlerSite m ~ UniWorX) => Entity Course -> m (AForm Handler CourseRegisterForm, ButtonCourseRegister)
-- ^ `CourseRegisterForm` for current user -- ^ `CourseRegisterForm` for current user
courseRegisterForm (Entity cid Course{..}) = liftHandlerT $ do courseRegisterForm (Entity cid Course{..}) = liftHandler $ do
muid <- maybeAuthId muid <- maybeAuthId
(registration, application) <- runDB $ do (registration, application) <- runDB $ do
registration <- fmap join . for muid $ getBy . flip UniqueParticipant cid registration <- fmap join . for muid $ getBy . flip UniqueParticipant cid
@ -108,7 +108,7 @@ courseRegisterForm (Entity cid Course{..}) = liftHandlerT $ do
-> fmap (assertM (not . Text.null) . fmap Text.strip) <$> wopt textField' fs (Just $ application >>= courseApplicationText . entityVal) -> fmap (assertM (not . Text.null) . fmap Text.strip) <$> wopt textField' fs (Just $ application >>= courseApplicationText . entityVal)
hasFiles <- for application $ \(Entity appId _) hasFiles <- for application $ \(Entity appId _)
-> fmap (not . null) . liftHandlerT . runDB $ selectKeysList [ CourseApplicationFileApplication ==. appId ] [ LimitTo 1 ] -> fmap (not . null) . liftHandler . runDB $ selectKeysList [ CourseApplicationFileApplication ==. appId ] [ LimitTo 1 ]
appCID <- for application $ encrypt . entityKey appCID <- for application $ encrypt . entityKey
let appFilesInfo = (,) <$> hasFiles <*> appCID let appFilesInfo = (,) <$> hasFiles <*> appCID
filesMsg = bool MsgCourseRegistrationFiles MsgCourseApplicationFiles courseApplicationsRequired filesMsg = bool MsgCourseRegistrationFiles MsgCourseApplicationFiles courseApplicationsRequired
@ -141,6 +141,9 @@ courseRegisterForm (Entity cid Course{..}) = liftHandlerT $ do
-> return $ FormSuccess Nothing -> return $ FormSuccess Nothing
| otherwise | otherwise
-> aFormToWForm $ fileUploadForm False (fslI . mkFs) courseApplicationsFiles -> aFormToWForm $ fileUploadForm False (fslI . mkFs) courseApplicationsFiles
when (is _Just $ registration >>= courseParticipantAllocated . entityVal) $
wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationAllocationLog
return $ CourseRegisterForm return $ CourseRegisterForm
<$ secretRes <$ secretRes
@ -191,13 +194,13 @@ postCRegisterR tid ssh csh = do
whenIsJust appRes $ whenIsJust appRes $
audit . TransactionCourseApplicationEdit cid uid audit . TransactionCourseApplicationEdit cid uid
whenIsJust ((,) <$> appRes <*> crfApplicationFiles) $ \(appId, fSource) -> do whenIsJust ((,) <$> appRes <*> crfApplicationFiles) $ \(appId, fSource) -> do
runConduit $ transPipe liftHandlerT fSource .| C.mapM_ (\f -> insert f >>= insert_ . CourseApplicationFile appId) runConduit $ transPipe liftHandler fSource .| C.mapM_ (\f -> insert f >>= insert_ . CourseApplicationFile appId)
return appRes return appRes
| otherwise | otherwise
= return $ Just () = return $ Just ()
mkRegistration = do mkRegistration = do
audit $ TransactionCourseParticipantEdit cid uid audit $ TransactionCourseParticipantEdit cid uid
insertUnique $ CourseParticipant cid uid cTime crfStudyFeatures False insertUnique $ CourseParticipant cid uid cTime crfStudyFeatures Nothing
deleteApplications = do deleteApplications = do
appIds <- selectKeysList [ CourseApplicationAllocation ==. Nothing, CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid ] [] appIds <- selectKeysList [ CourseApplicationAllocation ==. Nothing, CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid ] []
@ -222,7 +225,7 @@ postCRegisterR tid ssh csh = do
delete $ partId delete $ partId
audit $ TransactionCourseParticipantDeleted cid uid audit $ TransactionCourseParticipantDeleted cid uid
when courseParticipantAllocated $ do when (is _Just courseParticipantAllocated) $ do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
insert_ $ AllocationDeregister courseParticipantUser (Just courseParticipantCourse) now Nothing insert_ $ AllocationDeregister courseParticipantUser (Just courseParticipantCourse) now Nothing

60
src/Handler/Course/Show.hs
View File

@ -7,7 +7,6 @@ import Import
import Utils.Form import Utils.Form
import Handler.Utils import Handler.Utils
import Handler.Utils.Table.Cells
import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Utils as E
import Database.Esqueleto.Utils.TH import Database.Esqueleto.Utils.TH
@ -19,7 +18,7 @@ import qualified Database.Esqueleto as E
import Handler.Course.Register import Handler.Course.Register
import System.FilePath (addExtension) import System.FilePath (addExtension, pathSeparator)
import qualified Data.Conduit.List as C import qualified Data.Conduit.List as C
@ -27,7 +26,7 @@ import qualified Data.Conduit.List as C
getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCShowR tid ssh csh = do getCShowR tid ssh csh = do
mbAid <- maybeAuthId mbAid <- maybeAuthId
(cid,course,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication) <- runDB . maybeT notFound $ do (cid,course,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news) <- runDB . maybeT notFound $ do
[(E.Entity cid course, E.Value schoolName, E.Value participants, fmap entityVal -> registration)] [(E.Entity cid course, E.Value schoolName, E.Value participants, fmap entityVal -> registration)]
<- lift . E.select . E.from $ <- lift . E.select . E.from $
\((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do \((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do
@ -47,7 +46,7 @@ getCShowR tid ssh csh = do
E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid
E.orderBy [ E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName ] E.orderBy [ E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName ]
return ( lecturer E.^. LecturerType return ( lecturer E.^. LecturerType
, user E.^. UserEmail, user E.^. UserDisplayName, user E.^. UserSurname) , user E.^. UserDisplayEmail, user E.^. UserDisplayName, user E.^. UserSurname)
let partStaff :: (LecturerType, UserEmail, Text, Text) -> Either (UserEmail, Text, Text) (UserEmail, Text, Text) let partStaff :: (LecturerType, UserEmail, Text, Text) -> Either (UserEmail, Text, Text) (UserEmail, Text, Text)
partStaff (CourseLecturer ,name,surn,mail) = Right (name,surn,mail) partStaff (CourseLecturer ,name,surn,mail) = Right (name,surn,mail)
partStaff (_courseAssistant,name,surn,mail) = Left (name,surn,mail) partStaff (_courseAssistant,name,surn,mail) = Left (name,surn,mail)
@ -72,15 +71,31 @@ getCShowR tid ssh csh = do
hasApplicationTemplate <- lift . E.selectExists . E.from $ \courseAppInstructionFile -> hasApplicationTemplate <- lift . E.selectExists . E.from $ \courseAppInstructionFile ->
E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. E.val cid E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. E.val cid
mApplication <- lift . fmap (listToMaybe =<<) . for mbAid $ \uid -> selectList [CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid, CourseApplicationAllocation ==. Nothing] [] mApplication <- lift . fmap (listToMaybe =<<) . for mbAid $ \uid -> selectList [CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid, CourseApplicationAllocation ==. Nothing] []
return (cid,course,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication) news' <- lift $ selectList [ CourseNewsCourse ==. cid ] [ Desc CourseNewsVisibleFrom, Desc CourseNewsTitle, Desc CourseNewsSummary, Desc CourseNewsContent ]
cTime <- NTop . Just <$> liftIO getCurrentTime
news <- forMaybeM news' $ \(Entity nId n@CourseNews{..}) -> do
cID <- encrypt nId :: MaybeT (MaybeT DB) CryptoUUIDCourseNews
guardM . hasReadAccessTo $ CNewsR tid ssh csh cID CNShowR
let visible = cTime >= NTop courseNewsVisibleFrom
files' <- lift . lift . E.select . E.from $ \(newsFile `E.InnerJoin` file) -> do
E.on $ file E.^. FileId E.==. newsFile E.^. CourseNewsFileFile
E.where_ $ newsFile E.^. CourseNewsFileNews E.==. E.val nId
return (E.isNothing $ file E.^. FileContent, file E.^. FileTitle)
let files = files'
& over (mapped . _1) E.unValue
& over (mapped . _2) E.unValue
lastEditText <- formatTime SelFormatDateTime $ maybe id max (guardOn visible =<< courseNewsVisibleFrom) courseNewsLastEdit
mayEdit <- hasWriteAccessTo $ CNewsR tid ssh csh cID CNEditR
mayDelete <- hasWriteAccessTo $ CNewsR tid ssh csh cID CNDeleteR
return (cID, n, visible, files, lastEditText, mayEdit, mayDelete)
return (cid,course,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news)
let mDereg' = maybe id min (allocationOverrideDeregister =<< mAllocation) <$> courseDeregisterUntil course
mDereg <- traverse (formatTime SelFormatDateTime) mDereg'
mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course
mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course
mDereg <- traverse (formatTime SelFormatDateTime) $ courseDeregisterUntil course
mRegAt <- traverse (formatTime SelFormatDateTime) $ courseParticipantRegistration <$> registration
cID <- encrypt cid :: Handler CryptoUUIDCourse cID <- encrypt cid :: Handler CryptoUUIDCourse
mAllocation' <- for mAllocation $ \Allocation{..} -> (,) mAllocation' <- for mAllocation $ \alloc@Allocation{..} -> (,)
<$> pure allocationName <$> pure alloc
<*> toTextUrl (AllocationR allocationTerm allocationSchool allocationShorthand AShowR :#: cID) <*> toTextUrl (AllocationR allocationTerm allocationSchool allocationShorthand AShowR :#: cID)
regForm <- if regForm <- if
| is _Just mbAid -> do | is _Just mbAid -> do
@ -126,11 +141,12 @@ getCShowR tid ssh csh = do
, sortable Nothing (i18nCell MsgTutorialFreeCapacity) $ \DBRow{ dbrOutput = Entity tutid Tutorial{..} } -> case tutorialCapacity of , sortable Nothing (i18nCell MsgTutorialFreeCapacity) $ \DBRow{ dbrOutput = Entity tutid Tutorial{..} } -> case tutorialCapacity of
Nothing -> mempty Nothing -> mempty
Just tutorialCapacity' -> sqlCell $ do Just tutorialCapacity' -> sqlCell $ do
[E.Value freeCapacity] <- E.select $ let numParticipants = E.sub_select . E.from $ \participant -> do freeCapacity <- fmap (maybe 0 (max 0 . E.unValue) . listToMaybe)
E.where_ $ participant E.^. TutorialParticipantTutorial E.==. E.val tutid . E.select $ let numParticipants = E.sub_select . E.from $ \participant -> do
return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int)) E.where_ $ participant E.^. TutorialParticipantTutorial E.==. E.val tutid
in return $ E.val tutorialCapacity' E.-. numParticipants return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int))
return . toWidget . tshow $ max 0 freeCapacity in return $ E.val tutorialCapacity' E.-. numParticipants
return . toWidget $ tshow freeCapacity
, sortable Nothing mempty $ \DBRow{ dbrOutput = Entity tutId Tutorial{..} } -> sqlCell $ do , sortable Nothing mempty $ \DBRow{ dbrOutput = Entity tutId Tutorial{..} } -> sqlCell $ do
mayRegister <- (== Authorized) <$> evalAccessDB (CTutorialR tid ssh csh tutorialName TRegisterR) True mayRegister <- (== Authorized) <$> evalAccessDB (CTutorialR tid ssh csh tutorialName TRegisterR) True
isRegistered <- case mbAid of isRegistered <- case mbAid of
@ -138,7 +154,7 @@ getCShowR tid ssh csh = do
Just uid -> existsBy $ UniqueTutorialParticipant tutId uid Just uid -> existsBy $ UniqueTutorialParticipant tutId uid
if if
| mayRegister -> do | mayRegister -> do
(tutRegisterForm, tutRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered (tutRegisterForm, tutRegisterEnctype) <- liftHandler . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered
return $ wrapForm tutRegisterForm def return $ wrapForm tutRegisterForm def
{ formAction = Just . SomeRoute $ CTutorialR tid ssh csh tutorialName TRegisterR { formAction = Just . SomeRoute $ CTutorialR tid ssh csh tutorialName TRegisterR
, formEncoding = tutRegisterEnctype , formEncoding = tutRegisterEnctype
@ -199,7 +215,7 @@ getCShowR tid ssh csh = do
-- Just uid -> existsBy $ UniqueExamRegistration eId uid -- Just uid -> existsBy $ UniqueExamRegistration eId uid
-- if -- if
-- | mayRegister -> do -- | mayRegister -> do
-- (examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnExamRegister] [BtnExamDeregister] isRegistered -- (examRegisterForm, examRegisterEnctype) <- liftHandler . generateFormPost . buttonForm' $ bool [BtnExamRegister] [BtnExamDeregister] isRegistered
-- return $ wrapForm examRegisterForm def -- return $ wrapForm examRegisterForm def
-- { formAction = Just . SomeRoute $ CExamR tid ssh csh examName ERegisterR -- { formAction = Just . SomeRoute $ CExamR tid ssh csh examName ERegisterR
-- , formEncoding = examRegisterEnctype -- , formEncoding = examRegisterEnctype
@ -236,6 +252,14 @@ getCShowR tid ssh csh = do
& defaultSorting [SortAscBy "time"] & defaultSorting [SortAscBy "time"]
(Any hasExams, examTable) <- runDB $ dbTable examDBTableValidator examDBTable (Any hasExams, examTable) <- runDB $ dbTable examDBTableValidator examDBTable
let visibleNews = any (view _3) news
showNewsFiles fs = and
[ not $ null fs
, length fs <= 3
, all (notElem pathSeparator . view _2) fs
]
mayCreateNews <- hasWriteAccessTo $ CourseR tid ssh csh CNewsNewR
siteLayout (toWgt $ courseName course) $ do siteLayout (toWgt $ courseName course) $ do
setTitleI $ prependCourseTitle tid ssh csh (""::Text) setTitleI $ prependCourseTitle tid ssh csh (""::Text)
$(widgetFile "course") $(widgetFile "course")

37
src/Handler/Course/User.hs
View File

@ -16,6 +16,8 @@ import Text.Blaze.Html.Renderer.Text (renderHtml)
import Handler.Course.Register import Handler.Course.Register
import Jobs.Queue
getCUserR, postCUserR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDUser -> Handler Html getCUserR, postCUserR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDUser -> Handler Html
getCUserR = postCUserR getCUserR = postCUserR
@ -118,40 +120,53 @@ postCUserR tid ssh csh uCId = do
let regButton let regButton
| is _Just mRegistration = BtnCourseDeregister | is _Just mRegistration = BtnCourseDeregister
| otherwise = BtnCourseRegister | otherwise = BtnCourseRegister
((regButtonRes, regButtonView), regButtonEnctype) <- runFormPost . identifyForm FIDcRegButton $ buttonForm' [regButton] ((regButtonRes, regButtonView), regButtonEnctype) <- runFormPost . identifyForm FIDcRegButton $
if | is _Just $ courseParticipantAllocated . entityVal =<< mRegistration
-> renderWForm FormStandard $ fmap (regButton, )
<$ (wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationAllocationShouldLogTip)
<*> optionalActionW (areq (textField & cfStrip & guardField (not . null)) (fslI MsgCourseDeregistrationAllocationReason & setTooltip MsgCourseDeregistrationAllocationReasonTip) Nothing) (fslI MsgCourseDeregistrationAllocationShouldLog) (Just True)
| otherwise
-> \csrf -> pure (FormSuccess (regButton, Nothing), toWidget csrf)
let registrationButtonFrag :: Text let registrationButtonFrag :: Text
registrationButtonFrag = "registration-button" registrationButtonFrag = "registration-button"
regButtonWidget = wrapForm regButtonView FormSettings regButtonWidget = wrapForm' regButton regButtonView FormSettings
{ formMethod = POST { formMethod = POST
, formAction = Just . SomeRoute $ currentRoute :#: registrationButtonFrag , formAction = Just . SomeRoute $ currentRoute :#: registrationButtonFrag
, formEncoding = regButtonEnctype , formEncoding = regButtonEnctype
, formAttrs = [] , formAttrs = []
, formSubmit = FormNoSubmit , formSubmit = FormSubmit
, formAnchor = Just registrationButtonFrag , formAnchor = Just registrationButtonFrag
} }
formResult regButtonRes $ \case formResult regButtonRes $ \case
_ _
| not mayRegister | not mayRegister
-> permissionDenied "User may not be registered" -> permissionDenied "User may not be registered"
BtnCourseDeregister (BtnCourseDeregister, mbReason)
| Just (Entity pId _) <- mRegistration | Just (Entity pId CourseParticipant{..}) <- mRegistration
-> do -> do
runDB $ delete pId runDB $ do
delete pId
audit $ TransactionCourseParticipantDeleted cid courseParticipantUser
whenIsJust mbReason $ \reason -> do
now <- liftIO getCurrentTime
insert_ $ AllocationDeregister courseParticipantUser (Just cid) now (Just reason)
addMessageIconI Info IconEnrolFalse MsgCourseDeregisterOk addMessageIconI Info IconEnrolFalse MsgCourseDeregisterOk
redirect $ CourseR tid ssh csh CUsersR redirect $ CourseR tid ssh csh CUsersR
| otherwise | otherwise
-> invalidArgs ["User not registered"] -> invalidArgs ["User not registered"]
BtnCourseRegister -> do (BtnCourseRegister, _) -> do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
let field let field
| [(Entity featId _, _, _)] <- filter (\(Entity _ StudyFeatures{..}, _, _) -> studyFeaturesValid) studies | [(Entity featId _, _, _)] <- filter (\(Entity _ StudyFeatures{..}, _, _) -> studyFeaturesValid) studies
= Just featId = Just featId
| otherwise | otherwise
= Nothing = Nothing
pId <- runDB $ do pId <- runDBJobs $ do
pId <- insertUnique $ CourseParticipant cid uid now field False pId <- insertUnique $ CourseParticipant cid uid now field Nothing
when (is _Just pId) $ when (is _Just pId) $ do
queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cid
audit $ TransactionCourseParticipantEdit cid uid audit $ TransactionCourseParticipantEdit cid uid
return pId return pId
case pId of case pId of
@ -159,7 +174,7 @@ postCUserR tid ssh csh uCId = do
addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk
redirect currentRoute redirect currentRoute
Nothing -> invalidArgs ["User already registered"] Nothing -> invalidArgs ["User already registered"]
_other -> fail "Invalid @regButton@" _other -> error "Invalid @regButton@"
mRegAt <- for (courseParticipantRegistration . entityVal <$> mRegistration) $ formatTime SelFormatDateTime mRegAt <- for (courseParticipantRegistration . entityVal <$> mRegistration) $ formatTime SelFormatDateTime

131
src/Handler/Course/Users.hs
View File

@ -11,10 +11,6 @@ import Import
import Utils.Form import Utils.Form
import Handler.Utils import Handler.Utils
import Handler.Utils.Database
import Handler.Utils.Table.Cells
import Handler.Utils.Table.Columns
import Database.Persist.Sql (deleteWhereCount)
import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Utils as E
import Database.Esqueleto.Utils.TH import Database.Esqueleto.Utils.TH
@ -25,6 +21,8 @@ import qualified Data.Map as Map
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
import qualified Data.Csv as Csv
type UserTableExpr = (E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) type UserTableExpr = (E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant))
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseUserNote)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseUserNote))
@ -121,6 +119,38 @@ colUserDegreeShort = sortable (Just "degree-short") (i18nCell MsgStudyFeatureDeg
foldMap (i18nCell . ShortStudyDegree) . preview (_userTableFeatures . _2 . _Just) foldMap (i18nCell . ShortStudyDegree) . preview (_userTableFeatures . _2 . _Just)
data UserTableCsv = UserTableCsv
{ csvUserName :: Text
, csvUserMatriculation :: Maybe Text
, csvUserEmail :: CI Email
, csvUserField :: Maybe Text
, csvUserDegree :: Maybe Text
, csvUserSemester :: Maybe Int
, csvUserRegistration :: UTCTime
, csvUserNote :: Maybe Html
}
deriving (Generic)
makeLenses_ ''UserTableCsv
userTableCsvOptions :: Csv.Options
userTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 2 }
instance Csv.ToNamedRecord UserTableCsv where
toNamedRecord = Csv.genericToNamedRecord userTableCsvOptions
instance Csv.DefaultOrdered UserTableCsv where
headerOrder = Csv.genericHeaderOrder userTableCsvOptions
instance CsvColumnsExplained UserTableCsv where
csvColumnsExplanations = genericCsvColumnsExplanations userTableCsvOptions $ mconcat
[ singletonMap 'csvUserName MsgCsvColumnUserName
, singletonMap 'csvUserMatriculation MsgCsvColumnUserMatriculation
, singletonMap 'csvUserEmail MsgCsvColumnUserEmail
, singletonMap 'csvUserField MsgCsvColumnUserField
, singletonMap 'csvUserDegree MsgCsvColumnUserDegree
, singletonMap 'csvUserSemester MsgCsvColumnUserSemester
, singletonMap 'csvUserRegistration MsgCsvColumnUserRegistration
, singletonMap 'csvUserNote MsgCsvColumnUserNote
]
data CourseUserAction = CourseUserSendMail | CourseUserDeregister data CourseUserAction = CourseUserSendMail | CourseUserDeregister
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
@ -129,20 +159,27 @@ instance Finite CourseUserAction
nullaryPathPiece ''CourseUserAction $ camelToPathPiece' 2 nullaryPathPiece ''CourseUserAction $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''CourseUserAction id embedRenderMessage ''UniWorX ''CourseUserAction id
data CourseUserActionData = CourseUserSendMailData
| CourseUserDeregisterData
{ deregisterReason :: Maybe Text
}
deriving (Eq, Ord, Read, Show, Generic, Typeable)
makeCourseUserTable :: forall h acts.
makeCourseUserTable :: forall h act act'.
( Functor h, ToSortable h ( Functor h, ToSortable h
, MonoFoldable acts , Ord act, PathPiece act, RenderMessage UniWorX act
, RenderMessage UniWorX (Element acts), Eq (Element acts), PathPiece (Element acts)
) )
=> CourseId => CourseId
-> acts -> Map act (AForm Handler act')
-> (UserTableExpr -> E.SqlExpr (E.Value Bool)) -> (UserTableExpr -> E.SqlExpr (E.Value Bool))
-> Colonnade h UserTableData (DBCell (MForm Handler) (FormResult (First (Element acts), DBFormResult UserId Bool UserTableData))) -> Colonnade h UserTableData (DBCell (MForm Handler) (FormResult (First act', DBFormResult UserId Bool UserTableData)))
-> PSValidator (MForm Handler) (FormResult (First (Element acts), DBFormResult UserId Bool UserTableData)) -> PSValidator (MForm Handler) (FormResult (First act', DBFormResult UserId Bool UserTableData))
-> DB (FormResult (Element acts, Set UserId), Widget) -> DB (FormResult (act', Set UserId), Widget)
makeCourseUserTable cid acts restrict colChoices psValidator = do makeCourseUserTable cid acts restrict colChoices psValidator = do
Just currentRoute <- liftHandlerT getCurrentRoute currentRoute <- fromMaybe (error "makeCourseUserTable called from 404-handler") <$> liftHandler getCurrentRoute
Course{..} <- getJust cid
csvName <- getMessageRender <*> pure (MsgCourseUserCsvName courseTerm courseSchool courseShorthand)
-- -- psValidator has default sorting and filtering -- -- psValidator has default sorting and filtering
let dbtIdent = "courseUsers" :: Text let dbtIdent = "courseUsers" :: Text
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
@ -212,26 +249,54 @@ makeCourseUserTable cid acts restrict colChoices psValidator = do
, dbParamsFormAdditional , dbParamsFormAdditional
= renderAForm FormStandard = renderAForm FormStandard
$ (, mempty) . First . Just $ (, mempty) . First . Just
<$> areq (selectField $ optionsF acts) (fslI MsgAction) Nothing <$> multiActionA acts (fslI MsgAction) Nothing
, dbParamsFormEvaluate = liftHandlerT . runFormPost , dbParamsFormEvaluate = liftHandler . runFormPost
, dbParamsFormResult = id , dbParamsFormResult = id
, dbParamsFormIdent = def , dbParamsFormIdent = def
} }
dbtCsvEncode = noCsvEncode dbtCsvEncode = simpleCsvEncodeM csvName $ UserTableCsv
<$> view (hasUser . _userDisplayName)
<*> view (hasUser . _userMatrikelnummer)
<*> view (hasUser . _userEmail)
<*> preview ( _userTableFeatures . _3 . _Just . _studyTermsName . _Just
<> _userTableFeatures . _3 . _Just . _studyTermsKey . to tshow
)
<*> preview ( _userTableFeatures . _2 . _Just . _studyDegreeName . _Just
<> _userTableFeatures . _2 . _Just . _studyDegreeKey . to tshow
)
<*> preview (_userTableFeatures . _1 . _Just . _studyFeaturesSemester)
<*> view _userTableRegistration
<*> userNote
where
userNote = runMaybeT $ do
noteId <- MaybeT . preview $ _userTableNote . _Just
CourseUserNote{..} <- lift . lift $ getJust noteId
return courseUserNoteNote
dbtCsvDecode = Nothing dbtCsvDecode = Nothing
over _1 postprocess <$> dbTable psValidator DBTable{..} over _1 postprocess <$> dbTable psValidator DBTable{..}
where where
postprocess :: FormResult (First act, DBFormResult UserId Bool UserTableData) -> FormResult (act, Set UserId) postprocess :: FormResult (First act', DBFormResult UserId Bool UserTableData) -> FormResult (act', Set UserId)
postprocess inp = do postprocess inp = do
(First (Just act), usrMap) <- inp (First (Just act), usrMap) <- inp
let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
return (act, usrSet) return (act, usrSet)
courseUserDeregisterForm :: CourseId -> AForm Handler CourseUserActionData
courseUserDeregisterForm cid = wFormToAForm $ do
allocated <- liftHandler . runDB . E.selectExists . E.from $ \participant ->
E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid
E.&&. E.not_ (E.isNothing $ participant E.^. CourseParticipantAllocated)
if | allocated -> do
wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationAllocationShouldLogTip
fmap CourseUserDeregisterData <$> optionalActionW (areq (textField & cfStrip & guardField (not . null)) (fslI MsgCourseDeregistrationAllocationReason & setTooltip MsgCourseDeregistrationAllocationReasonTip) Nothing) (fslI MsgCourseDeregistrationAllocationShouldLog) (Just True)
| otherwise -> pure . pure $ CourseUserDeregisterData Nothing
getCUsersR, postCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCUsersR, postCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCUsersR = postCUsersR getCUsersR = postCUsersR
postCUsersR tid ssh csh = do postCUsersR tid ssh csh = do
(Entity cid course, numParticipants, (participantRes,participantTable)) <- runDB $ do (Entity cid course, numParticipants, (participantRes,participantTable)) <- runDB $ do
mayRegister <- hasWriteAccessTo $ CourseR tid ssh csh CAddUserR mayRegister <- hasWriteAccessTo $ CourseR tid ssh csh CAddUserR
ent@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh
let colChoices = mconcat let colChoices = mconcat
[ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
, colUserNameLink (CourseR tid ssh csh . CUserR) , colUserNameLink (CourseR tid ssh csh . CUserR)
@ -244,27 +309,33 @@ postCUsersR tid ssh csh = do
, colUserComment tid ssh csh , colUserComment tid ssh csh
] ]
psValidator = def & defaultSortingByName psValidator = def & defaultSortingByName
acts = catMaybes acts = mconcat
[ Just CourseUserSendMail [ singletonMap CourseUserSendMail $ pure CourseUserSendMailData
, guardOn mayRegister CourseUserDeregister , if
| mayRegister
-> singletonMap CourseUserDeregister $ courseUserDeregisterForm cid
| otherwise
-> mempty
] ]
ent@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh
numParticipants <- count [CourseParticipantCourse ==. cid] numParticipants <- count [CourseParticipantCourse ==. cid]
table <- makeCourseUserTable cid acts (const E.true) colChoices psValidator table <- makeCourseUserTable cid acts (const E.true) colChoices psValidator
return (ent, numParticipants, table) return (ent, numParticipants, table)
formResult participantRes $ \case formResult participantRes $ \case
(CourseUserSendMail, selectedUsers) -> do (CourseUserSendMailData, selectedUsers) -> do
cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser] cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser]
redirect (CourseR tid ssh csh CCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cids]) redirect (CourseR tid ssh csh CCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cids])
(CourseUserDeregister,selectedUsers) -> do (CourseUserDeregisterData{..}, selectedUsers) -> do
Sum nrDel <- fmap mconcat . runDB . forM (Set.toList selectedUsers) $ \uid -> do Sum nrDel <- fmap mconcat . runDB . forM (Set.toList selectedUsers) $ \uid -> fmap (maybe mempty Sum) . runMaybeT $ do
nrDel <- deleteWhereCount now <- liftIO getCurrentTime
[ CourseParticipantCourse ==. cid Entity reg CourseParticipant{..} <- MaybeT . getBy $ UniqueParticipant uid cid
, CourseParticipantUser ==. uid lift $ delete reg
] lift . audit $ TransactionCourseParticipantDeleted cid uid
unless (nrDel == 0) $ case deregisterReason of
audit $ TransactionCourseParticipantDeleted cid uid Just reason
return $ Sum nrDel | is _Just courseParticipantAllocated ->
lift . insert_ $ AllocationDeregister uid (Just cid) now (Just reason)
_other -> return ()
return 1
addMessageI Success $ MsgCourseUsersDeregistered nrDel addMessageI Success $ MsgCourseUsersDeregistered nrDel
redirect $ CourseR tid ssh csh CUsersR redirect $ CourseR tid ssh csh CUsersR
let headingLong = [whamlet|_{MsgMenuCourseMembers} #{courseName course} #{tid}|] let headingLong = [whamlet|_{MsgMenuCourseMembers} #{courseName course} #{tid}|]

10
src/Handler/Exam/AddUser.hs
View File

@ -29,9 +29,12 @@ data AddRecipientsResult = AddRecipientsResult
, aurSuccessCourse :: [UserEmail] , aurSuccessCourse :: [UserEmail]
} deriving (Read, Show, Generic, Typeable) } deriving (Read, Show, Generic, Typeable)
instance Semigroup AddRecipientsResult where
(<>) = mappenddefault
instance Monoid AddRecipientsResult where instance Monoid AddRecipientsResult where
mempty = memptydefault mempty = memptydefault
mappend = mappenddefault mappend = (<>)
getEAddUserR, postEAddUserR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html getEAddUserR, postEAddUserR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
@ -40,7 +43,7 @@ postEAddUserR tid ssh csh examn = do
eEnt@(Entity eid Exam{..}) <- runDB $ fetchExam tid ssh csh examn eEnt@(Entity eid Exam{..}) <- runDB $ fetchExam tid ssh csh examn
((usersToEnlist,formWgt),formEncoding) <- runFormPost . renderWForm FormStandard $ do ((usersToEnlist,formWgt),formEncoding) <- runFormPost . renderWForm FormStandard $ do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
occurrences <- liftHandlerT . runDB $ selectList [ExamOccurrenceExam ==. eid] [] occurrences <- liftHandler . runDB $ selectList [ExamOccurrenceExam ==. eid] []
let let
localNow = utcToLocalTime now localNow = utcToLocalTime now
@ -144,10 +147,11 @@ postEAddUserR tid ssh csh examn = do
{ courseParticipantCourse = cid { courseParticipantCourse = cid
, courseParticipantUser = uid , courseParticipantUser = uid
, courseParticipantRegistration = now , courseParticipantRegistration = now
, courseParticipantAllocated = False , courseParticipantAllocated = Nothing
, .. , ..
} }
lift . lift . audit $ TransactionCourseParticipantEdit cid uid lift . lift . audit $ TransactionCourseParticipantEdit cid uid
lift . lift . queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cid
lift $ lift examRegister lift $ lift examRegister
return $ case courseParticipantField of return $ case courseParticipantField of

10
src/Handler/Exam/CorrectorInvite.hs
View File

@ -55,15 +55,19 @@ examCorrectorInvitationConfig = InvitationConfig{..}
Course{..} <- get404 examCourse Course{..} <- get404 examCourse
return $ CExamR courseTerm courseSchool courseShorthand examName ECInviteR return $ CExamR courseTerm courseSchool courseShorthand examName ECInviteR
invitationResolveFor _ = do invitationResolveFor _ = do
Just (CExamR tid csh ssh examn ECInviteR) <- getCurrentRoute cRoute <- getCurrentRoute
fetchExamId tid csh ssh examn case cRoute of
Just (CExamR tid csh ssh examn ECInviteR) ->
fetchExamId tid csh ssh examn
_other ->
error "examCorrectorInvitationConfig called from unsupported route"
invitationSubject (Entity _ Exam{..}) _ = do invitationSubject (Entity _ Exam{..}) _ = do
Course{..} <- get404 examCourse Course{..} <- get404 examCourse
return . SomeMessage $ MsgMailSubjectExamCorrectorInvitation courseTerm courseSchool courseShorthand examName return . SomeMessage $ MsgMailSubjectExamCorrectorInvitation courseTerm courseSchool courseShorthand examName
invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamCorrectorInviteHeading examName invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamCorrectorInviteHeading examName
invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamCorrectorInviteExplanation}|] invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamCorrectorInviteExplanation}|]
invitationTokenConfig _ _ = do invitationTokenConfig _ _ = do
itAuthority <- liftHandlerT requireAuthId itAuthority <- liftHandler requireAuthId
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
invitationRestriction _ _ = return Authorized invitationRestriction _ _ = return Authorized
invitationForm _ _ _ = pure (JunctionExamCorrector, ()) invitationForm _ _ _ = pure (JunctionExamCorrector, ())

10
src/Handler/Exam/Edit.hs
View File

@ -18,12 +18,12 @@ import Jobs.Queue
getEEditR, postEEditR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html getEEditR, postEEditR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
getEEditR = postEEditR getEEditR = postEEditR
postEEditR tid ssh csh examn = do postEEditR tid ssh csh examn = do
(cid, eId, template) <- runDB $ do (cid, Entity eId oldExam, template) <- runDB $ do
(cid, exam@(Entity eId _)) <- fetchCourseIdExam tid ssh csh examn (cid, exam) <- fetchCourseIdExam tid ssh csh examn
template <- examFormTemplate exam template <- examFormTemplate exam
return (cid, eId, template) return (cid, exam, template)
((editExamResult, editExamWidget), editExamEnctype) <- runFormPost . validateForm validateExam . examForm $ Just template ((editExamResult, editExamWidget), editExamEnctype) <- runFormPost . validateForm validateExam . examForm $ Just template
@ -43,7 +43,7 @@ postEEditR tid ssh csh examn = do
, examStart = efStart , examStart = efStart
, examEnd = efEnd , examEnd = efEnd
, examFinished = efFinished , examFinished = efFinished
, examClosed = efClosed , examClosed = examClosed oldExam
, examPublicStatistics = efPublicStatistics , examPublicStatistics = efPublicStatistics
, examShowGrades = efShowGrades , examShowGrades = efShowGrades
, examDescription = efDescription , examDescription = efDescription
@ -85,6 +85,7 @@ postEEditR tid ssh csh examn = do
ExamPartForm{ epfId = Nothing, .. } -> insert_ ExamPartForm{ epfId = Nothing, .. } -> insert_
ExamPart ExamPart
{ examPartExam = eId { examPartExam = eId
, examPartNumber = epfNumber
, examPartName = epfName , examPartName = epfName
, examPartMaxPoints = epfMaxPoints , examPartMaxPoints = epfMaxPoints
, examPartWeight = epfWeight , examPartWeight = epfWeight
@ -96,6 +97,7 @@ postEEditR tid ssh csh examn = do
guard $ examPartExam oldPart == eId guard $ examPartExam oldPart == eId
lift $ replace epfId' ExamPart lift $ replace epfId' ExamPart
{ examPartExam = eId { examPartExam = eId
, examPartNumber = epfNumber
, examPartName = epfName , examPartName = epfName
, examPartMaxPoints = epfMaxPoints , examPartMaxPoints = epfMaxPoints
, examPartWeight = epfWeight , examPartWeight = epfWeight

49
src/Handler/Exam/Form.hs
View File

@ -26,6 +26,7 @@ import Text.Blaze.Html.Renderer.String (renderHtml)
data ExamForm = ExamForm data ExamForm = ExamForm
{ efName :: ExamName { efName :: ExamName
, efDescription :: Maybe Html , efDescription :: Maybe Html
, efShowGrades :: Bool
, efStart :: Maybe UTCTime , efStart :: Maybe UTCTime
, efEnd :: Maybe UTCTime , efEnd :: Maybe UTCTime
, efVisibleFrom :: Maybe UTCTime , efVisibleFrom :: Maybe UTCTime
@ -34,13 +35,11 @@ data ExamForm = ExamForm
, efDeregisterUntil :: Maybe UTCTime , efDeregisterUntil :: Maybe UTCTime
, efPublishOccurrenceAssignments :: Maybe UTCTime , efPublishOccurrenceAssignments :: Maybe UTCTime
, efFinished :: Maybe UTCTime , efFinished :: Maybe UTCTime
, efClosed :: Maybe UTCTime
, efOccurrences :: Set ExamOccurrenceForm , efOccurrences :: Set ExamOccurrenceForm
, efShowGrades :: Bool
, efPublicStatistics :: Bool , efPublicStatistics :: Bool
, efGradingRule :: ExamGradingRule , efGradingRule :: Maybe ExamGradingRule
, efBonusRule :: ExamBonusRule , efBonusRule :: Maybe ExamBonusRule
, efOccurrenceRule :: ExamOccurrenceRule , efOccurrenceRule :: Maybe ExamOccurrenceRule
, efCorrectors :: Set (Either UserEmail UserId) , efCorrectors :: Set (Either UserEmail UserId)
, efExamParts :: Set ExamPartForm , efExamParts :: Set ExamPartForm
} }
@ -57,7 +56,8 @@ data ExamOccurrenceForm = ExamOccurrenceForm
data ExamPartForm = ExamPartForm data ExamPartForm = ExamPartForm
{ epfId :: Maybe CryptoUUIDExamPart { epfId :: Maybe CryptoUUIDExamPart
, epfName :: ExamPartName , epfNumber :: ExamPartNumber
, epfName :: Maybe ExamPartName
, epfMaxPoints :: Maybe Points , epfMaxPoints :: Maybe Points
, epfWeight :: Rational , epfWeight :: Rational
} deriving (Read, Show, Eq, Ord, Generic, Typeable) } deriving (Read, Show, Eq, Ord, Generic, Typeable)
@ -80,6 +80,7 @@ examForm template html = do
flip (renderAForm FormStandard) html $ ExamForm flip (renderAForm FormStandard) html $ ExamForm
<$> areq ciField (fslpI MsgExamName (mr MsgExamName) & setTooltip MsgExamNameTip) (efName <$> template) <$> areq ciField (fslpI MsgExamName (mr MsgExamName) & setTooltip MsgExamNameTip) (efName <$> template)
<*> (assertM (not . null . renderHtml) <$> aopt htmlField (fslpI MsgExamDescription "Html") (efDescription <$> template)) <*> (assertM (not . null . renderHtml) <$> aopt htmlField (fslpI MsgExamDescription "Html") (efDescription <$> template))
<*> apopt checkBoxField (fslI MsgExamShowGrades & setTooltip MsgExamShowGradesTip) (efShowGrades <$> template <|> Just True)
<* aformSection MsgExamFormTimes <* aformSection MsgExamFormTimes
<*> aopt utcTimeField (fslpI MsgExamStart (mr MsgDate) & setTooltip MsgExamTimeTip) (efStart <$> template) <*> aopt utcTimeField (fslpI MsgExamStart (mr MsgDate) & setTooltip MsgExamTimeTip) (efStart <$> template)
<*> aopt utcTimeField (fslpI MsgExamEnd (mr MsgDate) & setTooltip MsgExamTimeTip) (efEnd <$> template) <*> aopt utcTimeField (fslpI MsgExamEnd (mr MsgDate) & setTooltip MsgExamTimeTip) (efEnd <$> template)
@ -89,15 +90,13 @@ examForm template html = do
<*> aopt utcTimeField (fslpI MsgExamDeregisterUntil (mr MsgDate)) (efDeregisterUntil <$> template) <*> aopt utcTimeField (fslpI MsgExamDeregisterUntil (mr MsgDate)) (efDeregisterUntil <$> template)
<*> aopt utcTimeField (fslpI MsgExamPublishOccurrenceAssignments (mr MsgDate) & setTooltip MsgExamPublishOccurrenceAssignmentsTip) (efPublishOccurrenceAssignments <$> template) <*> aopt utcTimeField (fslpI MsgExamPublishOccurrenceAssignments (mr MsgDate) & setTooltip MsgExamPublishOccurrenceAssignmentsTip) (efPublishOccurrenceAssignments <$> template)
<*> aopt utcTimeField (fslpI MsgExamFinished (mr MsgDate) & setTooltip MsgExamFinishedTip) (efFinished <$> template) <*> aopt utcTimeField (fslpI MsgExamFinished (mr MsgDate) & setTooltip MsgExamFinishedTip) (efFinished <$> template)
<*> aopt utcTimeField (fslpI MsgExamClosed (mr MsgDate) & setTooltip MsgExamClosedTip) (efClosed <$> template)
<* aformSection MsgExamFormOccurrences <* aformSection MsgExamFormOccurrences
<*> examOccurrenceForm (efOccurrences <$> template) <*> examOccurrenceForm (efOccurrences <$> template)
<* aformSection MsgExamFormAutomaticFunctions <* aformSection MsgExamFormAutomaticFunctions
<*> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamShowGrades & setTooltip MsgExamShowGradesTip) (Just . efShowGrades <$> template)) <*> apopt checkBoxField (fslI MsgExamPublicStatistics & setTooltip MsgExamPublicStatisticsTip) (efPublicStatistics <$> template <|> Just True)
<*> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamPublicStatistics & setTooltip MsgExamPublicStatisticsTip) (Just . efPublicStatistics <$> template)) <*> optionalActionA (examGradingRuleForm $ efGradingRule =<< template) (fslI MsgExamAutomaticGrading & setTooltip MsgExamAutomaticGradingTip) (is _Just . efGradingRule <$> template)
<*> examGradingRuleForm (efGradingRule <$> template) <*> optionalActionA (examBonusRuleForm $ efBonusRule =<< template) (fslI MsgExamBonus) (is _Just . efBonusRule <$> template)
<*> examBonusRuleForm (efBonusRule <$> template) <*> optionalActionA (examOccurrenceRuleForm $ efOccurrenceRule =<< template) (fslI MsgExamAutomaticOccurrenceAssignment & setTooltip MsgExamAutomaticOccurrenceAssignmentTip) (is _Just . efOccurrenceRule <$> template)
<*> examOccurrenceRuleForm (efOccurrenceRule <$> template)
<* aformSection MsgExamFormCorrection <* aformSection MsgExamFormCorrection
<*> examCorrectorsForm (efCorrectors <$> template) <*> examCorrectorsForm (efCorrectors <$> template)
<* aformSection MsgExamFormParts <* aformSection MsgExamFormParts
@ -106,8 +105,8 @@ examForm template html = do
examCorrectorsForm :: Maybe (Set (Either UserEmail UserId)) -> AForm Handler (Set (Either UserEmail UserId)) examCorrectorsForm :: Maybe (Set (Either UserEmail UserId)) -> AForm Handler (Set (Either UserEmail UserId))
examCorrectorsForm mPrev = wFormToAForm $ do examCorrectorsForm mPrev = wFormToAForm $ do
MsgRenderer mr <- getMsgRenderer MsgRenderer mr <- getMsgRenderer
Just currentRoute <- getCurrentRoute currentRoute <- fromMaybe (error "examCorrectorForm called from 404-handler") <$> getCurrentRoute
uid <- liftHandlerT requireAuthId uid <- liftHandler requireAuthId
let let
miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
@ -138,10 +137,11 @@ examCorrectorsForm mPrev = wFormToAForm $ do
miCell' :: Either UserEmail UserId -> Widget miCell' :: Either UserEmail UserId -> Widget
miCell' (Left email) = miCell' (Left email) = do
invWarnMsg <- messageI Warning MsgEmailInvitationWarning
$(widgetFile "widgets/massinput/examCorrectors/cellInvitation") $(widgetFile "widgets/massinput/examCorrectors/cellInvitation")
miCell' (Right userId) = do miCell' (Right userId) = do
User{..} <- liftHandlerT . runDB $ get404 userId User{..} <- liftHandler . runDB $ get404 userId
$(widgetFile "widgets/massinput/examCorrectors/cellKnown") $(widgetFile "widgets/massinput/examCorrectors/cellKnown")
miLayout' :: MassInputLayout ListLength (Either UserEmail UserId) () miLayout' :: MassInputLayout ListLength (Either UserEmail UserId) ()
@ -151,7 +151,7 @@ examCorrectorsForm mPrev = wFormToAForm $ do
examOccurrenceForm :: Maybe (Set ExamOccurrenceForm) -> AForm Handler (Set ExamOccurrenceForm) examOccurrenceForm :: Maybe (Set ExamOccurrenceForm) -> AForm Handler (Set ExamOccurrenceForm)
examOccurrenceForm prev = wFormToAForm $ do examOccurrenceForm prev = wFormToAForm $ do
Just currentRoute <- getCurrentRoute currentRoute <- fromMaybe (error "examOccurrenceForm called from 404-handler") <$> getCurrentRoute
let let
miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag
@ -193,7 +193,7 @@ examOccurrenceForm prev = wFormToAForm $ do
examPartsForm :: Maybe (Set ExamPartForm) -> AForm Handler (Set ExamPartForm) examPartsForm :: Maybe (Set ExamPartForm) -> AForm Handler (Set ExamPartForm)
examPartsForm prev = wFormToAForm $ do examPartsForm prev = wFormToAForm $ do
Just currentRoute <- getCurrentRoute currentRoute <- fromMaybe (error "examPartsForm called from 404-handler") <$> getCurrentRoute
let let
miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag
@ -202,12 +202,14 @@ examPartsForm prev = wFormToAForm $ do
where where
examPartForm' nudge mPrev csrf = do examPartForm' nudge mPrev csrf = do
(epfIdRes, epfIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ epfId =<< mPrev) (epfIdRes, epfIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ epfId =<< mPrev)
(epfNameRes, epfNameView) <- mpreq (textField & cfStrip & cfCI) ("" & addName (nudge "name")) (epfName <$> mPrev) (epfNumberRes, epfNumberView) <- mpreq (isoField (from _ExamPartNumber) $ textField & cfStrip & cfCI) ("" & addName (nudge "number") & addPlaceholder "1, 6a, 3.1.4, ...") (epfNumber <$> mPrev)
(epfNameRes, epfNameView) <- mopt (textField & cfStrip & cfCI) ("" & addName (nudge "name")) (epfName <$> mPrev)
(epfMaxPointsRes, epfMaxPointsView) <- mopt pointsField ("" & addName (nudge "max-points")) (epfMaxPoints <$> mPrev) (epfMaxPointsRes, epfMaxPointsView) <- mopt pointsField ("" & addName (nudge "max-points")) (epfMaxPoints <$> mPrev)
(epfWeightRes, epfWeightView) <- mpreq (checkBool (>= 0) MsgExamPartWeightNegative rationalField) ("" & addName (nudge "weight")) (epfWeight <$> mPrev <|> Just 1) (epfWeightRes, epfWeightView) <- mpreq (checkBool (>= 0) MsgExamPartWeightNegative rationalField) ("" & addName (nudge "weight")) (epfWeight <$> mPrev <|> Just 1)
return ( ExamPartForm return ( ExamPartForm
<$> epfIdRes <$> epfIdRes
<*> epfNumberRes
<*> epfNameRes <*> epfNameRes
<*> epfMaxPointsRes <*> epfMaxPointsRes
<*> epfWeightRes <*> epfWeightRes
@ -219,7 +221,8 @@ examPartsForm prev = wFormToAForm $ do
(res, formWidget) <- examPartForm' nudge Nothing csrf (res, formWidget) <- examPartForm' nudge Nothing csrf
let let
addRes = res <&> \newDat (Set.fromList -> oldDat) -> if addRes = res <&> \newDat (Set.fromList -> oldDat) -> if
| any (((==) `on` epfName) newDat) oldDat -> FormFailure [mr MsgExamPartAlreadyExists] | any (\old -> fromMaybe False $ (==) <$> epfName newDat <*> epfName old) oldDat
-> FormFailure [mr MsgExamPartAlreadyExists]
| otherwise -> FormSuccess $ pure newDat | otherwise -> FormSuccess $ pure newDat
return (addRes, $(widgetFile "widgets/massinput/examParts/add")) return (addRes, $(widgetFile "widgets/massinput/examParts/add"))
miCell' nudge dat = examPartForm' nudge (Just dat) miCell' nudge dat = examPartForm' nudge (Just dat)
@ -250,7 +253,6 @@ examFormTemplate (Entity eId Exam{..}) = do
, efStart = examStart , efStart = examStart
, efEnd = examEnd , efEnd = examEnd
, efFinished = examFinished , efFinished = examFinished
, efClosed = examClosed
, efShowGrades = examShowGrades , efShowGrades = examShowGrades
, efPublicStatistics = examPublicStatistics , efPublicStatistics = examPublicStatistics
, efDescription = examDescription , efDescription = examDescription
@ -269,6 +271,7 @@ examFormTemplate (Entity eId Exam{..}) = do
(Just -> epfId, ExamPart{..}) <- examParts' (Just -> epfId, ExamPart{..}) <- examParts'
return ExamPartForm return ExamPartForm
{ epfId { epfId
, epfNumber = examPartNumber
, epfName = examPartName , epfName = examPartName
, epfMaxPoints = examPartMaxPoints , epfMaxPoints = examPartMaxPoints
, epfWeight = examPartWeight , epfWeight = examPartWeight
@ -318,7 +321,6 @@ examTemplate cid = runMaybeT $ do
, efStart = dateOffset <$> examStart oldExam , efStart = dateOffset <$> examStart oldExam
, efEnd = dateOffset <$> examEnd oldExam , efEnd = dateOffset <$> examEnd oldExam
, efFinished = dateOffset <$> examFinished oldExam , efFinished = dateOffset <$> examFinished oldExam
, efClosed = dateOffset <$> examClosed oldExam
, efShowGrades = examShowGrades oldExam , efShowGrades = examShowGrades oldExam
, efPublicStatistics = examPublicStatistics oldExam , efPublicStatistics = examPublicStatistics oldExam
, efDescription = examDescription oldExam , efDescription = examDescription oldExam
@ -338,9 +340,6 @@ validateExam = do
guardValidation MsgExamEndMustBeAfterStart $ NTop efEnd >= NTop efStart guardValidation MsgExamEndMustBeAfterStart $ NTop efEnd >= NTop efStart
guardValidation MsgExamFinishedMustBeAfterEnd . fromMaybe True $ (>=) <$> efFinished <*> efEnd guardValidation MsgExamFinishedMustBeAfterEnd . fromMaybe True $ (>=) <$> efFinished <*> efEnd
guardValidation MsgExamFinishedMustBeAfterStart $ NTop efFinished >= NTop efStart guardValidation MsgExamFinishedMustBeAfterStart $ NTop efFinished >= NTop efStart
guardValidation MsgExamClosedMustBeAfterFinished . fromMaybe True $ (>=) <$> efClosed <*> efFinished
guardValidation MsgExamClosedMustBeAfterStart $ NTop efClosed >= NTop efStart
guardValidation MsgExamClosedMustBeAfterEnd . fromMaybe True $ (>=) <$> efClosed <*> efEnd
forM_ efOccurrences $ \ExamOccurrenceForm{..} -> do forM_ efOccurrences $ \ExamOccurrenceForm{..} -> do
guardValidation (MsgExamOccurrenceEndMustBeAfterStart eofName) $ NTop eofEnd >= NTop (Just eofStart) guardValidation (MsgExamOccurrenceEndMustBeAfterStart eofName) $ NTop eofEnd >= NTop (Just eofStart)

1
src/Handler/Exam/List.hs
View File

@ -5,7 +5,6 @@ module Handler.Exam.List
import Import import Import
import Handler.Utils import Handler.Utils
import Handler.Utils.Table.Cells
import qualified Data.Map as Map import qualified Data.Map as Map

3
src/Handler/Exam/New.hs
View File

@ -40,7 +40,7 @@ postCExamNewR tid ssh csh = do
, examStart = efStart , examStart = efStart
, examEnd = efEnd , examEnd = efEnd
, examFinished = efFinished , examFinished = efFinished
, examClosed = efClosed , examClosed = Nothing
, examShowGrades = efShowGrades , examShowGrades = efShowGrades
, examPublicStatistics = efPublicStatistics , examPublicStatistics = efPublicStatistics
, examDescription = efDescription , examDescription = efDescription
@ -50,6 +50,7 @@ postCExamNewR tid ssh csh = do
[ ExamPart{..} [ ExamPart{..}
| ExamPartForm{..} <- Set.toList efExamParts | ExamPartForm{..} <- Set.toList efExamParts
, let examPartExam = examid , let examPartExam = examid
examPartNumber = epfNumber
examPartName = epfName examPartName = epfName
examPartMaxPoints = epfMaxPoints examPartMaxPoints = epfMaxPoints
examPartWeight = epfWeight examPartWeight = epfWeight

19
src/Handler/Exam/RegistrationInvite.hs
View File

@ -18,6 +18,8 @@ import qualified Data.Set as Set
import Text.Hamlet (ihamlet) import Text.Hamlet (ihamlet)
import Data.Aeson hiding (Result(..)) import Data.Aeson hiding (Result(..))
import Jobs.Queue
instance IsInvitableJunction ExamRegistration where instance IsInvitableJunction ExamRegistration where
@ -63,15 +65,19 @@ examRegistrationInvitationConfig = InvitationConfig{..}
Course{..} <- get404 examCourse Course{..} <- get404 examCourse
return $ CExamR courseTerm courseSchool courseShorthand examName EInviteR return $ CExamR courseTerm courseSchool courseShorthand examName EInviteR
invitationResolveFor _ = do invitationResolveFor _ = do
Just (CExamR tid csh ssh examn EInviteR) <- getCurrentRoute cRoute <- getCurrentRoute
fetchExamId tid csh ssh examn case cRoute of
Just (CExamR tid csh ssh examn EInviteR) ->
fetchExamId tid csh ssh examn
_other ->
error "examRegistrationInvitationConfig called from unsupported route"
invitationSubject (Entity _ Exam{..}) _ = do invitationSubject (Entity _ Exam{..}) _ = do
Course{..} <- get404 examCourse Course{..} <- get404 examCourse
return . SomeMessage $ MsgMailSubjectExamRegistrationInvitation courseTerm courseSchool courseShorthand examName return . SomeMessage $ MsgMailSubjectExamRegistrationInvitation courseTerm courseSchool courseShorthand examName
invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamRegistrationInviteHeading examName invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamRegistrationInviteHeading examName
invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamRegistrationInviteExplanation}|] invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamRegistrationInviteExplanation}|]
invitationTokenConfig _ (InvDBDataExamRegistration{..}, _) = do invitationTokenConfig _ (InvDBDataExamRegistration{..}, _) = do
itAuthority <- liftHandlerT requireAuthId itAuthority <- liftHandler requireAuthId
let itExpiresAt = Just $ Just invDBExamRegistrationDeadline let itExpiresAt = Just $ Just invDBExamRegistrationDeadline
itAddAuth itAddAuth
| not invDBExamRegistrationCourseRegister | not invDBExamRegistrationCourseRegister
@ -81,8 +87,8 @@ examRegistrationInvitationConfig = InvitationConfig{..}
itStartsAt = Nothing itStartsAt = Nothing
return InvitationTokenConfig{..} return InvitationTokenConfig{..}
invitationRestriction _ _ = return Authorized invitationRestriction _ _ = return Authorized
invitationForm (Entity _ Exam{..}) (InvDBDataExamRegistration{..}, _) uid = hoistAForm liftHandlerT . wFormToAForm $ do invitationForm (Entity _ Exam{..}) (InvDBDataExamRegistration{..}, _) uid = hoistAForm liftHandler . wFormToAForm $ do
isRegistered <- fmap (is _Just) . liftHandlerT . runDB . getBy $ UniqueParticipant uid examCourse isRegistered <- fmap (is _Just) . liftHandler . runDB . getBy $ UniqueParticipant uid examCourse
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
case (isRegistered, invDBExamRegistrationCourseRegister) of case (isRegistered, invDBExamRegistrationCourseRegister) of
@ -93,7 +99,8 @@ examRegistrationInvitationConfig = InvitationConfig{..}
(True , _ ) -> return $ pure (JunctionExamRegistration invDBExamRegistrationOccurrence now, Nothing) (True , _ ) -> return $ pure (JunctionExamRegistration invDBExamRegistrationOccurrence now, Nothing)
invitationInsertHook (Entity eid Exam{..}) _ ExamRegistration{..} mField act = do invitationInsertHook (Entity eid Exam{..}) _ ExamRegistration{..} mField act = do
whenIsJust mField $ \cpField -> do whenIsJust mField $ \cpField -> do
insert_ $ CourseParticipant examCourse examRegistrationUser examRegistrationTime cpField False insert_ $ CourseParticipant examCourse examRegistrationUser examRegistrationTime cpField Nothing
queueDBJob . JobQueueNotification $ NotificationCourseRegistered examRegistrationUser examCourse
audit $ TransactionCourseParticipantEdit examCourse examRegistrationUser audit $ TransactionCourseParticipantEdit examCourse examRegistrationUser
let doAudit = audit $ TransactionExamRegister eid examRegistrationUser let doAudit = audit $ TransactionExamRegister eid examRegistrationUser

32
src/Handler/Exam/Show.hs
View File

@ -22,7 +22,7 @@ getEShowR tid ssh csh examn = do
cTime <- liftIO getCurrentTime cTime <- liftIO getCurrentTime
mUid <- maybeAuthId mUid <- maybeAuthId
(Entity _ Exam{..}, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister), occurrenceNamesShown) <- runDB $ do (Entity _ Exam{..}, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, bonus, occurrences, (registered, mayRegister), lecturerInfoShown) <- runDB $ do
exam@(Entity eId Exam{..}) <- fetchExam tid ssh csh examn exam@(Entity eId Exam{..}) <- fetchExam tid ssh csh examn
let examVisible = NTop (Just cTime) >= NTop examVisibleFrom let examVisible = NTop (Just cTime) >= NTop examVisibleFrom
@ -33,7 +33,7 @@ getEShowR tid ssh csh examn = do
let occurrenceAssignmentsVisible = NTop (Just cTime) >= NTop examPublishOccurrenceAssignments let occurrenceAssignmentsVisible = NTop (Just cTime) >= NTop examPublishOccurrenceAssignments
occurrenceAssignmentsShown <- or2M (return occurrenceAssignmentsVisible) . hasReadAccessTo $ CExamR tid ssh csh examn EEditR occurrenceAssignmentsShown <- or2M (return occurrenceAssignmentsVisible) . hasReadAccessTo $ CExamR tid ssh csh examn EEditR
examParts <- selectList [ ExamPartExam ==. eId ] [ Asc ExamPartName ] examParts <- sortOn (view $ _entityVal . _examPartNumber) <$> selectList [ ExamPartExam ==. eId ] [ Asc ExamPartName ]
resultsRaw <- for mUid $ \uid -> resultsRaw <- for mUid $ \uid ->
E.select . E.from $ \examPartResult -> do E.select . E.from $ \examPartResult -> do
@ -43,6 +43,7 @@ getEShowR tid ssh csh examn = do
let results = maybe Map.empty (\rs -> Map.fromList [ (examPartResultExamPart, res) | res@(Entity _ ExamPartResult{..}) <- rs ]) resultsRaw let results = maybe Map.empty (\rs -> Map.fromList [ (examPartResultExamPart, res) | res@(Entity _ ExamPartResult{..}) <- rs ]) resultsRaw
result <- fmap join . for mUid $ getBy . UniqueExamResult eId result <- fmap join . for mUid $ getBy . UniqueExamResult eId
bonus <- fmap join . for mUid $ getBy . UniqueExamBonus eId
occurrencesRaw <- E.select . E.from $ \examOccurrence -> do occurrencesRaw <- E.select . E.from $ \examOccurrence -> do
E.where_ $ examOccurrence E.^. ExamOccurrenceExam E.==. E.val eId E.where_ $ examOccurrence E.^. ExamOccurrenceExam E.==. E.val eId
@ -62,15 +63,33 @@ getEShowR tid ssh csh examn = do
registered <- for mUid $ existsBy . UniqueExamRegistration eId registered <- for mUid $ existsBy . UniqueExamRegistration eId
mayRegister <- (== Authorized) <$> evalAccessDB (CExamR tid ssh csh examName ERegisterR) True mayRegister <- (== Authorized) <$> evalAccessDB (CExamR tid ssh csh examName ERegisterR) True
occurrenceNamesShown <- hasReadAccessTo $ CExamR tid ssh csh examn EEditR lecturerInfoShown <- hasReadAccessTo $ CExamR tid ssh csh examn EEditR
return (exam, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister), occurrenceNamesShown) return (exam, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, bonus, occurrences, (registered, mayRegister), lecturerInfoShown)
let occurrenceNamesShown = lecturerInfoShown
partNumbersShown = lecturerInfoShown
examClosedShown = lecturerInfoShown
sumMaxPoints = sum [ fromRational examPartWeight * mPoints | Entity _ ExamPart{..} <- examParts, let Just mPoints = examPartMaxPoints ]
noBonus = fromMaybe False $ do
guardM $ bonusOnlyPassed <$> examBonusRule
return . fromMaybe True $ result ^? _Just . _entityVal . _examResultResult . _examResult . passingGrade . _Wrapped . to not
sumPoints = fmap getSum . mconcat $ catMaybes
[ Just $ foldMap (fmap Sum . examPartResultResult . entityVal) results
, guard (not noBonus) *> fmap (pure . Sum . examBonusBonus . entityVal) bonus
]
hasRegistration = any snd occurrences
let examTimes = all (\(Entity _ ExamOccurrence{..}, _) -> Just examOccurrenceStart == examStart && examOccurrenceEnd == examEnd) occurrences let examTimes = all (\(Entity _ ExamOccurrence{..}, _) -> Just examOccurrenceStart == examStart && examOccurrenceEnd == examEnd) occurrences
registerWidget registerWidget
| Just isRegistered <- registered | Just isRegistered <- registered
, mayRegister = Just $ do , mayRegister = Just $ do
(examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnExamRegister] [BtnExamDeregister] isRegistered (examRegisterForm, examRegisterEnctype) <- liftHandler . generateFormPost . buttonForm' $ bool [BtnExamRegister] [BtnExamDeregister] isRegistered
[whamlet| [whamlet|
<p> <p>
$if isRegistered $if isRegistered
@ -86,6 +105,9 @@ getEShowR tid ssh csh examn = do
| fromMaybe False registered = Just [whamlet|_{MsgExamRegistered}|] | fromMaybe False registered = Just [whamlet|_{MsgExamRegistered}|]
| otherwise = Nothing | otherwise = Nothing
showMaxPoints = any (has $ _entityVal . _examPartMaxPoints . _Just) examParts
showAchievedPoints = not $ null results
let heading = prependCourseTitle tid ssh csh $ CI.original examName let heading = prependCourseTitle tid ssh csh $ CI.original examName
siteLayoutMsg heading $ do siteLayoutMsg heading $ do

730
src/Handler/Exam/Users.hs
View File

@ -4,25 +4,27 @@ module Handler.Exam.Users
( getEUsersR, postEUsersR ( getEUsersR, postEUsersR
) where ) where
import Import import Import hiding ((<.), (.>))
import Handler.Utils import Handler.Utils
import Handler.Utils.Exam import Handler.Utils.Exam
import Handler.Utils.Table.Columns
import Handler.Utils.Table.Cells
import Handler.Utils.Csv import Handler.Utils.Csv
import Handler.ExamOffice.Exam (examCloseWidget)
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Utils as E
import Database.Esqueleto.Utils.TH import Database.Esqueleto.Utils.TH
import qualified Data.Csv as Csv import qualified Data.Csv as Csv
import Data.Map ((!)) import Data.Map ((!), (!?))
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.HashMap.Lazy as HashMap
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Data.Text.Lens as Text import qualified Data.Text.Lens as Text
import qualified Data.Conduit.List as C import qualified Data.Conduit.List as C
@ -33,9 +35,35 @@ import Numeric.Lens (integral)
import Database.Persist.Sql (deleteWhereCount, updateWhereCount) import Database.Persist.Sql (deleteWhereCount, updateWhereCount)
import Control.Lens.Indexed ((<.), (.>))
type ExamUserTableExpr = (E.SqlExpr (Entity ExamRegistration) `E.InnerJoin` E.SqlExpr (Entity User)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamOccurrence)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity CourseParticipant)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity StudyFeatures)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms)))) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamResult)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseUserNote)) import Jobs.Queue
type ExamUserTableData = DBRow (Entity ExamRegistration, Entity User, Maybe (Entity ExamOccurrence), Maybe (Entity StudyFeatures), Maybe (Entity StudyDegree), Maybe (Entity StudyTerms), Maybe (Entity ExamResult), Maybe (Entity CourseUserNote))
type ExamUserTableExpr = ( E.SqlExpr (Entity ExamRegistration)
`E.InnerJoin` E.SqlExpr (Entity User)
)
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamOccurrence))
`E.LeftOuterJoin` ( E.SqlExpr (Maybe (Entity CourseParticipant))
`E.LeftOuterJoin` ( E.SqlExpr (Maybe (Entity StudyFeatures))
`E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree))
`E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms))
)
)
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamBonus))
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamResult))
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseUserNote))
type ExamUserTableData = DBRow ( Entity ExamRegistration
, Entity User
, Maybe (Entity ExamOccurrence)
, Maybe (Entity StudyFeatures)
, Maybe (Entity StudyDegree)
, Maybe (Entity StudyTerms)
, Maybe (Entity ExamBonus)
, Maybe (Entity ExamResult)
, Map ExamPartId (ExamPart, Maybe (Entity ExamPartResult))
, Maybe (Entity CourseUserNote)
)
instance HasEntity ExamUserTableData User where instance HasEntity ExamUserTableData User where
hasEntity = _dbrOutput . _2 hasEntity = _dbrOutput . _2
@ -47,28 +75,51 @@ _userTableOccurrence :: Lens' ExamUserTableData (Maybe (Entity ExamOccurrence))
_userTableOccurrence = _dbrOutput . _3 _userTableOccurrence = _dbrOutput . _3
queryUser :: ExamUserTableExpr -> E.SqlExpr (Entity User) queryUser :: ExamUserTableExpr -> E.SqlExpr (Entity User)
queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 5 1) queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 6 1)
queryStudyFeatures :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures))
queryStudyFeatures = $(sqlIJproj 3 1) . $(sqlLOJproj 2 2) . $(sqlLOJproj 5 3)
queryExamRegistration :: ExamUserTableExpr -> E.SqlExpr (Entity ExamRegistration) queryExamRegistration :: ExamUserTableExpr -> E.SqlExpr (Entity ExamRegistration)
queryExamRegistration = $(sqlIJproj 2 1) . $(sqlLOJproj 5 1) queryExamRegistration = $(sqlIJproj 2 1) . $(sqlLOJproj 6 1)
queryExamOccurrence :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamOccurrence)) queryExamOccurrence :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamOccurrence))
queryExamOccurrence = $(sqlLOJproj 5 2) queryExamOccurrence = $(sqlLOJproj 6 2)
queryCourseParticipant :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity CourseParticipant))
queryCourseParticipant = $(sqlLOJproj 2 1) . $(sqlLOJproj 6 3)
queryStudyFeatures :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures))
queryStudyFeatures = $(sqlIJproj 3 1) . $(sqlLOJproj 2 2) . $(sqlLOJproj 6 3)
queryStudyDegree :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyDegree)) queryStudyDegree :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyDegree))
queryStudyDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 2 2) . $(sqlLOJproj 5 3) queryStudyDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 2 2) . $(sqlLOJproj 6 3)
queryStudyField :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyTerms)) queryStudyField :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyTerms))
queryStudyField = $(sqlIJproj 3 3) . $(sqlLOJproj 2 2) . $(sqlLOJproj 5 3) queryStudyField = $(sqlIJproj 3 3) . $(sqlLOJproj 2 2) . $(sqlLOJproj 6 3)
queryExamBonus :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamBonus))
queryExamBonus = $(sqlLOJproj 6 4)
queryExamResult :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamResult)) queryExamResult :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamResult))
queryExamResult = $(sqlLOJproj 5 4) queryExamResult = $(sqlLOJproj 6 5)
queryCourseNote :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity CourseUserNote)) queryCourseNote :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity CourseUserNote))
queryCourseNote = $(sqlLOJproj 5 5) queryCourseNote = $(sqlLOJproj 6 6)
queryExamPart :: forall a.
PersistField a
=> ExamPartId
-> (E.SqlExpr (Entity ExamPart) -> E.SqlExpr (Maybe (Entity ExamPartResult)) -> E.SqlQuery (E.SqlExpr (E.Value a)))
-> ExamUserTableExpr
-> E.SqlExpr (E.Value a)
queryExamPart epId cont inp = E.sub_select . E.from $ \(examPart `E.LeftOuterJoin` examPartResult) -> flip runReaderT inp $ do
examRegistration <- asks queryExamRegistration
lift $ do
E.on $ E.just (examPart E.^. ExamPartId) E.==. examPartResult E.?. ExamPartResultExamPart
E.&&. examPartResult E.?. ExamPartResultUser E.==. E.just (examRegistration E.^. ExamRegistrationUser)
E.where_ $ examPart E.^. ExamPartExam E.==. examRegistration E.^. ExamRegistrationExam
E.&&. examPart E.^. ExamPartId E.==. E.val epId
cont examPart examPartResult
resultExamRegistration :: Lens' ExamUserTableData (Entity ExamRegistration) resultExamRegistration :: Lens' ExamUserTableData (Entity ExamRegistration)
resultExamRegistration = _dbrOutput . _1 resultExamRegistration = _dbrOutput . _1
@ -88,11 +139,48 @@ resultStudyField = _dbrOutput . _6 . _Just
resultExamOccurrence :: Traversal' ExamUserTableData (Entity ExamOccurrence) resultExamOccurrence :: Traversal' ExamUserTableData (Entity ExamOccurrence)
resultExamOccurrence = _dbrOutput . _3 . _Just resultExamOccurrence = _dbrOutput . _3 . _Just
resultExamBonus :: Traversal' ExamUserTableData (Entity ExamBonus)
resultExamBonus = _dbrOutput . _7 . _Just
resultExamResult :: Traversal' ExamUserTableData (Entity ExamResult) resultExamResult :: Traversal' ExamUserTableData (Entity ExamResult)
resultExamResult = _dbrOutput . _7 . _Just resultExamResult = _dbrOutput . _8 . _Just
resultExamParts :: IndexedTraversal' ExamPartId ExamUserTableData (ExamPart, Maybe (Entity ExamPartResult))
resultExamParts = _dbrOutput . _9 . itraversed
-- resultExamParts' :: Traversal' ExamUserTableData (Entity ExamPart)
-- resultExamParts' = (resultExamParts <. _1) . withIndex . from _Entity
resultExamPartResult :: ExamPartId -> Lens' ExamUserTableData (Maybe (Entity ExamPartResult))
resultExamPartResult epId = _dbrOutput . _9 . unsafeSingular (ix epId) . _2
resultExamPartResults :: IndexedTraversal' ExamPartId ExamUserTableData (Maybe (Entity ExamPartResult))
resultExamPartResults = resultExamParts <. _2
resultCourseNote :: Traversal' ExamUserTableData (Entity CourseUserNote) resultCourseNote :: Traversal' ExamUserTableData (Entity CourseUserNote)
resultCourseNote = _dbrOutput . _8 . _Just resultCourseNote = _dbrOutput . _10 . _Just
resultAutomaticExamBonus :: Exam -> Map UserId SheetTypeSummary -> Fold ExamUserTableData Points
resultAutomaticExamBonus exam examBonus' = resultUser . _entityKey . folding (\uid -> examResultBonus <$> examBonusRule exam <*> pure (examBonusPossible uid examBonus') <*> pure (examBonusAchieved uid examBonus'))
resultAutomaticExamResult :: Exam -> Map UserId SheetTypeSummary -> Fold ExamUserTableData ExamResultGrade
resultAutomaticExamResult exam examBonus' = folding . runReader $ do
parts' <- asks $ sequence . toListOf (resultExamPartResults . to (^? _Just . _entityVal . _examPartResultResult))
bonus <- preview $ resultExamBonus . _entityVal . _examBonusBonus <> resultAutomaticExamBonus exam examBonus'
return $ examGrade exam bonus =<< parts'
csvExamPartHeader :: Prism' Csv.Name ExamPartNumber
csvExamPartHeader = prism' toHeader fromHeader
where
toHeader pName = encodeUtf8 $ partPrefix <> CI.foldedCase (pName ^. _ExamPartNumber)
fromHeader hdr = do
tHdr <- either (const Nothing) Just $ Text.decodeUtf8' hdr
review _ExamPartNumber . CI.mk <$> stripPrefix partPrefix tHdr
partPrefix = "part-"
data ExamUserTableCsv = ExamUserTableCsv data ExamUserTableCsv = ExamUserTableCsv
{ csvEUserSurname :: Maybe Text { csvEUserSurname :: Maybe Text
@ -103,24 +191,46 @@ data ExamUserTableCsv = ExamUserTableCsv
, csvEUserDegree :: Maybe Text , csvEUserDegree :: Maybe Text
, csvEUserSemester :: Maybe Int , csvEUserSemester :: Maybe Int
, csvEUserOccurrence :: Maybe (CI Text) , csvEUserOccurrence :: Maybe (CI Text)
, csvEUserExercisePoints :: Maybe Points , csvEUserExercisePoints :: Maybe (Maybe Points)
, csvEUserExerciseNumPasses :: Maybe Int , csvEUserExerciseNumPasses :: Maybe (Maybe Int)
, csvEUserExercisePointsMax :: Maybe Points , csvEUserExercisePointsMax :: Maybe (Maybe Points)
, csvEUserExerciseNumPassesMax :: Maybe Int , csvEUserExerciseNumPassesMax :: Maybe (Maybe Int)
, csvEUserBonus :: Maybe (Maybe Points)
, csvEUserExamPartResults :: Map ExamPartNumber (Maybe ExamResultPoints)
, csvEUserExamResult :: Maybe ExamResultPassedGrade , csvEUserExamResult :: Maybe ExamResultPassedGrade
, csvEUserCourseNote :: Maybe Html , csvEUserCourseNote :: Maybe Html
} }
deriving (Generic) deriving (Generic)
makeLenses_ ''ExamUserTableCsv makeLenses_ ''ExamUserTableCsv
examUserTableCsvOptions :: Csv.Options
examUserTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 3 }
instance ToNamedRecord ExamUserTableCsv where instance ToNamedRecord ExamUserTableCsv where
toNamedRecord = Csv.genericToNamedRecord examUserTableCsvOptions toNamedRecord ExamUserTableCsv{..} = Csv.namedRecord $
[ "surname" Csv..= csvEUserSurname
, "first-name" Csv..= csvEUserFirstName
, "name" Csv..= csvEUserName
, "matriculation" Csv..= csvEUserMatriculation
, "field" Csv..= csvEUserField
, "degree" Csv..= csvEUserDegree
, "semester" Csv..= csvEUserSemester
, "occurrence" Csv..= csvEUserOccurrence
] ++ catMaybes
[ fmap ("exercise-points" Csv..=) csvEUserExercisePoints
, fmap ("exercise-num-passes" Csv..=) csvEUserExerciseNumPasses
, fmap ("exercise-points-max" Csv..=) csvEUserExercisePointsMax
, fmap ("exercise-num-passes-max" Csv..=) csvEUserExerciseNumPassesMax
, fmap ("bonus" Csv..=) csvEUserBonus
]
++ examPartResults ++
[ "exam-result" Csv..= csvEUserExamResult
, "course-note" Csv..= csvEUserCourseNote
]
where
examPartResults
= flip ifoldMap csvEUserExamPartResults $
\pNumber pResult -> pure $ (csvExamPartHeader # pNumber) Csv..= pResult
instance FromNamedRecord ExamUserTableCsv where instance FromNamedRecord ExamUserTableCsv where
parseNamedRecord csv -- Manually defined awaiting issue #427 parseNamedRecord csv
= ExamUserTableCsv = ExamUserTableCsv
<$> csv .:?? "surname" <$> csv .:?? "surname"
<*> csv .:?? "first-name" <*> csv .:?? "first-name"
@ -130,36 +240,66 @@ instance FromNamedRecord ExamUserTableCsv where
<*> csv .:?? "degree" <*> csv .:?? "degree"
<*> csv .:?? "semester" <*> csv .:?? "semester"
<*> csv .:?? "occurrence" <*> csv .:?? "occurrence"
<*> csv .:?? "exercise-points" <*> fmap Just (csv .:?? "exercise-points")
<*> csv .:?? "exercise-num-passes" <*> fmap Just (csv .:?? "exercise-num-passes")
<*> csv .:?? "exercise-points-max" <*> fmap Just (csv .:?? "exercise-points-max")
<*> csv .:?? "exercise-num-passes-max" <*> fmap Just (csv .:?? "exercise-num-passes-max")
<*> fmap Just (csv .:?? "bonus")
<*> examPartResults
<*> csv .:?? "exam-result" <*> csv .:?? "exam-result"
<*> csv .:?? "course-note" <*> csv .:?? "course-note"
where
instance DefaultOrdered ExamUserTableCsv where examPartResults = fmap fold . sequence . flip HashMap.mapMaybeWithKey csv $ \pNumber' _ -> do
headerOrder = Csv.genericHeaderOrder examUserTableCsvOptions pNumber <- pNumber' ^? csvExamPartHeader
return . fmap (singletonMap pNumber ) $ csv .:?? pNumber'
instance CsvColumnsExplained ExamUserTableCsv where instance CsvColumnsExplained ExamUserTableCsv where
csvColumnsExplanations = genericCsvColumnsExplanations examUserTableCsvOptions $ Map.fromList csvColumnsExplanations _ = mconcat
[ ('csvEUserSurname , MsgCsvColumnExamUserSurname ) [ single "surname" MsgCsvColumnExamUserSurname
, ('csvEUserFirstName , MsgCsvColumnExamUserFirstName ) , single "first-name" MsgCsvColumnExamUserFirstName
, ('csvEUserName , MsgCsvColumnExamUserName ) , single "name" MsgCsvColumnExamUserName
, ('csvEUserMatriculation , MsgCsvColumnExamUserMatriculation ) , single "matriculation" MsgCsvColumnExamUserMatriculation
, ('csvEUserField , MsgCsvColumnExamUserField ) , single "field" MsgCsvColumnExamUserField
, ('csvEUserDegree , MsgCsvColumnExamUserDegree ) , single "degree" MsgCsvColumnExamUserDegree
, ('csvEUserSemester , MsgCsvColumnExamUserSemester ) , single "semester" MsgCsvColumnExamUserSemester
, ('csvEUserOccurrence , MsgCsvColumnExamUserOccurrence ) , single "occurrence" MsgCsvColumnExamUserOccurrence
, ('csvEUserExercisePoints , MsgCsvColumnExamUserExercisePoints ) , single "exercise-points" MsgCsvColumnExamUserExercisePoints
, ('csvEUserExerciseNumPasses , MsgCsvColumnExamUserExercisePasses ) , single "exercise-num-passes" MsgCsvColumnExamUserExercisePasses
, ('csvEUserExercisePointsMax , MsgCsvColumnExamUserExercisePointsMax ) , single "exercise-points-max" MsgCsvColumnExamUserExercisePointsMax
, ('csvEUserExerciseNumPassesMax, MsgCsvColumnExamUserExercisePassesMax ) , single "exercise-num-passes-max" MsgCsvColumnExamUserExercisePassesMax
, ('csvEUserExamResult , MsgCsvColumnExamUserResult ) , single "bonus" MsgCsvColumnExamUserBonus
, ('csvEUserCourseNote , MsgCsvColumnExamUserCourseNote ) , single "part-*" MsgCsvColumnExamUserParts
, single "exam-result" MsgCsvColumnExamUserResult
, single "course-note" MsgCsvColumnExamUserCourseNote
] ]
where
single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
single k v = singletonMap k [whamlet|_{v}|]
examUserTableCsvHeader :: ( MonoFoldable mono
, Element mono ~ ExamPartNumber
)
=> SheetGradeSummary -> Bool -> mono -> Csv.Header
examUserTableCsvHeader allBoni doBonus pNames = Csv.header $
[ "surname", "first-name", "name"
, "matriculation"
, "field", "degree", "semester"
, "course-note"
, "occurrence"
] ++ bool mempty ["exercise-points", "exercise-points-max"] (doBonus && showPoints)
++ bool mempty ["exercise-num-passes", "exercise-num-passes-max"] (doBonus && showPasses)
++ bool mempty ["bonus"] doBonus
++ map (review csvExamPartHeader) (sort $ otoList pNames) ++
[ "exam-result"
]
where
showPasses = numSheetsPasses allBoni /= 0
showPoints = getSum (numSheetsPoints allBoni) /= 0
data ExamUserAction = ExamUserDeregister data ExamUserAction = ExamUserDeregister
| ExamUserAssignOccurrence | ExamUserAssignOccurrence
| ExamUserAcceptComputedResult
| ExamUserResetToComputedResult
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
instance Universe ExamUserAction instance Universe ExamUserAction
@ -169,13 +309,21 @@ embedRenderMessage ''UniWorX ''ExamUserAction id
data ExamUserActionData = ExamUserDeregisterData data ExamUserActionData = ExamUserDeregisterData
| ExamUserAssignOccurrenceData (Maybe ExamOccurrenceId) | ExamUserAssignOccurrenceData (Maybe ExamOccurrenceId)
| ExamUserAcceptComputedResultData
| ExamUserResetToComputedResultData
{ examUserResetBonus :: Bool
}
data ExamUserCsvActionClass data ExamUserCsvActionClass
= ExamUserCsvCourseRegister = ExamUserCsvCourseRegister
| ExamUserCsvRegister | ExamUserCsvRegister
| ExamUserCsvAssignOccurrence | ExamUserCsvAssignOccurrence
| ExamUserCsvSetCourseField | ExamUserCsvSetCourseField
| ExamUserCsvSetPartResult
| ExamUserCsvSetBonus
| ExamUserCsvOverrideBonus
| ExamUserCsvSetResult | ExamUserCsvSetResult
| ExamUserCsvOverrideResult
| ExamUserCsvSetCourseNote | ExamUserCsvSetCourseNote
| ExamUserCsvDeregister | ExamUserCsvDeregister
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
@ -202,8 +350,19 @@ data ExamUserCsvAction
| ExamUserCsvDeregisterData | ExamUserCsvDeregisterData
{ examUserCsvActRegistration :: ExamRegistrationId { examUserCsvActRegistration :: ExamRegistrationId
} }
| ExamUserCsvSetResultData | ExamUserCsvSetPartResultData
{ examUserCsvActUser :: UserId { examUserCsvActUser :: UserId
, examUserCsvActExamPart :: ExamPartNumber
, examUserCsvActExamPartResult :: Maybe ExamResultPoints
}
| ExamUserCsvSetBonusData
{ examUserCsvIsBonusOverride :: Bool
, examUserCsvActUser :: UserId
, examUserCsvActExamBonus :: Maybe Points
}
| ExamUserCsvSetResultData
{ examUserCsvIsResultOverride :: Bool
, examUserCsvActUser :: UserId
, examUserCsvActExamResult :: Maybe ExamResultPassedGrade , examUserCsvActExamResult :: Maybe ExamResultPassedGrade
} }
| ExamUserCsvSetCourseNoteData | ExamUserCsvSetCourseNoteData
@ -230,73 +389,148 @@ embedRenderMessage ''UniWorX ''ExamUserCsvException id
getEUsersR, postEUsersR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html getEUsersR, postEUsersR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
getEUsersR = postEUsersR getEUsersR = postEUsersR
postEUsersR tid ssh csh examn = do postEUsersR tid ssh csh examn = do
(registrationResult, examUsersTable) <- runDB $ do (((Any computedValues, registrationResult), examUsersTable), Entity eId examVal, bonus) <- runDB $ do
exam@(Entity eid Exam{..}) <- fetchExam tid ssh csh examn exam@(Entity eid examVal@Exam{..}) <- fetchExam tid ssh csh examn
examParts <- selectList [ExamPartExam ==. eid] [Asc ExamPartName]
bonus <- examBonus exam bonus <- examBonus exam
let let
allBoni :: SheetGradeSummary
allBoni = (mappend <$> normalSummary <*> bonusSummary) $ fold bonus allBoni = (mappend <$> normalSummary <*> bonusSummary) $ fold bonus
showPasses = numSheetsPasses allBoni /= 0
showPoints = getSum (numSheetsPoints allBoni) /= 0 doBonus = is _Just examBonusRule
showPasses = doBonus && numSheetsPasses allBoni /= 0
showPoints = doBonus && getSum (numSheetsPoints allBoni) /= 0
resultView :: ExamResultGrade -> ExamResultPassedGrade resultView :: ExamResultGrade -> ExamResultPassedGrade
resultView = fmap $ bool (Left . view passingGrade) Right examShowGrades resultView = fmap $ bool (Left . view passingGrade) Right examShowGrades
examPartNumbers = examParts ^.. folded . _entityVal . _examPartNumber
resultAutomaticExamBonus' :: Fold ExamUserTableData Points
resultAutomaticExamBonus' = resultAutomaticExamBonus examVal bonus
resultAutomaticExamResult' :: Fold ExamUserTableData ExamResultGrade
resultAutomaticExamResult' = resultAutomaticExamResult examVal bonus
automaticCell :: forall msg m a b r.
( RenderMessage UniWorX msg
, IsDBTable m a
, Eq msg
, Monoid b
, a ~ (Any, b)
)
=> Getting (Endo [Either msg msg]) r (Either msg msg)
-> r
-> DBCell m a
automaticCell l r = case toListOf l r of
[] -> mempty
(Left auto : _)
-> i18nCell auto & cellAttrs <>~ [("class", "table__td--automatic")] & tellCell (Any True, mempty)
(Right man : others)
| all ((== man) . either id id) others
-> i18nCell man
| otherwise
-> i18nCell man & cellAttrs <>~ [("class", "table__td--overriden")] & tellCell (Any True, mempty)
csvName <- getMessageRender <*> pure (MsgExamUserCsvName tid ssh csh examn)
let let
examUsersDBTable = DBTable{..} examUsersDBTable = DBTable{..}
where where
dbtSQLQuery ((examRegistration `E.InnerJoin` user) `E.LeftOuterJoin` occurrence `E.LeftOuterJoin` (courseParticipant `E.LeftOuterJoin` (studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyField)) `E.LeftOuterJoin` examResult `E.LeftOuterJoin` courseUserNote) = do dbtSQLQuery = runReaderT $ do
E.on $ courseUserNote E.?. CourseUserNoteUser E.==. E.just (user E.^. UserId) examRegistration <- asks queryExamRegistration
E.&&. courseUserNote E.?. CourseUserNoteCourse E.==. E.just (E.val examCourse) user <- asks queryUser
E.on $ examResult E.?. ExamResultUser E.==. E.just (user E.^. UserId) occurrence <- asks queryExamOccurrence
E.&&. examResult E.?. ExamResultExam E.==. E.just (E.val eid) courseParticipant <- asks queryCourseParticipant
E.on $ studyField E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField studyFeatures <- asks queryStudyFeatures
E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree studyDegree <- asks queryStudyDegree
E.on $ studyFeatures E.?. StudyFeaturesId E.==. E.joinV (courseParticipant E.?. CourseParticipantField) studyField <- asks queryStudyField
E.on $ courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val examCourse) examBonus' <- asks queryExamBonus
E.&&. courseParticipant E.?. CourseParticipantUser E.==. E.just (user E.^. UserId) examResult <- asks queryExamResult
E.on $ occurrence E.?. ExamOccurrenceExam E.==. E.just (E.val eid) courseUserNote <- asks queryCourseNote
E.&&. occurrence E.?. ExamOccurrenceId E.==. examRegistration E.^. ExamRegistrationOccurrence
E.on $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId lift $ do
E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eid E.on $ courseUserNote E.?. CourseUserNoteUser E.==. E.just (user E.^. UserId)
return (examRegistration, user, occurrence, studyFeatures, studyDegree, studyField, examResult, courseUserNote) E.&&. courseUserNote E.?. CourseUserNoteCourse E.==. E.just (E.val examCourse)
E.on $ examResult E.?. ExamResultUser E.==. E.just (user E.^. UserId)
E.&&. examResult E.?. ExamResultExam E.==. E.just (E.val eid)
E.on $ examBonus' E.?. ExamBonusUser E.==. E.just (user E.^. UserId)
E.&&. examBonus' E.?. ExamBonusExam E.==. E.just (E.val eid)
E.on $ studyField E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField
E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree
E.on $ studyFeatures E.?. StudyFeaturesId E.==. E.joinV (courseParticipant E.?. CourseParticipantField)
E.on $ courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val examCourse)
E.&&. courseParticipant E.?. CourseParticipantUser E.==. E.just (user E.^. UserId)
E.on $ occurrence E.?. ExamOccurrenceExam E.==. E.just (E.val eid)
E.&&. occurrence E.?. ExamOccurrenceId E.==. examRegistration E.^. ExamRegistrationOccurrence
E.on $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId
E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eid
return (examRegistration, user, occurrence, studyFeatures, studyDegree, studyField, examBonus', examResult, courseUserNote)
dbtRowKey = queryExamRegistration >>> (E.^. ExamRegistrationId) dbtRowKey = queryExamRegistration >>> (E.^. ExamRegistrationId)
dbtProj = return dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $
(,,,,,,,,,)
<$> view _1 <*> view _2 <*> view _3 <*> view _4 <*> view _5 <*> view _6 <*> view _7 <*> view _8
<*> getExamParts
<*> view _9
where
getExamParts :: ReaderT _ (MaybeT (YesodDB UniWorX)) (Map ExamPartId (ExamPart, Maybe (Entity ExamPartResult)))
getExamParts = do
uid <- view $ _2 . _entityKey
rawResults <- lift . lift . E.select . E.from $ \(examPart `E.LeftOuterJoin` examPartResult) -> do
E.on $ examPartResult E.?. ExamPartResultExamPart E.==. E.just (examPart E.^. ExamPartId)
E.&&. examPartResult E.?. ExamPartResultUser E.==. E.just (E.val uid)
E.where_ $ examPart E.^. ExamPartExam E.==. E.val eid
return (examPart, examPartResult)
return $ Map.fromList
[ (epId, (examPart, mbRes))
| (Entity epId examPart, mbRes) <- rawResults
]
dbtColonnade = mconcat $ catMaybes dbtColonnade = mconcat $ catMaybes
[ pure $ dbSelect (applying _2) id $ return . view (resultExamRegistration . _entityKey) [ pure $ dbSelect (_2 . applying _2) _1 $ return . view (resultExamRegistration . _entityKey)
, pure $ colUserNameLink (CourseR tid ssh csh . CUserR) , pure $ colUserNameLink (CourseR tid ssh csh . CUserR)
, pure colUserMatriclenr , pure colUserMatriclenr
, pure $ colField resultStudyField , pure $ colField resultStudyField
, pure $ colDegreeShort resultStudyDegree , pure $ colDegreeShort resultStudyDegree
, pure $ colFeaturesSemester resultStudyFeatures , pure $ colFeaturesSemester resultStudyFeatures
, pure $ sortable (Just "occurrence") (i18nCell MsgExamOccurrence) $ maybe mempty (anchorCell' (\n -> CExamR tid ssh csh examn EShowR :#: [st|exam-occurrence__#{n}|]) id . examOccurrenceName . entityVal) . view _userTableOccurrence , pure $ sortable (Just "occurrence") (i18nCell MsgExamOccurrence) $ maybe mempty (anchorCell' (\n -> CExamR tid ssh csh examn EShowR :#: [st|exam-occurrence__#{n}|]) id . examOccurrenceName . entityVal) . view _userTableOccurrence
, guardOn showPasses $ sortable Nothing (i18nCell MsgAchievedPasses) $ \(view $ resultUser . _entityKey -> uid) -> fromMaybe mempty $ do , guardOn showPasses $ sortable Nothing (i18nCell MsgAchievedPasses) $ \(view $ resultUser . _entityKey -> uid) ->
SheetGradeSummary{achievedPasses} <- examBonusAchieved uid bonus let SheetGradeSummary{achievedPasses} = examBonusAchieved uid bonus
SheetGradeSummary{numSheetsPasses} <- examBonusPossible uid bonus SheetGradeSummary{numSheetsPasses} = examBonusPossible uid bonus
return $ propCell (getSum achievedPasses) (getSum numSheetsPasses) in propCell (getSum achievedPasses) (getSum numSheetsPasses)
, guardOn showPoints $ sortable Nothing (i18nCell MsgAchievedPoints) $ \(view $ resultUser . _entityKey -> uid) -> fromMaybe mempty $ do , guardOn showPoints $ sortable Nothing (i18nCell MsgAchievedPoints) $ \(view $ resultUser . _entityKey -> uid) ->
SheetGradeSummary{achievedPoints} <- examBonusAchieved uid bonus let SheetGradeSummary{achievedPoints} = examBonusAchieved uid bonus
SheetGradeSummary{sumSheetsPoints} <- examBonusPossible uid bonus SheetGradeSummary{sumSheetsPoints} = examBonusPossible uid bonus
return $ propCell (getSum achievedPoints) (getSum sumSheetsPoints) in propCell (getSum achievedPoints) (getSum sumSheetsPoints)
, guardOn examShowGrades $ sortable (Just "result") (i18nCell MsgExamResult) $ maybe mempty i18nCell . preview (resultExamResult . _entityVal . _examResultResult) , guardOn doBonus $ sortable (Just "bonus") (i18nCell MsgExamBonusAchieved) . automaticCell $ resultExamBonus . _entityVal . _examBonusBonus . to Right <> resultAutomaticExamBonus' . to Left
, guardOn (not examShowGrades) $ sortable (Just "result-bool") (i18nCell MsgExamResult) $ maybe mempty i18nCell . preview (resultExamResult . _entityVal . _examResultResult . to (over _examResult $ view passingGrade)) , pure $ mconcat
[ sortable (Just $ fromText [st|part-#{toPathPiece examPartNumber}|]) (i18nCell $ MsgExamPartNumbered examPartNumber) $ maybe mempty i18nCell . preview (resultExamPartResult epId . _Just . _entityVal . _examPartResultResult)
| Entity epId ExamPart{..} <- sortOn (examPartNumber . entityVal) examParts
]
, pure $ sortable (Just $ bool "result-bool" "result" examShowGrades) (i18nCell MsgExamResult) . automaticCell $ (resultExamResult . _entityVal . _examResultResult . to Right <> resultAutomaticExamResult' . to Left) . to (bimap resultView resultView)
, pure . sortable (Just "note") (i18nCell MsgCourseUserNote) $ \((,) <$> view (resultUser . _entityKey) <*> has resultCourseNote -> (uid, hasNote)) , pure . sortable (Just "note") (i18nCell MsgCourseUserNote) $ \((,) <$> view (resultUser . _entityKey) <*> has resultCourseNote -> (uid, hasNote))
-> bool mempty (anchorCellM (CourseR tid ssh csh . CUserR <$> encrypt uid) $ hasComment True) hasNote -> bool mempty (anchorCellM (CourseR tid ssh csh . CUserR <$> encrypt uid) $ hasComment True) hasNote
] ]
dbtSorting = Map.fromList dbtSorting = mconcat
[ sortUserNameLink queryUser [ uncurry singletonMap $ sortUserNameLink queryUser
, sortUserMatriclenr queryUser , uncurry singletonMap $ sortUserMatriclenr queryUser
, sortField queryStudyField , uncurry singletonMap $ sortField queryStudyField
, sortDegreeShort queryStudyDegree , uncurry singletonMap $ sortDegreeShort queryStudyDegree
, sortFeaturesSemester queryStudyFeatures , uncurry singletonMap $ sortFeaturesSemester queryStudyFeatures
, ("occurrence", SortColumn $ queryExamOccurrence >>> (E.?. ExamOccurrenceName)) , mconcat
, ("result", SortColumn $ queryExamResult >>> (E.?. ExamResultResult)) [ singletonMap (fromText [st|part-#{toPathPiece examPartNumber}|]) . SortColumn . queryExamPart epId $ \_ examPartResult -> return $ examPartResult E.?. ExamPartResultResult
, ("result-bool", SortColumn $ queryExamResult >>> (E.?. ExamResultResult) >>> E.orderByList [Just ExamVoided, Just ExamNoShow, Just $ ExamAttended Grade50]) | Entity epId ExamPart{..} <- examParts
, ("note", SortColumn $ queryCourseNote >>> \note -> -- sort by last edit date ]
, singletonMap "occurrence" . SortColumn $ queryExamOccurrence >>> (E.?. ExamOccurrenceName)
, singletonMap "bonus" . SortColumn $ queryExamBonus >>> (E.?. ExamBonusBonus)
, singletonMap "result" . SortColumn $ queryExamResult >>> (E.?. ExamResultResult)
, singletonMap "result-bool" . SortColumn $ queryExamResult >>> (E.?. ExamResultResult) >>> E.orderByList [Just ExamVoided, Just ExamNoShow, Just $ ExamAttended Grade50]
, singletonMap "note" . SortColumn $ queryCourseNote >>> \note -> -- sort by last edit date
E.sub_select . E.from $ \edit -> do E.sub_select . E.from $ \edit -> do
E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote) E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote)
return . E.max_ $ edit E.^. CourseUserNoteEditTime return . E.max_ $ edit E.^. CourseUserNoteEditTime
)
] ]
dbtFilter = Map.fromList dbtFilter = Map.fromList
[ fltrUserNameEmail queryUser [ fltrUserNameEmail queryUser
@ -339,40 +573,55 @@ postEUsersR tid ssh csh examn = do
, dbParamsFormAdditional = \csrf -> do , dbParamsFormAdditional = \csrf -> do
let let
actionMap :: Map ExamUserAction (AForm Handler ExamUserActionData) actionMap :: Map ExamUserAction (AForm Handler ExamUserActionData)
actionMap = Map.fromList actionMap = mconcat
[ ( ExamUserDeregister [ singletonMap ExamUserDeregister $
, pure ExamUserDeregisterData pure ExamUserDeregisterData
) , singletonMap ExamUserAssignOccurrence $
, ( ExamUserAssignOccurrence ExamUserAssignOccurrenceData
, ExamUserAssignOccurrenceData
<$> aopt (examOccurrenceField eid) (fslI MsgExamOccurrence) (Just Nothing) <$> aopt (examOccurrenceField eid) (fslI MsgExamOccurrence) (Just Nothing)
) , bool mempty computeActionMap $ is _Just examGradingRule
]
computeActionMap = mconcat
[ singletonMap ExamUserAcceptComputedResult $
pure ExamUserAcceptComputedResultData
, singletonMap ExamUserResetToComputedResult $
ExamUserResetToComputedResultData
<$> bool (pure True) (apopt checkBoxField (fslI MsgExamUserResetBonus) (Just True)) (is _Just examBonusRule)
] ]
(res, formWgt) <- multiActionM actionMap (fslI MsgAction) Nothing csrf (res, formWgt) <- multiActionM actionMap (fslI MsgAction) Nothing csrf
let formRes = (, mempty) . First . Just <$> res let formRes = (, mempty) . First . Just <$> res
return (formRes, formWgt) return (formRes, formWgt)
, dbParamsFormEvaluate = liftHandlerT . runFormPost , dbParamsFormEvaluate = liftHandler . runFormPost
, dbParamsFormResult = id , dbParamsFormResult = _2
, dbParamsFormIdent = def , dbParamsFormIdent = def
} }
dbtIdent :: Text dbtIdent :: Text
dbtIdent = "exam-users" dbtIdent = "exam-users"
dbtCsvEncode :: DBTCsvEncode ExamUserTableData ExamUserTableCsv dbtCsvEncode = Just DBTCsvEncode
dbtCsvEncode = DictJust . C.map $ ExamUserTableCsv { dbtCsvExportForm = pure ()
<$> view (resultUser . _entityVal . _userSurname . to Just) , dbtCsvDoEncode = \() -> C.map (doEncode' . view _2)
<*> view (resultUser . _entityVal . _userFirstName . to Just) , dbtCsvName = unpack csvName
<*> view (resultUser . _entityVal . _userDisplayName . to Just) , dbtCsvNoExportData = Just id
<*> view (resultUser . _entityVal . _userMatrikelnummer) , dbtCsvHeader = const . return . examUserTableCsvHeader allBoni doBonus $ examParts ^.. folded . _entityVal . _examPartNumber
<*> preview (resultStudyField . _entityVal . to (\StudyTerms{..} -> studyTermsName <|> studyTermsShorthand <|> Just (tshow studyTermsKey)) . _Just) }
<*> preview (resultStudyDegree . _entityVal . to (\StudyDegree{..} -> studyDegreeName <|> studyDegreeShorthand <|> Just (tshow studyDegreeKey)) . _Just) where
<*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester) doEncode' = ExamUserTableCsv
<*> preview (resultExamOccurrence . _entityVal . _examOccurrenceName) <$> view (resultUser . _entityVal . _userSurname . to Just)
<*> preview (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPoints . _Wrapped) <*> view (resultUser . _entityVal . _userFirstName . to Just)
<*> preview (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPasses . _Wrapped . integral) <*> view (resultUser . _entityVal . _userDisplayName . to Just)
<*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _sumSheetsPoints . _Wrapped) <*> view (resultUser . _entityVal . _userMatrikelnummer)
<*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _numSheetsPasses . _Wrapped . integral) <*> preview (resultStudyField . _entityVal . to (\StudyTerms{..} -> studyTermsName <|> studyTermsShorthand <|> Just (tshow studyTermsKey)) . _Just)
<*> preview (resultExamResult . _entityVal . _examResultResult . to resultView) <*> preview (resultStudyDegree . _entityVal . to (\StudyDegree{..} -> studyDegreeName <|> studyDegreeShorthand <|> Just (tshow studyDegreeKey)) . _Just)
<*> preview (resultCourseNote . _entityVal . _courseUserNoteNote) <*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester)
<*> preview (resultExamOccurrence . _entityVal . _examOccurrenceName)
<*> previews (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _achievedPoints . _Wrapped) (bool (const Nothing) Just showPoints)
<*> previews (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _achievedPasses . _Wrapped . integral) (bool (const Nothing) Just showPasses)
<*> previews (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _sumSheetsPoints . _Wrapped) (bool (const Nothing) Just showPoints)
<*> previews (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _numSheetsPasses . _Wrapped . integral) (bool (const Nothing) Just showPasses)
<*> previews (resultExamBonus . _entityVal . _examBonusBonus <> resultAutomaticExamBonus') (bool (const Nothing) Just doBonus)
<*> (Map.fromList . map (over _1 examPartNumber . over (_2 . _Just) (examPartResultResult . entityVal)) <$> asks (toListOf resultExamParts))
<*> previews (resultExamResult . _entityVal . _examResultResult <> resultAutomaticExamResult') resultView
<*> preview (resultCourseNote . _entityVal . _courseUserNoteNote)
dbtCsvDecode = Just DBTCsvDecode dbtCsvDecode = Just DBTCsvDecode
{ dbtCsvRowKey = \csv -> do { dbtCsvRowKey = \csv -> do
uid <- lift $ view _2 <$> guessUser csv uid <- lift $ view _2 <$> guessUser csv
@ -381,20 +630,28 @@ postEUsersR tid ssh csh examn = do
DBCsvDiffMissing{dbCsvOldKey} DBCsvDiffMissing{dbCsvOldKey}
-> yield . ExamUserCsvDeregisterData $ E.unValue dbCsvOldKey -> yield . ExamUserCsvDeregisterData $ E.unValue dbCsvOldKey
DBCsvDiffNew{dbCsvNewKey = Just _} DBCsvDiffNew{dbCsvNewKey = Just _}
-> fail "An UniqueExamRegistration could be found, but the ExamRegistrationKey is not among the existing keys" -> error "An UniqueExamRegistration could be found, but the ExamRegistrationKey is not among the existing keys"
DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do
(isPart, uid) <- lift $ guessUser dbCsvNew (isPart, uid) <- lift $ guessUser dbCsvNew
if if
| isPart -> do | isPart -> do
yieldM $ ExamUserCsvRegisterData <$> pure uid <*> lookupOccurrence dbCsvNew yieldM $ ExamUserCsvRegisterData <$> pure uid <*> lookupOccurrence dbCsvNew
newFeatures <- lift $ lookupStudyFeatures dbCsvNew newFeatures <- lift $ lookupStudyFeatures dbCsvNew
Just (Entity cpId CourseParticipant{ courseParticipantField = oldFeatures }) <- lift . getBy $ UniqueParticipant uid examCourse Entity cpId CourseParticipant{ courseParticipantField = oldFeatures } <- lift . getJustBy $ UniqueParticipant uid examCourse
when (newFeatures /= oldFeatures) $ when (newFeatures /= oldFeatures) $
yield $ ExamUserCsvSetCourseFieldData cpId newFeatures yield $ ExamUserCsvSetCourseFieldData cpId newFeatures
| otherwise -> | otherwise ->
yieldM $ ExamUserCsvCourseRegisterData uid <$> lookupStudyFeatures dbCsvNew <*> lookupOccurrence dbCsvNew yieldM $ ExamUserCsvCourseRegisterData uid <$> lookupStudyFeatures dbCsvNew <*> lookupOccurrence dbCsvNew
iforMOf_ (ifolded <. _Just) (csvEUserExamPartResults dbCsvNew) $ \epNumber epRes ->
when (epNumber `elem` examPartNumbers) $
yield $ ExamUserCsvSetPartResultData uid epNumber (Just epRes)
when (doBonus && is _Just (join $ csvEUserBonus dbCsvNew)) $
yield . ExamUserCsvSetBonusData False uid . join $ csvEUserBonus dbCsvNew
when (is _Just $ csvEUserExamResult dbCsvNew) $ when (is _Just $ csvEUserExamResult dbCsvNew) $
yield . ExamUserCsvSetResultData uid $ csvEUserExamResult dbCsvNew yield . ExamUserCsvSetResultData False uid $ csvEUserExamResult dbCsvNew
note <- lift . getBy $ UniqueCourseUserNote uid examCourse note <- lift . getBy $ UniqueCourseUserNote uid examCourse
when (csvEUserCourseNote dbCsvNew /= note ^? _Just . _entityVal . _courseUserNoteNote) $ when (csvEUserCourseNote dbCsvNew /= note ^? _Just . _entityVal . _courseUserNoteNote) $
@ -406,11 +663,56 @@ postEUsersR tid ssh csh examn = do
newFeatures <- lift $ lookupStudyFeatures dbCsvNew newFeatures <- lift $ lookupStudyFeatures dbCsvNew
when (newFeatures /= dbCsvOld ^? resultStudyFeatures . _entityKey) $ do when (newFeatures /= dbCsvOld ^? resultStudyFeatures . _entityKey) $ do
Just (Entity cpId _) <- lift . getBy . flip UniqueParticipant examCourse $ dbCsvOld ^. resultUser . _entityKey Entity cpId _ <- lift . getJustBy . flip UniqueParticipant examCourse $ dbCsvOld ^. resultUser . _entityKey
yield $ ExamUserCsvSetCourseFieldData cpId newFeatures yield $ ExamUserCsvSetCourseFieldData cpId newFeatures
when (csvEUserExamResult dbCsvNew /= dbCsvOld ^? resultExamResult . _entityVal . _examResultResult . to resultView) $ let uid = dbCsvOld ^. resultUser . _entityKey
yield . ExamUserCsvSetResultData (dbCsvOld ^. resultUser . _entityKey) $ csvEUserExamResult dbCsvNew
forM_ examPartNumbers $ \epNumber ->
let oldPartResult = dbCsvOld ^? resultExamParts . filtered (views (_1 . _examPartNumber) (== epNumber)) . _2 . _Just . _entityVal . _examPartResultResult
in whenIsJust (csvEUserExamPartResults dbCsvNew !? epNumber) $ \epRes ->
when (epRes /= oldPartResult) $
yield $ ExamUserCsvSetPartResultData uid epNumber epRes
let newResults :: Maybe (Map ExamPartNumber ExamResultPoints)
newResults = sequence (csvEUserExamPartResults dbCsvNew)
<|> sequence (toMapOf (resultExamParts .> ito (over _1 $ examPartNumber) <. to (fmap $ examPartResultResult . entityVal)) dbCsvOld)
newBonus, oldBonus :: Maybe Points
newBonus = join (csvEUserBonus dbCsvNew)
oldBonus = dbCsvOld ^? (resultExamBonus . _entityVal . _examBonusBonus <> resultAutomaticExamBonus')
newResult, oldResult :: Maybe ExamResultPassedGrade
newResult = fmap resultView <$> examGrade examVal (newBonus <|> oldBonus) =<< newResults
oldResult = dbCsvOld ^? (resultExamResult . _entityVal . _examResultResult <> resultAutomaticExamResult') . to resultView
when doBonus $
case newBonus of
_ | newBonus == oldBonus
-> return ()
_ | is _Nothing newBonus
-> return ()
_ | Just ExamBonusManual{} <- examBonusRule
-> yield $ ExamUserCsvSetBonusData False uid newBonus
Nothing
-> yield $ ExamUserCsvSetBonusData False uid newBonus
Just _
-> yield $ ExamUserCsvSetBonusData True uid newBonus
case newResult of
_ | csvEUserExamResult dbCsvNew == oldResult
-> return ()
_ | is _Nothing $ csvEUserExamResult dbCsvNew
-> return ()
Nothing
-> yield . ExamUserCsvSetResultData False uid $ csvEUserExamResult dbCsvNew
Just _
| csvEUserExamResult dbCsvNew /= newResult
-> yield . ExamUserCsvSetResultData True uid $ csvEUserExamResult dbCsvNew
| oldResult /= newResult
-> yield . ExamUserCsvSetResultData False uid $ csvEUserExamResult dbCsvNew
| otherwise
-> return ()
when (csvEUserCourseNote dbCsvNew /= dbCsvOld ^? resultCourseNote . _entityVal . _courseUserNoteNote) $ when (csvEUserCourseNote dbCsvNew /= dbCsvOld ^? resultCourseNote . _entityVal . _courseUserNoteNote) $
yield . ExamUserCsvSetCourseNoteData (dbCsvOld ^. resultUser . _entityKey) $ csvEUserCourseNote dbCsvNew yield . ExamUserCsvSetCourseNoteData (dbCsvOld ^. resultUser . _entityKey) $ csvEUserCourseNote dbCsvNew
@ -420,7 +722,13 @@ postEUsersR tid ssh csh examn = do
ExamUserCsvDeregisterData{} -> ExamUserCsvDeregister ExamUserCsvDeregisterData{} -> ExamUserCsvDeregister
ExamUserCsvAssignOccurrenceData{} -> ExamUserCsvAssignOccurrence ExamUserCsvAssignOccurrenceData{} -> ExamUserCsvAssignOccurrence
ExamUserCsvSetCourseFieldData{} -> ExamUserCsvSetCourseField ExamUserCsvSetCourseFieldData{} -> ExamUserCsvSetCourseField
ExamUserCsvSetResultData{} -> ExamUserCsvSetResult ExamUserCsvSetPartResultData{} -> ExamUserCsvSetPartResult
ExamUserCsvSetBonusData{..}
| examUserCsvIsBonusOverride -> ExamUserCsvOverrideBonus
| otherwise -> ExamUserCsvSetBonus
ExamUserCsvSetResultData{..}
| examUserCsvIsResultOverride -> ExamUserCsvOverrideResult
| otherwise -> ExamUserCsvSetResult
ExamUserCsvSetCourseNoteData{} -> ExamUserCsvSetCourseNote ExamUserCsvSetCourseNoteData{} -> ExamUserCsvSetCourseNote
, dbtCsvCoarsenActionClass = \case , dbtCsvCoarsenActionClass = \case
ExamUserCsvCourseRegister -> DBCsvActionNew ExamUserCsvCourseRegister -> DBCsvActionNew
@ -436,8 +744,9 @@ postEUsersR tid ssh csh examn = do
, courseParticipantUser = examUserCsvActUser , courseParticipantUser = examUserCsvActUser
, courseParticipantRegistration = now , courseParticipantRegistration = now
, courseParticipantField = examUserCsvActCourseField , courseParticipantField = examUserCsvActCourseField
, courseParticipantAllocated = False , courseParticipantAllocated = Nothing
} }
queueDBJob . JobQueueNotification $ NotificationCourseRegistered examUserCsvActUser examCourse
audit $ TransactionCourseParticipantEdit examCourse examUserCsvActUser audit $ TransactionCourseParticipantEdit examCourse examUserCsvActUser
insert_ ExamRegistration insert_ ExamRegistration
{ examRegistrationExam = eid { examRegistrationExam = eid
@ -461,6 +770,34 @@ postEUsersR tid ssh csh examn = do
update examUserCsvActCourseParticipant [ CourseParticipantField =. examUserCsvActCourseField ] update examUserCsvActCourseParticipant [ CourseParticipantField =. examUserCsvActCourseField ]
CourseParticipant{..} <- getJust examUserCsvActCourseParticipant CourseParticipant{..} <- getJust examUserCsvActCourseParticipant
audit $ TransactionCourseParticipantEdit examCourse courseParticipantUser audit $ TransactionCourseParticipantEdit examCourse courseParticipantUser
ExamUserCsvSetPartResultData{..} -> do
epid <- getKeyJustBy $ UniqueExamPartNumber eid examUserCsvActExamPart
case examUserCsvActExamPartResult of
Nothing -> do
deleteBy $ UniqueExamPartResult epid examUserCsvActUser
audit $ TransactionExamPartResultDeleted epid examUserCsvActUser
Just res -> do
now <- liftIO getCurrentTime
void $ upsertBy
(UniqueExamPartResult epid examUserCsvActUser)
(ExamPartResult epid examUserCsvActUser res now)
[ ExamPartResultResult =. res
, ExamPartResultLastChanged =. now
]
audit $ TransactionExamPartResultEdit epid examUserCsvActUser
ExamUserCsvSetBonusData{..} -> case examUserCsvActExamBonus of
Nothing -> do
deleteBy $ UniqueExamBonus eid examUserCsvActUser
audit $ TransactionExamBonusDeleted eid examUserCsvActUser
Just res -> do
now <- liftIO getCurrentTime
void $ upsertBy
(UniqueExamBonus eid examUserCsvActUser)
(ExamBonus eid examUserCsvActUser res now)
[ ExamBonusBonus =. res
, ExamBonusLastChanged =. now
]
audit $ TransactionExamBonusEdit eid examUserCsvActUser
ExamUserCsvSetResultData{..} -> case examUserCsvActExamResult of ExamUserCsvSetResultData{..} -> case examUserCsvActExamResult of
Nothing -> do Nothing -> do
deleteBy $ UniqueExamResult eid examUserCsvActUser deleteBy $ UniqueExamResult eid examUserCsvActUser
@ -490,13 +827,13 @@ postEUsersR tid ssh csh examn = do
delete nid delete nid
ExamUserCsvSetCourseNoteData{ examUserCsvActCourseNote = Just note, .. } -> do ExamUserCsvSetCourseNoteData{ examUserCsvActCourseNote = Just note, .. } -> do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
uid <- liftHandlerT requireAuthId uid <- liftHandler requireAuthId
Entity nid _ <- upsert (CourseUserNote examCourse examUserCsvActUser note) [ CourseUserNoteNote =. note ] Entity nid _ <- upsert (CourseUserNote examCourse examUserCsvActUser note) [ CourseUserNoteNote =. note ]
insert_ $ CourseUserNoteEdit uid now nid insert_ $ CourseUserNoteEdit uid now nid
return $ CExamR tid ssh csh examn EUsersR return $ CExamR tid ssh csh examn EUsersR
, dbtCsvRenderKey = \(registeredUserName -> registeredUserName') -> \case , dbtCsvRenderKey = \(registeredUserName -> registeredUserName') -> \case
ExamUserCsvCourseRegisterData{..} -> do ExamUserCsvCourseRegisterData{..} -> do
(User{..}, occ) <- liftHandlerT . runDB $ (,) <$> getJust examUserCsvActUser <*> for examUserCsvActOccurrence getJust (User{..}, occ) <- liftHandler . runDB $ (,) <$> getJust examUserCsvActUser <*> for examUserCsvActOccurrence getJust
[whamlet| [whamlet|
$newline never $newline never
^{nameWidget userDisplayName userSurname} ^{nameWidget userDisplayName userSurname}
@ -510,7 +847,7 @@ postEUsersR tid ssh csh examn = do
\ (_{MsgExamNoOccurrence}) \ (_{MsgExamNoOccurrence})
|] |]
ExamUserCsvRegisterData{..} -> do ExamUserCsvRegisterData{..} -> do
(User{..}, occ) <- liftHandlerT . runDB $ (,) <$> getJust examUserCsvActUser <*> for examUserCsvActOccurrence getJust (User{..}, occ) <- liftHandler . runDB $ (,) <$> getJust examUserCsvActUser <*> for examUserCsvActOccurrence getJust
[whamlet| [whamlet|
$newline never $newline never
^{nameWidget userDisplayName userSurname} ^{nameWidget userDisplayName userSurname}
@ -520,7 +857,7 @@ postEUsersR tid ssh csh examn = do
\ (_{MsgExamNoOccurrence}) \ (_{MsgExamNoOccurrence})
|] |]
ExamUserCsvAssignOccurrenceData{..} -> do ExamUserCsvAssignOccurrenceData{..} -> do
occ <- for examUserCsvActOccurrence $ liftHandlerT . runDB . getJust occ <- for examUserCsvActOccurrence $ liftHandler . runDB . getJust
[whamlet| [whamlet|
$newline never $newline never
^{registeredUserName' examUserCsvActRegistration} ^{registeredUserName' examUserCsvActRegistration}
@ -530,7 +867,7 @@ postEUsersR tid ssh csh examn = do
\ (_{MsgExamNoOccurrence}) \ (_{MsgExamNoOccurrence})
|] |]
ExamUserCsvSetCourseFieldData{..} -> do ExamUserCsvSetCourseFieldData{..} -> do
User{..} <- liftHandlerT . runDB $ getJust . courseParticipantUser =<< getJust examUserCsvActCourseParticipant User{..} <- liftHandler . runDB $ getJust . courseParticipantUser =<< getJust examUserCsvActCourseParticipant
[whamlet| [whamlet|
$newline never $newline never
^{nameWidget userDisplayName userSurname} ^{nameWidget userDisplayName userSurname}
@ -539,8 +876,34 @@ postEUsersR tid ssh csh examn = do
$nothing $nothing
, _{MsgCourseStudyFeatureNone} , _{MsgCourseStudyFeatureNone}
|] |]
ExamUserCsvSetPartResultData{..} -> do
(User{..}, Entity _ ExamPart{..}) <- liftHandler . runDB $
(,) <$> getJust examUserCsvActUser
<*> getJustBy (UniqueExamPartNumber eid examUserCsvActExamPart)
[whamlet|
$newline never
^{nameWidget userDisplayName userSurname}
$maybe pName <- examPartName
, „#{pName}“
$nothing
, _{MsgExamPartNumbered examPartNumber}
$maybe newResult <- examUserCsvActExamPartResult
, _{newResult}
$nothing
, _{MsgExamResultNone}
|]
ExamUserCsvSetBonusData{..} -> do
User{..} <- liftHandler . runDB $ getJust examUserCsvActUser
[whamlet|
$newline never
^{nameWidget userDisplayName userSurname}
$maybe newBonus <- examUserCsvActExamBonus
, _{newBonus}
$nothing
, _{MsgExamBonusNone}
|]
ExamUserCsvSetResultData{..} -> do ExamUserCsvSetResultData{..} -> do
User{..} <- liftHandlerT . runDB $ getJust examUserCsvActUser User{..} <- liftHandler . runDB $ getJust examUserCsvActUser
[whamlet| [whamlet|
$newline never $newline never
^{nameWidget userDisplayName userSurname} ^{nameWidget userDisplayName userSurname}
@ -550,7 +913,7 @@ postEUsersR tid ssh csh examn = do
, _{MsgExamResultNone} , _{MsgExamResultNone}
|] |]
ExamUserCsvSetCourseNoteData{..} -> do ExamUserCsvSetCourseNoteData{..} -> do
User{..} <- liftHandlerT . runDB $ getJust examUserCsvActUser User{..} <- liftHandler . runDB $ getJust examUserCsvActUser
[whamlet| [whamlet|
$newline never $newline never
^{nameWidget userDisplayName userSurname} ^{nameWidget userDisplayName userSurname}
@ -571,22 +934,31 @@ postEUsersR tid ssh csh examn = do
guessUser :: ExamUserTableCsv -> DB (Bool, UserId) guessUser :: ExamUserTableCsv -> DB (Bool, UserId)
guessUser ExamUserTableCsv{..} = $cachedHereBinary (csvEUserMatriculation, csvEUserName, csvEUserSurname) $ do guessUser ExamUserTableCsv{..} = $cachedHereBinary (csvEUserMatriculation, csvEUserName, csvEUserSurname) $ do
users <- E.select . E.from $ \user -> do users <- E.select . E.from $ \user -> do
E.where_ . E.and $ catMaybes E.where_ . E.or $ catMaybes
[ (user E.^. UserMatrikelnummer E.==.) . E.val . Just <$> csvEUserMatriculation [ (user E.^. UserMatrikelnummer E.==.) . E.val . Just <$> csvEUserMatriculation
, (user E.^. UserDisplayName E.==.) . E.val <$> csvEUserName , (user E.^. UserDisplayName `E.hasInfix`) . E.val <$> csvEUserName
, (user E.^. UserSurname E.==.) . E.val <$> csvEUserSurname , (user E.^. UserSurname `E.hasInfix`) . E.val <$> csvEUserSurname
, (user E.^. UserFirstName E.==.) . E.val <$> csvEUserFirstName , (user E.^. UserFirstName `E.hasInfix`) . E.val <$> csvEUserFirstName
] ]
let isCourseParticipant = E.exists . E.from $ \courseParticipant -> let isCourseParticipant = E.exists . E.from $ \courseParticipant ->
E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. E.val examCourse E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. E.val examCourse
E.&&. courseParticipant E.^. CourseParticipantUser E.==. user E.^. UserId E.&&. courseParticipant E.^. CourseParticipantUser E.==. user E.^. UserId
E.limit 2 return (isCourseParticipant, user)
return (isCourseParticipant, user E.^. UserId) let users' = reverse $ sortBy closeness users
case users of closeness :: (E.Value Bool, Entity User) -> (E.Value Bool, Entity User) -> Ordering
(filter . view $ _1 . _Value -> [(E.Value isPart, E.Value uid)]) closeness = mconcat $ catMaybes
-> return (isPart, uid) [ pure $ comparing (preview $ _2 . _entityVal . _userMatrikelnummer . only csvEUserMatriculation)
[(E.Value isPart, E.Value uid)] , pure $ comparing (view _1)
-> return (isPart, uid) , csvEUserSurname <&> \surn -> comparing (preview $ _2 . _entityVal . _userSurname . to CI.mk . only (CI.mk surn))
, csvEUserFirstName <&> \firstn -> comparing (preview $ _2 . _entityVal . _userFirstName . to CI.mk . only (CI.mk firstn))
, csvEUserName <&> \dispn -> comparing (preview $ _2 . _entityVal . _userDisplayName . to CI.mk . only (CI.mk dispn))
]
case users' of
[(E.Value isPart, Entity uid _)]
-> return (isPart, uid)
(x@(E.Value isPart, Entity uid _) : x' : _)
| GT <- x `closeness` x'
-> return (isPart, uid)
_other _other
-> throwM ExamUserCsvExceptionNoMatchingUser -> throwM ExamUserCsvExceptionNoMatchingUser
@ -650,21 +1022,21 @@ postEUsersR tid ssh csh examn = do
examUsersDBTableValidator = def & defaultSorting [SortAscBy "user-name"] examUsersDBTableValidator = def & defaultSorting [SortAscBy "user-name"]
& defaultPagesize PagesizeAll & defaultPagesize PagesizeAll
postprocess :: FormResult (First ExamUserActionData, DBFormResult ExamRegistrationId Bool ExamUserTableData) -> FormResult (ExamUserActionData, Set ExamRegistrationId) postprocess :: FormResult (First ExamUserActionData, DBFormResult ExamRegistrationId (Bool, ExamUserTableData) ExamUserTableData) -> FormResult (ExamUserActionData, Map ExamRegistrationId ExamUserTableData)
postprocess inp = do postprocess inp = do
(First (Just act), regMap) <- inp (First (Just act), regMap) <- inp
let regSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) regMap let regMap' = Map.mapMaybe (uncurry guardOn) $ getDBFormResult (False,) regMap
return (act, regSet) return (act, regMap')
over _1 postprocess <$> dbTable examUsersDBTableValidator examUsersDBTable (, exam, bonus) . over (_1 . _2) postprocess <$> dbTable examUsersDBTableValidator examUsersDBTable
formResult registrationResult $ \case formResult registrationResult $ \case
(ExamUserDeregisterData, selectedRegistrations) -> do (ExamUserDeregisterData, Map.keysSet -> selectedRegistrations) -> do
nrDel <- runDB $ deleteWhereCount nrDel <- runDB $ deleteWhereCount
[ ExamRegistrationId <-. Set.toList selectedRegistrations [ ExamRegistrationId <-. Set.toList selectedRegistrations
] ]
addMessageI Success $ MsgExamUsersDeregistered nrDel addMessageI Success $ MsgExamUsersDeregistered nrDel
redirect $ CExamR tid ssh csh examn EUsersR redirect $ CExamR tid ssh csh examn EUsersR
(ExamUserAssignOccurrenceData occId, selectedRegistrations) -> do (ExamUserAssignOccurrenceData occId, Map.keysSet -> selectedRegistrations) -> do
nrUpdated <- runDB $ updateWhereCount nrUpdated <- runDB $ updateWhereCount
[ ExamRegistrationId <-. Set.toList selectedRegistrations [ ExamRegistrationId <-. Set.toList selectedRegistrations
] ]
@ -672,7 +1044,67 @@ postEUsersR tid ssh csh examn = do
] ]
addMessageI Success $ MsgExamUsersOccurrenceUpdated nrUpdated addMessageI Success $ MsgExamUsersOccurrenceUpdated nrUpdated
redirect $ CExamR tid ssh csh examn EUsersR redirect $ CExamR tid ssh csh examn EUsersR
(ExamUserAcceptComputedResultData, Map.elems -> rows) -> do
nrAccepted <- fmap (getSum . fold) . runDB . forM rows . runReaderT $ do
now <- liftIO getCurrentTime
uid <- view $ resultUser . _entityKey
hasResult <- asks $ has resultExamResult
hasBonus <- asks $ has resultExamBonus
autoResult <- preview $ resultAutomaticExamResult examVal bonus
autoBonus <- preview $ resultAutomaticExamBonus examVal bonus
lift $ if
| not hasResult
, Just examResultResult <- autoResult
-> do
if
| Just examBonusBonus <- autoBonus
, not hasBonus
-> do
insert_ ExamBonus
{ examBonusExam = eId
, examBonusUser = uid
, examBonusLastChanged = now
, ..
}
audit $ TransactionExamBonusEdit eId uid
| otherwise
-> return ()
insert_ ExamResult
{ examResultExam = eId
, examResultUser = uid
, examResultLastChanged = now
, ..
}
audit $ TransactionExamResultEdit eId uid
return $ Sum 1
| otherwise
-> return mempty
addMessageI Success $ MsgExamUsersResultsAccepted nrAccepted
redirect $ CExamR tid ssh csh examn EUsersR
(ExamUserResetToComputedResultData{..}, Map.elems -> rows) -> do
nrReset <- fmap (getSum . fold) . runDB . forM rows . runReaderT $ do
uid <- view $ resultUser . _entityKey
lift $ do
when examUserResetBonus $ do
bonusId' <- getKeyBy $ UniqueExamBonus eId uid
whenIsJust bonusId' $ \bonusId -> do
delete bonusId
audit $ TransactionExamBonusDeleted eId uid
result <- getKeyBy $ UniqueExamResult eId uid
case result of
Just resId -> do
delete resId
audit $ TransactionExamResultDeleted eId uid
return $ Sum 1
Nothing -> return mempty
addMessageI Success $ MsgExamUsersResultsReset nrReset
redirect $ CExamR tid ssh csh examn EUsersR
closeWgt <- examCloseWidget (SomeRoute $ CExamR tid ssh csh examn EUsersR) eId
siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamUsersHeading) $ do siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamUsersHeading) $ do
setTitleI $ prependCourseTitle tid ssh csh MsgExamUsersHeading setTitleI $ prependCourseTitle tid ssh csh MsgExamUsersHeading
let computedValuesTip = $(i18nWidgetFile "exam-users/computed-values-tip")
$(widgetFile "exam-users") $(widgetFile "exam-users")

8
src/Handler/ExamOffice.hs Normal file
View File

@ -0,0 +1,8 @@
module Handler.ExamOffice
( module Handler.ExamOffice
) where
import Handler.ExamOffice.Exams as Handler.ExamOffice
import Handler.ExamOffice.Fields as Handler.ExamOffice
import Handler.ExamOffice.Users as Handler.ExamOffice
import Handler.ExamOffice.Exam as Handler.ExamOffice

75
src/Handler/ExamOffice/Course.hs Normal file
View File

@ -0,0 +1,75 @@
module Handler.ExamOffice.Course
( getCExamOfficeR, postCExamOfficeR
) where
import Import
import qualified Data.Set as Set
import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E
import Handler.Utils.ExamOffice.Course
import Handler.Utils
examOfficeOptOutForm :: UserId -> CourseId -> Maybe (Set SchoolId) -> Form (Set SchoolId)
-- ^ Deals with sets of _opt outs_
examOfficeOptOutForm uid cid (fromMaybe Set.empty -> template) = renderWForm FormStandard $ do
schools <- liftHandler . runDB . E.select $ courseExamOfficeSchools (E.val uid) (E.val cid)
res <- fmap sequence . forM schools $ \(Entity ssh School{..}, E.Value isForced)
-> fmap (ssh, ) <$> bool wpopt wforcedJust isForced checkBoxField (fslI schoolName) (Just $ ssh `Set.notMember` template)
return $ res <&> setOf (folded . filtered (not . view _2) . _1)
getCExamOfficeR, postCExamOfficeR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCExamOfficeR = postCExamOfficeR
postCExamOfficeR tid ssh csh = do
uid <- requireAuthId
isModal <- hasCustomHeader HeaderIsModal
(cid, optOuts, hasForced) <- runDB $ do
cid <- getKeyBy404 (TermSchoolCourseShort tid ssh csh)
optOuts <- selectList [ CourseUserExamOfficeOptOutCourse ==. cid, CourseUserExamOfficeOptOutUser ==. uid ] []
hasForced <- E.selectExists $ do
(_school, isForced) <- courseExamOfficeSchools (E.val uid) (E.val cid)
E.where_ isForced
return (cid, optOuts, hasForced)
((optOutRes, optOutView), optOutEnc)
<- runFormPost $ examOfficeOptOutForm uid cid (Just $ setOf (folded . _entityVal . _courseUserExamOfficeOptOutSchool) optOuts )
formResultModal optOutRes (CourseR tid ssh csh CExamOfficeR) $ \optOuts' -> do
lift . runDB $ do
deleteWhere [ CourseUserExamOfficeOptOutCourse ==. cid
, CourseUserExamOfficeOptOutUser ==. uid
, CourseUserExamOfficeOptOutSchool /<-. Set.toList optOuts'
]
forM_ optOuts' $ \ssh' ->
void $ insertUnique CourseUserExamOfficeOptOut
{ courseUserExamOfficeOptOutCourse = cid
, courseUserExamOfficeOptOutUser = uid
, courseUserExamOfficeOptOutSchool = ssh'
}
tell . pure =<< messageI Success MsgExamOfficeOptOutsChanged
let optOutView' = wrapForm optOutView def
{ formAction = Just . SomeRoute $ CourseR tid ssh csh CExamOfficeR
, formEncoding = optOutEnc
, formAttrs = [ asyncSubmitAttr | isModal ]
}
siteLayoutMsg MsgMenuCourseExamOffice $ do
setTitleI MsgMenuCourseExamOffice
let explanation = $(i18nWidgetFile "course-exam-office-explanation")
[whamlet|
$newline never
<section>
^{explanation}
<section>
^{optOutView'}
|]

443
src/Handler/ExamOffice/Exam.hs Normal file
View File

@ -0,0 +1,443 @@
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
module Handler.ExamOffice.Exam
( getEGradesR, postEGradesR
, examCloseWidget
) where
import Import
import Handler.Utils
import Handler.Utils.Exam
import Handler.Utils.Csv
import qualified Handler.Utils.ExamOffice.Exam as Exam
import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E
import qualified Data.Csv as Csv
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.Conduit.List as C
import qualified Colonnade
data ButtonCloseExam = BtnCloseExam
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
instance Universe ButtonCloseExam
instance Finite ButtonCloseExam
nullaryPathPiece ''ButtonCloseExam $ camelToPathPiece' 1
embedRenderMessage ''UniWorX ''ButtonCloseExam id
instance Button UniWorX ButtonCloseExam where
btnClasses BtnCloseExam = [BCIsButton]
examCloseWidget :: SomeRoute UniWorX -> ExamId -> Handler Widget
examCloseWidget dest eId = do
Exam{..} <- runDB $ get404 eId
((closeRes, closeView), closeEnc) <- runFormPost $ identifyForm BtnCloseExam buttonForm
formResult closeRes $ \case
BtnCloseExam -> do
now <- liftIO getCurrentTime
unless (is _Nothing examClosed) $
invalidArgs ["Exam is already closed"]
runDB $ update eId [ ExamClosed =. Just now ]
addMessageI Success MsgExamDidClose
redirect dest
let closeView' = wrapForm closeView def
{ formSubmit = FormNoSubmit
, formAction = Just dest
, formEncoding = closeEnc
}
examClosed' <- for examClosed $ formatTime SelFormatDateTime
return $(widgetFile "widgets/exam-close")
type ExamUserTableExpr = ( E.SqlExpr (Entity ExamResult)
`E.InnerJoin` E.SqlExpr (Entity User)
)
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamRegistration))
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamOccurrence))
`E.LeftOuterJoin` ( E.SqlExpr (Maybe (Entity CourseParticipant))
`E.LeftOuterJoin` ( E.SqlExpr (Maybe (Entity StudyFeatures))
`E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree))
`E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms))
)
)
type ExamUserTableData = DBRow ( Entity ExamResult
, Entity User
, Maybe (Entity ExamOccurrence)
, Maybe (Entity StudyFeatures)
, Maybe (Entity StudyDegree)
, Maybe (Entity StudyTerms)
, Maybe (Entity ExamRegistration)
, Bool
, [(UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand)]
)
queryExamRegistration :: Getter ExamUserTableExpr (E.SqlExpr (Maybe (Entity ExamRegistration)))
queryExamRegistration = to $(E.sqlLOJproj 4 2)
queryUser :: Getter ExamUserTableExpr (E.SqlExpr (Entity User))
queryUser = to $ $(E.sqlIJproj 2 2) . $(E.sqlLOJproj 4 1)
queryExamOccurrence :: Getter ExamUserTableExpr (E.SqlExpr (Maybe (Entity ExamOccurrence)))
queryExamOccurrence = to $(E.sqlLOJproj 4 3)
queryCourseParticipant :: Getter ExamUserTableExpr (E.SqlExpr (Maybe (Entity CourseParticipant)))
queryCourseParticipant = to $ $(E.sqlLOJproj 2 1) . $(E.sqlLOJproj 4 4)
queryStudyFeatures :: Getter ExamUserTableExpr (E.SqlExpr (Maybe (Entity StudyFeatures)))
queryStudyFeatures = to $ $(E.sqlIJproj 3 1) . $(E.sqlLOJproj 2 2) . $(E.sqlLOJproj 4 4)
queryStudyDegree :: Getter ExamUserTableExpr (E.SqlExpr (Maybe (Entity StudyDegree)))
queryStudyDegree = to $ $(E.sqlIJproj 3 2) . $(E.sqlLOJproj 2 2) . $(E.sqlLOJproj 4 4)
queryStudyField :: Getter ExamUserTableExpr (E.SqlExpr (Maybe (Entity StudyTerms)))
queryStudyField = to $ $(E.sqlIJproj 3 3) . $(E.sqlLOJproj 2 2) . $(E.sqlLOJproj 4 4)
queryExamResult :: Getter ExamUserTableExpr (E.SqlExpr (Entity ExamResult))
queryExamResult = to $ $(E.sqlIJproj 2 1) . $(E.sqlLOJproj 4 1)
-- resultExamRegistration :: Traversal' ExamUserTableData (Entity ExamRegistration)
-- resultExamRegistration = _dbrOutput . _7 . _Just
queryIsSynced :: E.SqlExpr (E.Value UserId) -> Getter ExamUserTableExpr (E.SqlExpr (E.Value Bool))
queryIsSynced authId = to $ Exam.resultIsSynced authId <$> view queryExamResult
resultUser :: Lens' ExamUserTableData (Entity User)
resultUser = _dbrOutput . _2
resultStudyFeatures :: Traversal' ExamUserTableData (Entity StudyFeatures)
resultStudyFeatures = _dbrOutput . _4 . _Just
resultStudyDegree :: Traversal' ExamUserTableData (Entity StudyDegree)
resultStudyDegree = _dbrOutput . _5 . _Just
resultStudyField :: Traversal' ExamUserTableData (Entity StudyTerms)
resultStudyField = _dbrOutput . _6 . _Just
resultExamOccurrence :: Traversal' ExamUserTableData (Entity ExamOccurrence)
resultExamOccurrence = _dbrOutput . _3 . _Just
resultExamResult :: Lens' ExamUserTableData (Entity ExamResult)
resultExamResult = _dbrOutput . _1
resultIsSynced :: Lens' ExamUserTableData Bool
resultIsSynced = _dbrOutput . _8
resultSynchronised :: Traversal' ExamUserTableData (UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand)
resultSynchronised = _dbrOutput . _9 . traverse
data ExamUserTableCsv = ExamUserTableCsv
{ csvEUserSurname :: Text
, csvEUserFirstName :: Text
, csvEUserName :: Text
, csvEUserMatriculation :: Maybe Text
, csvEUserField :: Maybe Text
, csvEUserDegree :: Maybe Text
, csvEUserSemester :: Maybe Int
, csvEUserOccurrenceStart :: Maybe ZonedTime
, csvEUserExamResult :: ExamResultPassedGrade
}
deriving (Generic)
makeLenses_ ''ExamUserTableCsv
examUserTableCsvOptions :: Csv.Options
examUserTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 3 }
instance ToNamedRecord ExamUserTableCsv where
toNamedRecord = Csv.genericToNamedRecord examUserTableCsvOptions
instance DefaultOrdered ExamUserTableCsv where
headerOrder = Csv.genericHeaderOrder examUserTableCsvOptions
instance CsvColumnsExplained ExamUserTableCsv where
csvColumnsExplanations = genericCsvColumnsExplanations examUserTableCsvOptions $ Map.fromList
[ ('csvEUserSurname , MsgCsvColumnExamUserSurname )
, ('csvEUserFirstName , MsgCsvColumnExamUserFirstName )
, ('csvEUserName , MsgCsvColumnExamUserName )
, ('csvEUserMatriculation , MsgCsvColumnExamUserMatriculation )
, ('csvEUserField , MsgCsvColumnExamUserField )
, ('csvEUserDegree , MsgCsvColumnExamUserDegree )
, ('csvEUserSemester , MsgCsvColumnExamUserSemester )
, ('csvEUserOccurrenceStart , MsgCsvColumnExamOfficeExamUserOccurrenceStart )
, ('csvEUserExamResult , MsgCsvColumnExamUserResult )
]
data ExamUserAction = ExamUserMarkSynchronised
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
instance Universe ExamUserAction
instance Finite ExamUserAction
nullaryPathPiece ''ExamUserAction $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''ExamUserAction id
data ExamUserActionData = ExamUserMarkSynchronisedData
newtype ExamUserCsvExportData = ExamUserCsvExportData
{ csvEUserMarkSynchronised :: Bool
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
-- | View a list of all users' grades that the current user has access to
getEGradesR, postEGradesR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
getEGradesR = postEGradesR
postEGradesR tid ssh csh examn = do
uid <- requireAuthId
now <- liftIO getCurrentTime
((usersResult, examUsersTable), Entity eId _) <- runDB $ do
exam@(Entity eid Exam{..}) <- fetchExam tid ssh csh examn
csvName <- getMessageRender <*> pure (MsgExamUserCsvName tid ssh csh examn)
isLecturer <- hasReadAccessTo $ CExamR tid ssh csh examn EUsersR
userFunctions <- selectList [ UserFunctionUser ==. uid, UserFunctionFunction ==. SchoolExamOffice ] []
let
participantLink :: MonadCrypto m => UserId -> m (SomeRoute UniWorX)
participantLink partId = do
cID <- encrypt partId
return . SomeRoute . CourseR tid ssh csh $ CUserR cID
participantAnchor :: ExamUserTableData -> DBCell _ _ -> DBCell _ _
participantAnchor x = cellContents . mapped <>~ partAnchor
where
partAnchor :: Widget
partAnchor = do
let partId = x ^. resultUser . _entityKey
cID <- encrypt partId :: WidgetFor UniWorX CryptoUUIDUser
[whamlet|
$newline never
<span ##{toPathPiece cID}>
|]
markSynced :: ExamResultId -> DB ()
markSynced resId
| null userFunctions =
insert_ ExamOfficeResultSynced
{ examOfficeResultSyncedOffice = uid
, examOfficeResultSyncedResult = resId
, examOfficeResultSyncedTime = now
, examOfficeResultSyncedSchool = Nothing
}
| otherwise =
insertMany_ [ ExamOfficeResultSynced
{ examOfficeResultSyncedOffice = uid
, examOfficeResultSyncedResult = resId
, examOfficeResultSyncedTime = now
, examOfficeResultSyncedSchool = Just userFunctionSchool
}
| Entity _ UserFunction{..} <- userFunctions
]
examUsersDBTable = DBTable{..}
where
dbtSQLQuery = runReaderT $ do
examResult <- view queryExamResult
user <- view queryUser
examRegistration <- view queryExamRegistration
occurrence <- view queryExamOccurrence
courseParticipant <- view queryCourseParticipant
studyFeatures <- view queryStudyFeatures
studyDegree <- view queryStudyDegree
studyField <- view queryStudyField
isSynced <- view . queryIsSynced $ E.val uid
lift $ do
E.on $ studyField E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField
E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree
E.on $ studyFeatures E.?. StudyFeaturesId E.==. E.joinV (courseParticipant E.?. CourseParticipantField)
E.on $ courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val examCourse)
E.&&. courseParticipant E.?. CourseParticipantUser E.==. E.just (user E.^. UserId)
E.on $ occurrence E.?. ExamOccurrenceExam E.==. E.just (E.val eid)
E.&&. occurrence E.?. ExamOccurrenceId E.==. E.joinV (examRegistration E.?. ExamRegistrationOccurrence)
E.on $ examRegistration E.?. ExamRegistrationUser E.==. E.just (user E.^. UserId)
E.&&. examRegistration E.?. ExamRegistrationExam E.==. E.just (E.val eid)
E.on $ examResult E.^. ExamResultUser E.==. user E.^. UserId
E.&&. examResult E.^. ExamResultExam E.==. E.val eid
E.where_ $ examResult E.^. ExamResultExam E.==. E.val eid
unless isLecturer $
E.where_ $ Exam.examOfficeExamResultAuth (E.val uid) examResult
return (examResult, user, occurrence, studyFeatures, studyDegree, studyField, examRegistration, isSynced)
dbtRowKey = views queryExamResult (E.^. ExamResultId)
dbtProj :: DBRow _ -> MaybeT (YesodDB UniWorX) ExamUserTableData
dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $
(,,,,,,,,)
<$> view _1 <*> view _2 <*> view _3 <*> view _4 <*> view _5 <*> view _6 <*> view _7 <*> view (_8 . _Value)
<*> getSynchronised
where
getSynchronised :: ReaderT _ (MaybeT (YesodDB UniWorX)) [(UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand)]
getSynchronised = do
resId <- view $ _1 . _entityKey
syncs <- lift . lift . E.select . E.from $ \(examOfficeResultSynced `E.InnerJoin` user) -> do
E.on $ examOfficeResultSynced E.^. ExamOfficeResultSyncedOffice E.==. user E.^. UserId
E.where_ $ examOfficeResultSynced E.^. ExamOfficeResultSyncedResult E.==. E.val resId
return ( examOfficeResultSynced E.^. ExamOfficeResultSyncedOffice
, ( user E.^. UserDisplayName
, user E.^. UserSurname
, examOfficeResultSynced E.^. ExamOfficeResultSyncedTime
, examOfficeResultSynced E.^. ExamOfficeResultSyncedSchool
)
)
let syncs' = Map.fromListWith
(\(dn, sn, t, sshs) (_, _, _, sshs') -> (dn, sn, t, Set.union sshs sshs'))
[ ((officeId, t), (dn, sn, t, maybe Set.empty Set.singleton ssh'))
| (E.Value officeId, (E.Value dn, E.Value sn, E.Value t, fmap unSchoolKey . E.unValue -> ssh')) <- syncs
]
return $ Map.elems syncs'
colSynced = Colonnade.singleton (fromSortable . Sortable (Just "is-synced") $ i18nCell MsgExamUserSynchronised) $ \x -> cell . flip runReaderT x $ do
syncs <- asks $ sortOn (Down . view _3) . toListOf resultSynchronised
lastChange <- view $ resultExamResult . _entityVal . _examResultLastChanged
user <- view $ resultUser . _entityVal
isSynced <- view resultIsSynced
let
hasSyncs = has folded syncs
syncs' = [ Right sync | sync@(_, _, t, _) <- syncs, t > lastChange]
++ [ Left lastChange ]
++ [ Right sync | sync@(_, _, t, _) <- syncs, t <= lastChange]
syncIcon :: Widget
syncIcon
| not isSynced
, not hasSyncs
= mempty
| not isSynced
= toWidget iconNotOK
| otherwise
= toWidget iconOK
syncsModal :: Widget
syncsModal = $(widgetFile "exam-office/exam-result-synced")
lift $ bool id (flip modal $ Right syncsModal) hasSyncs syncIcon
dbtColonnade :: Colonnade Sortable _ _
dbtColonnade = mconcat
[ dbSelect (applying _2) id $ return . view (resultExamResult . _entityKey)
, colSynced
, imapColonnade participantAnchor . anchorColonnadeM (views (resultUser . _entityKey) participantLink) $ colUserDisplayName (resultUser . _entityVal . $(multifocusL 2) _userDisplayName _userSurname)
, colUserMatriculation (resultUser . _entityVal . _userMatrikelnummer)
, emptyOpticColonnade (resultStudyField . _entityVal) colStudyTerms
, emptyOpticColonnade (resultStudyDegree . _entityVal) colStudyDegree
, emptyOpticColonnade (resultStudyFeatures . _entityVal . _studyFeaturesSemester) colStudyFeaturesSemester
, Colonnade.singleton (fromSortable . Sortable (Just "occurrence-start") $ i18nCell MsgExamTime) $ \x -> cell . flip runReaderT x $ do
start <- preview $ resultExamOccurrence . _entityVal . _examOccurrenceStart <> like examStart . _Just
end <- preview $ resultExamOccurrence . _entityVal . _examOccurrenceEnd . _Just <> like examEnd . _Just
lift $ maybe mempty (flip (formatTimeRangeW SelFormatDateTime) end) start
, colExamResult examShowGrades (resultExamResult . _entityVal . _examResultResult)
]
dbtSorting = mconcat
[ sortUserName' (queryUser . to ((,) <$> (E.^. UserDisplayName) <*> (E.^. UserSurname)))
, sortUserMatriculation (queryUser . to (E.^. UserMatrikelnummer))
, sortStudyTerms queryStudyField
, sortStudyDegree queryStudyDegree
, sortStudyFeaturesSemester (queryStudyFeatures . to (E.?. StudyFeaturesSemester))
, sortOccurrenceStart (queryExamOccurrence . to (E.maybe (E.val examStart) E.just . (E.?. ExamOccurrenceStart)))
, maybeOpticSortColumn (sortExamResult examShowGrades) (queryExamResult . to (E.^. ExamResultResult))
, singletonMap "is-synced" . SortColumn $ view (queryIsSynced $ E.val uid)
]
dbtFilter = mconcat
[ fltrUserName' (queryUser . to (E.^. UserDisplayName))
, fltrUserMatriculation (queryUser . to (E.^. UserMatrikelnummer))
, fltrStudyTerms queryStudyField
, fltrStudyDegree queryStudyDegree
, fltrStudyFeaturesSemester (queryStudyFeatures . to (E.?. StudyFeaturesSemester))
, fltrExamResultPoints examShowGrades (queryExamResult . to (E.^. ExamResultResult))
, singletonMap "is-synced" . FilterColumn $ E.mkExactFilter (view . queryIsSynced $ E.val uid)
]
dbtFilterUI = mconcat
[ fltrUserNameUI'
, fltrUserMatriculationUI
, fltrStudyTermsUI
, fltrStudyDegreeUI
, fltrStudyFeaturesSemesterUI
, fltrExamResultPointsUI examShowGrades
, \mPrev -> prismAForm (singletonFilter "is-synced" . maybePrism _PathPiece) mPrev $ aopt boolField (fslI MsgExamUserSynchronised)
]
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
dbtParams = DBParamsForm
{ dbParamsFormMethod = POST
, dbParamsFormAction = Just . SomeRoute $ CExamR tid ssh csh examn EGradesR
, dbParamsFormAttrs = []
, dbParamsFormSubmit = FormSubmit
, dbParamsFormAdditional = \csrf -> do
let
actionMap :: Map ExamUserAction (AForm Handler ExamUserActionData)
actionMap = Map.fromList
[ ( ExamUserMarkSynchronised
, pure ExamUserMarkSynchronisedData
)
]
(res, formWgt) <- multiActionM actionMap (fslI MsgAction) Nothing csrf
let formRes = (, mempty) . First . Just <$> res
return (formRes, formWgt)
, dbParamsFormEvaluate = liftHandler . runFormPost
, dbParamsFormResult = id
, dbParamsFormIdent = def
}
dbtIdent :: Text
dbtIdent = "exam-results"
dbtCsvEncode = Just DBTCsvEncode
{ dbtCsvExportForm = ExamUserCsvExportData
<$> apopt checkBoxField (fslI MsgExamUserMarkSynchronisedCsv) (Just True)
, dbtCsvDoEncode = \ExamUserCsvExportData{..} -> C.mapM $ \(E.Value k, row) -> do
when csvEUserMarkSynchronised $ markSynced k
return $ ExamUserTableCsv
(row ^. resultUser . _entityVal . _userSurname)
(row ^. resultUser . _entityVal . _userFirstName)
(row ^. resultUser . _entityVal . _userDisplayName)
(row ^. resultUser . _entityVal . _userMatrikelnummer)
(row ^? resultStudyField . _entityVal . to (\StudyTerms{..} -> fromMaybe (tshow studyTermsKey) $ studyTermsName <|> studyTermsShorthand))
(row ^? resultStudyDegree . _entityVal . to (\StudyDegree{..} -> fromMaybe (tshow studyDegreeKey) $ studyDegreeName <|> studyDegreeShorthand))
(row ^? resultStudyFeatures . _entityVal . _studyFeaturesSemester)
(row ^? (resultExamOccurrence . _entityVal . _examOccurrenceStart <> like examStart . _Just) . to utcToZonedTime)
(row ^. resultExamResult . _entityVal . _examResultResult . to (fmap $ bool (Left . view passingGrade) Right examShowGrades))
, dbtCsvName = unpack csvName
, dbtCsvNoExportData = Nothing
, dbtCsvHeader = const . return $ Csv.headerOrder (error "headerOrder" :: ExamUserTableCsv)
}
dbtCsvDecode = Nothing
examUsersDBTableValidator = def & defaultSorting [SortAscBy "is-synced", SortAscBy "user-name"]
& defaultPagesize PagesizeAll
postprocess :: FormResult (First ExamUserActionData, DBFormResult ExamResultId Bool ExamUserTableData) -> FormResult (ExamUserActionData, Set ExamResultId)
postprocess inp = do
(First (Just act), regMap) <- inp
let regSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) regMap
return (act, regSet)
(usersResult, examUsersTable) <- over _1 postprocess <$> dbTable examUsersDBTableValidator examUsersDBTable
usersResult' <- formResultMaybe usersResult $ \case
(ExamUserMarkSynchronisedData, selectedResults) -> do
forM_ selectedResults markSynced
return . Just $ do
addMessageI Success $ MsgExamUserMarkedSynchronised (length selectedResults)
redirect $ CExamR tid ssh csh examn EGradesR
return ((usersResult', examUsersTable), exam)
whenIsJust usersResult join
closeWgt <- examCloseWidget (SomeRoute $ CExamR tid ssh csh examn EGradesR) eId
siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamOfficeExamUsersHeading) $ do
setTitleI $ prependCourseTitle tid ssh csh MsgExamOfficeExamUsersHeading
$(widgetFile "exam-office/exam-results")

200
src/Handler/ExamOffice/Exams.hs Normal file
View File

@ -0,0 +1,200 @@
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
module Handler.ExamOffice.Exams
( getEOExamsR
) where
import Import
import Handler.Utils
import qualified Handler.Utils.ExamOffice.Exam as Exam
import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E
import qualified Colonnade
type ExamsTableExpr = E.SqlExpr (Entity Exam)
`E.InnerJoin` E.SqlExpr (Entity Course)
type ExamsTableData = DBRow ( Entity Exam
, Entity Course
, Natural, Natural
)
queryExam :: Getter ExamsTableExpr (E.SqlExpr (Entity Exam))
queryExam = to $(E.sqlIJproj 2 1)
queryCourse :: Getter ExamsTableExpr (E.SqlExpr (Entity Course))
queryCourse = to $(E.sqlIJproj 2 2)
querySynchronised :: E.SqlExpr (E.Value UserId) -> Getter ExamsTableExpr (E.SqlExpr (E.Value Natural))
querySynchronised office = to . runReader $ do
exam <- view queryExam
let
synchronised = E.sub_select . E.from $ \examResult -> do
E.where_ $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId
E.where_ $ Exam.examOfficeExamResultAuth office examResult
E.where_ $ Exam.resultIsSynced office examResult
return E.countRows
return synchronised
queryResults :: E.SqlExpr (E.Value UserId) -> Getter ExamsTableExpr (E.SqlExpr (E.Value Natural))
queryResults office = to . runReader $ do
exam <- view queryExam
let
results = E.sub_select . E.from $ \examResult -> do
E.where_ $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId
E.where_ $ Exam.examOfficeExamResultAuth office examResult
return E.countRows
return results
queryIsSynced :: UTCTime -> E.SqlExpr (E.Value UserId) -> Getter ExamsTableExpr (E.SqlExpr (E.Value Bool))
queryIsSynced now office = to . runReader $ do
exam <- view queryExam
let
synchronised = E.not_ . E.exists . E.from $ \examResult -> do
E.where_ $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId
E.where_ $ Exam.examOfficeExamResultAuth office examResult
E.where_ . E.not_ $ Exam.resultIsSynced office examResult
open = E.maybe E.true (E.>. E.val now) $ exam E.^. ExamClosed
return $ synchronised E.||. open
resultExam :: Lens' ExamsTableData (Entity Exam)
resultExam = _dbrOutput . _1
resultCourse :: Lens' ExamsTableData (Entity Course)
resultCourse = _dbrOutput . _2
resultSynchronised, resultResults :: Lens' ExamsTableData Natural
resultSynchronised = _dbrOutput . _3
resultResults = _dbrOutput . _4
resultIsSynced :: Getter ExamsTableData Bool
resultIsSynced = to $ (>=) <$> view resultSynchronised <*> view resultResults
-- | List of all exams where the current user may (in her function as
-- exam-office) access users grades
getEOExamsR :: Handler Html
getEOExamsR = do
uid <- requireAuthId
now <- liftIO getCurrentTime
examsTable <- runDB $ do
let
examLink :: Course -> Exam -> SomeRoute UniWorX
examLink Course{..} Exam{..}
= SomeRoute $ CExamR courseTerm courseSchool courseShorthand examName EGradesR
courseLink :: Course -> SomeRoute UniWorX
courseLink Course{..}
= SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR
querySynchronised' = querySynchronised $ E.val uid
queryResults' = queryResults $ E.val uid
queryIsSynced' = queryIsSynced now $ E.val uid
examsDBTable = DBTable{..}
where
dbtSQLQuery = runReaderT $ do
exam <- view queryExam
course <- view queryCourse
synchronised <- view querySynchronised'
results <- view queryResults'
lift $ do
E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId
E.where_ $ results E.>. E.val 0
return (exam, course, synchronised, results)
dbtRowKey = views queryExam (E.^. ExamId)
dbtProj :: DBRow _ -> MaybeT (YesodDB UniWorX) ExamsTableData
dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $ do
exam <- view $ _1 . _entityVal
course <- view $ _2 . _entityVal
guard =<< hasReadAccessTo (urlRoute $ examLink course exam)
(,,,)
<$> view _1 <*> view _2 <*> view (_3 . _Value) <*> view (_4 . _Value)
colSynced = Colonnade.singleton (fromSortable . Sortable (Just "synced") $ i18nCell MsgExamSynchronised) $ \x -> flip runReader x $ do
Entity _ Exam{examClosed} <- view resultExam
if
| NTop examClosed > NTop (Just now)
-> return . cell $ toWidget iconNew
| otherwise
-> do
synced <- view resultSynchronised
results <- view resultResults
isSynced <- view resultIsSynced
return $ cell
[whamlet|
$newline never
$if isSynced
#{iconOK}
$else
#{synced}/#{results}
|]
& cellAttrs <>~ [ ("class", "heated")
, ("style", [st|--hotness: #{tshow (heat results synced)}|])
]
dbtColonnade :: Colonnade Sortable _ _
dbtColonnade = mconcat
[ colSynced
, anchorColonnade (views ($(multifocusG 2) (resultCourse . _entityVal) (resultExam . _entityVal)) (uncurry examLink))
$ colExamName (resultExam . _entityVal . _examName)
, colExamTime (resultExam . _entityVal . $(multifocusG 2) _examStart _examEnd)
, colExamFinishedOffice (resultExam . _entityVal . _examFinished)
, colExamClosed (resultExam . _entityVal . _examClosed)
, anchorColonnade (views (resultCourse . _entityVal) courseLink)
$ colCourseName (resultCourse . _entityVal . _courseName)
, colSchool (resultCourse . _entityVal . _courseSchool)
, colTermShort (resultCourse . _entityVal . _courseTerm)
]
dbtSorting = mconcat
[ singletonMap "synced" . SortColumn $ (E./.) <$> view querySynchronised' <*> view queryResults'
, singletonMap "is-synced" . SortColumn $ view queryIsSynced'
, sortExamName (queryExam . to (E.^. ExamName))
, sortExamTime (queryExam . $(multifocusG 2) (to (E.^. ExamStart)) (to (E.^. ExamEnd)))
, sortExamFinished (queryExam . to (E.^. ExamFinished))
, sortExamClosed (queryExam . to (E.^. ExamClosed))
, sortCourseName (queryCourse . to (E.^. CourseName))
, sortSchool (queryCourse . to (E.^. CourseSchool))
, sortTerm (queryCourse . to (E.^. CourseTerm))
]
dbtFilter = mconcat
[
]
dbtFilterUI = mconcat
[
]
dbtStyle = def -- { dbsFilterLayout = defaultDBSFilterLayout }
dbtParams = def
dbtIdent :: Text
dbtIdent = "exams"
dbtCsvEncode = noCsvEncode
dbtCsvDecode = Nothing
examsDBTableValidator = def & defaultSorting [SortAscBy "is-synced", SortAscBy "exam-time"]
dbTableWidget' examsDBTableValidator examsDBTable
siteLayoutMsg MsgMenuExamList $ do
setTitleI MsgMenuExamList
examsTable

116
src/Handler/ExamOffice/Fields.hs Normal file
View File

@ -0,0 +1,116 @@
module Handler.ExamOffice.Fields
( getEOFieldsR
, postEOFieldsR
) where
import Import
import Utils.Form
import qualified Database.Esqueleto as E
import qualified Data.Set as Set
import qualified Data.Map as Map
data ExamOfficeFieldMode
= EOFNotSubscribed
| EOFSubscribed
| EOFForced
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
embedRenderMessage ''UniWorX ''ExamOfficeFieldMode $ concat . set (ix 0) "ExamOfficeField" . splitCamel
instance Universe ExamOfficeFieldMode
instance Finite ExamOfficeFieldMode
nullaryPathPiece ''ExamOfficeFieldMode $ camelToPathPiece' 1
instance Default ExamOfficeFieldMode where
def = EOFNotSubscribed
eofModeField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m ExamOfficeFieldMode
-- ^ Always required
eofModeField = Field{..}
where
fieldEnctype = UrlEncoded
fieldView = \theId name attrs val _isReq -> $(widgetFile "widgets/fields/examOfficeFieldMode")
fieldParse = \e _ -> return $ parser e
parser [] = Right Nothing
parser (x:_)
| Just mode <- fromPathPiece x
= Right $ Just mode
parser (x:_)
= Left . SomeMessage $ MsgInvalidExamOfficeFieldMode x
isChecked :: Eq a => a -> Either Text a -> Bool
isChecked opt = either (const False) (== opt)
makeExamOfficeFieldsForm :: UserId -> Maybe (Map StudyTermsId Bool) -> Form (Map StudyTermsId Bool)
makeExamOfficeFieldsForm uid template = renderWForm FormStandard $ do
availableFields <- liftHandler . runDB . E.select . E.from $ \(terms `E.InnerJoin` schoolTerms) -> do
E.on $ terms E.^. StudyTermsId E.==. schoolTerms E.^. SchoolTermsTerms
E.where_ . E.exists . E.from $ \userFunction ->
E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val uid
E.&&. userFunction E.^. UserFunctionFunction E.==. E.val SchoolExamOffice
E.&&. userFunction E.^. UserFunctionSchool E.==. schoolTerms E.^. SchoolTermsSchool
return terms
let available = imap (\k terms -> (terms, view forced $ template >>= Map.lookup k)) $ toMapOf (folded .> _entityVal) availableFields
forced :: Iso' (Maybe Bool) ExamOfficeFieldMode
forced = iso fromForced toForced
where
fromForced = maybe EOFNotSubscribed $ bool EOFSubscribed EOFForced
toForced = \case
EOFNotSubscribed -> Nothing
EOFSubscribed -> Just False
EOFForced -> Just True
fmap (fmap (Map.mapMaybe $ review forced) . sequence) . forM available $ \(StudyTerms{..}, template')
-> let label = fromMaybe (tshow studyTermsKey) $ studyTermsName <|> studyTermsShorthand
in wpopt eofModeField (fsl label) $ Just template'
-- | Manage the list of `StudyTerms` this user (in her function as exam-office)
-- has an interest in, i.e. that authorize her to view an users grades, iff
-- they study one of the selected fields
getEOFieldsR, postEOFieldsR :: Handler Html
getEOFieldsR = postEOFieldsR
postEOFieldsR = do
uid <- requireAuthId
oldFields <- runDB $ do
fields <- E.select . E.from $ \examOfficeField -> do
E.where_ $ examOfficeField E.^. ExamOfficeFieldOffice E.==. E.val uid
return $ (examOfficeField E.^. ExamOfficeFieldField, examOfficeField E.^. ExamOfficeFieldForced)
return $ toMapOf (folded .> ito (over _1 E.unValue . over _2 E.unValue)) fields
((fieldsRes, fieldsView), fieldsEnc) <- runFormPost . makeExamOfficeFieldsForm uid $ Just oldFields
formResult fieldsRes $ \newFields -> do
runDB . forM_ (Map.keysSet newFields `Set.union` Map.keysSet oldFields) $ \fieldId -> if
| Just forced <- Map.lookup fieldId newFields
, fieldId `Map.member` oldFields -> do
updateBy (UniqueExamOfficeField uid fieldId) [ ExamOfficeFieldForced =. forced ]
audit $ TransactionExamOfficeFieldEdit uid fieldId
| Just forced <- Map.lookup fieldId newFields -> do
insert_ $ ExamOfficeField uid fieldId forced
audit $ TransactionExamOfficeFieldEdit uid fieldId
| otherwise -> do
deleteBy $ UniqueExamOfficeField uid fieldId
audit $ TransactionExamOfficeFieldDelete uid fieldId
addMessageI Success $ MsgTransactionExamOfficeFieldsUpdated (Set.size . Set.map (view _1) $ (setSymmDiff `on` assocsSet) newFields oldFields)
redirect $ ExamOfficeR EOExamsR
let
fieldsView' = wrapForm fieldsView def
{ formAction = Just . SomeRoute $ ExamOfficeR EOFieldsR
, formEncoding = fieldsEnc
}
siteLayoutMsg MsgMenuExamOfficeFields $ do
setTitleI MsgMenuExamOfficeFields
[whamlet|
$newline never
<p>
_{MsgExamOfficeSubscribedFieldsExplanation}
^{fieldsView'}
|]

188
src/Handler/ExamOffice/Users.hs Normal file
View File

@ -0,0 +1,188 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Handler.ExamOffice.Users
( getEOUsersR, postEOUsersR
, getEOUsersInviteR, postEOUsersInviteR
) where
import Import
import Utils.Form
import Handler.Utils
import Handler.Utils.Invitations
import Text.Hamlet (ihamlet)
import Data.Aeson hiding (Result(..))
import Jobs.Queue
import qualified Database.Esqueleto as E
import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.Map ((!), (!?))
instance IsInvitableJunction ExamOfficeUser where
type InvitationFor ExamOfficeUser = User
data InvitableJunction ExamOfficeUser = JunctionExamOfficeUser
deriving (Eq, Ord, Read, Show, Generic, Typeable)
data InvitationDBData ExamOfficeUser = InvDBDataExamOfficeUser
deriving (Eq, Ord, Read, Show, Generic, Typeable)
data InvitationTokenData ExamOfficeUser = InvTokenDataExamOfficeUser
{ invTokenExamOfficeUserOffice :: CryptoUUIDUser
}
deriving (Eq, Ord, Read, Show, Generic, Typeable)
_InvitableJunction = iso
(\ExamOfficeUser{..} -> (examOfficeUserUser, examOfficeUserOffice, JunctionExamOfficeUser))
(\(examOfficeUserUser, examOfficeUserOffice, JunctionExamOfficeUser) -> ExamOfficeUser{..})
instance ToJSON (InvitableJunction ExamOfficeUser) where
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
instance FromJSON (InvitableJunction ExamOfficeUser) where
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
instance ToJSON (InvitationDBData ExamOfficeUser) where
toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
instance FromJSON (InvitationDBData ExamOfficeUser) where
parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
instance ToJSON (InvitationTokenData ExamOfficeUser) where
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 5 }
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 5 }
instance FromJSON (InvitationTokenData ExamOfficeUser) where
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 5 }
examOfficeUserInvitationConfig :: InvitationConfig ExamOfficeUser
examOfficeUserInvitationConfig = InvitationConfig{..}
where
invitationRoute _ _ = return $ ExamOfficeR EOUsersInviteR
invitationResolveFor InvTokenDataExamOfficeUser{..} = do
officeId <- decrypt invTokenExamOfficeUserOffice
bool notFound (return officeId) =<< existsKey officeId
invitationSubject (Entity _ User{..}) _ = do
return . SomeMessage $ MsgMailSubjectExamOfficeUserInvitation userDisplayName
invitationHeading (Entity _ User{..}) _ = do
return . SomeMessage $ MsgExamOfficeUserInviteHeading userDisplayName
invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamOfficeUserInviteExplanation}|]
invitationTokenConfig _ _ = do
itAuthority <- liftHandler requireAuthId
let itExpiresAt = Nothing
itStartsAt = Nothing
itAddAuth = Nothing
return InvitationTokenConfig{..}
invitationRestriction _ _ = return Authorized
invitationForm _ _ _ = pure (JunctionExamOfficeUser, ())
invitationInsertHook _ _ ExamOfficeUser{..} _ act = do
res <- act
audit $ TransactionExamOfficeUserAdd examOfficeUserOffice examOfficeUserUser
return res
invitationSuccessMsg _ _ =
return $ SomeMessage MsgExamOfficeUserInvitationAccepted
invitationUltDest _ _ = return $ SomeRoute HomeR
makeExamOfficeUsersForm :: Maybe (Set (Either UserEmail UserId)) -> Form (Set (Either UserEmail UserId))
makeExamOfficeUsersForm template = renderWForm FormStandard $ do
cRoute <- fromMaybe (error "makeExamOfficeUsersForm called from 404-handler") <$> getCurrentRoute
let
miAdd' :: (Text -> Text)
-> FieldView UniWorX
-> Form ([Either UserEmail UserId] -> FormResult [Either UserEmail UserId])
miAdd' nudge btn csrf = do
MsgRenderer mr <- getMsgRenderer
(addRes, addView) <- mpreq (multiUserField False Nothing) ("" & addName (nudge "users") & addPlaceholder (mr MsgLdapIdentificationOrEmail)) Nothing
let
res' :: FormResult ([Either UserEmail UserId] -> FormResult [Either UserEmail UserId])
res' = addRes <&> \newUsers oldUsers -> if
| null newUsers
-> pure oldUsers
| otherwise
-> pure . nub $ oldUsers ++ Set.toList newUsers
return (res', $(widgetFile "widgets/massinput/examOfficeUsers/add"))
miCell' :: Either UserEmail UserId -> Widget
miCell' (Left email) = do
invWarnMsg <- messageI Warning MsgEmailInvitationWarning
$(widgetFile "widgets/massinput/examOfficeUsers/cellInvitation")
miCell' (Right uid) = do
User{..} <- liftHandler . runDB $ getJust uid
$(widgetFile "widgets/massinput/examOfficeUsers/cellKnown")
miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
miButtonAction' frag = Just . SomeRoute $ cRoute :#: frag
miLayout' :: MassInputLayout ListLength _ ()
miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/examOfficeUsers/layout")
miIdent' :: Text
miIdent' = "exam-office-users"
fSettings :: FieldSettings UniWorX
fSettings = fslI MsgExamOfficeSubscribedUsers
& setTooltip MsgExamOfficeSubscribedUsersTip
fRequired :: Bool
fRequired = False
template' <- for template $ \uids -> liftHandler . runDB $ do
let (invitations, knownUsers) = partitionEithers $ Set.toList uids
knownUsers' <- fmap (map E.unValue) . E.select . E.from $ \user -> do
E.where_ $ user E.^. UserId `E.in_` E.valList knownUsers
E.orderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName]
return $ user E.^. UserId
return $ map Left invitations ++ map Right knownUsers'
fmap Set.fromList <$> massInputAccumW miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired template'
-- | Manage the list of users this user (in her function as exam-office)
-- has an interest in, i.e. that authorize her to view their grades
getEOUsersR, postEOUsersR :: Handler Html
getEOUsersR = postEOUsersR
postEOUsersR = do
uid <- requireAuthId
oldUsers <- liftHandler . runDB $ do
users <- E.select . E.from $ \(user `E.InnerJoin` examOfficeUser) -> do
E.on $ user E.^. UserId E.==. examOfficeUser E.^. ExamOfficeUserUser
E.&&. examOfficeUser E.^. ExamOfficeUserOffice E.==. E.val uid
return $ user E.^. UserId
invites <- Map.keysSet <$> sourceInvitationsF @ExamOfficeUser uid
return $ setOf (folded . _Value . re _Right) users <> Set.mapMonotonic Left invites
((usersRes, usersView), usersEnc) <- runFormPost . makeExamOfficeUsersForm $ Just oldUsers
formResult usersRes $ \(setSymmDiff oldUsers -> changes) -> do
liftHandler . runDBJobs . forM_ changes $ \change -> if
| change `Set.member` oldUsers -> case change of
Right change' -> do
deleteBy $ UniqueExamOfficeUser uid change'
audit $ TransactionExamOfficeUserDelete uid change'
Left change' ->
deleteInvitation @ExamOfficeUser uid change'
| otherwise -> case change of
Right change' -> do
insert_ $ ExamOfficeUser uid change'
audit $ TransactionExamOfficeUserAdd uid change'
Left change' -> do
cID <- encrypt uid
sinkInvitation examOfficeUserInvitationConfig (change', uid, (InvDBDataExamOfficeUser, InvTokenDataExamOfficeUser cID))
addMessageI Success $ MsgTransactionExamOfficeUsersUpdated (Set.size $ changes `Set.intersection` oldUsers) (Set.size $ changes `Set.difference` oldUsers)
redirect $ ExamOfficeR EOExamsR
let
usersView' = wrapForm usersView def
{ formAction = Just . SomeRoute $ ExamOfficeR EOUsersR
, formEncoding = usersEnc
}
siteLayoutMsg MsgMenuExamOfficeUsers $ do
setTitleI MsgMenuExamOfficeUsers
[whamlet|
$newline never
<p>
_{MsgExamOfficeSubscribedUsersExplanation}
^{usersView'}
|]
getEOUsersInviteR, postEOUsersInviteR :: Handler Html
getEOUsersInviteR = postEOUsersInviteR
postEOUsersInviteR = invitationR examOfficeUserInvitationConfig

2
src/Handler/Health.hs
View File

@ -27,7 +27,7 @@ getHealthR = do
waitResult <- atomically $ maybe (pure $ Left False) (fmap (const $ Left True) . waitDelay) delay <|> (fmap Right . assertM (not. Set.null) $ readTVar reportStore) waitResult <- atomically $ maybe (pure $ Left False) (fmap (const $ Left True) . waitDelay) delay <|> (fmap Right . assertM (not. Set.null) $ readTVar reportStore)
case waitResult of case waitResult of
Left False -> sendResponseStatus noContent204 () Left False -> sendResponseStatus noContent204 ()
Left True -> fail "System is not generating HealthReports" Left True -> sendResponseStatus internalServerError500 ("System is not generating HealthReports" :: Text)
Right _ -> redirect HealthR Right _ -> redirect HealthR
Just healthReports -> do Just healthReports -> do
let (Max lastUpdated, Min status) = ofoldMap1 (Max *** Min . healthReportStatus) healthReports let (Max lastUpdated, Min status) = ofoldMap1 (Max *** Min . healthReportStatus) healthReports

10
src/Handler/Home.hs
View File

@ -3,8 +3,6 @@ module Handler.Home where
import Import import Import
import Handler.Utils import Handler.Utils
import Handler.Utils.Table.Cells
import qualified Data.Map as Map import qualified Data.Map as Map
import Database.Esqueleto.Utils.TH import Database.Esqueleto.Utils.TH
@ -60,7 +58,7 @@ homeUpcomingSheets uid = do
, E.Value UTCTime , E.Value UTCTime
, E.Value (Maybe SubmissionId) , E.Value (Maybe SubmissionId)
)) ))
(DBCell (HandlerT UniWorX IO) ()) (DBCell Handler ())
colonnade = mconcat colonnade = mconcat
[ -- dbRow [ -- dbRow
-- TOOD: sortable (Just "term") (textCell MsgTerm) $ \DBRow{ dbrOutput=(view _1 -> E.Value tid) } -> -- TOOD: sortable (Just "term") (textCell MsgTerm) $ \DBRow{ dbrOutput=(view _1 -> E.Value tid) } ->
@ -84,7 +82,7 @@ homeUpcomingSheets uid = do
(hasTickmark True) (hasTickmark True)
] ]
let validator = def & defaultSorting [SortDescBy "done", SortAscBy "deadline"] let validator = def & defaultSorting [SortDescBy "done", SortAscBy "deadline"]
sheetTable <- liftHandlerT . runDB $ dbTableWidget' validator DBTable sheetTable <- liftHandler . runDB $ dbTableWidget' validator DBTable
{ dbtSQLQuery = tableData { dbtSQLQuery = tableData
, dbtRowKey = \((_ `E.InnerJoin` _ `E.InnerJoin` sheet) `E.LeftOuterJoin` _) -> sheet E.^. SheetId , dbtRowKey = \((_ `E.InnerJoin` _ `E.InnerJoin` sheet) `E.LeftOuterJoin` _) -> sheet E.^. SheetId
, dbtColonnade = colonnade , dbtColonnade = colonnade
@ -129,7 +127,7 @@ homeUpcomingSheets uid = do
homeUpcomingExams :: UserId -> Widget homeUpcomingExams :: UserId -> Widget
homeUpcomingExams uid = do homeUpcomingExams uid = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
((Any hasExams, examTable), warningDays) <- liftHandlerT . runDB $ do ((Any hasExams, examTable), warningDays) <- liftHandler . runDB $ do
User {userWarningDays} <- get404 uid User {userWarningDays} <- get404 uid
let fortnight = addUTCTime userWarningDays now let fortnight = addUTCTime userWarningDays now
let -- code copied and slightly adapted from Handler.Course.getCShowR: let -- code copied and slightly adapted from Handler.Course.getCShowR:
@ -204,7 +202,7 @@ homeUpcomingExams uid = do
isRegistered <- existsBy $ UniqueExamRegistration eId uid isRegistered <- existsBy $ UniqueExamRegistration eId uid
if if
| mayRegister -> do | mayRegister -> do
(examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered (examRegisterForm, examRegisterEnctype) <- liftHandler . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered
return $ wrapForm examRegisterForm def return $ wrapForm examRegisterForm def
{ formAction = Just . SomeRoute $ CExamR courseTerm courseSchool courseShorthand examName ERegisterR { formAction = Just . SomeRoute $ CExamR courseTerm courseSchool courseShorthand examName ERegisterR
, formEncoding = examRegisterEnctype , formEncoding = examRegisterEnctype

21
src/Handler/Info.hs
View File

@ -47,4 +47,23 @@ getInfoLecturerR =
siteLayoutMsg' MsgInfoLecturerTitle $ do siteLayoutMsg' MsgInfoLecturerTitle $ do
setTitleI MsgInfoLecturerTitle setTitleI MsgInfoLecturerTitle
$(i18nWidgetFile "info-lecturer") $(i18nWidgetFile "info-lecturer")
where
tooltipNew, tooltipProblem, tooltipPlanned, tooltipNewU2W :: WidgetFor UniWorX ()
tooltipNew = [whamlet| _{MsgLecturerInfoTooltipNew} |]
tooltipProblem = [whamlet| _{MsgLecturerInfoTooltipProblem} |]
tooltipPlanned = [whamlet| _{MsgLecturerInfoTooltipPlanned} |]
tooltipNewU2W = [whamlet| _{MsgLecturerInfoTooltipNewU2W} |]
newU2WFeat, probFeatInline, plannedFeat, plannedFeatInline :: WidgetFor UniWorX ()
newU2WFeat = [whamlet| ^{iconTooltip tooltipNew (Just IconAnnounce) True} |] -- to be used inside text blocks
probFeatInline = [whamlet| ^{iconTooltip tooltipProblem (Just IconProblem) True} |] -- to be used inside text blocks
plannedFeat = [whamlet| ^{iconTooltip tooltipPlanned (Just IconPlanned) False} |]
plannedFeatInline = [whamlet| ^{iconTooltip tooltipPlanned (Just IconPlanned) True} |] -- to be used inside text blocks
-- new feature with given introduction date
newFeat :: Integer -> Int -> Int -> WidgetFor UniWorX ()
newFeat year month day = do
currentTime <- liftIO getCurrentTime
let expiryTime = UTCTime (addGregorianMonthsRollOver 1 $ fromGregorian year month day) 0
if currentTime > expiryTime
then mempty
else toWidget [whamlet| ^{iconTooltip tooltipNewU2W (Just IconNew) False} |]

19
src/Handler/Material.hs
View File

@ -17,8 +17,6 @@ import Database.Esqueleto.Utils.TH
import Utils.Form import Utils.Form
import Handler.Utils import Handler.Utils
import Handler.Utils.Delete import Handler.Utils.Delete
import Handler.Utils.Table.Cells
import Handler.Utils.Table.Columns
import Control.Monad.Writer (MonadWriter(..), execWriterT) import Control.Monad.Writer (MonadWriter(..), execWriterT)
@ -30,7 +28,7 @@ data MaterialForm = MaterialForm
, mfType :: Maybe (CI Text) , mfType :: Maybe (CI Text)
, mfDescription :: Maybe Html , mfDescription :: Maybe Html
, mfVisibleFrom :: Maybe UTCTime , mfVisibleFrom :: Maybe UTCTime
, mfFiles :: Maybe (Source Handler (Either FileId File)) , mfFiles :: Maybe (ConduitT () (Either FileId File) Handler ())
} }
makeMaterialForm :: CourseId -> Maybe MaterialForm -> Form MaterialForm makeMaterialForm :: CourseId -> Maybe MaterialForm -> Form MaterialForm
@ -42,7 +40,7 @@ makeMaterialForm cid template = identifyForm FIDmaterial $ \html -> do
| Just source <- template >>= mfFiles | Just source <- template >>= mfFiles
= runConduit $ source .| C.foldMap setIds = runConduit $ source .| C.foldMap setIds
| otherwise = return Set.empty | otherwise = return Set.empty
typeOptions :: HandlerT UniWorX IO (OptionList (CI Text)) typeOptions :: HandlerFor UniWorX (OptionList (CI Text))
typeOptions = do typeOptions = do
let defaults = Set.fromList $ map (CI.mk . mr) [MsgMaterialTypeSlides,MsgMaterialTypeCode,MsgMaterialTypeExample] let defaults = Set.fromList $ map (CI.mk . mr) [MsgMaterialTypeSlides,MsgMaterialTypeCode,MsgMaterialTypeExample]
previouslyUsed <- runDB $ previouslyUsed <- runDB $
@ -63,7 +61,7 @@ makeMaterialForm cid template = identifyForm FIDmaterial $ \html -> do
flip (renderAForm FormStandard) html $ MaterialForm flip (renderAForm FormStandard) html $ MaterialForm
<$> areq (textField & cfStrip & cfCI) (fslI MsgMaterialName) (mfName <$> template) <$> areq (textField & cfStrip & cfCI) (fslI MsgMaterialName) (mfName <$> template)
<*> aopt (textField & cfStrip & cfCI & addDatalist typeOptions) <*> aopt (textField & cfStrip & guardField (not . null) & cfCI & addDatalist typeOptions)
(fslpI MsgMaterialType $ mr MsgMaterialTypePlaceholder) (fslpI MsgMaterialType $ mr MsgMaterialTypePlaceholder)
(mfType <$> template) (mfType <$> template)
<*> aopt htmlField (fslpI MsgMaterialDescription "Html") <*> aopt htmlField (fslpI MsgMaterialDescription "Html")
@ -79,8 +77,8 @@ getMaterialKeyBy404 tid ssh csh mnm = do
getKeyBy404 $ UniqueMaterial cid mnm getKeyBy404 $ UniqueMaterial cid mnm
fetchMaterial :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> DB (Entity Material) fetchMaterial :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> DB (Entity Material)
fetchMaterial tid ssh csh mnm = do fetchMaterial tid ssh csh mnm =
[matEnt] <- E.select . E.from $ -- uniqueness guaranteed by DB constraints maybe notFound return . listToMaybe <=< E.select . E.from $ -- uniqueness guaranteed by DB constraints
\(course `E.InnerJoin` material) -> do \(course `E.InnerJoin` material) -> do
E.on $ course E.^. CourseId E.==. material E.^. MaterialCourse E.on $ course E.^. CourseId E.==. material E.^. MaterialCourse
E.where_ $ course E.^. CourseTerm E.==. E.val tid E.where_ $ course E.^. CourseTerm E.==. E.val tid
@ -88,7 +86,6 @@ fetchMaterial tid ssh csh mnm = do
E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. course E.^. CourseShorthand E.==. E.val csh
E.&&. material E.^. MaterialName E.==. E.val mnm E.&&. material E.^. MaterialName E.==. E.val mnm
return material return material
return matEnt
getMaterialListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getMaterialListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
@ -247,7 +244,7 @@ postMEditR tid ssh csh mnm = do
E.on $ matFile E.^. MaterialFileFile E.==. file E.^. FileId E.on $ matFile E.^. MaterialFileFile E.==. file E.^. FileId
E.where_ $ matFile E.^. MaterialFileMaterial E.==. E.val (entityKey matEnt) E.where_ $ matFile E.^. MaterialFileMaterial E.==. E.val (entityKey matEnt)
return $ file E.^. FileId return $ file E.^. FileId
return (matEnt, (Left . E.unValue) <$> fileIds) return (matEnt, Left . E.unValue <$> fileIds)
-- let cid = materialCourse -- let cid = materialCourse
let template = Just MaterialForm let template = Just MaterialForm
{ mfName = materialName { mfName = materialName
@ -310,14 +307,14 @@ handleMaterialEdit tid ssh csh cid template dbMaterial = do
when saveOk $ redirect -- redirect must happen outside of runDB when saveOk $ redirect -- redirect must happen outside of runDB
$ CourseR tid ssh csh (MaterialR mfName MShowR) $ CourseR tid ssh csh (MaterialR mfName MShowR)
insertMaterialFile' :: MaterialId -> Source Handler (Either FileId File) -> DB () insertMaterialFile' :: MaterialId -> ConduitT () (Either FileId File) Handler () -> DB ()
insertMaterialFile' mid fs = do insertMaterialFile' mid fs = do
oldFileIdVals <- E.select . E.from $ \(file `E.InnerJoin` materialFile) -> do oldFileIdVals <- E.select . E.from $ \(file `E.InnerJoin` materialFile) -> do
E.on $ materialFile E.^. MaterialFileFile E.==. file E.^. FileId E.on $ materialFile E.^. MaterialFileFile E.==. file E.^. FileId
E.where_ $ materialFile E.^. MaterialFileMaterial E.==. E.val mid E.where_ $ materialFile E.^. MaterialFileMaterial E.==. E.val mid
return $ file E.^. FileId return $ file E.^. FileId
let oldFileIds = setFromList $ map E.unValue oldFileIdVals let oldFileIds = setFromList $ map E.unValue oldFileIdVals
keep <- execWriterT . runConduit $ transPipe (lift . lift) fs =$= C.mapM_ finsert keep <- execWriterT . runConduit $ transPipe (lift . lift) fs .| C.mapM_ finsert
mapM_ deleteCascade (oldFileIds \\ keep :: Set FileId) mapM_ deleteCascade (oldFileIds \\ keep :: Set FileId)
where where
finsert (Left fileId) = tell $ singleton fileId finsert (Left fileId) = tell $ singleton fileId

227
src/Handler/Profile.hs
View File

@ -1,9 +1,17 @@
module Handler.Profile where module Handler.Profile
( getProfileR, postProfileR
, getProfileDataR, makeProfileData
, getAuthPredsR, postAuthPredsR
, getUserNotificationR, postUserNotificationR
, getSetDisplayEmailR, postSetDisplayEmailR
, getCsvOptionsR, postCsvOptionsR
) where
import Import import Import
import Handler.Utils import Handler.Utils
import Handler.Utils.Table.Cells import Handler.Utils.Profile
import Handler.Utils.Tokens
-- import Colonnade hiding (fromMaybe, singleton) -- import Colonnade hiding (fromMaybe, singleton)
-- import Yesod.Colonnade -- import Yesod.Colonnade
@ -17,25 +25,33 @@ import qualified Database.Esqueleto.Utils as E
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import Jobs
data SettingsForm = SettingsForm data SettingsForm = SettingsForm
{ stgMaxFavourties :: Int { stgDisplayName :: UserDisplayName
, stgTheme :: Theme , stgDisplayEmail :: UserEmail
, stgDateTime :: DateTimeFormat , stgMaxFavourites :: Int
, stgDate :: DateTimeFormat , stgMaxFavouriteTerms :: Int
, stgTime :: DateTimeFormat , stgTheme :: Theme
, stgDownloadFiles :: Bool , stgDateTime :: DateTimeFormat
, stgWarningDays :: NominalDiffTime , stgDate :: DateTimeFormat
, stgSchools :: Set SchoolId , stgTime :: DateTimeFormat
, stgDownloadFiles :: Bool
, stgWarningDays :: NominalDiffTime
, stgSchools :: Set SchoolId
, stgNotificationSettings :: NotificationSettings , stgNotificationSettings :: NotificationSettings
} }
makeLenses_ ''SettingsForm
data NotificationTriggerKind data NotificationTriggerKind
= NTKAll = NTKAll
| NTKCourseParticipant | NTKCourseParticipant
| NTKExamParticipant | NTKExamParticipant
| NTKCorrector | NTKCorrector
| NTKCourseLecturer
| NTKAllocationStaff | NTKAllocationStaff
| NTKAllocationParticipant
| NTKFunctionary SchoolFunction | NTKFunctionary SchoolFunction
deriving (Eq, Ord, Generic, Typeable) deriving (Eq, Ord, Generic, Typeable)
deriveFinite ''NotificationTriggerKind deriveFinite ''NotificationTriggerKind
@ -46,7 +62,9 @@ instance RenderMessage UniWorX NotificationTriggerKind where
NTKCourseParticipant -> mr MsgNotificationTriggerKindCourseParticipant NTKCourseParticipant -> mr MsgNotificationTriggerKindCourseParticipant
NTKExamParticipant -> mr MsgNotificationTriggerKindExamParticipant NTKExamParticipant -> mr MsgNotificationTriggerKindExamParticipant
NTKCorrector -> mr MsgNotificationTriggerKindCorrector NTKCorrector -> mr MsgNotificationTriggerKindCorrector
NTKCourseLecturer -> mr MsgNotificationTriggerKindCourseLecturer
NTKAllocationStaff -> mr MsgNotificationTriggerKindAllocationStaff NTKAllocationStaff -> mr MsgNotificationTriggerKindAllocationStaff
NTKAllocationParticipant -> mr MsgNotificationTriggerKindAllocationParticipant
NTKFunctionary SchoolAdmin -> mr MsgNotificationTriggerKindAdmin NTKFunctionary SchoolAdmin -> mr MsgNotificationTriggerKindAdmin
NTKFunctionary SchoolLecturer -> mr MsgNotificationTriggerKindLecturer NTKFunctionary SchoolLecturer -> mr MsgNotificationTriggerKindLecturer
NTKFunctionary SchoolExamOffice -> mr MsgNotificationTriggerKindExamOffice NTKFunctionary SchoolExamOffice -> mr MsgNotificationTriggerKindExamOffice
@ -58,9 +76,14 @@ instance RenderMessage UniWorX NotificationTriggerKind where
makeSettingForm :: Maybe SettingsForm -> Form SettingsForm makeSettingForm :: Maybe SettingsForm -> Form SettingsForm
makeSettingForm template html = do makeSettingForm template html = do
(result, widget) <- flip (renderAForm FormStandard) html $ SettingsForm (result, widget) <- flip (renderAForm FormStandard) html $ SettingsForm
<$ aformSection MsgFormCosmetics <$ aformSection MsgFormPersonalAppearance
<*> areq (natFieldI $ MsgNatField "Favoriten") -- TODO: natFieldI not working here <*> areq (textField & cfStrip) (fslI MsgUserDisplayName & setTooltip MsgUserDisplayNameRulesBelow) (stgDisplayName <$> template)
(fslpI MsgFavoriten "Anzahl Favoriten") (stgMaxFavourties <$> template) <*> areq (emailField & cfStrip & cfCI) (fslI MsgUserDisplayEmail & setTooltip MsgUserDisplayEmailTip) (stgDisplayEmail <$> template)
<* aformSection MsgFormCosmetics
<*> areq (natFieldI $ MsgNatField "Favoriten")
(fslpI MsgFavourites "Anzahl Favoriten" & setTooltip MsgFavouritesTip) (stgMaxFavourites <$> template)
<*> areq (natFieldI $ MsgNatField "Favoriten-Semester")
(fslpI MsgFavouriteSemesters "Anzahl Semester") (stgMaxFavouriteTerms <$> template)
<*> areq (selectField . return $ mkOptionList themeList) <*> areq (selectField . return $ mkOptionList themeList)
(fslI MsgTheme) { fsId = Just "theme-select" } (stgTheme <$> template) (fslI MsgTheme) { fsId = Just "theme-select" } (stgTheme <$> template)
<*> areq (selectField $ dateTimeFormatOptions SelFormatDateTime) (fslI MsgDateTimeFormat) (stgDateTime <$> template) <*> areq (selectField $ dateTimeFormatOptions SelFormatDateTime) (fslI MsgDateTimeFormat) (stgDateTime <$> template)
@ -85,7 +108,7 @@ schoolsForm template = formToAForm $ schoolsFormView =<< renderWForm FormStandar
where where
schoolsForm' :: WForm Handler (FormResult (Set SchoolId)) schoolsForm' :: WForm Handler (FormResult (Set SchoolId))
schoolsForm' = do schoolsForm' = do
allSchools <- liftHandlerT . runDB $ selectList [] [Asc SchoolName] allSchools <- liftHandler . runDB $ selectList [] [Asc SchoolName]
let let
schoolForm (Entity ssh School{schoolName}) schoolForm (Entity ssh School{schoolName})
@ -107,7 +130,7 @@ schoolsForm template = formToAForm $ schoolsFormView =<< renderWForm FormStandar
notificationForm :: Maybe NotificationSettings -> AForm Handler NotificationSettings notificationForm :: Maybe NotificationSettings -> AForm Handler NotificationSettings
notificationForm template = wFormToAForm $ do notificationForm template = wFormToAForm $ do
mbUid <- liftHandlerT maybeAuthId mbUid <- liftHandler maybeAuthId
isAdmin <- hasReadAccessTo AdminR isAdmin <- hasReadAccessTo AdminR
let let
@ -132,10 +155,14 @@ notificationForm template = wFormToAForm $ do
, NTKExamParticipant <- nt , NTKExamParticipant <- nt
= fmap not . E.selectExists . E.from $ \examRegistration -> = fmap not . E.selectExists . E.from $ \examRegistration ->
E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val uid E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val uid
| Just uid <- mbUid
, NTKCourseLecturer <- nt
= fmap not . E.selectExists . E.from $ \lecturer ->
E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid
| otherwise | otherwise
= return False = return False
ntHidden <- liftHandlerT . runDB ntHidden <- liftHandler . runDB
$ Set.fromList universeF $ Set.fromList universeF
& Map.fromSet sectionIsHidden & Map.fromSet sectionIsHidden
& sequenceA & sequenceA
@ -151,28 +178,43 @@ notificationForm template = wFormToAForm $ do
= apopt checkBoxField (fslI nt) (flip notificationAllowed nt <$> template) = apopt checkBoxField (fslI nt) (flip notificationAllowed nt <$> template)
ntSection = \case ntSection = \case
NTSubmissionRatedGraded -> Just NTKCourseParticipant NTSubmissionRatedGraded -> Just NTKCourseParticipant
NTSubmissionRated -> Just NTKCourseParticipant NTSubmissionRated -> Just NTKCourseParticipant
NTSheetActive -> Just NTKCourseParticipant NTSheetActive -> Just NTKCourseParticipant
NTSheetSoonInactive -> Just NTKCourseParticipant NTSheetSoonInactive -> Just NTKCourseParticipant
NTSheetInactive -> Just $ NTKFunctionary SchoolLecturer NTSheetInactive -> Just NTKCourseLecturer
NTCorrectionsAssigned -> Just NTKCorrector NTCorrectionsAssigned -> Just NTKCorrector
NTCorrectionsNotDistributed -> Just $ NTKFunctionary SchoolLecturer NTCorrectionsNotDistributed -> Just NTKCourseLecturer
NTUserRightsUpdate -> Just NTKAll NTUserRightsUpdate -> Just NTKAll
NTUserAuthModeUpdate -> Just NTKAll NTUserAuthModeUpdate -> Just NTKAll
NTExamResult -> Just NTKExamParticipant NTExamRegistrationActive -> Just NTKCourseParticipant
NTAllocationStaffRegister -> Just $ NTKFunctionary SchoolLecturer NTExamRegistrationSoonInactive -> Just NTKCourseParticipant
NTAllocationAllocation -> Just NTKAllocationStaff NTExamDeregistrationSoonInactive -> Just NTKCourseParticipant
NTAllocationRegister -> Just NTKAll NTExamResult -> Just NTKExamParticipant
NTAllocationOutdatedRatings -> Just NTKAllocationStaff NTAllocationStaffRegister -> Just $ NTKFunctionary SchoolLecturer
NTAllocationUnratedApplications -> Just NTKAllocationStaff NTAllocationAllocation -> Just NTKAllocationStaff
-- _other -> Nothing NTAllocationRegister -> Just NTKAll
NTAllocationOutdatedRatings -> Just NTKAllocationStaff
NTAllocationUnratedApplications -> Just NTKAllocationStaff
NTAllocationResults -> Just NTKAllocationParticipant
NTExamOfficeExamResults -> Just $ NTKFunctionary SchoolExamOffice
NTExamOfficeExamResultsChanged -> Just $ NTKFunctionary SchoolExamOffice
NTCourseRegistered -> Just NTKAll
-- _other -> Nothing
forcedTriggers = [NTUserRightsUpdate, NTUserAuthModeUpdate] forcedTriggers = [NTUserRightsUpdate, NTUserAuthModeUpdate]
aFormToWForm $ NotificationSettings <$> sectionedFuncForm ntSection nsForm (fslI MsgNotificationSettings) False aFormToWForm $ NotificationSettings <$> sectionedFuncForm ntSection nsForm (fslI MsgNotificationSettings) False
validateSettings :: User -> FormValidator SettingsForm Handler ()
validateSettings User{..} = do
userDisplayName' <- use _stgDisplayName
guardValidation MsgUserDisplayNameInvalid $
validDisplayName userTitle userFirstName userSurname userDisplayName'
data ButtonResetTokens = BtnResetTokens data ButtonResetTokens = BtnResetTokens
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
instance Universe ButtonResetTokens instance Universe ButtonResetTokens
@ -195,7 +237,7 @@ nullaryPathPiece ''ProfileAnchor $ camelToPathPiece' 1
getProfileR, postProfileR :: Handler Html getProfileR, postProfileR :: Handler Html
getProfileR = postProfileR getProfileR = postProfileR
postProfileR = do postProfileR = do
(uid, User{..}) <- requireAuthPair (uid, user@User{..}) <- requireAuthPair
userSchools <- fmap (setOf $ folded . _Value) . runDB . E.select . E.from $ \school -> do userSchools <- fmap (setOf $ folded . _Value) . runDB . E.select . E.from $ \school -> do
E.where_ . E.exists . E.from $ \userSchool -> E.where_ . E.exists . E.from $ \userSchool ->
E.where_ $ E.not_ (userSchool E.^. UserSchoolIsOptOut) E.where_ $ E.not_ (userSchool E.^. UserSchoolIsOptOut)
@ -203,36 +245,38 @@ postProfileR = do
E.&&. userSchool E.^. UserSchoolSchool E.==. school E.^. SchoolId E.&&. userSchool E.^. UserSchoolSchool E.==. school E.^. SchoolId
return $ school E.^. SchoolId return $ school E.^. SchoolId
let settingsTemplate = Just SettingsForm let settingsTemplate = Just SettingsForm
{ stgMaxFavourties = userMaxFavourites { stgDisplayName = userDisplayName
, stgTheme = userTheme , stgDisplayEmail = userDisplayEmail
, stgDateTime = userDateTimeFormat , stgMaxFavourites = userMaxFavourites
, stgDate = userDateFormat , stgMaxFavouriteTerms = userMaxFavouriteTerms
, stgTime = userTimeFormat , stgTheme = userTheme
, stgDownloadFiles = userDownloadFiles , stgDateTime = userDateTimeFormat
, stgSchools = userSchools , stgDate = userDateFormat
, stgTime = userTimeFormat
, stgDownloadFiles = userDownloadFiles
, stgSchools = userSchools
, stgNotificationSettings = userNotificationSettings , stgNotificationSettings = userNotificationSettings
, stgWarningDays = userWarningDays , stgWarningDays = userWarningDays
} }
((res,formWidget), formEnctype) <- runFormPost . identifyForm ProfileSettings $ makeSettingForm settingsTemplate ((res,formWidget), formEnctype) <- runFormPost . validateForm (validateSettings user) . identifyForm ProfileSettings $ makeSettingForm settingsTemplate
formResult res $ \SettingsForm{..} -> do formResult res $ \SettingsForm{..} -> do
runDB $ do runDBJobs $ do
update uid [ UserMaxFavourites =. stgMaxFavourties update uid $
, UserTheme =. stgTheme [ UserDisplayName =. stgDisplayName
, UserDateTimeFormat =. stgDateTime , UserMaxFavourites =. stgMaxFavourites
, UserDateFormat =. stgDate , UserMaxFavouriteTerms =. stgMaxFavouriteTerms
, UserTimeFormat =. stgTime , UserTheme =. stgTheme
, UserDownloadFiles =. stgDownloadFiles , UserDateTimeFormat =. stgDateTime
, UserWarningDays =. stgWarningDays , UserDateFormat =. stgDate
, UserNotificationSettings =. stgNotificationSettings , UserTimeFormat =. stgTime
] , UserDownloadFiles =. stgDownloadFiles
when (stgMaxFavourties < userMaxFavourites) $ do , UserWarningDays =. stgWarningDays
-- prune Favourites to user-defined size , UserNotificationSettings =. stgNotificationSettings
oldFavs <- selectKeysList [ CourseFavouriteUser ==. uid] ] ++ [ UserDisplayEmail =. stgDisplayEmail | userDisplayEmail == stgDisplayEmail ]
[ Desc CourseFavouriteTime when (stgDisplayEmail /= userDisplayEmail) $ do
, OffsetBy stgMaxFavourties queueDBJob $ JobChangeUserDisplayEmail uid stgDisplayEmail
] addMessageI Info $ MsgUserDisplayEmailChangeSent stgDisplayEmail
mapM_ delete oldFavs
let let
symDiff = (stgSchools `Set.difference` userSchools) `Set.union` (userSchools `Set.difference` stgSchools) symDiff = (stgSchools `Set.difference` userSchools) `Set.union` (userSchools `Set.difference` stgSchools)
forM_ symDiff $ \ssh -> if forM_ symDiff $ \ssh -> if
@ -252,7 +296,7 @@ postProfileR = do
} }
[ UserSchoolIsOptOut =. True [ UserSchoolIsOptOut =. True
] ]
addMessageI Info MsgSettingsUpdate addMessageI Success MsgSettingsUpdate
redirect $ ProfileR :#: ProfileSettings redirect $ ProfileR :#: ProfileSettings
((tokenRes, tokenFormWidget), tokenEnctype) <- runFormPost . identifyForm ProfileResetTokens $ buttonForm ((tokenRes, tokenFormWidget), tokenEnctype) <- runFormPost . identifyForm ProfileResetTokens $ buttonForm
@ -286,6 +330,7 @@ postProfileR = do
, formAnchor = Just ProfileResetTokens , formAnchor = Just ProfileResetTokens
} }
tokenExplanation = $(i18nWidgetFile "profile/tokenExplanation") tokenExplanation = $(i18nWidgetFile "profile/tokenExplanation")
displayNameRules = $(i18nWidgetFile "profile/displayNameRules")
$(widgetFile "profile/profile") $(widgetFile "profile/profile")
@ -726,3 +771,65 @@ postUserNotificationR cID = do
siteLayoutMsg (MsgNotificationSettingsHeading userDisplayName) $ do siteLayoutMsg (MsgNotificationSettingsHeading userDisplayName) $ do
setTitleI $ MsgNotificationSettingsHeading userDisplayName setTitleI $ MsgNotificationSettingsHeading userDisplayName
formWidget formWidget
data ButtonSetDisplayEmail = BtnSetDisplayEmail
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
instance Universe ButtonSetDisplayEmail
instance Finite ButtonSetDisplayEmail
nullaryPathPiece ''ButtonSetDisplayEmail $ camelToPathPiece' 1
embedRenderMessage ''UniWorX ''ButtonSetDisplayEmail id
instance Button UniWorX ButtonSetDisplayEmail where
btnClasses _ = [BCIsButton]
getSetDisplayEmailR, postSetDisplayEmailR :: Handler Html
getSetDisplayEmailR = postSetDisplayEmailR
postSetDisplayEmailR = do
uid <- requireAuthId
mDisplayEmail <- requireCurrentTokenRestrictions
case mDisplayEmail of
Nothing -> invalidArgs ["Bearer token required"]
Just displayEmail -> do
((btnRes, btnView), btnEnc) <- runFormPost $ formEmbedJwtPost buttonForm
let btnView' = wrapForm btnView def
{ formSubmit = FormNoSubmit
, formAction = Just $ SomeRoute SetDisplayEmailR
, formEncoding = btnEnc
}
formResult btnRes $ \case
BtnSetDisplayEmail -> do
runDB $
update uid [UserDisplayEmail =. displayEmail]
addMessageI Success MsgUserDisplayEmailChanged
redirect ProfileR
siteLayoutMsg MsgTitleChangeUserDisplayEmail $ do
setTitleI MsgTitleChangeUserDisplayEmail
$(i18nWidgetFile "set-display-email")
getCsvOptionsR, postCsvOptionsR :: Handler Html
getCsvOptionsR = postCsvOptionsR
postCsvOptionsR = do
Entity uid User{userCsvOptions} <- requireAuth
((optionsRes, optionsWgt'), optionsEnctype) <- runFormPost . renderAForm FormStandard $
csvOptionsForm (fslI MsgCsvOptions & setTooltip MsgCsvOptionsTip) (Just userCsvOptions)
formResultModal optionsRes CsvOptionsR $ \opts -> do
lift . runDB $ update uid [ UserCsvOptions =. opts ]
tell . pure =<< messageI Success MsgCsvOptionsUpdated
siteLayoutMsg MsgCsvOptions $ do
setTitleI MsgCsvOptions
isModal <- hasCustomHeader HeaderIsModal
wrapForm optionsWgt' def
{ formAction = Just $ SomeRoute CsvOptionsR
, formEncoding = optionsEnctype
, formAttrs = [ asyncSubmitAttr | isModal ]
}

3
src/Handler/School.hs
View File

@ -2,7 +2,6 @@ module Handler.School where
import Import import Import
import Handler.Utils import Handler.Utils
import Handler.Utils.Table.Columns
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
@ -71,7 +70,7 @@ mkSchoolForm mSsh template = renderAForm FormStandard $ SchoolForm
<*> areq (textField & cfStrip & cfCI) (fslI MsgSchoolName) (sfName <$> template) <*> areq (textField & cfStrip & cfCI) (fslI MsgSchoolName) (sfName <$> template)
<*> (Set.fromList . mapMaybe (fmap CI.mk . assertM' (not . Text.null) . Text.strip . CI.original) <$> massInputListA (ciField & addDatalist ldapOrgs) (const "") (const Nothing) ("ldap-organisations" :: Text) (fslI MsgSchoolLdapOrganisations & setTooltip MsgSchoolLdapOrganisationsTip) False (Set.toList . sfOrgUnits <$> template)) <*> (Set.fromList . mapMaybe (fmap CI.mk . assertM' (not . Text.null) . Text.strip . CI.original) <$> massInputListA (ciField & addDatalist ldapOrgs) (const "") (const Nothing) ("ldap-organisations" :: Text) (fslI MsgSchoolLdapOrganisations & setTooltip MsgSchoolLdapOrganisationsTip) False (Set.toList . sfOrgUnits <$> template))
where where
ldapOrgs :: HandlerT UniWorX IO (OptionList (CI Text)) ldapOrgs :: HandlerFor UniWorX (OptionList (CI Text))
ldapOrgs = fmap (mkOptionList . map (\t -> Option (CI.original t) t (CI.original t)) . Set.toAscList) . runDB $ ldapOrgs = fmap (mkOptionList . map (\t -> Option (CI.original t) t (CI.original t)) . Set.toAscList) . runDB $
setOf (folded . _entityVal . _schoolLdapOrgUnit) <$> selectList [] [] setOf (folded . _entityVal . _schoolLdapOrgUnit) <$> selectList [] []

Some files were not shown because too many files have changed in this diff Show More