Merge branch 'master' into 455-datepicker-interagieren-schlecht-mit-modals
This commit is contained in:
Sarah Vaupel
commit
bd97587ee5
391
CHANGELOG.md
391
CHANGELOG.md
@ -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.
|
||||
|
||||
## [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)
|
||||
|
||||
|
||||
|
||||
36
README.md
36
README.md
@ -5,6 +5,14 @@ The following description applies to Ubuntu and similar debian based Linux distr
|
||||
## Prerequisites
|
||||
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 this repository and navigate into it
|
||||
```sh
|
||||
@ -41,7 +49,7 @@ You'll get a prompt:
|
||||
|
||||
```sh
|
||||
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
|
||||
...
|
||||
```
|
||||
@ -89,18 +97,6 @@ $ sudo apt-get install pkg-config
|
||||
$ 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 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
|
||||
```
|
||||
|
||||
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
|
||||
After building the app you can prepare the database and add some dummy data:
|
||||
```sh
|
||||
@ -118,7 +126,7 @@ $ ./db.sh -f
|
||||
|
||||
## Run Uni2work
|
||||
```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.
|
||||
|
||||
@ -67,7 +67,7 @@ update = do
|
||||
restartAppInNewThread tidStore = modifyStoredIORef tidStore $ \tid -> do
|
||||
killThread tid
|
||||
withStore doneStore takeMVar
|
||||
readStore doneStore >>= start
|
||||
withStore doneStore start
|
||||
|
||||
|
||||
-- | Start the server in a separate thread.
|
||||
@ -77,10 +77,7 @@ update = do
|
||||
(port, site, app) <- getApplicationRepl
|
||||
resourceForkIO $ do
|
||||
finally (liftIO $ runSettings (setPort port defaultSettings) app)
|
||||
-- Note that this implies concurrency
|
||||
-- between shutdownApp and the next app that is starting.
|
||||
-- Normally this should be fine
|
||||
(liftIO $ putMVar done () >> shutdownApp site)
|
||||
(liftIO $ shutdownApp site `finally` putMVar done ())
|
||||
|
||||
-- | kill the server
|
||||
shutdown :: IO ()
|
||||
|
||||
13
clean.sh
13
clean.sh
@ -10,6 +10,8 @@ case $1 in
|
||||
;;
|
||||
*)
|
||||
target=".stack-work-${1}"
|
||||
shift
|
||||
|
||||
if [[ ! -d "${target}" ]]; then
|
||||
printf "%s does not exist or is no directory\n" "${target}" >&2
|
||||
exit 1
|
||||
@ -20,7 +22,11 @@ case $1 in
|
||||
fi
|
||||
|
||||
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
|
||||
}
|
||||
|
||||
@ -28,6 +34,9 @@ case $1 in
|
||||
mv -v "${target}" .stack-work
|
||||
trap move-back EXIT
|
||||
|
||||
stack clean
|
||||
(
|
||||
set -ex
|
||||
stack clean $@
|
||||
)
|
||||
;;
|
||||
esac
|
||||
|
||||
@ -24,8 +24,8 @@ job-flush-interval: "_env:JOB_FLUSH:30"
|
||||
job-cron-interval: "_env:CRON_INTERVAL:60"
|
||||
job-stale-threshold: 300
|
||||
notification-rate-limit: 3600
|
||||
notification-collate-delay: 300
|
||||
notification-expiration: 259201
|
||||
notification-collate-delay: 7200
|
||||
notification-expiration: 259200
|
||||
session-timeout: 7200
|
||||
jwt-expiration: 604800
|
||||
jwt-encoding: HS256
|
||||
@ -122,13 +122,23 @@ widget-memcached:
|
||||
expiration: "_env:MEMCACHEDEXPIRATION:3600"
|
||||
|
||||
user-defaults:
|
||||
max-favourites: 12
|
||||
theme: Default
|
||||
date-time-format: "%a %d %b %Y %R"
|
||||
date-format: "%d.%m.%Y"
|
||||
time-format: "%R"
|
||||
download-files: false
|
||||
warning-days: 1209600
|
||||
max-favourites: 12
|
||||
max-favourite-terms: 2
|
||||
theme: Default
|
||||
date-time-format: "%a %d %b %Y %R"
|
||||
date-format: "%d.%m.%Y"
|
||||
time-format: "%R"
|
||||
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"
|
||||
ribbon: "_env:RIBBON:"
|
||||
|
||||
@ -8,3 +8,5 @@ log-settings:
|
||||
destination: "test.log"
|
||||
|
||||
auth-dummy-login: true
|
||||
|
||||
job-workers: 1
|
||||
|
||||
@ -56,6 +56,10 @@
|
||||
font-size: 18px;
|
||||
padding-left: 10px;
|
||||
}
|
||||
|
||||
.asidenav__box-subtitle {
|
||||
display: none;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
@ -95,6 +99,14 @@
|
||||
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 */
|
||||
|
||||
.asidenav__logo {
|
||||
@ -170,7 +182,7 @@
|
||||
position: absolute;
|
||||
bottom: -40px;
|
||||
right: 25px;
|
||||
opacity: 0.2;
|
||||
opacity: 0.1;
|
||||
|
||||
> img {
|
||||
width: 350px;
|
||||
@ -314,8 +326,16 @@
|
||||
color: var(--color-lightwhite);
|
||||
|
||||
&:hover {
|
||||
background-color: var(--color-dark);
|
||||
background-color: var(--color-darker);
|
||||
}
|
||||
|
||||
&::before {
|
||||
display: none;
|
||||
}
|
||||
}
|
||||
|
||||
.asidenav__box-subtitle {
|
||||
display: none;
|
||||
}
|
||||
|
||||
.asidenav__link-shorthand {
|
||||
|
||||
@ -25,17 +25,6 @@ const FORM_DATE_FORMAT_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.
|
||||
* 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!');
|
||||
}
|
||||
|
||||
// format any existing dates to fancy display format on pageload
|
||||
this.formatElementValue(true);
|
||||
|
||||
// initialize tail.datetime (datepicker) instance
|
||||
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
|
||||
this._element.form.addEventListener('submit', () => this.formatElementValue());
|
||||
|
||||
// format any existing dates to fancy display format on pageload
|
||||
this.formatElementValue(true);
|
||||
}
|
||||
|
||||
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.
|
||||
*/
|
||||
formatElementValue(toFancy) {
|
||||
const dp = this.datepickerInstance;
|
||||
if (this._element.value) {
|
||||
if (toFancy) {
|
||||
const parsedDate = parseDateWithFormat(this._element.value, FORM_DATE_FORMAT[this.elementType]);
|
||||
if (parsedDate) dp.selectDate();
|
||||
} else {
|
||||
this._element.value = this.unformat();
|
||||
}
|
||||
this._element.value = this.unformat(toFancy);
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
|
||||
/**
|
||||
* 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() {
|
||||
return reformatDateString(this._element.value, FORM_DATE_FORMAT_MOMENT[this.elementType], FORM_DATE_FORMAT[this.elementType]);
|
||||
unformat(toFancy) {
|
||||
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 formData;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
@ -33,11 +33,14 @@
|
||||
margin: 7px 0;
|
||||
}
|
||||
|
||||
.form-section-title__hint {
|
||||
margin-top: 7px;
|
||||
.form-group__hint, .form-section-title__hint {
|
||||
color: var(--color-fontsec);
|
||||
font-size: 0.9rem;
|
||||
font-weight: 600;
|
||||
}
|
||||
|
||||
.form-section-title__hint {
|
||||
margin-top: 7px;
|
||||
|
||||
+ .form-group {
|
||||
margin-top: 11px;
|
||||
@ -58,6 +61,7 @@
|
||||
.form-group--required .form-group-label__caption::after, .form-group__required-marker::before {
|
||||
content: ' *';
|
||||
color: var(--color-error);
|
||||
font-weight: 600;
|
||||
}
|
||||
|
||||
.form-group--optional {
|
||||
|
||||
@ -1,8 +1,7 @@
|
||||
.tooltip {
|
||||
position: relative;
|
||||
display: inline-block;
|
||||
height: 1.5rem;
|
||||
vertical-align: -0.375rem;
|
||||
vertical-align: middle;
|
||||
|
||||
&:hover .tooltip__content {
|
||||
display: inline-block;
|
||||
@ -10,13 +9,10 @@
|
||||
}
|
||||
|
||||
.tooltip__handle {
|
||||
background-color: var(--color-dark);
|
||||
border-radius: 50%;
|
||||
color: var(--color-light);
|
||||
height: 1.5rem;
|
||||
width: 1.5rem;
|
||||
line-height: 1.5rem;
|
||||
font-size: 1.2rem;
|
||||
color: white;
|
||||
display: inline-block;
|
||||
text-align: center;
|
||||
margin: 0 10px;
|
||||
@ -24,27 +20,45 @@
|
||||
position: relative;
|
||||
|
||||
&::before {
|
||||
content: '\f128';
|
||||
position: absolute;
|
||||
top: 0;
|
||||
left: 0;
|
||||
font-family: 'Font Awesome 5 Free';
|
||||
top: 50%;
|
||||
left: 50%;
|
||||
transform: translate(-50%, -50%);
|
||||
font-size: 15px;
|
||||
}
|
||||
|
||||
&.tooltip__handle--danger::before {
|
||||
content: '\f12a';
|
||||
&.tooltip__handle.urgency__success {
|
||||
color: var(--color-success);
|
||||
}
|
||||
|
||||
&.tooltip__handle--danger {
|
||||
background-color: var(--color-warning);
|
||||
&.tooltip__handle.urgency__warning {
|
||||
color: var(--color-warning);
|
||||
}
|
||||
&.tooltip__handle.urgency__error {
|
||||
color: var(--color-error);
|
||||
}
|
||||
|
||||
&: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;
|
||||
top: -10px;
|
||||
transform: translateY(-100%);
|
||||
right: 3px;
|
||||
left: 3px;
|
||||
width: 275px;
|
||||
z-index: 10;
|
||||
background-color: #fafafa;
|
||||
@ -68,7 +82,7 @@
|
||||
background-color: #fafafa;
|
||||
transform: rotate(45deg);
|
||||
position: absolute;
|
||||
right: 10px;
|
||||
left: 10px;
|
||||
bottom: -8px;
|
||||
}
|
||||
}
|
||||
|
||||
@ -15,4 +15,4 @@ if [[ -d .stack-work-doc ]]; then
|
||||
trap move-back EXIT
|
||||
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 ${@}
|
||||
|
||||
@ -1,5 +1,7 @@
|
||||
#!/usr/bin/env bash
|
||||
|
||||
[[ -n "${FORCE_RELEASE}" ]] && exit 0
|
||||
|
||||
set -e
|
||||
|
||||
if [ -n "$(git status --porcelain)" ]; then
|
||||
|
||||
@ -36,6 +36,10 @@ RegisterTo: Anmeldungen bis
|
||||
DeRegUntil: Abmeldungen bis
|
||||
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
|
||||
GenericShort: Kürzel
|
||||
GenericIsNew: Neu
|
||||
@ -173,6 +177,7 @@ CourseApplicationTemplateApplication: Bewerbungsvorlage(n)
|
||||
CourseApplicationTemplateRegistration: Anmeldungsvorlage(n)
|
||||
CourseApplicationTemplateArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-bewerbungsvorlagen
|
||||
CourseApplication: Bewerbung
|
||||
CourseApplicationIsParticipant: Kursteilnehmer
|
||||
|
||||
CourseApplicationExists: Sie haben sich bereits für diesen Kurs beworben
|
||||
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.
|
||||
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.
|
||||
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.
|
||||
UnauthorizedLecturer: Sie sind nicht als Veranstalter für diese Veranstaltung 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.
|
||||
UnauthorizedExamResult: Sie haben keine Ergebnisse in dieser Prüfung.
|
||||
UnauthorizedParticipant: Angegebener Benutzer ist nicht als Teilnehmer dieser Veranstaltung registriert.
|
||||
UnauthorizedCourseNewsParticipant: Sie sind kein Teilnehmer dieser Veranstaltung.
|
||||
UnauthorizedCourseTime: Dieses Kurs erlaubt momentan keine Anmeldungen.
|
||||
UnauthorizedAllocationRegisterTime: Diese Zentralanmeldung erlaubt momentan keine Bewerbungen.
|
||||
UnauthorizedSheetTime: Dieses Übungsblatt ist momentan nicht freigegeben.
|
||||
UnauthorizedApplicationTime: Diese Bewerbung ist momentan nicht freigegeben.
|
||||
UnauthorizedMaterialTime: Dieses Material ist momentan nicht freigegeben.
|
||||
UnauthorizedTutorialTime: Dieses Tutorium erlaubt momentan keine Anmeldungen.
|
||||
UnauthorizedCourseNewsTime: Diese Nachricht ist momentan nicht freigegeben.
|
||||
UnauthorizedExamTime: Diese Prüfung ist momentan nicht freigegeben.
|
||||
UnauthorizedSubmissionOwner: Sie sind an dieser Abgabe nicht beteiligt.
|
||||
UnauthorizedSubmissionRated: Diese Abgabe ist noch nicht korrigiert.
|
||||
@ -471,7 +480,9 @@ LdapSynced: LDAP-Synchronisiert
|
||||
LdapSyncedBefore: Letzte LDAP-Synchronisation vor
|
||||
NoMatrikelKnown: Keine Matrikelnummer
|
||||
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
|
||||
Ident: Identifikation
|
||||
LastLogin: Letzter Login
|
||||
@ -638,6 +649,7 @@ UserSchoolsTip: Sie erhalten nur institutweite Benachrichtigungen für Institute
|
||||
FormNotifications: Benachrichtigungen
|
||||
FormBehaviour: Verhalten
|
||||
FormCosmetics: Oberfläche
|
||||
FormPersonalAppearance: Öffentliche Daten
|
||||
FormFieldRequiredTip: Gekennzeichnete Pflichtfelder sind immer auszufüllen
|
||||
|
||||
ActiveAuthTags: Aktivierte Authorisierungsprädikate
|
||||
@ -688,6 +700,9 @@ UploadModeSpecific: Upload, vorgegebene Dateinamen
|
||||
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.
|
||||
|
||||
AutoUnzip: ZIPs automatisch entpacken
|
||||
AutoUnzipInfo: Entpackt hochgeladene ZIP-Dateien (*.zip) automatisch und fügt den Inhalt dem Stamm-Verzeichnis hinzu.
|
||||
|
||||
UploadModeExtensionRestriction: Zulässige Dateiendungen
|
||||
UploadModeExtensionRestrictionTip: Komma-separiert. Wenn keine Dateiendungen angegeben werden erfolgt keine Einschränkung.
|
||||
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
|
||||
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
|
||||
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
|
||||
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.
|
||||
MailLecturerRights n@Int: Als Dozent dürfen Sie Veranstaltungen innerhalb #{pluralDE n "Ihres Instituts" "Ihrer Institute"} anlegen.
|
||||
|
||||
MailSubjectUserAuthModeUpdate: Änderung Ihres Uni2work-Anmeldemodus
|
||||
UserAuthModePWHashChangedToLDAP: Sie melden sich nun mit Ihrer Campus-Kennung an
|
||||
UserAuthModeLDAPChangedToPWHash: Sie melden sich nun mit einer Uni2work-internen Kennung an
|
||||
MailSubjectUserAuthModeUpdate: Ihr Uni2work-Login
|
||||
UserAuthModePWHashChangedToLDAP: Sie können sich nun mit Ihrer Campus-Kennung in Uni2work einloggen
|
||||
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:
|
||||
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.
|
||||
@ -796,8 +831,10 @@ MailSubjectSupportCustom customSubject@Text: [Support] #{customSubject}
|
||||
CommCourseSubject: Kursmitteilung
|
||||
MailSubjectLecturerInvitation tid@TermId ssh@SchoolId csh@CourseShorthand: [#{tid}-#{ssh}-#{csh}] Einladung zum Kursverwalter
|
||||
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}
|
||||
|
||||
@ -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}
|
||||
|
||||
MailSubjectExamOfficeUserInvitation displayName@Text: Berücksichtigung von Prüfungsleistungen in Uni2work
|
||||
|
||||
MailSubjectPasswordReset: Uni2work-Passwort ändern bzw. setzen
|
||||
|
||||
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
|
||||
NotificationTriggerUserRightsUpdate: Meine Berechtigungen wurden 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
|
||||
NotificationTriggerAllocationStaffRegister: Ich kann Kurse bei einer neuen Zentralanmeldung eintragen
|
||||
NotificationTriggerAllocationAllocation: Ich kann Zentralanmeldung-Bewerbungen für einen meiner Kurse bewerten
|
||||
NotificationTriggerAllocationRegister: Ich kann mich bei einer neuen Zentralanmeldung bewerben
|
||||
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
|
||||
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
|
||||
NotificationTriggerKindCourseParticipant: Für Kursteilnehmer
|
||||
NotificationTriggerKindExamParticipant: Für Prüfungsteilnehmer
|
||||
NotificationTriggerKindCorrector: Für Korrektoren
|
||||
NotificationTriggerKindLecturer: Für Dozenten
|
||||
NotificationTriggerKindCourseLecturer: Für Kursverwalter
|
||||
NotificationTriggerKindAdmin: Für Administratoren
|
||||
NotificationTriggerKindExamOffice: Für das Prüfungsamt
|
||||
NotificationTriggerKindEvaluation: Für Vorlesungsumfragen
|
||||
NotificationTriggerKindAllocationStaff: Für Zentralanmeldungen
|
||||
NotificationTriggerKindAllocationStaff: Für Zentralanmeldungen (Dozenten)
|
||||
NotificationTriggerKindAllocationParticipant: Für Zentralanmeldungen
|
||||
|
||||
CorrCreate: Abgaben erstellen
|
||||
UnknownPseudonymWord pseudonymWord@Text: Unbekanntes Pseudonym-Wort "#{pseudonymWord}"
|
||||
@ -993,11 +1041,13 @@ MenuAllocationList: Zentralanmeldungen
|
||||
MenuCourseList: Kurse
|
||||
MenuCourseMembers: Kursteilnehmer
|
||||
MenuCourseAddMembers: Kursteilnehmer hinzufügen
|
||||
MenuCourseCommunication: Kursmitteilung
|
||||
MenuCourseCommunication: Kursmitteilung (E-Mail)
|
||||
MenuCourseApplications: Bewerbungen
|
||||
MenuCourseExamOffice: Prüfungsämter
|
||||
MenuTermShow: Semester
|
||||
MenuSubmissionDelete: Abgabe löschen
|
||||
MenuUsers: Benutzer
|
||||
MenuUserAdd: Benutzer anlegen
|
||||
MenuUserNotifications: Benachrichtigungs-Einstellungen
|
||||
MenuUserPassword: Passwort
|
||||
MenuAdminTest: Admin-Demo
|
||||
@ -1045,18 +1095,25 @@ MenuExamList: Prüfungen
|
||||
MenuExamNew: Neue Prüfung anlegen
|
||||
MenuExamEdit: Bearbeiten
|
||||
MenuExamUsers: Teilnehmer
|
||||
MenuExamGrades: Prüfungsleistungen
|
||||
MenuExamAddMembers: Prüfungsteilnehmer hinzufügen
|
||||
MenuExamOfficeExams: Prüfungen
|
||||
MenuExamOfficeFields: Fächer
|
||||
MenuExamOfficeUsers: Benutzer
|
||||
MenuLecturerInvite: Dozenten hinzufügen
|
||||
MenuAllocationInfo: Hinweise zum Ablauf einer Zentralanmeldung
|
||||
MenuCourseApplicationsFiles: Dateien aller Bewerbungen
|
||||
MenuSchoolList: Institute
|
||||
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.
|
||||
AuthPredsActive: Aktive Authorisierungsprädikate
|
||||
AuthPredsActiveChanged: Authorisierungseinstellungen für aktuelle Sitzung gespeichert
|
||||
AuthTagFree: Seite ist universell zugänglich
|
||||
AuthTagAdmin: Nutzer ist Administrator
|
||||
AuthTagExamOffice: Nutzer ist Teil eines Prüfungsamts
|
||||
AuthTagToken: Nutzer präsentiert Authorisierungs-Token
|
||||
AuthTagNoEscalation: Nutzer-Rechte werden nicht auf fremde Institute ausgeweitet
|
||||
AuthTagDeprecated: Seite ist nicht überholt
|
||||
@ -1089,6 +1146,7 @@ AuthTagRead: Zugriff ist nur lesend
|
||||
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.
|
||||
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
|
||||
DeleteConfirmationWrong: Bestätigung muss genau dem angezeigten Text entsprechen.
|
||||
|
||||
@ -1101,10 +1159,14 @@ NavigationFavourites: Favoriten
|
||||
|
||||
CommSubject: Betreff
|
||||
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
|
||||
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
|
||||
CommSuccess n@Int: Nachricht wurde an #{n} Empfänger versandt
|
||||
CommUndisclosedRecipients: Verborgene Empfänger
|
||||
CommAllRecipients: alle-empfaenger
|
||||
|
||||
CommCourseHeading: Kursmitteilung
|
||||
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}
|
||||
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
|
||||
InvitationActionTip: Abgelehnte Einladungen können nicht mehr angenommen werden
|
||||
InvitationMissingRestrictions: Authorisierungs-Token fehlen benötigte Daten
|
||||
@ -1246,6 +1312,9 @@ HealthSMTPConnect: SMTP-Server kann erreicht werden
|
||||
HealthWidgetMemcached: Memcached-Server liefert Widgets korrekt aus
|
||||
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
|
||||
CourseParticipantsInvited n@Int: #{n} #{pluralDE n "Einladung" "Einladungen"} per E-Mail verschickt
|
||||
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
|
||||
ExamPublishOccurrenceAssignmentsParticipant: Termin- bzw. Raumzuteilung einsehbar ab
|
||||
ExamFinished: Bewertung abgeschlossen ab
|
||||
ExamFinishedOffice: Noten bekannt gegeben
|
||||
ExamFinishedParticipant: Bewertung vorrausichtlich abgeschlossen
|
||||
ExamFinishedTip: Zeitpunkt zu dem Prüfungergebnisse den Teilnehmern gemeldet werden
|
||||
ExamClosed: Noten stehen fest ab
|
||||
ExamClosedTip: Zeitpunkt ab dem keine Änderungen an den Ergebnissen zulässig sind; Prüfungsämter bekommen Einsicht
|
||||
ExamShowGrades: Noten anzeigen
|
||||
ExamShowGradesTip: Soll den Teilnehmern ihre genaue Note angezeigt werden, oder sollen sie nur informiert werden, ob sie bestanden haben?
|
||||
ExamClosed: Noten gemeldet
|
||||
ExamClosedTip: Prüfungsämter, die im System Noten einsehen, werden zu diesem Zeitpunkt benachrichtigt und danach bei Änderungen informiert
|
||||
ExamShowGrades: Klausur ist benotet
|
||||
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
|
||||
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
|
||||
ExamGradingManual': Keine automatische Berechnung
|
||||
ExamGradingKey': Nach Schlü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
|
||||
PointsMustBeNonNegative: Punktegrenzen dürfen nicht negativ sein
|
||||
PointsMustBeMonotonic: Punktegrenzen müssen aufsteigend sein
|
||||
GradingFrom: Ab
|
||||
ExamNew: Neue Prüfung
|
||||
ExamBonus: Bonuspunkte-System
|
||||
ExamBonusRule: Prüfungsbonus aus Übungsbetrieb
|
||||
ExamNoBonus': Kein automatischer Bonus
|
||||
ExamBonusPoints': Umrechnung von Übungspunkten
|
||||
ExamBonusManual': Manuelle Berechnung
|
||||
|
||||
ExamBonusAchieved: Bonuspunkte
|
||||
|
||||
ExamEditHeading examn@ExamName: #{examn} bearbeiten
|
||||
|
||||
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
|
||||
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
|
||||
ExamRoomManual': Keine automatische Zuteilung
|
||||
ExamRoomSurname': Nach Nachname
|
||||
@ -1334,6 +1416,8 @@ ExamRoomDescription: Beschreibung
|
||||
ExamTimeTip: Nur zur Information der Studierenden, die tatsächliche Zeitangabe erfolgt pro Prüfung
|
||||
ExamRoomRegistered: Zugeteilt
|
||||
|
||||
ExamOccurrenceStart: Prüfungsbeginn
|
||||
|
||||
ExamFormTimes: Zeiten
|
||||
ExamFormOccurrences: Prüfungstermine/Räume
|
||||
ExamFormAutomaticFunctions: Automatische Funktionen
|
||||
@ -1343,12 +1427,17 @@ ExamFormParts: Teile
|
||||
ExamCorrectors: Korrektoren
|
||||
ExamCorrectorAlreadyAdded: Ein Korrektor mit dieser E-Mail ist bereits für diese Prüfung eingetragen
|
||||
|
||||
ExamParts: Teilaufgaben
|
||||
ExamPartWeightNegative: Gewicht aller Teilaufgaben muss größer oder gleich Null sein
|
||||
ExamPartAlreadyExists: Teilaufgabe mit diesem Namen existiert bereits
|
||||
ExamPartName: Name
|
||||
ExamParts: Teilprüfungen/Aufgaben
|
||||
ExamPartWeightNegative: Gewicht aller Teilprüfungen muss größer oder gleich Null sein
|
||||
ExamPartAlreadyExists: Teilprüfung mit diesem Namen existiert bereits
|
||||
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
|
||||
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
|
||||
|
||||
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
|
||||
ExamVoided: Entwertet
|
||||
|
||||
ExamBonusManualParticipants: Von den Kursverwaltern manuell berechnet
|
||||
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
|
||||
|
||||
@ -1391,11 +1481,30 @@ VersionHistory: Versionsgeschichte
|
||||
KnownBugs: Bekannte Bugs
|
||||
ImplementationDetails: Implementierung
|
||||
|
||||
ExamSynchronised: Synchronisiert
|
||||
|
||||
ExamUsersHeading: Prüfungsteilnehmer
|
||||
ExamUserDeregister: Teilnehmer von Prüfung abmelden
|
||||
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
|
||||
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
|
||||
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)}%)
|
||||
|
||||
CsvColumnsExplanationsLabel: Spalten
|
||||
CsvColumnsExplanationsTip: Bedeutung der in der CSV-Datei enthaltenen Spalten
|
||||
CourseUserCsvName tid@TermId ssh@SchoolId csh@CourseShorthand: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-teilnehmer
|
||||
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
|
||||
CsvColumnExamUserFirstName: Vorname(n) des Teilnehmers
|
||||
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
|
||||
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
|
||||
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")
|
||||
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
|
||||
CsvColumnApplicationsApplication: Eindeutige Nummer der Bewerbung (zur Zuordnung im ZIP-Archiv aller Bewerbungsdateien)
|
||||
CsvColumnApplicationsName: Voller Name des Bewerbers
|
||||
@ -1441,7 +1568,7 @@ CsvColumnApplicationsSemester: Fachsemester des Bewerbes im assoziierten Studien
|
||||
CsvColumnApplicationsText: Text-Bewerbung
|
||||
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
|
||||
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
|
||||
|
||||
Action: Aktion
|
||||
@ -1457,8 +1584,13 @@ ExamUserCsvRegister: Kursteilnehmer zur Prüfung anmelden
|
||||
ExamUserCsvAssignOccurrence: Teilnehmern einen anderen Termin/Raum zuweisen
|
||||
ExamUserCsvDeregister: Teilnehmer von der Prüfung abmelden
|
||||
ExamUserCsvSetCourseField: Kurs-assoziiertes Studienfach ändern
|
||||
ExamUserCsvOverrideBonus: Bonuspunkte entgegen Bonusregelung überschreiben
|
||||
ExamUserCsvOverrideResult: Ergebnis entgegen automatischer Notenberechnung überschreiben
|
||||
ExamUserCsvSetBonus: Bonuspunkte eintragen
|
||||
ExamUserCsvSetResult: Ergebnis eintragen
|
||||
ExamUserCsvSetPartResult: Ergebnis einer Teilprüfung eintragen
|
||||
ExamUserCsvSetCourseNote: Teilnehmer-Notizen anpassen
|
||||
ExamBonusNone: Keine Bonuspunkte
|
||||
|
||||
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
|
||||
AllocationTitle termText@Text ssh'@SchoolShorthand allocation@AllocationName: #{termText} - #{ssh'}: #{allocation}
|
||||
AllocationShortTitle termText@Text ssh'@SchoolShorthand ash@AllocationShorthand: #{termText} - #{ssh'} - #{ash}
|
||||
AllocationSchool: Institut
|
||||
AllocationSemester: Semester
|
||||
AllocationDescription: Beschreibung
|
||||
AllocationStaffDescription: Beschreibung für Dozenten
|
||||
AllocationStaffRegisterFrom: Eintragung der Kurse ab
|
||||
AllocationStaffRegister: Eintragung der Kurse
|
||||
AllocationRegisterFrom: Bewerbung ab
|
||||
@ -1539,6 +1674,13 @@ AllocationRegisterClosed: Die Zentralanmeldung ist aktuell geschlossen.
|
||||
AllocationRegisterOpensIn difftime@Text: Die Zentralanmeldung öffnet voraussichtlich in #{difftime}
|
||||
AllocationStaffAllocationFrom: Bewertung der Bewerbungen ab
|
||||
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
|
||||
AllocationNoApplication: Keine Bewerbung
|
||||
AllocationPriority: Priorität
|
||||
@ -1586,9 +1728,16 @@ CourseApplicationNoVeto: Kein Veto
|
||||
CourseApplicationNoRatingPoints: Keine Bewertung
|
||||
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
|
||||
|
||||
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
|
||||
SchoolName: Name
|
||||
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
|
||||
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
|
||||
|
||||
@ -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
|
||||
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
|
||||
fingerprint AllocationFingerprint Maybe
|
||||
matchingLog FileId Maybe
|
||||
TermSchoolAllocationShort term school shorthand -- shorthand must be unique within school and semester
|
||||
TermSchoolAllocationName term school name -- name must be unique within school and semester
|
||||
deriving Show Eq Ord Generic
|
||||
@ -35,6 +37,7 @@ AllocationUser
|
||||
allocation AllocationId
|
||||
user UserId
|
||||
totalCourses Natural -- number of total allocated courses for this user must be <= than this number
|
||||
priority AllocationPriority Maybe
|
||||
UniqueAllocationUser allocation user
|
||||
|
||||
AllocationDeregister -- self-inflicted user-deregistrations from an allocated course
|
||||
@ -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
|
||||
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
|
||||
applicationsRequired Bool
|
||||
applicationsRequired Bool default=false
|
||||
applicationsInstructions Html Maybe
|
||||
applicationsText Bool
|
||||
applicationsFiles UploadMode
|
||||
applicationsRatingsVisible Bool
|
||||
applicationsText Bool default=false
|
||||
applicationsFiles UploadMode "default='{\"mode\": \"no-upload\"}'::jsonb"
|
||||
applicationsRatingsVisible Bool default=false
|
||||
TermSchoolCourseShort term school shorthand -- shorthand must be unique within school and semester
|
||||
TermSchoolCourseName term school name -- name must be unique within school and semester
|
||||
deriving Generic
|
||||
@ -35,12 +35,6 @@ CourseEdit -- who edited when a row in table "Course", kept indef
|
||||
user UserId
|
||||
time UTCTime
|
||||
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
|
||||
user UserId
|
||||
course CourseId
|
||||
@ -51,7 +45,7 @@ CourseParticipant -- course enrolement
|
||||
user UserId
|
||||
registration UTCTime -- time of last enrolement for this course
|
||||
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
|
||||
-- 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
|
||||
@ -71,19 +65,8 @@ CourseUserNoteEdit -- who edited a participants course note when
|
||||
time UTCTime
|
||||
note CourseUserNoteId -- PROBLEM: deleted notes have no modification date any more
|
||||
|
||||
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
|
||||
CourseUserExamOfficeOptOut
|
||||
course CourseId
|
||||
user UserId
|
||||
school SchoolId
|
||||
UniqueCourseUserExamOfficeOptOut course user school
|
||||
16
models/courses/applications.model
Normal file
16
models/courses/applications.model
Normal 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
10
models/courses/favourite.model
Normal 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
|
||||
@ -9,4 +9,5 @@ Material -- course material for disemination to course participants
|
||||
deriving Generic
|
||||
MaterialFile -- a file that is part of a material distribution
|
||||
material MaterialId
|
||||
file FileId
|
||||
file FileId
|
||||
UniqueMaterialFile material file
|
||||
12
models/courses/news.model
Normal file
12
models/courses/news.model
Normal 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
14
models/exam-office.model
Normal 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
|
||||
@ -1,9 +1,9 @@
|
||||
Exam
|
||||
course CourseId
|
||||
name ExamName
|
||||
gradingRule ExamGradingRule
|
||||
bonusRule ExamBonusRule
|
||||
occurrenceRule ExamOccurrenceRule
|
||||
gradingRule ExamGradingRule Maybe
|
||||
bonusRule ExamBonusRule Maybe
|
||||
occurrenceRule ExamOccurrenceRule Maybe
|
||||
visibleFrom UTCTime Maybe
|
||||
registerFrom UTCTime Maybe
|
||||
registerTo UTCTime Maybe
|
||||
@ -19,10 +19,12 @@ Exam
|
||||
UniqueExam course name
|
||||
ExamPart
|
||||
exam ExamId
|
||||
name (CI Text)
|
||||
number ExamPartNumber
|
||||
name ExamPartName Maybe
|
||||
maxPoints Points Maybe
|
||||
weight Rational
|
||||
UniqueExamPart exam name
|
||||
UniqueExamPartNumber exam number
|
||||
UniqueExamPartName exam name !force
|
||||
ExamOccurrence
|
||||
exam ExamId
|
||||
name ExamOccurrenceName
|
||||
@ -42,7 +44,14 @@ ExamPartResult
|
||||
examPart ExamPartId
|
||||
user UserId
|
||||
result ExamResultPoints
|
||||
lastChanged UTCTime default=now()
|
||||
UniqueExamPartResult examPart user
|
||||
ExamBonus
|
||||
exam ExamId
|
||||
user UserId
|
||||
bonus Points
|
||||
lastChanged UTCTime default=now()
|
||||
UniqueExamBonus exam user
|
||||
ExamResult
|
||||
exam ExamId
|
||||
user UserId
|
||||
@ -13,4 +13,5 @@ SchoolLdap
|
||||
UniqueOrgUnit orgUnit
|
||||
SchoolTerms
|
||||
school SchoolId
|
||||
terms StudyTermsId
|
||||
terms StudyTermsId
|
||||
UniqueSchoolTerms school terms
|
||||
@ -9,9 +9,10 @@
|
||||
--
|
||||
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'
|
||||
displayName UserDisplayName -- we only show LDAP-DisplayName, and highlight LDAP-Surname within (appended if not contained)
|
||||
email (CI Text) -- Case-insensitive eMail address
|
||||
ident (CI Text) -- Case-insensitive user-identifier
|
||||
displayName UserDisplayName
|
||||
displayEmail UserEmail
|
||||
email UserEmail -- Case-insensitive eMail address
|
||||
ident UserIdent -- Case-insensitive user-identifier
|
||||
authentication AuthenticationMode -- 'AuthLDAP' or ('AuthPWHash'+password-hash)
|
||||
lastAuthentication UTCTime Maybe -- last login date
|
||||
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,...)
|
||||
firstName Text -- For export in tables, pre-split firstName from displayName
|
||||
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
|
||||
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
|
||||
@ -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
|
||||
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
|
||||
csvOptions CsvOptions "default='{}'::jsonb"
|
||||
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
|
||||
deriving Show Eq Ord Generic -- Haskell-specific settings for runtime-value representing a row in memory
|
||||
@ -4,6 +4,6 @@
|
||||
import ((nixpkgs {}).fetchFromGitHub {
|
||||
owner = "NixOS";
|
||||
repo = "nixpkgs";
|
||||
rev = "19.03";
|
||||
sha256 = "0q2m2qhyga9yq29yz90ywgjbn9hdahs7i8wwlq7b55rdbyiwa5dy";
|
||||
rev = "10e61bf5be57736035ec7a804cb0bf3d083bf2cf";
|
||||
sha256 = "0fplfm2zx4vk7gs8bdcxnvzkdmpx2w0llqwf8475z9dz9cl132rm";
|
||||
})
|
||||
|
||||
14
package-lock.json
generated
14
package-lock.json
generated
@ -1,6 +1,6 @@
|
||||
{
|
||||
"name": "uni2work",
|
||||
"version": "6.6.0",
|
||||
"version": "7.10.0",
|
||||
"lockfileVersion": 1,
|
||||
"requires": true,
|
||||
"dependencies": {
|
||||
@ -7702,9 +7702,9 @@
|
||||
"dev": true
|
||||
},
|
||||
"handlebars": {
|
||||
"version": "4.1.2",
|
||||
"resolved": "https://registry.npmjs.org/handlebars/-/handlebars-4.1.2.tgz",
|
||||
"integrity": "sha512-nvfrjqvt9xQ8Z/w0ijewdD/vvWDTOweBUm96NTr66Wfvo1mJenBLwcYmPs3TIBP5ruzYGD7Hx/DaM9RmhroGPw==",
|
||||
"version": "4.3.1",
|
||||
"resolved": "https://registry.npmjs.org/handlebars/-/handlebars-4.3.1.tgz",
|
||||
"integrity": "sha512-c0HoNHzDiHpBt4Kqe99N8tdLPKAnGCQ73gYMPWtAYM4PwGnf7xl8PBUHJqh9ijlzt2uQKaSRxbXRt+rZ7M2/kA==",
|
||||
"dev": true,
|
||||
"requires": {
|
||||
"neo-async": "^2.6.0",
|
||||
@ -15623,9 +15623,9 @@
|
||||
"dev": true
|
||||
},
|
||||
"uglify-js": {
|
||||
"version": "3.5.15",
|
||||
"resolved": "https://registry.npmjs.org/uglify-js/-/uglify-js-3.5.15.tgz",
|
||||
"integrity": "sha512-fe7aYFotptIddkwcm6YuA0HmknBZ52ZzOsUxZEdhhkSsz7RfjHDX2QDxwKTiv4JQ5t5NhfmpgAK+J7LiDhKSqg==",
|
||||
"version": "3.6.0",
|
||||
"resolved": "https://registry.npmjs.org/uglify-js/-/uglify-js-3.6.0.tgz",
|
||||
"integrity": "sha512-W+jrUHJr3DXKhrsS7NUVxn3zqMOFn0hL/Ei6v0anCIMoKC93TjcflTagwIHLW7SfMFfiQuktQyFVCFHGUE0+yg==",
|
||||
"dev": true,
|
||||
"optional": true,
|
||||
"requires": {
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
{
|
||||
"name": "uni2work",
|
||||
"version": "6.6.0",
|
||||
"version": "7.10.0",
|
||||
"description": "",
|
||||
"keywords": [],
|
||||
"author": "",
|
||||
@ -14,7 +14,9 @@
|
||||
"yesod:start": "./start.sh",
|
||||
"yesod:lint": "./hlint.sh",
|
||||
"yesod:test": "./test.sh",
|
||||
"yesod:test:watch": "./test.sh --file-watch",
|
||||
"yesod:build": "./build.sh",
|
||||
"yesod:build:watch": "./build.sh --file-watch",
|
||||
"frontend:lint": "eslint frontend/src",
|
||||
"frontend:test": "karma start --conf karma.conf.js",
|
||||
"frontend:test:watch": "karma start --conf karma.conf.js --single-run false",
|
||||
|
||||
60
package.yaml
60
package.yaml
@ -1,41 +1,39 @@
|
||||
name: uniworx
|
||||
version: 6.6.0
|
||||
version: 7.10.0
|
||||
|
||||
dependencies:
|
||||
# Due to a bug in GHC 8.0.1, we block its usage
|
||||
# See: https://ghc.haskell.org/trac/ghc/ticket/12130
|
||||
- base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5
|
||||
# version 1.0 had a bug in reexporting Handler, causing trouble
|
||||
- classy-prelude-yesod >=0.10.2 && <1.0 || >=1.1
|
||||
- foreign-store
|
||||
- yesod >=1.4.3 && <1.5
|
||||
- yesod-core >=1.4.30 && <1.5
|
||||
- yesod-auth >=1.4.0 && <1.5
|
||||
- yesod-static >=1.4.0.3 && <1.6
|
||||
- yesod-form >=1.4.0 && <1.5
|
||||
- classy-prelude >=0.10.2
|
||||
- classy-prelude-conduit >=0.10.2
|
||||
- bytestring >=0.9 && <0.11
|
||||
- base >=4.9.1.0 && <5
|
||||
- yesod >=1.6 && <1.7
|
||||
- yesod-core >=1.6 && <1.7
|
||||
- yesod-auth >=1.6 && <1.7
|
||||
- yesod-static >=1.6 && <1.7
|
||||
- yesod-form >=1.6 && <1.7
|
||||
- classy-prelude >=1.5 && <1.6
|
||||
- classy-prelude-conduit >=1.5 && <1.6
|
||||
- classy-prelude-yesod >=1.5 && <1.6
|
||||
- bytestring >=0.10 && <0.11
|
||||
- text >=0.11 && <2.0
|
||||
- persistent >=2.7.2 && <2.8
|
||||
- persistent-postgresql >=2.1.1 && <2.8
|
||||
- persistent-template >=2.0 && <2.8
|
||||
- persistent >=2.9 && <2.10
|
||||
- persistent-postgresql >=2.9 && <2.10
|
||||
- persistent-template >=2.5 && <2.9
|
||||
- persistent-qq >=2.9 && <2.10
|
||||
- template-haskell
|
||||
- shakespeare >=2.0 && <2.1
|
||||
- hjsmin >=0.1 && <0.3
|
||||
- monad-control >=0.3 && <1.1
|
||||
- wai-extra >=3.0 && <3.1
|
||||
- yaml >=0.8 && <0.9
|
||||
- http-conduit >=2.1 && <2.3
|
||||
- yaml >=0.11 && <0.12
|
||||
- http-conduit >=2.3 && <2.4
|
||||
- directory >=1.1 && <1.4
|
||||
- warp >=3.0 && <3.3
|
||||
- data-default
|
||||
- aeson >=0.6 && <1.3
|
||||
- aeson >=1.4 && <1.5
|
||||
- conduit >=1.0 && <2.0
|
||||
- conduit-combinators
|
||||
- monad-logger >=0.3 && <0.4
|
||||
- fast-logger >=2.2 && <2.5
|
||||
- wai-logger >=2.2 && <2.4
|
||||
- foreign-store
|
||||
- file-embed
|
||||
- safe
|
||||
- unordered-containers
|
||||
@ -52,11 +50,12 @@ dependencies:
|
||||
- http-api-data
|
||||
- profunctors
|
||||
- colonnade >=1.1.1
|
||||
- yesod-colonnade >=1.1.0
|
||||
- blaze-markup
|
||||
- zip-stream
|
||||
- encoding
|
||||
- filepath
|
||||
- transformers
|
||||
- transformers-base
|
||||
- wl-pprint-text
|
||||
- uuid-types
|
||||
- path-pieces
|
||||
@ -100,8 +99,10 @@ dependencies:
|
||||
- th-abstraction
|
||||
- HaskellNet
|
||||
- HaskellNet-SSL
|
||||
- network
|
||||
- resource-pool
|
||||
- network >=3
|
||||
- network-bsd
|
||||
- unliftio
|
||||
- unliftio-pool
|
||||
- mime-mail
|
||||
- hashable
|
||||
- aeson-pretty
|
||||
@ -116,7 +117,6 @@ dependencies:
|
||||
- pkcs7
|
||||
- memcached-binary
|
||||
- directory-tree
|
||||
- lifted-base
|
||||
- lattices
|
||||
- hsass
|
||||
- semigroupoids
|
||||
@ -126,7 +126,6 @@ dependencies:
|
||||
- mono-traversable
|
||||
- lens-aeson
|
||||
- systemd
|
||||
- lifted-async
|
||||
- streaming-commons
|
||||
- hourglass
|
||||
- unix
|
||||
@ -137,6 +136,10 @@ dependencies:
|
||||
- memory
|
||||
- pqueue
|
||||
- deepseq
|
||||
- multiset
|
||||
- retry
|
||||
- generic-lens
|
||||
- array
|
||||
|
||||
other-extensions:
|
||||
- GeneralizedNewtypeDeriving
|
||||
@ -182,6 +185,7 @@ default-extensions:
|
||||
- DeriveLift
|
||||
- DeriveFunctor
|
||||
- DerivingStrategies
|
||||
- DerivingVia
|
||||
- DataKinds
|
||||
- BinaryLiterals
|
||||
- PolyKinds
|
||||
@ -189,14 +193,18 @@ default-extensions:
|
||||
- TypeApplications
|
||||
- RecursiveDo
|
||||
- TypeFamilyDependencies
|
||||
- QuantifiedConstraints
|
||||
|
||||
ghc-options:
|
||||
- -Wall
|
||||
- -Wmissing-home-modules
|
||||
- -Wredundant-constraints
|
||||
- -fno-warn-type-defaults
|
||||
- -fno-warn-unrecognised-pragmas
|
||||
- -fno-warn-partial-type-signatures
|
||||
- -fno-max-relevant-binds
|
||||
- -j
|
||||
- -freduction-depth=0
|
||||
|
||||
when:
|
||||
- condition: flag(pedantic)
|
||||
|
||||
23
routes
23
routes
@ -51,6 +51,7 @@
|
||||
/users/#CryptoUUIDUser/password UserPasswordR GET POST !selfANDis-pw-hash
|
||||
!/users/functionary-invite/new AdminNewFunctionaryInviteR GET POST
|
||||
!/users/functionary-invite AdminFunctionaryInviteR GET POST
|
||||
!/users/add AdminUserAddR GET POST
|
||||
/admin AdminR GET
|
||||
/admin/features AdminFeaturesR GET POST
|
||||
/admin/test AdminTestR GET POST
|
||||
@ -70,6 +71,14 @@
|
||||
/user ProfileR GET POST !free
|
||||
/user/profile ProfileDataR GET !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/current TermCurrentR GET !free
|
||||
@ -95,7 +104,8 @@
|
||||
!/course/new CourseNewR GET POST !lecturer
|
||||
/course/#TermId/#SchoolId/#CourseShorthand CourseR !lecturer:
|
||||
/ 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
|
||||
/edit CEditR GET POST
|
||||
/lecturer-invite CLecInviteR GET POST
|
||||
@ -107,6 +117,7 @@
|
||||
/correctors CHiWisR GET
|
||||
/communication CCommR GET POST
|
||||
/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/assigned CAssignR GET POST
|
||||
/sheet SheetListR GET !course-registered !materials !corrector
|
||||
@ -156,18 +167,26 @@
|
||||
/exams CExamListR GET !free
|
||||
/exams/new CExamNewR GET POST
|
||||
/exams/#ExamName ExamR:
|
||||
/show EShowR GET !time
|
||||
/show EShowR GET !time !exam-office
|
||||
/edit EEditR GET POST
|
||||
/corrector-invite ECInviteR GET POST
|
||||
/users EUsersR GET POST
|
||||
/users/new EAddUserR GET POST
|
||||
/users/invite EInviteR GET POST
|
||||
/register ERegisterR POST !timeANDcourse-registeredAND¬exam-registered !timeANDexam-registeredAND¬exam-result
|
||||
/grades EGradesR GET POST !exam-office
|
||||
/apps CApplicationsR GET POST
|
||||
!/apps/files CAppsFilesR GET
|
||||
/apps/#CryptoFileNameCourseApplication CourseApplicationR:
|
||||
/ CAEditR GET POST !timeANDself !lecturerANDstaff-time !selfANDread
|
||||
/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/upload CorrectionsUploadR GET POST !corrector !lecturer
|
||||
|
||||
@ -19,7 +19,7 @@ let
|
||||
'';
|
||||
|
||||
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 = ''
|
||||
export PROMPT_INFO="${oldAttrs.name}"
|
||||
|
||||
@ -47,6 +47,12 @@ let
|
||||
set +xe
|
||||
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}
|
||||
'';
|
||||
};
|
||||
|
||||
@ -24,7 +24,7 @@ import Language.Haskell.TH.Syntax (qLocation)
|
||||
import Network.Wai (Middleware)
|
||||
import Network.Wai.Handler.Warp (Settings, defaultSettings,
|
||||
defaultShouldDisplayException,
|
||||
runSettingsSocket, setHost,
|
||||
runSettings, runSettingsSocket, setHost,
|
||||
setBeforeMainLoop,
|
||||
setOnException, setPort, getPort)
|
||||
import Data.Streaming.Network (bindPortTCP)
|
||||
@ -44,7 +44,6 @@ import qualified Data.UUID as UUID
|
||||
import qualified Data.UUID.V4 as UUID
|
||||
|
||||
import System.Directory
|
||||
import System.FilePath
|
||||
|
||||
import Jobs
|
||||
|
||||
@ -55,7 +54,9 @@ import qualified Data.ByteString.Lazy as LBS
|
||||
|
||||
import Network.HaskellNet.SSL 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
|
||||
|
||||
@ -71,17 +72,17 @@ import System.Exit
|
||||
import qualified Database.Memcached.Binary.IO as Memcached
|
||||
|
||||
import qualified System.Systemd.Daemon as Systemd
|
||||
import Control.Concurrent.Async.Lifted.Safe
|
||||
import System.Environment (lookupEnv)
|
||||
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 Network (socketPort)
|
||||
import Network.Socket (socketPort, Socket, PortNumber)
|
||||
import qualified Network.Socket as Socket (close)
|
||||
|
||||
import Control.Concurrent.STM.Delay
|
||||
import Control.Monad.STM (retry)
|
||||
import Control.Monad.Trans.Cont (runContT, callCC)
|
||||
|
||||
import qualified Data.Set as Set
|
||||
|
||||
@ -109,6 +110,7 @@ import Handler.SystemMessage
|
||||
import Handler.Health
|
||||
import Handler.Exam
|
||||
import Handler.Allocation
|
||||
import Handler.ExamOffice
|
||||
|
||||
|
||||
-- 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
|
||||
-- the place to put your migrate statements to have automatic database
|
||||
-- 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
|
||||
-- Some basic initializations: HTTP connection manager, logger, and static
|
||||
-- subsite.
|
||||
@ -146,7 +148,7 @@ makeFoundation appSettings'@AppSettings{..} = do
|
||||
oldLogger <- atomically . swapTVar tVar =<< mkLogger newSettings
|
||||
rmLoggerSet $ loggerSet oldLogger
|
||||
updateLogger newSettings
|
||||
(tVar, ) <$> fork (updateLogger initialSettings)
|
||||
(tVar, ) <$> forkIO (updateLogger initialSettings)
|
||||
appLogger <- over _2 fst <$> allocate mkLogger' (\(tVar, tId) -> killThread tId >> (readTVarIO tVar >>= rmLoggerSet . loggerSet))
|
||||
|
||||
let appStatic = embeddedStatic
|
||||
@ -250,7 +252,7 @@ readInstanceIDFile idFile = liftIO . handle generateInstead $ LBS.readFile idFil
|
||||
instanceId <- UUID.nextRandom
|
||||
LBS.writeFile idFile $ UUID.toByteString instanceId
|
||||
return instanceId
|
||||
| otherwise = throw e
|
||||
| otherwise = throwIO e
|
||||
|
||||
createSmtpPool :: MonadLoggerIO m => SmtpConf -> m SMTPPool
|
||||
createSmtpPool SmtpConf{ smtpPool = ResourcePoolConf{..}, .. } = do
|
||||
@ -327,7 +329,7 @@ warpSettings foundation = defaultSettings
|
||||
void $ liftIO Systemd.notifyReady
|
||||
if
|
||||
| foundation ^. _appHealthCheckDelayNotify
|
||||
-> void . fork $ do
|
||||
-> void . forkIO $ do
|
||||
let activeChecks = Set.fromList universeF
|
||||
& Set.filter (is _Just . (foundation ^. _appHealthCheckInterval))
|
||||
atomically $ do
|
||||
@ -365,11 +367,20 @@ develMain = runResourceT $ do
|
||||
wsettings <- liftIO . getDevSettings $ warpSettings 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
|
||||
liftIO . develMainHelper $ return (wsettings, app)
|
||||
void . liftIO $ awaitTermination `race` runSettings wsettings app
|
||||
|
||||
-- | The @main@ function for an executable running this site.
|
||||
appMain :: MonadResourceBase m => m ()
|
||||
appMain :: forall m. (MonadUnliftIO m, MonadMask m) => m ()
|
||||
appMain = runResourceT $ do
|
||||
settings <- getAppSettings
|
||||
|
||||
@ -397,7 +408,7 @@ appMain = runResourceT $ do
|
||||
$logInfoS "bind" [st|Listening on #{tshow host} port #{tshow port} as per configuration|]
|
||||
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
|
||||
liftIO . void . flip (installHandler sigTERM) Nothing . Signals.CatchInfo $ \SignalInfo{..} -> runAppLoggingT foundation $ do
|
||||
@ -445,7 +456,7 @@ appMain = runResourceT $ do
|
||||
_other -> return ()
|
||||
|
||||
go status
|
||||
in void $ allocate (async notifyWatchdog >>= \a -> a <$ link a) cancel
|
||||
in void $ allocateLinkedAsync notifyWatchdog
|
||||
_other -> return ()
|
||||
|
||||
let runWarp socket = runSettingsSocket (warpSettings foundation) socket app
|
||||
@ -461,7 +472,7 @@ appMain = runResourceT $ do
|
||||
foundationStoreNum :: Word32
|
||||
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
|
||||
settings <- getAppDevSettings
|
||||
foundation <- makeFoundation settings
|
||||
@ -475,7 +486,7 @@ getApplicationRepl = do
|
||||
|
||||
return (getPort wsettings, foundation, app1)
|
||||
|
||||
shutdownApp :: (MonadIO m, MonadBaseControl IO m) => UniWorX -> m ()
|
||||
shutdownApp :: (MonadIO m, MonadUnliftIO m) => UniWorX -> m ()
|
||||
shutdownApp app = do
|
||||
stopJobCtl app
|
||||
liftIO $ do
|
||||
@ -494,7 +505,7 @@ handler :: Handler a -> IO a
|
||||
handler h = runResourceT $ getAppDevSettings >>= makeFoundation >>= liftIO . flip unsafeHandler h
|
||||
|
||||
-- | Run DB queries
|
||||
db :: ReaderT SqlBackend (HandlerT UniWorX IO) a -> IO a
|
||||
db :: DB a -> IO a
|
||||
db = handler . runDB
|
||||
|
||||
addPWEntry :: User
|
||||
|
||||
@ -22,7 +22,7 @@ import qualified Network.Socket as Wai
|
||||
import qualified Net.IP as IP
|
||||
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) #-}
|
||||
|
||||
@ -79,7 +79,6 @@ instance Exception AuditException
|
||||
|
||||
|
||||
audit :: ( AuthId (HandlerSite m) ~ Key User
|
||||
, AuthEntity (HandlerSite m) ~ User
|
||||
, IsSqlBackend (YesodPersistBackend (HandlerSite m))
|
||||
, SqlBackendCanWrite (YesodPersistBackend (HandlerSite m))
|
||||
, HasInstanceID (HandlerSite m) InstanceId
|
||||
@ -99,7 +98,7 @@ audit (toJSON -> transactionLogInfo) = do
|
||||
|
||||
transactionLogTime <- liftIO getCurrentTime
|
||||
transactionLogInstance <- getsYesod $ view instanceID
|
||||
transactionLogInitiator <- liftHandlerT maybeAuthId
|
||||
transactionLogInitiator <- liftHandler maybeAuthId
|
||||
transactionLogRemote <- handle (throwM . AuditRemoteException) $ Just <$> getRemote
|
||||
|
||||
insert_ TransactionLog{..}
|
||||
|
||||
@ -23,6 +23,24 @@ data Transaction
|
||||
{ transactionExam :: ExamId
|
||||
, transactionUser :: UserId
|
||||
}
|
||||
|
||||
| TransactionExamPartResultEdit
|
||||
{ transactionExamPart :: ExamPartId
|
||||
, transactionUser :: UserId
|
||||
}
|
||||
| TransactionExamPartResultDeleted
|
||||
{ transactionExamPart :: ExamPartId
|
||||
, transactionUser :: UserId
|
||||
}
|
||||
|
||||
| TransactionExamBonusEdit
|
||||
{ transactionExam :: ExamId
|
||||
, transactionUser :: UserId
|
||||
}
|
||||
| TransactionExamBonusDeleted
|
||||
{ transactionExam :: ExamId
|
||||
, transactionUser :: UserId
|
||||
}
|
||||
|
||||
| TransactionExamResultEdit
|
||||
{ transactionExam :: ExamId
|
||||
@ -98,6 +116,23 @@ data Transaction
|
||||
{ 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)
|
||||
|
||||
deriveJSON defaultOptions
|
||||
|
||||
@ -17,41 +17,47 @@ data DummyMessage = MsgDummyIdent
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
||||
|
||||
|
||||
dummyForm :: ( RenderMessage site FormMessage
|
||||
, RenderMessage site DummyMessage
|
||||
, YesodPersist site
|
||||
, SqlBackendCanRead (YesodPersistBackend site)
|
||||
, Button site ButtonSubmit
|
||||
) => AForm (HandlerT site IO) (CI Text)
|
||||
dummyForm :: ( RenderMessage (HandlerSite m) FormMessage
|
||||
, RenderMessage (HandlerSite m) DummyMessage
|
||||
, YesodPersist (HandlerSite m)
|
||||
, SqlBackendCanRead (YesodPersistBackend (HandlerSite m))
|
||||
, Button (HandlerSite m) ButtonSubmit
|
||||
, MonadHandler m
|
||||
) => AForm m (CI Text)
|
||||
dummyForm = areq (ciField & addDatalist userList) (fslI MsgDummyIdent & noAutocomplete) Nothing
|
||||
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)
|
||||
|
||||
dummyLogin :: ( YesodAuth site
|
||||
dummyLogin :: forall site.
|
||||
( YesodAuth site
|
||||
, YesodPersist site
|
||||
, SqlBackendCanRead (YesodPersistBackend site)
|
||||
, RenderMessage site FormMessage
|
||||
, RenderMessage site AFormMessage
|
||||
, RenderMessage site DummyMessage
|
||||
, Button site ButtonSubmit
|
||||
) => AuthPlugin site
|
||||
dummyLogin = AuthPlugin{..}
|
||||
where
|
||||
apName :: Text
|
||||
apName = "dummy"
|
||||
-- apDispatch :: Text -> [Text] -> HandlerT Auth (HandlerT site IO) TypedContent
|
||||
apDispatch "POST" [] = do
|
||||
((loginRes, _), _) <- lift . runFormPost $ renderAForm FormStandard dummyForm
|
||||
|
||||
apDispatch :: forall m. MonadAuthHandler site m => Text -> [Text] -> m TypedContent
|
||||
apDispatch "POST" [] = liftSubHandler $ do
|
||||
((loginRes, _), _) <- runFormPost $ renderAForm FormStandard dummyForm
|
||||
tp <- getRouteToParent
|
||||
case loginRes of
|
||||
FormFailure errs -> do
|
||||
lift . forM_ errs $ addMessage Error . toHtml
|
||||
redirect LoginR
|
||||
forM_ errs $ addMessage Error . toHtml
|
||||
redirect $ tp LoginR
|
||||
FormMissing -> do
|
||||
lift $ addMessageI Warning MsgDummyNoFormData
|
||||
redirect LoginR
|
||||
addMessageI Warning MsgDummyNoFormData
|
||||
redirect $ tp LoginR
|
||||
FormSuccess ident ->
|
||||
lift . setCredsRedirect $ Creds "dummy" (CI.original ident) []
|
||||
setCredsRedirect $ Creds "dummy" (CI.original ident) []
|
||||
apDispatch _ _ = notFound
|
||||
|
||||
apLogin :: (Route Auth -> Route site) -> WidgetFor site ()
|
||||
apLogin toMaster = do
|
||||
(login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard dummyForm
|
||||
let loginForm = wrapForm login FormSettings
|
||||
|
||||
@ -84,7 +84,7 @@ instance Exception 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
|
||||
Ldap.bind ldap ldapDn ldapPassword
|
||||
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
|
||||
]
|
||||
|
||||
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}
|
||||
= runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUser conf pool (Creds apLdap (CI.original userIdent) [])
|
||||
|
||||
|
||||
campusForm :: ( RenderMessage site FormMessage
|
||||
, RenderMessage site CampusMessage
|
||||
, Button site ButtonSubmit
|
||||
) => WForm (HandlerT site IO) (FormResult CampusLogin)
|
||||
campusForm :: ( RenderMessage (HandlerSite m) FormMessage
|
||||
, RenderMessage (HandlerSite m) CampusMessage
|
||||
, MonadHandler m
|
||||
) => WForm m (FormResult CampusLogin)
|
||||
campusForm = do
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
|
||||
@ -133,24 +133,26 @@ apLdap = "LDAP"
|
||||
|
||||
campusLogin :: forall site.
|
||||
( YesodAuth site
|
||||
, RenderMessage site FormMessage
|
||||
, RenderMessage site CampusMessage
|
||||
, RenderMessage site AFormMessage
|
||||
, Button site ButtonSubmit
|
||||
) => LdapConf -> LdapPool -> AuthPlugin site
|
||||
campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
|
||||
where
|
||||
apName :: Text
|
||||
apName = apLdap
|
||||
apDispatch :: Text -> [Text] -> HandlerT Auth (HandlerT site IO) TypedContent
|
||||
apDispatch "POST" [] = do
|
||||
((loginRes, _), _) <- lift . runFormPost $ renderWForm FormStandard campusForm
|
||||
|
||||
apDispatch :: forall m. MonadAuthHandler site m => Text -> [Text] -> m TypedContent
|
||||
apDispatch "POST" [] = liftSubHandler $ do
|
||||
((loginRes, _), _) <- runFormPost $ renderWForm FormStandard campusForm
|
||||
tp <- getRouteToParent
|
||||
case loginRes of
|
||||
FormFailure errs -> do
|
||||
forM_ errs $ addMessage Error . toHtml
|
||||
redirect LoginR
|
||||
FormMissing -> redirect LoginR
|
||||
redirect $ tp LoginR
|
||||
FormMissing -> redirect $ tp LoginR
|
||||
FormSuccess CampusLogin{ campusIdent = CI.original -> campusIdent, ..} -> do
|
||||
ldapResult <- withLdap pool $ \ldap -> do
|
||||
ldapResult <- withLdap pool $ \ldap -> liftIO $ do
|
||||
Ldap.bind ldap ldapDn ldapPassword
|
||||
searchResults <- findUser conf ldap campusIdent [ldapUserPrincipalName]
|
||||
case searchResults of
|
||||
@ -169,11 +171,13 @@ campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
|
||||
$logErrorS "LDAP" $ "Error during login: " <> tshow err
|
||||
loginErrorMessageI LoginR Msg.AuthError
|
||||
Right (Right (userDN, credsIdent)) ->
|
||||
lift . setCredsRedirect $ Creds apName credsIdent [("DN", userDN)]
|
||||
setCredsRedirect $ Creds apName credsIdent [("DN", userDN)]
|
||||
Right (Left searchResults) -> do
|
||||
$logWarnS "LDAP" $ "Could not extract principal name: " <> tshow searchResults
|
||||
loginErrorMessageI LoginR Msg.AuthError
|
||||
apDispatch _ _ = notFound
|
||||
|
||||
apLogin :: (Route Auth -> Route site) -> WidgetFor site ()
|
||||
apLogin toMaster = do
|
||||
(login, loginEnctype) <- handlerToWidget . generateFormPost $ renderWForm FormStandard campusForm
|
||||
let loginForm = wrapForm login FormSettings
|
||||
|
||||
@ -26,68 +26,50 @@ data PWHashMessage = MsgPWHashIdent
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
||||
|
||||
|
||||
hashForm :: ( RenderMessage site FormMessage
|
||||
, RenderMessage site PWHashMessage
|
||||
, Button site ButtonSubmit
|
||||
) => AForm (HandlerT site IO) HashLogin
|
||||
hashForm :: ( RenderMessage (HandlerSite m) FormMessage
|
||||
, RenderMessage (HandlerSite m) PWHashMessage
|
||||
, MonadHandler m
|
||||
) => AForm m HashLogin
|
||||
hashForm = HashLogin
|
||||
<$> areq ciField (fslpI MsgPWHashIdent "Identifikation") Nothing
|
||||
<*> areq passwordField (fslpI MsgPWHashPassword "Passwort") Nothing
|
||||
|
||||
|
||||
hashLogin :: ( YesodAuth site
|
||||
hashLogin :: forall site.
|
||||
( YesodAuth site
|
||||
, YesodPersist site
|
||||
, SqlBackendCanRead (YesodPersistBackend site)
|
||||
, RenderMessage site FormMessage
|
||||
, PersistRecordBackend User (YesodPersistBackend site)
|
||||
, RenderMessage site PWHashMessage
|
||||
, RenderMessage site AFormMessage
|
||||
, Button site ButtonSubmit
|
||||
) => PWHashAlgorithm -> AuthPlugin site
|
||||
hashLogin pwHashAlgo = AuthPlugin{..}
|
||||
where
|
||||
apName :: Text
|
||||
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
|
||||
FormFailure errs -> do
|
||||
forM_ errs $ addMessage Error . toHtml
|
||||
redirect LoginR
|
||||
FormMissing -> redirect LoginR
|
||||
redirect $ tp LoginR
|
||||
FormMissing -> redirect $ tp LoginR
|
||||
FormSuccess HashLogin{..} -> do
|
||||
user <- lift . runDB . getBy $ UniqueAuthentication hashIdent
|
||||
user <- liftHandler . runDB . getBy $ UniqueAuthentication hashIdent
|
||||
case user of
|
||||
Just (Entity _ User{ userAuthentication = AuthPWHash{..}, userIdent = CI.original -> userIdent })
|
||||
| verifyPasswordWith pwHashAlgo (2^) (encodeUtf8 hashPassword) (encodeUtf8 authPWHash) -> -- (2^) is magic.
|
||||
lift . setCredsRedirect $ Creds apName userIdent []
|
||||
setCredsRedirect $ Creds apName userIdent []
|
||||
other -> do
|
||||
$logDebugS "PWHash" $ tshow other
|
||||
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
|
||||
|
||||
apLogin :: (Route Auth -> Route site) -> WidgetFor site ()
|
||||
apLogin toMaster = do
|
||||
(login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard hashForm
|
||||
let loginForm = wrapForm login FormSettings
|
||||
|
||||
@ -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
|
||||
@ -8,11 +8,12 @@ module CryptoID
|
||||
, module System.FilePath.Cryptographic.ImplicitNamespace
|
||||
) where
|
||||
|
||||
import CryptoID.TH
|
||||
|
||||
import ClassyPrelude
|
||||
import Import.NoModel
|
||||
import Model
|
||||
|
||||
import CryptoID.TH
|
||||
|
||||
import qualified Data.CryptoID as E
|
||||
import Data.CryptoID.Poly.ImplicitNamespace
|
||||
import Data.UUID.Cryptographic.ImplicitNamespace
|
||||
@ -20,9 +21,6 @@ import System.FilePath.Cryptographic.ImplicitNamespace
|
||||
|
||||
import qualified Data.Text as Text
|
||||
|
||||
-- import Data.UUID.Types
|
||||
import Web.PathPieces
|
||||
|
||||
import Data.CaseInsensitive (CI)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
@ -50,6 +48,7 @@ decCryptoIDs [ ''SubmissionId
|
||||
, ''AllocationId
|
||||
, ''CourseApplicationId
|
||||
, ''CourseId
|
||||
, ''CourseNewsId
|
||||
]
|
||||
|
||||
-- CryptoIDNamespace (CI FilePath) SubmissionId ~ "Submission"
|
||||
|
||||
@ -1,5 +1,6 @@
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
|
||||
|
||||
module Data.CaseInsensitive.Instances
|
||||
(
|
||||
|
||||
@ -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
|
||||
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
|
||||
|
||||
@ -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|]
|
||||
@ -1,7 +1,7 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Data.Time.Clock.Instances
|
||||
(
|
||||
( iso8601OutputFormat, iso8601ParseFormat
|
||||
) where
|
||||
|
||||
import ClassyPrelude
|
||||
@ -17,6 +17,8 @@ import Data.Time.Clock
|
||||
import Data.Time.Calendar.Instances ()
|
||||
import Web.PathPieces
|
||||
|
||||
import qualified Data.Csv as Csv
|
||||
|
||||
|
||||
instance Hashable DiffTime where
|
||||
hashWithSalt s = hashWithSalt s . toRational
|
||||
@ -29,12 +31,23 @@ instance PersistFieldSql NominalDiffTime where
|
||||
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
|
||||
instance Hashable UTCTime
|
||||
|
||||
instance PathPiece UTCTime where
|
||||
toPathPiece = pack . formatTime defaultTimeLocale "%0Y-%m-%dT%H:%M:%S%Q%z"
|
||||
fromPathPiece = parseTimeM False defaultTimeLocale "%Y-%m-%dT%H:%M:%S%Q%z" . unpack
|
||||
toPathPiece = pack . formatTime defaultTimeLocale iso8601OutputFormat
|
||||
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
|
||||
|
||||
@ -12,6 +12,12 @@ import Data.Binary (Binary)
|
||||
|
||||
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 Typeable TimeOfDay
|
||||
@ -21,3 +27,9 @@ instance Binary TimeOfDay
|
||||
|
||||
|
||||
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
|
||||
|
||||
@ -1,4 +1,5 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
|
||||
|
||||
module Database.Esqueleto.Utils
|
||||
( true, false
|
||||
@ -6,19 +7,19 @@ module Database.Esqueleto.Utils
|
||||
, isInfixOf, hasInfix
|
||||
, or, and
|
||||
, any, all
|
||||
, SqlIn(..)
|
||||
, mkExactFilter, mkExactFilterWith
|
||||
, mkContainsFilter, mkContainsFilterWith
|
||||
, mkExistsFilter
|
||||
, anyFilter, allFilter
|
||||
, orderByList
|
||||
, orderByOrd, orderByEnum
|
||||
, lower, ciEq
|
||||
, strip, lower, ciEq
|
||||
, selectExists
|
||||
, SqlHashable
|
||||
, sha256
|
||||
, maybe
|
||||
, SqlProject(..)
|
||||
, module Database.Esqueleto.Utils.TH
|
||||
) where
|
||||
|
||||
|
||||
@ -61,24 +62,22 @@ false :: E.SqlExpr (E.Value Bool)
|
||||
false = E.val False
|
||||
|
||||
-- | 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
|
||||
|
||||
infix 4 `isInfixOf`, `hasInfix`
|
||||
|
||||
-- | Check if the first string is contained in the text derived from the second argument
|
||||
isInfixOf :: ( E.Esqueleto query expr backend
|
||||
, E.SqlString s1
|
||||
isInfixOf :: ( E.SqlString s1
|
||||
, 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.%)
|
||||
|
||||
hasInfix :: ( E.Esqueleto query expr backend
|
||||
, E.SqlString s1
|
||||
hasInfix :: ( E.SqlString s1
|
||||
, 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
|
||||
|
||||
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.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 a b = lower a E.==. lower b
|
||||
|
||||
@ -8,11 +8,14 @@ module Database.Persist.Class.Instances
|
||||
import ClassyPrelude
|
||||
|
||||
import Database.Persist.Class
|
||||
import Database.Persist.Types (HaskellName, DBName, PersistValue)
|
||||
import Database.Persist.Types.Instances ()
|
||||
|
||||
import Data.Binary (Binary)
|
||||
import qualified Data.Binary as Binary
|
||||
|
||||
import qualified Data.Map as Map
|
||||
|
||||
|
||||
instance PersistEntity record => Hashable (Key record) where
|
||||
hashWithSalt s = hashWithSalt s . toPersistValue
|
||||
@ -24,3 +27,13 @@ instance PersistEntity record => Binary (Key record) where
|
||||
|
||||
instance PersistEntity record => NFData (Key record) where
|
||||
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
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -21,7 +21,6 @@ import Database.Persist.Sql (fromSqlKey)
|
||||
import qualified Database.Esqueleto as E
|
||||
import Database.Esqueleto.Utils (mkExactFilter, mkContainsFilter)
|
||||
|
||||
import Handler.Utils.Table.Cells
|
||||
import qualified Handler.Utils.TermCandidates as Candidates
|
||||
|
||||
-- import Colonnade hiding (fromMaybe)
|
||||
@ -55,7 +54,7 @@ instance Button UniWorX ButtonCreate where
|
||||
btnClasses CreateInf = [BCIsButton, BCPrimary]
|
||||
-- END Button needed only here
|
||||
|
||||
emailTestForm :: AForm (HandlerT UniWorX IO) (Email, MailContext)
|
||||
emailTestForm :: AForm (HandlerFor UniWorX) (Email, MailContext)
|
||||
emailTestForm = (,)
|
||||
<$> areq emailField (fslI MsgMailTestFormEmail) Nothing
|
||||
<*> ( MailContext
|
||||
@ -113,7 +112,7 @@ postAdminTestR = do
|
||||
jId <- queueJob $ JobSendTestEmail email ls
|
||||
tell . pure $ Message Success [shamlet|Email-test gestartet (Job ##{tshow (fromSqlKey jId)})|] (Just IconEmail)
|
||||
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`
|
||||
|
||||
let emailWidget' = wrapForm emailWidget def
|
||||
@ -147,7 +146,14 @@ postAdminTestR = do
|
||||
$forall m <- msgs
|
||||
<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@.
|
||||
|
||||
@ -190,7 +196,7 @@ postAdminTestR = do
|
||||
-- | How does the shape (`ListLength`) change if a certain cell is deleted?
|
||||
deleteCell :: Map ListPosition Int -- ^ Current shape, including initialisation data
|
||||
-> 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
|
||||
-- | 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
|
||||
@ -375,7 +381,7 @@ postAdminFeaturesR = do
|
||||
-> Getter (DBRow r) (Maybe Text)
|
||||
-> Getter (DBRow r) i
|
||||
-> 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)
|
||||
(\row _mkUnique -> (\(res,fieldView) -> (set lensRes . assertM (not . Text.null) <$> res, fvInput fieldView))
|
||||
<$> mopt textField "" (Just $ row ^. lensDefault)
|
||||
@ -386,7 +392,7 @@ postAdminFeaturesR = do
|
||||
-> Getter (DBRow r) Bool
|
||||
-> Getter (DBRow r) i
|
||||
-> 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)
|
||||
( \row _mkUnique -> (\(res, fieldView) -> (set lensRes <$> res, fvInput fieldView))
|
||||
<$> mpopt checkBoxField "" (Just $ row ^. lensDefault)
|
||||
|
||||
@ -52,7 +52,7 @@ data ApplicationForm = ApplicationForm
|
||||
{ afPriority :: Maybe Natural
|
||||
, afField :: Maybe StudyFeaturesId
|
||||
, afText :: Maybe Text
|
||||
, afFiles :: Maybe (Source Handler File)
|
||||
, afFiles :: Maybe (ConduitT () File Handler ())
|
||||
, afRatingVeto :: Bool
|
||||
, afRatingPoints :: Maybe ExamGrade
|
||||
, afRatingComment :: Maybe Text
|
||||
@ -77,13 +77,12 @@ applicationForm :: (Maybe AllocationId)
|
||||
-> Html -> MForm Handler (FormResult ApplicationForm, ApplicationFormView)
|
||||
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]
|
||||
coursesNum <- fromIntegral . fromMaybe 1 <$> for maId (\aId -> count [AllocationCourseAllocation ==. aId])
|
||||
course <- getJust cid
|
||||
[E.Value (fromMaybe 0 -> maxPrio)] <- E.select . E.from $ \courseApplication -> do
|
||||
E.where_ $ courseApplication E.^. CourseApplicationCourse E.==. E.val cid
|
||||
E.&&. courseApplication E.^. CourseApplicationUser E.==. E.val uid
|
||||
(fromMaybe 0 -> maxPrio) <- fmap ((>>= E.unValue) . listToMaybe) . E.select . E.from $ \courseApplication -> do
|
||||
E.where_ $ courseApplication E.^. CourseApplicationUser E.==. E.val uid
|
||||
E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.val maId
|
||||
E.&&. E.not_ (E.isNothing $ 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)
|
||||
|
||||
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
|
||||
let appFilesInfo = (,) <$> hasFiles <*> appCID
|
||||
|
||||
@ -296,7 +295,7 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do
|
||||
fId <- insert file
|
||||
insert_ $ CourseApplicationFile appId fId
|
||||
forM_ afFiles $ \afFiles' ->
|
||||
runConduit $ transPipe liftHandlerT afFiles' .| C.mapM_ sinkFile'
|
||||
runConduit $ transPipe liftHandler afFiles' .| C.mapM_ sinkFile'
|
||||
audit $ TransactionCourseApplicationEdit cid uid appId
|
||||
addMessageI Success $ MsgCourseApplicationCreated courseShorthand
|
||||
| is _BtnAllocationApplicationEdit afAction || is _BtnAllocationApplicationRate afAction
|
||||
@ -327,7 +326,7 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do
|
||||
fId <- lift $ insert file
|
||||
lift . insert_ $ CourseApplicationFile appId 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) ]
|
||||
return changes
|
||||
| otherwise
|
||||
|
||||
@ -1,3 +1,5 @@
|
||||
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
|
||||
|
||||
module Handler.Allocation.List
|
||||
( getAllocationListR
|
||||
) where
|
||||
|
||||
@ -50,6 +50,7 @@ postARegisterR tid ssh ash = do
|
||||
{ allocationUserAllocation = aId
|
||||
, allocationUserUser = uid
|
||||
, allocationUserTotalCourses = arfTotalCourses
|
||||
, allocationUserPriority = Nothing
|
||||
}
|
||||
[ AllocationUserTotalCourses =. arfTotalCourses
|
||||
]
|
||||
|
||||
@ -23,11 +23,16 @@ getAShowR tid ssh ash = do
|
||||
resultCourseApplication = _2 . _Just
|
||||
resultHasTemplate :: Simple Field3 a (E.Value Bool) => Lens' a Bool
|
||||
resultHasTemplate = _3 . _Value
|
||||
resultIsRegistered :: Simple Field4 a (E.Value Bool) => Lens' a Bool
|
||||
resultIsRegistered = _4 . _Value
|
||||
|
||||
(Entity aId Allocation{..}, courses, registration) <- runDB $ do
|
||||
alloc@(Entity aId _) <- getBy404 $ TermSchoolAllocationShort tid ssh ash
|
||||
(Entity aId Allocation{..}, School{..}, isAnyLecturer, courses, registration) <- runDB $ do
|
||||
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.&&. courseApplication E.?. CourseApplicationUser E.==. E.val muid
|
||||
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]
|
||||
let hasTemplate = E.exists . E.from $ \courseAppInstructionFile ->
|
||||
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
|
||||
|
||||
return (alloc, nubOn (view $ resultCourse . _entityKey) courses, registration)
|
||||
isAnyLecturer <- hasWriteAccessTo CourseNewR
|
||||
|
||||
return (alloc, school, isAnyLecturer, nubOn (view $ resultCourse . _entityKey) courses, registration)
|
||||
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
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
|
||||
hasApplicationTemplate = cEntry ^. resultHasTemplate
|
||||
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
|
||||
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
|
||||
Nothing -> return . AllocationR tid ssh ash $ AApplyR cID
|
||||
Just (Entity appId _) -> CApplicationR courseTerm courseSchool courseShorthand <$> encrypt appId <*> pure CAEditR
|
||||
|
||||
@ -1,13 +1,12 @@
|
||||
module Handler.Corrections where
|
||||
|
||||
import Import
|
||||
import Import hiding (link)
|
||||
-- import System.FilePath (takeFileName)
|
||||
|
||||
import Jobs
|
||||
import Handler.Utils
|
||||
import Handler.Utils hiding (colSchool)
|
||||
import Handler.Utils.Corrections
|
||||
import Handler.Utils.Submission
|
||||
import Handler.Utils.Table.Cells
|
||||
import Handler.Utils.SheetType
|
||||
import Handler.Utils.Delete
|
||||
-- import Handler.Utils.Zip
|
||||
@ -72,8 +71,8 @@ correctionsTableQuery whereClause returnStatement t@((course `E.InnerJoin` sheet
|
||||
E.where_ $ whereClause t
|
||||
return $ returnStatement t
|
||||
|
||||
lastEditQuery :: Database.Esqueleto.Internal.Language.From query expr backend (expr (Entity SubmissionEdit))
|
||||
=> expr (Entity Submission) -> expr (E.Value (Maybe UTCTime))
|
||||
lastEditQuery :: Database.Esqueleto.Internal.Language.From (E.SqlExpr (Entity SubmissionEdit))
|
||||
=> E.SqlExpr (Entity Submission) -> E.SqlExpr (E.Value (Maybe UTCTime))
|
||||
lastEditQuery submission = E.sub_select $ E.from $ \edit -> do
|
||||
E.where_ $ edit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId
|
||||
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 = 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 _ 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)
|
||||
)
|
||||
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
|
||||
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)
|
||||
@ -399,9 +398,9 @@ data ActionCorrectionsData = CorrDownloadData
|
||||
| CorrAutoSetCorrectorData SheetId
|
||||
| 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
|
||||
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)
|
||||
{ drAbort = SomeRoute currentRoute
|
||||
@ -417,7 +416,7 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do
|
||||
, dbParamsFormAdditional = \frag -> do
|
||||
(actionRes, action) <- multiActionM actions "" Nothing mempty
|
||||
return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action)
|
||||
, dbParamsFormEvaluate = liftHandlerT . runFormPost
|
||||
, dbParamsFormEvaluate = liftHandler . runFormPost
|
||||
, dbParamsFormResult = _1
|
||||
, dbParamsFormIdent = def
|
||||
}
|
||||
@ -467,7 +466,7 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do
|
||||
]
|
||||
addMessageI Success $ MsgUpdatedAssignedCorrectorSingle num
|
||||
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.where_ $ submission E.^. SubmissionId `E.in_` E.valList subs
|
||||
E.&&. submission E.^. SubmissionRatingBy E.==. E.just (subuser E.^. SubmissionUserUser)
|
||||
@ -538,7 +537,7 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do
|
||||
where
|
||||
authorizedToAssign :: SubmissionId -> DB Bool
|
||||
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.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
|
||||
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
|
||||
(== Authorized) <$> evalAccessDB route True
|
||||
|
||||
type ActionCorrections' = (ActionCorrections, AForm (HandlerT UniWorX IO) ActionCorrectionsData)
|
||||
type ActionCorrections' = (ActionCorrections, AForm (HandlerFor UniWorX) ActionCorrectionsData)
|
||||
|
||||
downloadAction, deleteAction :: ActionCorrections'
|
||||
downloadAction = ( CorrDownload
|
||||
@ -561,7 +560,7 @@ deleteAction = ( CorrDelete
|
||||
assignAction :: Either CourseId SheetId -> ActionCorrections'
|
||||
assignAction selId = ( CorrSetCorrector
|
||||
, 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 $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
|
||||
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
|
||||
|
||||
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
|
||||
)
|
||||
|
||||
@ -741,7 +740,7 @@ postCorrectionR tid ssh csh shn cid = do
|
||||
}
|
||||
|
||||
formResult corrResult $ \(rated, ratingPoints', ratingComment') -> do
|
||||
uid <- liftHandlerT requireAuthId
|
||||
uid <- liftHandler requireAuthId
|
||||
now <- liftIO getCurrentTime
|
||||
|
||||
if
|
||||
@ -1014,7 +1013,7 @@ postCorrectionsGradeR = do
|
||||
, colCommentField
|
||||
] -- Continue here
|
||||
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)
|
||||
dbtProj' i@(Entity subId _, Entity _ Sheet{ sheetName = shn }, (_, csh, tid, ssh), _, _, _) = do
|
||||
cID <- encrypt subId
|
||||
@ -1266,10 +1265,6 @@ assignHandler tid ssh csh cid assignSids = do
|
||||
showAvgsDays :: Maybe NominalDiffTime -> Integer -> Text
|
||||
showAvgsDays Nothing _ = mempty
|
||||
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
|
||||
| 0 < Map.size assignment = MsgMenuCorrectionsAssignSheet $ Text.intercalate ", " $ fmap CI.original $ Map.keys assignment
|
||||
| otherwise = MsgMenuCorrectionsAssign
|
||||
|
||||
@ -16,6 +16,8 @@ import Handler.Course.Show as Handler.Course
|
||||
import Handler.Course.User as Handler.Course
|
||||
import Handler.Course.Users 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
|
||||
@ -27,3 +29,6 @@ getCNotesR, postCNotesR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
-- If they are shared, adjust MsgCourseUserNoteTooltip
|
||||
getCNotesR = postCNotesR
|
||||
postCNotesR _ _ _ = defaultLayout [whamlet|You have corrector access to this course.|]
|
||||
|
||||
postCFavouriteR :: TermId -> SchoolId -> CourseShorthand -> Handler ()
|
||||
postCFavouriteR _ _ _ = error "not implemented"
|
||||
|
||||
@ -1,3 +1,5 @@
|
||||
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
|
||||
|
||||
module Handler.Course.Application.Files
|
||||
( getCAFilesR
|
||||
, getCAppsFilesR
|
||||
@ -47,7 +49,7 @@ getCAppsFilesR tid ssh csh = do
|
||||
archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ MsgCourseAllApplicationsArchiveName tid ssh csh
|
||||
|
||||
let
|
||||
fsSource :: Source DB File
|
||||
fsSource :: ConduitT () File DB ()
|
||||
fsSource = 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
|
||||
|
||||
@ -1,4 +1,5 @@
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
|
||||
|
||||
module Handler.Course.Application.List
|
||||
( getCApplicationsR, postCApplicationsR
|
||||
@ -7,7 +8,6 @@ module Handler.Course.Application.List
|
||||
import Import
|
||||
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Table.Columns
|
||||
|
||||
import qualified Database.Esqueleto 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 Handler.Course.ParticipantInvite
|
||||
|
||||
import Jobs.Queue
|
||||
|
||||
|
||||
type CourseApplicationsTableExpr = ( E.SqlExpr (Entity CourseApplication)
|
||||
`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 StudyDegree))
|
||||
)
|
||||
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseParticipant))
|
||||
type CourseApplicationsTableData = DBRow ( Entity CourseApplication
|
||||
, Entity User
|
||||
, E.Value Bool -- hasFiles
|
||||
, Bool -- hasFiles
|
||||
, Maybe (Entity Allocation)
|
||||
, Maybe (Entity StudyFeatures)
|
||||
, Maybe (Entity StudyTerms)
|
||||
, Maybe (Entity StudyDegree)
|
||||
, Bool -- isParticipant
|
||||
)
|
||||
|
||||
courseApplicationsIdent :: Text
|
||||
courseApplicationsIdent = "applications"
|
||||
|
||||
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 = to $ $(sqlIJproj 2 2) . $(sqlLOJproj 3 1)
|
||||
queryUser = to $ $(sqlIJproj 2 2) . $(sqlLOJproj 4 1)
|
||||
|
||||
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
|
||||
hasFiles appl = E.exists . E.from $ \courseApplicationFile ->
|
||||
E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. appl E.^. CourseApplicationId
|
||||
|
||||
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 = to $ $(sqlIJproj 3 1) . $(sqlLOJproj 3 3)
|
||||
queryStudyFeatures = to $ $(sqlIJproj 3 1) . $(sqlLOJproj 4 3)
|
||||
|
||||
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 = 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 = _dbrOutput . _1
|
||||
@ -77,7 +89,7 @@ resultUser :: Lens' CourseApplicationsTableData (Entity User)
|
||||
resultUser = _dbrOutput . _2
|
||||
|
||||
resultHasFiles :: Lens' CourseApplicationsTableData Bool
|
||||
resultHasFiles = _dbrOutput . _3 . _Value
|
||||
resultHasFiles = _dbrOutput . _3
|
||||
|
||||
resultAllocation :: Traversal' CourseApplicationsTableData (Entity Allocation)
|
||||
resultAllocation = _dbrOutput . _4 . _Just
|
||||
@ -91,6 +103,9 @@ resultStudyTerms = _dbrOutput . _6 . _Just
|
||||
resultStudyDegree :: Traversal' CourseApplicationsTableData (Entity StudyDegree)
|
||||
resultStudyDegree = _dbrOutput . _7 . _Just
|
||||
|
||||
resultIsParticipant :: Lens' CourseApplicationsTableData Bool
|
||||
resultIsParticipant = _dbrOutput . _8
|
||||
|
||||
|
||||
newtype CourseApplicationsTableVeto = CourseApplicationsTableVeto Bool
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
@ -104,7 +119,7 @@ instance Csv.ToField CourseApplicationsTableVeto where
|
||||
instance Csv.FromField CourseApplicationsTableVeto where
|
||||
parseField f = do
|
||||
(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" ]
|
||||
|
||||
data CourseApplicationsTableCsv = CourseApplicationsTableCsv
|
||||
@ -205,14 +220,47 @@ data CourseApplicationsTableCsvException
|
||||
instance Exception CourseApplicationsTableCsvException
|
||||
|
||||
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
|
||||
postCApplicationsR tid ssh csh = do
|
||||
table <- runDB $ do
|
||||
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
(table, allocationsBounds, mayAccept) <- runDB $ do
|
||||
Entity cid Course{..} <- getBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
|
||||
csvName <- getMessageRender <*> pure (MsgCourseApplicationsTableCsvName tid ssh csh)
|
||||
let
|
||||
allocationLink :: Allocation -> SomeRoute UniWorX
|
||||
allocationLink Allocation{..} = SomeRoute $ AllocationR allocationTerm allocationSchool allocationShorthand AShowR
|
||||
@ -236,31 +284,43 @@ postCApplicationsR tid ssh csh = do
|
||||
studyFeatures <- view queryStudyFeatures
|
||||
studyTerms <- view queryStudyTerms
|
||||
studyDegree <- view queryStudyDegree
|
||||
courseParticipant <- view queryCourseParticipant
|
||||
|
||||
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 $ studyTerms E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField
|
||||
E.on $ studyFeatures E.?. StudyFeaturesId E.==. courseApplication E.^. CourseApplicationField
|
||||
E.on $ courseApplication E.^. CourseApplicationAllocation E.==. allocation E.?. AllocationId
|
||||
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 = runReaderT $ do
|
||||
appId <- view $ resultCourseApplication . _entityKey
|
||||
appId <- view $ _dbrOutput . _1 . _entityKey
|
||||
cID <- encrypt appId
|
||||
|
||||
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)
|
||||
|
||||
dbtColonnade :: Colonnade Sortable _ _
|
||||
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 (resultUser . _entityKey) participantLink) $ colUserDisplayName (resultUser . _entityVal . $(multifocusL 2) _userDisplayName _userSurname)
|
||||
, colUserMatriculation (resultUser . _entityVal . _userMatrikelnummer)
|
||||
@ -268,14 +328,15 @@ postCApplicationsR tid ssh csh = do
|
||||
, emptyOpticColonnade (resultStudyDegree . _entityVal) colStudyDegree
|
||||
, emptyOpticColonnade (resultStudyFeatures . _entityVal . _studyFeaturesSemester) colStudyFeaturesSemester
|
||||
, 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)
|
||||
, colApplicationRatingPoints (resultCourseApplication . _entityVal . _courseApplicationRatingPoints)
|
||||
, colApplicationRatingComment (resultCourseApplication . _entityVal . _courseApplicationRatingComment)
|
||||
]
|
||||
|
||||
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))
|
||||
, sortUserMatriculation $ queryUser . to (E.^. UserMatrikelnummer)
|
||||
, sortStudyTerms queryStudyTerms
|
||||
@ -320,8 +381,7 @@ postCApplicationsR tid ssh csh = do
|
||||
}
|
||||
dbtParams = def
|
||||
|
||||
dbtCsvEncode :: DBTCsvEncode CourseApplicationsTableData CourseApplicationsTableCsv
|
||||
dbtCsvEncode = DictJust . C.mapM . runReaderT $ CourseApplicationsTableCsv
|
||||
dbtCsvEncode = simpleCsvEncodeM csvName $ CourseApplicationsTableCsv
|
||||
<$> preview (resultAllocation . _entityVal . _allocationShorthand)
|
||||
<*> (preview (resultCourseApplication . _entityKey) >>= traverse encrypt)
|
||||
<*> preview (resultUser . _entityVal . _userDisplayName)
|
||||
@ -532,10 +592,101 @@ postCApplicationsR tid ssh csh = do
|
||||
psValidator = def
|
||||
& 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
|
||||
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
|
||||
setTitleI title
|
||||
table
|
||||
$(widgetFile "course/applications-list")
|
||||
|
||||
@ -44,7 +44,7 @@ data CourseForm = CourseForm
|
||||
, cfAllocation :: Maybe AllocationCourseForm
|
||||
, cfAppRequired :: Bool
|
||||
, cfAppInstructions :: Maybe Html
|
||||
, cfAppInstructionFiles :: Maybe (Source Handler (Either FileId File))
|
||||
, cfAppInstructionFiles :: Maybe (ConduitT () (Either FileId File) Handler ())
|
||||
, cfAppText :: Bool
|
||||
, cfAppFiles :: UploadMode
|
||||
, cfAppRatingsVisible :: Bool
|
||||
@ -101,22 +101,23 @@ allocationCourseToForm (Entity _ AllocationCourse{..}) = AllocationCourseForm
|
||||
|
||||
makeCourseForm :: (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)) -> Maybe CourseForm -> Form CourseForm
|
||||
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
|
||||
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
|
||||
uid <- liftHandlerT requireAuthId
|
||||
(lecturerSchools, adminSchools) <- liftHandlerT . runDB $ do
|
||||
uid <- liftHandler requireAuthId
|
||||
(lecturerSchools, adminSchools, oldSchool) <- liftHandler . runDB $ do
|
||||
lecturerSchools <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolLecturer]] []
|
||||
protoAdminSchools <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolAdmin]] []
|
||||
adminSchools <- filterM (hasWriteAccessTo . flip SchoolR SchoolEditR) protoAdminSchools
|
||||
return (lecturerSchools, adminSchools)
|
||||
let userSchools = nub $ lecturerSchools ++ adminSchools
|
||||
oldSchool <- forM (cfCourseId =<< template) $ fmap courseSchool . getJust
|
||||
return (lecturerSchools, adminSchools, oldSchool)
|
||||
let userSchools = nub . maybe id (:) oldSchool $ lecturerSchools ++ adminSchools
|
||||
|
||||
termsField <- case template of
|
||||
-- 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
|
||||
mayEditTerm <- isAuthorized TermEditR 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))))
|
||||
miAdd _ _ nudge btn = Just $ \csrf -> do
|
||||
(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
|
||||
FormSuccess (CI.mk -> email, 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 _ (Right lid) defType nudge = \csrf -> do
|
||||
(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")
|
||||
return (Just <$> lrwRes,lrwView')
|
||||
miCell _ (Left lEmail) defType nudge = \csrf -> do
|
||||
(lrwRes,lrwView) <- mopt (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) defType
|
||||
invWarnMsg <- messageI Warning MsgEmailInvitationWarning
|
||||
let lrwView' = $(widgetFile "course/lecturerMassInput/cellInvitation")
|
||||
return (lrwRes,lrwView')
|
||||
|
||||
miDelete :: Map ListPosition (Either UserEmail UserId) -- ^ Current shape
|
||||
-> ListPosition -- ^ Coordinate to delete
|
||||
-> MaybeT (MForm (HandlerT UniWorX IO)) (Map ListPosition ListPosition)
|
||||
-> MaybeT (MForm (HandlerFor UniWorX)) (Map ListPosition ListPosition)
|
||||
miDelete = miDeleteList
|
||||
|
||||
miAllowAdd :: ListPosition -> Natural -> ListLength -> Bool
|
||||
@ -194,7 +196,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
|
||||
(newRegFrom,newRegTo,newDeRegUntil) <- case template of
|
||||
(Just cform) | (Just _cid) <- cfCourseId cform -> return (Nothing,Nothing,Nothing)
|
||||
_allIOtherCases -> do
|
||||
mbLastTerm <- liftHandlerT $ runDB $ selectFirst [TermActive ==. True] [Desc TermName]
|
||||
mbLastTerm <- liftHandler $ runDB $ selectFirst [TermActive ==. True] [Desc TermName]
|
||||
return ( (Just . toMidnight . termStart . entityVal) <$> mbLastTerm
|
||||
, (Just . beforeMidnight . termEnd . entityVal) <$> mbLastTerm
|
||||
, (Just . beforeMidnight . termEnd . entityVal) <$> mbLastTerm )
|
||||
@ -202,7 +204,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
|
||||
let
|
||||
allocationForm :: AForm Handler (Maybe AllocationCourseForm)
|
||||
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
|
||||
|
||||
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
|
||||
|
||||
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
|
||||
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)
|
||||
|
||||
-- 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
|
||||
<$> pure (cfCourseId =<< template)
|
||||
<*> areq (textField & cfStrip & cfCI) (fslI MsgCourseName) (cfName <$> template)
|
||||
@ -295,7 +300,7 @@ validateCourse = do
|
||||
CourseForm{..} <- State.get
|
||||
|
||||
now <- liftIO getCurrentTime
|
||||
uid <- liftHandlerT requireAuthId
|
||||
uid <- liftHandler requireAuthId
|
||||
userAdmin <- hasWriteAccessTo $ SchoolR cfSchool SchoolEditR
|
||||
allocationTerm <- for (acfAllocation <$> cfAllocation) $ lift . fmap allocationTerm . getJust
|
||||
|
||||
@ -303,10 +308,11 @@ validateCourse = do
|
||||
prevAllocationCourse <- getBy $ UniqueAllocationCourse cid
|
||||
prevAllocation <- fmap join . traverse get $ allocationCourseAllocation . entityVal <$> prevAllocationCourse
|
||||
|
||||
fmap join . for prevAllocation $ \Allocation{allocationStaffRegisterTo} -> if
|
||||
fmap join . for prevAllocation $ \Allocation{allocationStaffAllocationTo, allocationRegisterByCourse} -> if
|
||||
| userAdmin
|
||||
-> return Nothing
|
||||
| NTop allocationStaffRegisterTo <= NTop (Just now)
|
||||
| NTop allocationStaffAllocationTo <= NTop (Just now)
|
||||
, NTop allocationRegisterByCourse > NTop (Just now)
|
||||
-> Just . courseCapacity <$> getJust cid
|
||||
| otherwise
|
||||
-> return Nothing
|
||||
@ -516,7 +522,7 @@ courseEditHandler miButtonAction mbCourseForm = do
|
||||
tell $ Set.singleton fId
|
||||
lift $
|
||||
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 ] []
|
||||
mapM_ deleteCascade $ map (courseAppInstructionFileFile . entityVal) acfs
|
||||
|
||||
@ -533,7 +539,7 @@ courseEditHandler miButtonAction mbCourseForm = do
|
||||
, 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
|
||||
now <- liftIO getCurrentTime
|
||||
Course{..} <- getJust cid
|
||||
|
||||
@ -57,16 +57,19 @@ lecturerInvitationConfig = InvitationConfig{..}
|
||||
where
|
||||
invitationRoute (Entity _ Course{..}) _ = return . CourseR courseTerm courseSchool courseShorthand $ CLecInviteR
|
||||
invitationResolveFor _ = do
|
||||
Just (CourseR tid csh ssh CLecInviteR) <- getCurrentRoute
|
||||
getKeyBy404 $ TermSchoolCourseShort tid csh ssh
|
||||
cRoute <- getCurrentRoute
|
||||
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
|
||||
invitationHeading (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseLecInviteHeading $ CI.original courseName
|
||||
invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgCourseLecInviteExplanation}|]
|
||||
invitationTokenConfig _ _ = do
|
||||
itAuthority <- liftHandlerT requireAuthId
|
||||
itAuthority <- liftHandler requireAuthId
|
||||
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
|
||||
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
|
||||
Just lType -> aforced (selectField optionsFinite) lFs lType
|
||||
where
|
||||
|
||||
@ -12,8 +12,7 @@ import Data.Maybe (fromJust)
|
||||
|
||||
import Utils.Form
|
||||
-- import Utils.DB
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Table.Cells
|
||||
import Handler.Utils hiding (colSchoolShort)
|
||||
|
||||
import Data.Function ((&))
|
||||
|
||||
@ -87,7 +86,7 @@ makeCourseTable whereClause colChoices psValidator = do
|
||||
E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser
|
||||
E.where_ $ cid E.==. lecturer E.^. LecturerCourse E.&&. lecturer E.^. LecturerType E.==. E.val CourseLecturer
|
||||
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
|
||||
lecturerList <- lift $ E.select $ E.from $ lecturerQuery $ E.val $ entityKey course
|
||||
courseAlloc <- lift $ getBy (UniqueAllocationCourse $ entityKey course)
|
||||
|
||||
9
src/Handler/Course/News.hs
Normal file
9
src/Handler/Course/News.hs
Normal 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
44
src/Handler/Course/News/Delete.hs
Normal 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
41
src/Handler/Course/News/Download.hs
Normal 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
54
src/Handler/Course/News/Edit.hs
Normal 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
71
src/Handler/Course/News/Form.hs
Normal 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
47
src/Handler/Course/News/New.hs
Normal 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
17
src/Handler/Course/News/Show.hs
Normal 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")
|
||||
@ -4,6 +4,9 @@ module Handler.Course.ParticipantInvite
|
||||
( InvitableJunction(..), InvitationDBData(..), InvitationTokenData(..)
|
||||
, getCInviteR, postCInviteR
|
||||
, getCAddUserR, postCAddUserR
|
||||
, AddParticipantsResult(..)
|
||||
, addParticipantsResultMessages
|
||||
, registerUsers, registerUser
|
||||
) where
|
||||
|
||||
import Import
|
||||
@ -35,7 +38,7 @@ instance IsInvitableJunction CourseParticipant where
|
||||
data InvitableJunction CourseParticipant = JunctionParticipant
|
||||
{ jParticipantRegistration :: UTCTime
|
||||
, jParticipantField :: Maybe StudyFeaturesId
|
||||
, jParticipantAllocated :: Bool
|
||||
, jParticipantAllocated :: Maybe AllocationId
|
||||
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
data InvitationDBData CourseParticipant = InvDBDataParticipant
|
||||
-- no data needed in DB to manage participant invitation
|
||||
@ -70,20 +73,24 @@ participantInvitationConfig = InvitationConfig{..}
|
||||
where
|
||||
invitationRoute (Entity _ Course{..}) _ = return $ CourseR courseTerm courseSchool courseShorthand CInviteR
|
||||
invitationResolveFor _ = do
|
||||
Just (CourseR tid csh ssh CInviteR) <- getCurrentRoute
|
||||
getKeyBy404 $ TermSchoolCourseShort tid csh ssh
|
||||
cRoute <- getCurrentRoute
|
||||
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
|
||||
invitationHeading (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseParticipantInviteHeading $ CI.original courseName
|
||||
invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgCourseParticipantInviteExplanation}|]
|
||||
invitationTokenConfig _ _ = do
|
||||
itAuthority <- liftHandlerT requireAuthId
|
||||
itAuthority <- liftHandler requireAuthId
|
||||
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
|
||||
invitationRestriction _ _ = return Authorized
|
||||
invitationForm (Entity _ Course{..}) _ uid = hoistAForm lift . wFormToAForm $ do
|
||||
now <- liftIO getCurrentTime
|
||||
studyFeatures <- wreq (studyFeaturesFieldFor Nothing False [] $ Just uid)
|
||||
(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
|
||||
res <- act
|
||||
audit $ TransactionCourseParticipantEdit courseParticipantCourse courseParticipantUser
|
||||
@ -92,15 +99,18 @@ participantInvitationConfig = InvitationConfig{..}
|
||||
return . SomeMessage $ MsgCourseParticipantInvitationAccepted (CI.original courseName)
|
||||
invitationUltDest (Entity _ Course{..}) _ = return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR
|
||||
|
||||
data AddRecipientsResult = AddRecipientsResult
|
||||
data AddParticipantsResult = AddParticipantsResult
|
||||
{ aurAlreadyRegistered
|
||||
, aurNoUniquePrimaryField
|
||||
, aurSuccess :: [UserEmail]
|
||||
, aurSuccess :: Set UserId
|
||||
} deriving (Read, Show, Generic, Typeable)
|
||||
|
||||
instance Monoid AddRecipientsResult where
|
||||
instance Semigroup AddParticipantsResult where
|
||||
(<>) = mappenddefault
|
||||
|
||||
instance Monoid AddParticipantsResult where
|
||||
mempty = memptydefault
|
||||
mappend = mappenddefault
|
||||
mappend = (<>)
|
||||
|
||||
getCAddUserR, postCAddUserR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getCAddUserR = postCAddUserR
|
||||
@ -111,7 +121,9 @@ postCAddUserR tid ssh csh = do
|
||||
wreq (multiUserField (maybe True not $ formResultToMaybe enlist) 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
|
||||
|
||||
@ -121,57 +133,74 @@ postCAddUserR tid ssh csh = do
|
||||
{ formEncoding
|
||||
, 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) $
|
||||
tell . pure <=< messageI Success . MsgCourseParticipantsInvited $ length emails
|
||||
registerUsers :: CourseId -> Set (Either UserEmail UserId) -> WriterT [Message] (YesodJobDB UniWorX) ()
|
||||
registerUsers cid users = do
|
||||
let (emails,uids) = partitionEithers $ Set.toList users
|
||||
|
||||
unless (null aurAlreadyRegistered) $ do
|
||||
let modalTrigger = [whamlet|_{MsgCourseParticipantsAlreadyRegistered (length aurAlreadyRegistered)}|]
|
||||
modalContent = $(widgetFile "messages/courseInvitationAlreadyRegistered")
|
||||
tell . pure <=< messageWidget Info $ msgModal modalTrigger (Right modalContent)
|
||||
-- send Invitation eMails to unkown users
|
||||
lift $ sinkInvitationsF participantInvitationConfig [(mail,cid,(InvDBDataParticipant,InvTokenDataParticipant)) | mail <- emails]
|
||||
-- register known users
|
||||
tell <=< lift . addParticipantsResultMessages <=< lift . execWriterT $ mapM_ (registerUser cid) uids
|
||||
|
||||
unless (null aurNoUniquePrimaryField) $ do
|
||||
let modalTrigger = [whamlet|_{MsgCourseParticipantsRegisteredWithoutField (length aurNoUniquePrimaryField)}|]
|
||||
modalContent = $(widgetFile "messages/courseInvitationRegisteredWithoutField")
|
||||
tell . pure <=< messageWidget Warning $ msgModal modalTrigger (Right modalContent)
|
||||
unless (null emails) $
|
||||
tell . pure <=< messageI Success . MsgCourseParticipantsInvited $ length emails
|
||||
|
||||
unless (null aurSuccess) $
|
||||
tell . pure <=< messageI Success . MsgCourseParticipantsRegistered $ length aurSuccess
|
||||
|
||||
registerUser :: CourseId -> UserId -> WriterT AddRecipientsResult (YesodJobDB UniWorX) ()
|
||||
registerUser cid uid = exceptT tell tell $ do
|
||||
User{..} <- lift . lift $ getJust uid
|
||||
addParticipantsResultMessages :: (MonadHandler m, HandlerSite m ~ UniWorX)
|
||||
=> AddParticipantsResult
|
||||
-> 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) $
|
||||
throwError $ mempty { aurAlreadyRegistered = pure userEmail }
|
||||
unless (null aurAlreadyRegistered) $ do
|
||||
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
|
||||
| [f] <- features = Just f
|
||||
| otherwise = Nothing
|
||||
unless (null aurSuccess) $
|
||||
tell . pure <=< messageI Success . MsgCourseParticipantsRegistered $ length aurSuccess
|
||||
|
||||
courseParticipantRegistration <- liftIO getCurrentTime
|
||||
void . lift . lift . insert $ CourseParticipant
|
||||
{ courseParticipantCourse = cid
|
||||
, courseParticipantUser = uid
|
||||
, courseParticipantAllocated = False
|
||||
, ..
|
||||
}
|
||||
lift . lift . audit $ TransactionCourseParticipantEdit cid uid
|
||||
|
||||
return $ case courseParticipantField of
|
||||
Nothing -> mempty { aurNoUniquePrimaryField = pure userEmail }
|
||||
Just _ -> mempty { aurSuccess = pure userEmail }
|
||||
registerUser :: CourseId
|
||||
-> UserId
|
||||
-> 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
|
||||
|
||||
@ -41,12 +41,12 @@ instance Button UniWorX ButtonCourseRegister where
|
||||
data CourseRegisterForm = CourseRegisterForm
|
||||
{ crfStudyFeatures :: Maybe StudyFeaturesId
|
||||
, 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` for current user
|
||||
courseRegisterForm (Entity cid Course{..}) = liftHandlerT $ do
|
||||
courseRegisterForm (Entity cid Course{..}) = liftHandler $ do
|
||||
muid <- maybeAuthId
|
||||
(registration, application) <- runDB $ do
|
||||
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)
|
||||
|
||||
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
|
||||
let appFilesInfo = (,) <$> hasFiles <*> appCID
|
||||
filesMsg = bool MsgCourseRegistrationFiles MsgCourseApplicationFiles courseApplicationsRequired
|
||||
@ -141,6 +141,9 @@ courseRegisterForm (Entity cid Course{..}) = liftHandlerT $ do
|
||||
-> return $ FormSuccess Nothing
|
||||
| otherwise
|
||||
-> aFormToWForm $ fileUploadForm False (fslI . mkFs) courseApplicationsFiles
|
||||
|
||||
when (is _Just $ registration >>= courseParticipantAllocated . entityVal) $
|
||||
wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationAllocationLog
|
||||
|
||||
return $ CourseRegisterForm
|
||||
<$ secretRes
|
||||
@ -191,13 +194,13 @@ postCRegisterR tid ssh csh = do
|
||||
whenIsJust appRes $
|
||||
audit . TransactionCourseApplicationEdit cid uid
|
||||
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
|
||||
| otherwise
|
||||
= return $ Just ()
|
||||
mkRegistration = do
|
||||
audit $ TransactionCourseParticipantEdit cid uid
|
||||
insertUnique $ CourseParticipant cid uid cTime crfStudyFeatures False
|
||||
insertUnique $ CourseParticipant cid uid cTime crfStudyFeatures Nothing
|
||||
|
||||
deleteApplications = do
|
||||
appIds <- selectKeysList [ CourseApplicationAllocation ==. Nothing, CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid ] []
|
||||
@ -222,7 +225,7 @@ postCRegisterR tid ssh csh = do
|
||||
delete $ partId
|
||||
audit $ TransactionCourseParticipantDeleted cid uid
|
||||
|
||||
when courseParticipantAllocated $ do
|
||||
when (is _Just courseParticipantAllocated) $ do
|
||||
now <- liftIO getCurrentTime
|
||||
insert_ $ AllocationDeregister courseParticipantUser (Just courseParticipantCourse) now Nothing
|
||||
|
||||
|
||||
@ -7,7 +7,6 @@ import Import
|
||||
|
||||
import Utils.Form
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Table.Cells
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
import Database.Esqueleto.Utils.TH
|
||||
|
||||
@ -19,7 +18,7 @@ import qualified Database.Esqueleto as E
|
||||
|
||||
import Handler.Course.Register
|
||||
|
||||
import System.FilePath (addExtension)
|
||||
import System.FilePath (addExtension, pathSeparator)
|
||||
|
||||
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 tid ssh csh = do
|
||||
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)]
|
||||
<- lift . E.select . E.from $
|
||||
\((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.orderBy [ E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName ]
|
||||
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)
|
||||
partStaff (CourseLecturer ,name,surn,mail) = Right (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 ->
|
||||
E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. E.val cid
|
||||
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
|
||||
mAllocation' <- for mAllocation $ \Allocation{..} -> (,)
|
||||
<$> pure allocationName
|
||||
mAllocation' <- for mAllocation $ \alloc@Allocation{..} -> (,)
|
||||
<$> pure alloc
|
||||
<*> toTextUrl (AllocationR allocationTerm allocationSchool allocationShorthand AShowR :#: cID)
|
||||
regForm <- if
|
||||
| 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
|
||||
Nothing -> mempty
|
||||
Just tutorialCapacity' -> sqlCell $ do
|
||||
[E.Value freeCapacity] <- E.select $ let numParticipants = E.sub_select . E.from $ \participant -> do
|
||||
E.where_ $ participant E.^. TutorialParticipantTutorial E.==. E.val tutid
|
||||
return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int))
|
||||
in return $ E.val tutorialCapacity' E.-. numParticipants
|
||||
return . toWidget . tshow $ max 0 freeCapacity
|
||||
freeCapacity <- fmap (maybe 0 (max 0 . E.unValue) . listToMaybe)
|
||||
. E.select $ let numParticipants = E.sub_select . E.from $ \participant -> do
|
||||
E.where_ $ participant E.^. TutorialParticipantTutorial E.==. E.val tutid
|
||||
return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int))
|
||||
in return $ E.val tutorialCapacity' E.-. numParticipants
|
||||
return . toWidget $ tshow freeCapacity
|
||||
, sortable Nothing mempty $ \DBRow{ dbrOutput = Entity tutId Tutorial{..} } -> sqlCell $ do
|
||||
mayRegister <- (== Authorized) <$> evalAccessDB (CTutorialR tid ssh csh tutorialName TRegisterR) True
|
||||
isRegistered <- case mbAid of
|
||||
@ -138,7 +154,7 @@ getCShowR tid ssh csh = do
|
||||
Just uid -> existsBy $ UniqueTutorialParticipant tutId uid
|
||||
if
|
||||
| mayRegister -> do
|
||||
(tutRegisterForm, tutRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered
|
||||
(tutRegisterForm, tutRegisterEnctype) <- liftHandler . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered
|
||||
return $ wrapForm tutRegisterForm def
|
||||
{ formAction = Just . SomeRoute $ CTutorialR tid ssh csh tutorialName TRegisterR
|
||||
, formEncoding = tutRegisterEnctype
|
||||
@ -199,7 +215,7 @@ getCShowR tid ssh csh = do
|
||||
-- Just uid -> existsBy $ UniqueExamRegistration eId uid
|
||||
-- if
|
||||
-- | mayRegister -> do
|
||||
-- (examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnExamRegister] [BtnExamDeregister] isRegistered
|
||||
-- (examRegisterForm, examRegisterEnctype) <- liftHandler . generateFormPost . buttonForm' $ bool [BtnExamRegister] [BtnExamDeregister] isRegistered
|
||||
-- return $ wrapForm examRegisterForm def
|
||||
-- { formAction = Just . SomeRoute $ CExamR tid ssh csh examName ERegisterR
|
||||
-- , formEncoding = examRegisterEnctype
|
||||
@ -236,6 +252,14 @@ getCShowR tid ssh csh = do
|
||||
& defaultSorting [SortAscBy "time"]
|
||||
(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
|
||||
setTitleI $ prependCourseTitle tid ssh csh (""::Text)
|
||||
$(widgetFile "course")
|
||||
|
||||
@ -16,6 +16,8 @@ import Text.Blaze.Html.Renderer.Text (renderHtml)
|
||||
|
||||
import Handler.Course.Register
|
||||
|
||||
import Jobs.Queue
|
||||
|
||||
|
||||
getCUserR, postCUserR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDUser -> Handler Html
|
||||
getCUserR = postCUserR
|
||||
@ -118,40 +120,53 @@ postCUserR tid ssh csh uCId = do
|
||||
let regButton
|
||||
| is _Just mRegistration = BtnCourseDeregister
|
||||
| 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
|
||||
registrationButtonFrag = "registration-button"
|
||||
regButtonWidget = wrapForm regButtonView FormSettings
|
||||
regButtonWidget = wrapForm' regButton regButtonView FormSettings
|
||||
{ formMethod = POST
|
||||
, formAction = Just . SomeRoute $ currentRoute :#: registrationButtonFrag
|
||||
, formEncoding = regButtonEnctype
|
||||
, formAttrs = []
|
||||
, formSubmit = FormNoSubmit
|
||||
, formSubmit = FormSubmit
|
||||
, formAnchor = Just registrationButtonFrag
|
||||
}
|
||||
formResult regButtonRes $ \case
|
||||
_
|
||||
| not mayRegister
|
||||
-> permissionDenied "User may not be registered"
|
||||
BtnCourseDeregister
|
||||
| Just (Entity pId _) <- mRegistration
|
||||
(BtnCourseDeregister, mbReason)
|
||||
| Just (Entity pId CourseParticipant{..}) <- mRegistration
|
||||
-> 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
|
||||
redirect $ CourseR tid ssh csh CUsersR
|
||||
| otherwise
|
||||
-> invalidArgs ["User not registered"]
|
||||
BtnCourseRegister -> do
|
||||
(BtnCourseRegister, _) -> do
|
||||
now <- liftIO getCurrentTime
|
||||
let field
|
||||
| [(Entity featId _, _, _)] <- filter (\(Entity _ StudyFeatures{..}, _, _) -> studyFeaturesValid) studies
|
||||
= Just featId
|
||||
| otherwise
|
||||
= Nothing
|
||||
pId <- runDB $ do
|
||||
pId <- insertUnique $ CourseParticipant cid uid now field False
|
||||
when (is _Just pId) $
|
||||
pId <- runDBJobs $ do
|
||||
pId <- insertUnique $ CourseParticipant cid uid now field Nothing
|
||||
when (is _Just pId) $ do
|
||||
queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cid
|
||||
audit $ TransactionCourseParticipantEdit cid uid
|
||||
return pId
|
||||
case pId of
|
||||
@ -159,7 +174,7 @@ postCUserR tid ssh csh uCId = do
|
||||
addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk
|
||||
redirect currentRoute
|
||||
Nothing -> invalidArgs ["User already registered"]
|
||||
_other -> fail "Invalid @regButton@"
|
||||
_other -> error "Invalid @regButton@"
|
||||
|
||||
mRegAt <- for (courseParticipantRegistration . entityVal <$> mRegistration) $ formatTime SelFormatDateTime
|
||||
|
||||
|
||||
@ -11,10 +11,6 @@ import Import
|
||||
|
||||
import Utils.Form
|
||||
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 Database.Esqueleto.Utils.TH
|
||||
|
||||
@ -25,6 +21,8 @@ import qualified Data.Map as Map
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
import qualified Data.Csv as Csv
|
||||
|
||||
|
||||
type UserTableExpr = (E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant))
|
||||
`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)
|
||||
|
||||
|
||||
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
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
||||
|
||||
@ -129,20 +159,27 @@ instance Finite CourseUserAction
|
||||
nullaryPathPiece ''CourseUserAction $ camelToPathPiece' 2
|
||||
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
|
||||
, MonoFoldable acts
|
||||
, RenderMessage UniWorX (Element acts), Eq (Element acts), PathPiece (Element acts)
|
||||
, Ord act, PathPiece act, RenderMessage UniWorX act
|
||||
)
|
||||
=> CourseId
|
||||
-> acts
|
||||
-> Map act (AForm Handler act')
|
||||
-> (UserTableExpr -> E.SqlExpr (E.Value Bool))
|
||||
-> Colonnade h UserTableData (DBCell (MForm Handler) (FormResult (First (Element acts), DBFormResult UserId Bool UserTableData)))
|
||||
-> PSValidator (MForm Handler) (FormResult (First (Element acts), DBFormResult UserId Bool UserTableData))
|
||||
-> DB (FormResult (Element acts, Set UserId), Widget)
|
||||
-> Colonnade h UserTableData (DBCell (MForm Handler) (FormResult (First act', DBFormResult UserId Bool UserTableData)))
|
||||
-> PSValidator (MForm Handler) (FormResult (First act', DBFormResult UserId Bool UserTableData))
|
||||
-> DB (FormResult (act', Set UserId), Widget)
|
||||
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
|
||||
let dbtIdent = "courseUsers" :: Text
|
||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||||
@ -212,26 +249,54 @@ makeCourseUserTable cid acts restrict colChoices psValidator = do
|
||||
, dbParamsFormAdditional
|
||||
= renderAForm FormStandard
|
||||
$ (, mempty) . First . Just
|
||||
<$> areq (selectField $ optionsF acts) (fslI MsgAction) Nothing
|
||||
, dbParamsFormEvaluate = liftHandlerT . runFormPost
|
||||
<$> multiActionA acts (fslI MsgAction) Nothing
|
||||
, dbParamsFormEvaluate = liftHandler . runFormPost
|
||||
, dbParamsFormResult = id
|
||||
, 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
|
||||
over _1 postprocess <$> dbTable psValidator DBTable{..}
|
||||
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
|
||||
(First (Just act), usrMap) <- inp
|
||||
let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
|
||||
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
|
||||
postCUsersR tid ssh csh = do
|
||||
(Entity cid course, numParticipants, (participantRes,participantTable)) <- runDB $ do
|
||||
mayRegister <- hasWriteAccessTo $ CourseR tid ssh csh CAddUserR
|
||||
ent@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
let colChoices = mconcat
|
||||
[ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
|
||||
, colUserNameLink (CourseR tid ssh csh . CUserR)
|
||||
@ -244,27 +309,33 @@ postCUsersR tid ssh csh = do
|
||||
, colUserComment tid ssh csh
|
||||
]
|
||||
psValidator = def & defaultSortingByName
|
||||
acts = catMaybes
|
||||
[ Just CourseUserSendMail
|
||||
, guardOn mayRegister CourseUserDeregister
|
||||
acts = mconcat
|
||||
[ singletonMap CourseUserSendMail $ pure CourseUserSendMailData
|
||||
, if
|
||||
| mayRegister
|
||||
-> singletonMap CourseUserDeregister $ courseUserDeregisterForm cid
|
||||
| otherwise
|
||||
-> mempty
|
||||
]
|
||||
ent@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
numParticipants <- count [CourseParticipantCourse ==. cid]
|
||||
table <- makeCourseUserTable cid acts (const E.true) colChoices psValidator
|
||||
return (ent, numParticipants, table)
|
||||
formResult participantRes $ \case
|
||||
(CourseUserSendMail, selectedUsers) -> do
|
||||
(CourseUserSendMailData, selectedUsers) -> do
|
||||
cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser]
|
||||
redirect (CourseR tid ssh csh CCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cids])
|
||||
(CourseUserDeregister,selectedUsers) -> do
|
||||
Sum nrDel <- fmap mconcat . runDB . forM (Set.toList selectedUsers) $ \uid -> do
|
||||
nrDel <- deleteWhereCount
|
||||
[ CourseParticipantCourse ==. cid
|
||||
, CourseParticipantUser ==. uid
|
||||
]
|
||||
unless (nrDel == 0) $
|
||||
audit $ TransactionCourseParticipantDeleted cid uid
|
||||
return $ Sum nrDel
|
||||
(CourseUserDeregisterData{..}, selectedUsers) -> do
|
||||
Sum nrDel <- fmap mconcat . runDB . forM (Set.toList selectedUsers) $ \uid -> fmap (maybe mempty Sum) . runMaybeT $ do
|
||||
now <- liftIO getCurrentTime
|
||||
Entity reg CourseParticipant{..} <- MaybeT . getBy $ UniqueParticipant uid cid
|
||||
lift $ delete reg
|
||||
lift . audit $ TransactionCourseParticipantDeleted cid uid
|
||||
case deregisterReason of
|
||||
Just reason
|
||||
| is _Just courseParticipantAllocated ->
|
||||
lift . insert_ $ AllocationDeregister uid (Just cid) now (Just reason)
|
||||
_other -> return ()
|
||||
return 1
|
||||
addMessageI Success $ MsgCourseUsersDeregistered nrDel
|
||||
redirect $ CourseR tid ssh csh CUsersR
|
||||
let headingLong = [whamlet|_{MsgMenuCourseMembers} #{courseName course} #{tid}|]
|
||||
|
||||
@ -29,9 +29,12 @@ data AddRecipientsResult = AddRecipientsResult
|
||||
, aurSuccessCourse :: [UserEmail]
|
||||
} deriving (Read, Show, Generic, Typeable)
|
||||
|
||||
instance Semigroup AddRecipientsResult where
|
||||
(<>) = mappenddefault
|
||||
|
||||
instance Monoid AddRecipientsResult where
|
||||
mempty = memptydefault
|
||||
mappend = mappenddefault
|
||||
mappend = (<>)
|
||||
|
||||
|
||||
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
|
||||
((usersToEnlist,formWgt),formEncoding) <- runFormPost . renderWForm FormStandard $ do
|
||||
now <- liftIO getCurrentTime
|
||||
occurrences <- liftHandlerT . runDB $ selectList [ExamOccurrenceExam ==. eid] []
|
||||
occurrences <- liftHandler . runDB $ selectList [ExamOccurrenceExam ==. eid] []
|
||||
|
||||
let
|
||||
localNow = utcToLocalTime now
|
||||
@ -144,10 +147,11 @@ postEAddUserR tid ssh csh examn = do
|
||||
{ courseParticipantCourse = cid
|
||||
, courseParticipantUser = uid
|
||||
, courseParticipantRegistration = now
|
||||
, courseParticipantAllocated = False
|
||||
, courseParticipantAllocated = Nothing
|
||||
, ..
|
||||
}
|
||||
lift . lift . audit $ TransactionCourseParticipantEdit cid uid
|
||||
lift . lift . queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cid
|
||||
lift $ lift examRegister
|
||||
|
||||
return $ case courseParticipantField of
|
||||
|
||||
@ -55,15 +55,19 @@ examCorrectorInvitationConfig = InvitationConfig{..}
|
||||
Course{..} <- get404 examCourse
|
||||
return $ CExamR courseTerm courseSchool courseShorthand examName ECInviteR
|
||||
invitationResolveFor _ = do
|
||||
Just (CExamR tid csh ssh examn ECInviteR) <- getCurrentRoute
|
||||
fetchExamId tid csh ssh examn
|
||||
cRoute <- getCurrentRoute
|
||||
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
|
||||
Course{..} <- get404 examCourse
|
||||
return . SomeMessage $ MsgMailSubjectExamCorrectorInvitation courseTerm courseSchool courseShorthand examName
|
||||
invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamCorrectorInviteHeading examName
|
||||
invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamCorrectorInviteExplanation}|]
|
||||
invitationTokenConfig _ _ = do
|
||||
itAuthority <- liftHandlerT requireAuthId
|
||||
itAuthority <- liftHandler requireAuthId
|
||||
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
|
||||
invitationRestriction _ _ = return Authorized
|
||||
invitationForm _ _ _ = pure (JunctionExamCorrector, ())
|
||||
|
||||
@ -18,12 +18,12 @@ import Jobs.Queue
|
||||
getEEditR, postEEditR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
|
||||
getEEditR = postEEditR
|
||||
postEEditR tid ssh csh examn = do
|
||||
(cid, eId, template) <- runDB $ do
|
||||
(cid, exam@(Entity eId _)) <- fetchCourseIdExam tid ssh csh examn
|
||||
(cid, Entity eId oldExam, template) <- runDB $ do
|
||||
(cid, exam) <- fetchCourseIdExam tid ssh csh examn
|
||||
|
||||
template <- examFormTemplate exam
|
||||
|
||||
return (cid, eId, template)
|
||||
return (cid, exam, template)
|
||||
|
||||
((editExamResult, editExamWidget), editExamEnctype) <- runFormPost . validateForm validateExam . examForm $ Just template
|
||||
|
||||
@ -43,7 +43,7 @@ postEEditR tid ssh csh examn = do
|
||||
, examStart = efStart
|
||||
, examEnd = efEnd
|
||||
, examFinished = efFinished
|
||||
, examClosed = efClosed
|
||||
, examClosed = examClosed oldExam
|
||||
, examPublicStatistics = efPublicStatistics
|
||||
, examShowGrades = efShowGrades
|
||||
, examDescription = efDescription
|
||||
@ -85,6 +85,7 @@ postEEditR tid ssh csh examn = do
|
||||
ExamPartForm{ epfId = Nothing, .. } -> insert_
|
||||
ExamPart
|
||||
{ examPartExam = eId
|
||||
, examPartNumber = epfNumber
|
||||
, examPartName = epfName
|
||||
, examPartMaxPoints = epfMaxPoints
|
||||
, examPartWeight = epfWeight
|
||||
@ -96,6 +97,7 @@ postEEditR tid ssh csh examn = do
|
||||
guard $ examPartExam oldPart == eId
|
||||
lift $ replace epfId' ExamPart
|
||||
{ examPartExam = eId
|
||||
, examPartNumber = epfNumber
|
||||
, examPartName = epfName
|
||||
, examPartMaxPoints = epfMaxPoints
|
||||
, examPartWeight = epfWeight
|
||||
|
||||
@ -26,6 +26,7 @@ import Text.Blaze.Html.Renderer.String (renderHtml)
|
||||
data ExamForm = ExamForm
|
||||
{ efName :: ExamName
|
||||
, efDescription :: Maybe Html
|
||||
, efShowGrades :: Bool
|
||||
, efStart :: Maybe UTCTime
|
||||
, efEnd :: Maybe UTCTime
|
||||
, efVisibleFrom :: Maybe UTCTime
|
||||
@ -34,13 +35,11 @@ data ExamForm = ExamForm
|
||||
, efDeregisterUntil :: Maybe UTCTime
|
||||
, efPublishOccurrenceAssignments :: Maybe UTCTime
|
||||
, efFinished :: Maybe UTCTime
|
||||
, efClosed :: Maybe UTCTime
|
||||
, efOccurrences :: Set ExamOccurrenceForm
|
||||
, efShowGrades :: Bool
|
||||
, efPublicStatistics :: Bool
|
||||
, efGradingRule :: ExamGradingRule
|
||||
, efBonusRule :: ExamBonusRule
|
||||
, efOccurrenceRule :: ExamOccurrenceRule
|
||||
, efGradingRule :: Maybe ExamGradingRule
|
||||
, efBonusRule :: Maybe ExamBonusRule
|
||||
, efOccurrenceRule :: Maybe ExamOccurrenceRule
|
||||
, efCorrectors :: Set (Either UserEmail UserId)
|
||||
, efExamParts :: Set ExamPartForm
|
||||
}
|
||||
@ -57,7 +56,8 @@ data ExamOccurrenceForm = ExamOccurrenceForm
|
||||
|
||||
data ExamPartForm = ExamPartForm
|
||||
{ epfId :: Maybe CryptoUUIDExamPart
|
||||
, epfName :: ExamPartName
|
||||
, epfNumber :: ExamPartNumber
|
||||
, epfName :: Maybe ExamPartName
|
||||
, epfMaxPoints :: Maybe Points
|
||||
, epfWeight :: Rational
|
||||
} deriving (Read, Show, Eq, Ord, Generic, Typeable)
|
||||
@ -80,6 +80,7 @@ examForm template html = do
|
||||
flip (renderAForm FormStandard) html $ ExamForm
|
||||
<$> areq ciField (fslpI MsgExamName (mr MsgExamName) & setTooltip MsgExamNameTip) (efName <$> template)
|
||||
<*> (assertM (not . null . renderHtml) <$> aopt htmlField (fslpI MsgExamDescription "Html") (efDescription <$> template))
|
||||
<*> apopt checkBoxField (fslI MsgExamShowGrades & setTooltip MsgExamShowGradesTip) (efShowGrades <$> template <|> Just True)
|
||||
<* aformSection MsgExamFormTimes
|
||||
<*> aopt utcTimeField (fslpI MsgExamStart (mr MsgDate) & setTooltip MsgExamTimeTip) (efStart <$> 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 MsgExamPublishOccurrenceAssignments (mr MsgDate) & setTooltip MsgExamPublishOccurrenceAssignmentsTip) (efPublishOccurrenceAssignments <$> template)
|
||||
<*> aopt utcTimeField (fslpI MsgExamFinished (mr MsgDate) & setTooltip MsgExamFinishedTip) (efFinished <$> template)
|
||||
<*> aopt utcTimeField (fslpI MsgExamClosed (mr MsgDate) & setTooltip MsgExamClosedTip) (efClosed <$> template)
|
||||
<* aformSection MsgExamFormOccurrences
|
||||
<*> examOccurrenceForm (efOccurrences <$> template)
|
||||
<* aformSection MsgExamFormAutomaticFunctions
|
||||
<*> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamShowGrades & setTooltip MsgExamShowGradesTip) (Just . efShowGrades <$> template))
|
||||
<*> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamPublicStatistics & setTooltip MsgExamPublicStatisticsTip) (Just . efPublicStatistics <$> template))
|
||||
<*> examGradingRuleForm (efGradingRule <$> template)
|
||||
<*> examBonusRuleForm (efBonusRule <$> template)
|
||||
<*> examOccurrenceRuleForm (efOccurrenceRule <$> template)
|
||||
<*> apopt checkBoxField (fslI MsgExamPublicStatistics & setTooltip MsgExamPublicStatisticsTip) (efPublicStatistics <$> template <|> Just True)
|
||||
<*> optionalActionA (examGradingRuleForm $ efGradingRule =<< template) (fslI MsgExamAutomaticGrading & setTooltip MsgExamAutomaticGradingTip) (is _Just . efGradingRule <$> template)
|
||||
<*> optionalActionA (examBonusRuleForm $ efBonusRule =<< template) (fslI MsgExamBonus) (is _Just . efBonusRule <$> template)
|
||||
<*> optionalActionA (examOccurrenceRuleForm $ efOccurrenceRule =<< template) (fslI MsgExamAutomaticOccurrenceAssignment & setTooltip MsgExamAutomaticOccurrenceAssignmentTip) (is _Just . efOccurrenceRule <$> template)
|
||||
<* aformSection MsgExamFormCorrection
|
||||
<*> examCorrectorsForm (efCorrectors <$> template)
|
||||
<* aformSection MsgExamFormParts
|
||||
@ -106,8 +105,8 @@ examForm template html = do
|
||||
examCorrectorsForm :: Maybe (Set (Either UserEmail UserId)) -> AForm Handler (Set (Either UserEmail UserId))
|
||||
examCorrectorsForm mPrev = wFormToAForm $ do
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
Just currentRoute <- getCurrentRoute
|
||||
uid <- liftHandlerT requireAuthId
|
||||
currentRoute <- fromMaybe (error "examCorrectorForm called from 404-handler") <$> getCurrentRoute
|
||||
uid <- liftHandler requireAuthId
|
||||
|
||||
let
|
||||
miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
|
||||
@ -138,10 +137,11 @@ examCorrectorsForm mPrev = wFormToAForm $ do
|
||||
|
||||
|
||||
miCell' :: Either UserEmail UserId -> Widget
|
||||
miCell' (Left email) =
|
||||
miCell' (Left email) = do
|
||||
invWarnMsg <- messageI Warning MsgEmailInvitationWarning
|
||||
$(widgetFile "widgets/massinput/examCorrectors/cellInvitation")
|
||||
miCell' (Right userId) = do
|
||||
User{..} <- liftHandlerT . runDB $ get404 userId
|
||||
User{..} <- liftHandler . runDB $ get404 userId
|
||||
$(widgetFile "widgets/massinput/examCorrectors/cellKnown")
|
||||
|
||||
miLayout' :: MassInputLayout ListLength (Either UserEmail UserId) ()
|
||||
@ -151,7 +151,7 @@ examCorrectorsForm mPrev = wFormToAForm $ do
|
||||
|
||||
examOccurrenceForm :: Maybe (Set ExamOccurrenceForm) -> AForm Handler (Set ExamOccurrenceForm)
|
||||
examOccurrenceForm prev = wFormToAForm $ do
|
||||
Just currentRoute <- getCurrentRoute
|
||||
currentRoute <- fromMaybe (error "examOccurrenceForm called from 404-handler") <$> getCurrentRoute
|
||||
let
|
||||
miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
|
||||
miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag
|
||||
@ -193,7 +193,7 @@ examOccurrenceForm prev = wFormToAForm $ do
|
||||
|
||||
examPartsForm :: Maybe (Set ExamPartForm) -> AForm Handler (Set ExamPartForm)
|
||||
examPartsForm prev = wFormToAForm $ do
|
||||
Just currentRoute <- getCurrentRoute
|
||||
currentRoute <- fromMaybe (error "examPartsForm called from 404-handler") <$> getCurrentRoute
|
||||
let
|
||||
miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
|
||||
miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag
|
||||
@ -202,12 +202,14 @@ examPartsForm prev = wFormToAForm $ do
|
||||
where
|
||||
examPartForm' nudge mPrev csrf = do
|
||||
(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)
|
||||
(epfWeightRes, epfWeightView) <- mpreq (checkBool (>= 0) MsgExamPartWeightNegative rationalField) ("" & addName (nudge "weight")) (epfWeight <$> mPrev <|> Just 1)
|
||||
|
||||
return ( ExamPartForm
|
||||
<$> epfIdRes
|
||||
<*> epfNumberRes
|
||||
<*> epfNameRes
|
||||
<*> epfMaxPointsRes
|
||||
<*> epfWeightRes
|
||||
@ -219,7 +221,8 @@ examPartsForm prev = wFormToAForm $ do
|
||||
(res, formWidget) <- examPartForm' nudge Nothing csrf
|
||||
let
|
||||
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
|
||||
return (addRes, $(widgetFile "widgets/massinput/examParts/add"))
|
||||
miCell' nudge dat = examPartForm' nudge (Just dat)
|
||||
@ -250,7 +253,6 @@ examFormTemplate (Entity eId Exam{..}) = do
|
||||
, efStart = examStart
|
||||
, efEnd = examEnd
|
||||
, efFinished = examFinished
|
||||
, efClosed = examClosed
|
||||
, efShowGrades = examShowGrades
|
||||
, efPublicStatistics = examPublicStatistics
|
||||
, efDescription = examDescription
|
||||
@ -269,6 +271,7 @@ examFormTemplate (Entity eId Exam{..}) = do
|
||||
(Just -> epfId, ExamPart{..}) <- examParts'
|
||||
return ExamPartForm
|
||||
{ epfId
|
||||
, epfNumber = examPartNumber
|
||||
, epfName = examPartName
|
||||
, epfMaxPoints = examPartMaxPoints
|
||||
, epfWeight = examPartWeight
|
||||
@ -318,7 +321,6 @@ examTemplate cid = runMaybeT $ do
|
||||
, efStart = dateOffset <$> examStart oldExam
|
||||
, efEnd = dateOffset <$> examEnd oldExam
|
||||
, efFinished = dateOffset <$> examFinished oldExam
|
||||
, efClosed = dateOffset <$> examClosed oldExam
|
||||
, efShowGrades = examShowGrades oldExam
|
||||
, efPublicStatistics = examPublicStatistics oldExam
|
||||
, efDescription = examDescription oldExam
|
||||
@ -338,9 +340,6 @@ validateExam = do
|
||||
guardValidation MsgExamEndMustBeAfterStart $ NTop efEnd >= NTop efStart
|
||||
guardValidation MsgExamFinishedMustBeAfterEnd . fromMaybe True $ (>=) <$> efFinished <*> efEnd
|
||||
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
|
||||
guardValidation (MsgExamOccurrenceEndMustBeAfterStart eofName) $ NTop eofEnd >= NTop (Just eofStart)
|
||||
|
||||
@ -5,7 +5,6 @@ module Handler.Exam.List
|
||||
import Import
|
||||
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Table.Cells
|
||||
|
||||
import qualified Data.Map as Map
|
||||
|
||||
|
||||
@ -40,7 +40,7 @@ postCExamNewR tid ssh csh = do
|
||||
, examStart = efStart
|
||||
, examEnd = efEnd
|
||||
, examFinished = efFinished
|
||||
, examClosed = efClosed
|
||||
, examClosed = Nothing
|
||||
, examShowGrades = efShowGrades
|
||||
, examPublicStatistics = efPublicStatistics
|
||||
, examDescription = efDescription
|
||||
@ -50,6 +50,7 @@ postCExamNewR tid ssh csh = do
|
||||
[ ExamPart{..}
|
||||
| ExamPartForm{..} <- Set.toList efExamParts
|
||||
, let examPartExam = examid
|
||||
examPartNumber = epfNumber
|
||||
examPartName = epfName
|
||||
examPartMaxPoints = epfMaxPoints
|
||||
examPartWeight = epfWeight
|
||||
|
||||
@ -18,6 +18,8 @@ import qualified Data.Set as Set
|
||||
import Text.Hamlet (ihamlet)
|
||||
|
||||
import Data.Aeson hiding (Result(..))
|
||||
|
||||
import Jobs.Queue
|
||||
|
||||
|
||||
instance IsInvitableJunction ExamRegistration where
|
||||
@ -63,15 +65,19 @@ examRegistrationInvitationConfig = InvitationConfig{..}
|
||||
Course{..} <- get404 examCourse
|
||||
return $ CExamR courseTerm courseSchool courseShorthand examName EInviteR
|
||||
invitationResolveFor _ = do
|
||||
Just (CExamR tid csh ssh examn EInviteR) <- getCurrentRoute
|
||||
fetchExamId tid csh ssh examn
|
||||
cRoute <- getCurrentRoute
|
||||
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
|
||||
Course{..} <- get404 examCourse
|
||||
return . SomeMessage $ MsgMailSubjectExamRegistrationInvitation courseTerm courseSchool courseShorthand examName
|
||||
invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamRegistrationInviteHeading examName
|
||||
invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamRegistrationInviteExplanation}|]
|
||||
invitationTokenConfig _ (InvDBDataExamRegistration{..}, _) = do
|
||||
itAuthority <- liftHandlerT requireAuthId
|
||||
itAuthority <- liftHandler requireAuthId
|
||||
let itExpiresAt = Just $ Just invDBExamRegistrationDeadline
|
||||
itAddAuth
|
||||
| not invDBExamRegistrationCourseRegister
|
||||
@ -81,8 +87,8 @@ examRegistrationInvitationConfig = InvitationConfig{..}
|
||||
itStartsAt = Nothing
|
||||
return InvitationTokenConfig{..}
|
||||
invitationRestriction _ _ = return Authorized
|
||||
invitationForm (Entity _ Exam{..}) (InvDBDataExamRegistration{..}, _) uid = hoistAForm liftHandlerT . wFormToAForm $ do
|
||||
isRegistered <- fmap (is _Just) . liftHandlerT . runDB . getBy $ UniqueParticipant uid examCourse
|
||||
invitationForm (Entity _ Exam{..}) (InvDBDataExamRegistration{..}, _) uid = hoistAForm liftHandler . wFormToAForm $ do
|
||||
isRegistered <- fmap (is _Just) . liftHandler . runDB . getBy $ UniqueParticipant uid examCourse
|
||||
now <- liftIO getCurrentTime
|
||||
|
||||
case (isRegistered, invDBExamRegistrationCourseRegister) of
|
||||
@ -93,7 +99,8 @@ examRegistrationInvitationConfig = InvitationConfig{..}
|
||||
(True , _ ) -> return $ pure (JunctionExamRegistration invDBExamRegistrationOccurrence now, Nothing)
|
||||
invitationInsertHook (Entity eid Exam{..}) _ ExamRegistration{..} mField act = 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
|
||||
|
||||
let doAudit = audit $ TransactionExamRegister eid examRegistrationUser
|
||||
|
||||
@ -22,7 +22,7 @@ getEShowR tid ssh csh examn = do
|
||||
cTime <- liftIO getCurrentTime
|
||||
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
|
||||
|
||||
let examVisible = NTop (Just cTime) >= NTop examVisibleFrom
|
||||
@ -33,7 +33,7 @@ getEShowR tid ssh csh examn = do
|
||||
let occurrenceAssignmentsVisible = NTop (Just cTime) >= NTop examPublishOccurrenceAssignments
|
||||
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 ->
|
||||
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
|
||||
|
||||
result <- fmap join . for mUid $ getBy . UniqueExamResult eId
|
||||
bonus <- fmap join . for mUid $ getBy . UniqueExamBonus eId
|
||||
|
||||
occurrencesRaw <- E.select . E.from $ \examOccurrence -> do
|
||||
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
|
||||
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
|
||||
registerWidget
|
||||
| Just isRegistered <- registered
|
||||
, mayRegister = Just $ do
|
||||
(examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnExamRegister] [BtnExamDeregister] isRegistered
|
||||
(examRegisterForm, examRegisterEnctype) <- liftHandler . generateFormPost . buttonForm' $ bool [BtnExamRegister] [BtnExamDeregister] isRegistered
|
||||
[whamlet|
|
||||
<p>
|
||||
$if isRegistered
|
||||
@ -86,6 +105,9 @@ getEShowR tid ssh csh examn = do
|
||||
| fromMaybe False registered = Just [whamlet|_{MsgExamRegistered}|]
|
||||
| otherwise = Nothing
|
||||
|
||||
showMaxPoints = any (has $ _entityVal . _examPartMaxPoints . _Just) examParts
|
||||
showAchievedPoints = not $ null results
|
||||
|
||||
let heading = prependCourseTitle tid ssh csh $ CI.original examName
|
||||
|
||||
siteLayoutMsg heading $ do
|
||||
|
||||
@ -4,25 +4,27 @@ module Handler.Exam.Users
|
||||
( getEUsersR, postEUsersR
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Import hiding ((<.), (.>))
|
||||
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Exam
|
||||
import Handler.Utils.Table.Columns
|
||||
import Handler.Utils.Table.Cells
|
||||
import Handler.Utils.Csv
|
||||
|
||||
import Handler.ExamOffice.Exam (examCloseWidget)
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
import Database.Esqueleto.Utils.TH
|
||||
|
||||
import qualified Data.Csv as Csv
|
||||
|
||||
import Data.Map ((!))
|
||||
import Data.Map ((!), (!?))
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.HashMap.Lazy as HashMap
|
||||
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.Encoding as Text
|
||||
import qualified Data.Text.Lens as Text
|
||||
|
||||
import qualified Data.Conduit.List as C
|
||||
@ -33,9 +35,35 @@ import Numeric.Lens (integral)
|
||||
|
||||
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))
|
||||
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))
|
||||
import Jobs.Queue
|
||||
|
||||
|
||||
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
|
||||
hasEntity = _dbrOutput . _2
|
||||
@ -47,28 +75,51 @@ _userTableOccurrence :: Lens' ExamUserTableData (Maybe (Entity ExamOccurrence))
|
||||
_userTableOccurrence = _dbrOutput . _3
|
||||
|
||||
queryUser :: ExamUserTableExpr -> E.SqlExpr (Entity User)
|
||||
queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 5 1)
|
||||
|
||||
queryStudyFeatures :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures))
|
||||
queryStudyFeatures = $(sqlIJproj 3 1) . $(sqlLOJproj 2 2) . $(sqlLOJproj 5 3)
|
||||
queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 6 1)
|
||||
|
||||
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 = $(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 = $(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 = $(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 = $(sqlLOJproj 5 4)
|
||||
queryExamResult = $(sqlLOJproj 6 5)
|
||||
|
||||
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 = _dbrOutput . _1
|
||||
@ -88,11 +139,48 @@ resultStudyField = _dbrOutput . _6 . _Just
|
||||
resultExamOccurrence :: Traversal' ExamUserTableData (Entity ExamOccurrence)
|
||||
resultExamOccurrence = _dbrOutput . _3 . _Just
|
||||
|
||||
resultExamBonus :: Traversal' ExamUserTableData (Entity ExamBonus)
|
||||
resultExamBonus = _dbrOutput . _7 . _Just
|
||||
|
||||
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 = _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
|
||||
{ csvEUserSurname :: Maybe Text
|
||||
@ -103,24 +191,46 @@ data ExamUserTableCsv = ExamUserTableCsv
|
||||
, csvEUserDegree :: Maybe Text
|
||||
, csvEUserSemester :: Maybe Int
|
||||
, csvEUserOccurrence :: Maybe (CI Text)
|
||||
, csvEUserExercisePoints :: Maybe Points
|
||||
, csvEUserExerciseNumPasses :: Maybe Int
|
||||
, csvEUserExercisePointsMax :: Maybe Points
|
||||
, csvEUserExerciseNumPassesMax :: Maybe Int
|
||||
, csvEUserExercisePoints :: Maybe (Maybe Points)
|
||||
, csvEUserExerciseNumPasses :: Maybe (Maybe Int)
|
||||
, csvEUserExercisePointsMax :: Maybe (Maybe Points)
|
||||
, csvEUserExerciseNumPassesMax :: Maybe (Maybe Int)
|
||||
, csvEUserBonus :: Maybe (Maybe Points)
|
||||
, csvEUserExamPartResults :: Map ExamPartNumber (Maybe ExamResultPoints)
|
||||
, csvEUserExamResult :: Maybe ExamResultPassedGrade
|
||||
, csvEUserCourseNote :: Maybe Html
|
||||
}
|
||||
deriving (Generic)
|
||||
makeLenses_ ''ExamUserTableCsv
|
||||
|
||||
examUserTableCsvOptions :: Csv.Options
|
||||
examUserTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 3 }
|
||||
|
||||
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
|
||||
parseNamedRecord csv -- Manually defined awaiting issue #427
|
||||
parseNamedRecord csv
|
||||
= ExamUserTableCsv
|
||||
<$> csv .:?? "surname"
|
||||
<*> csv .:?? "first-name"
|
||||
@ -130,36 +240,66 @@ instance FromNamedRecord ExamUserTableCsv where
|
||||
<*> csv .:?? "degree"
|
||||
<*> csv .:?? "semester"
|
||||
<*> csv .:?? "occurrence"
|
||||
<*> csv .:?? "exercise-points"
|
||||
<*> csv .:?? "exercise-num-passes"
|
||||
<*> csv .:?? "exercise-points-max"
|
||||
<*> csv .:?? "exercise-num-passes-max"
|
||||
<*> fmap Just (csv .:?? "exercise-points")
|
||||
<*> fmap Just (csv .:?? "exercise-num-passes")
|
||||
<*> fmap Just (csv .:?? "exercise-points-max")
|
||||
<*> fmap Just (csv .:?? "exercise-num-passes-max")
|
||||
<*> fmap Just (csv .:?? "bonus")
|
||||
<*> examPartResults
|
||||
<*> csv .:?? "exam-result"
|
||||
<*> csv .:?? "course-note"
|
||||
|
||||
instance DefaultOrdered ExamUserTableCsv where
|
||||
headerOrder = Csv.genericHeaderOrder examUserTableCsvOptions
|
||||
where
|
||||
examPartResults = fmap fold . sequence . flip HashMap.mapMaybeWithKey csv $ \pNumber' _ -> do
|
||||
pNumber <- pNumber' ^? csvExamPartHeader
|
||||
return . fmap (singletonMap pNumber ) $ csv .:?? pNumber'
|
||||
|
||||
instance CsvColumnsExplained ExamUserTableCsv where
|
||||
csvColumnsExplanations = genericCsvColumnsExplanations examUserTableCsvOptions $ Map.fromList
|
||||
[ ('csvEUserSurname , MsgCsvColumnExamUserSurname )
|
||||
, ('csvEUserFirstName , MsgCsvColumnExamUserFirstName )
|
||||
, ('csvEUserName , MsgCsvColumnExamUserName )
|
||||
, ('csvEUserMatriculation , MsgCsvColumnExamUserMatriculation )
|
||||
, ('csvEUserField , MsgCsvColumnExamUserField )
|
||||
, ('csvEUserDegree , MsgCsvColumnExamUserDegree )
|
||||
, ('csvEUserSemester , MsgCsvColumnExamUserSemester )
|
||||
, ('csvEUserOccurrence , MsgCsvColumnExamUserOccurrence )
|
||||
, ('csvEUserExercisePoints , MsgCsvColumnExamUserExercisePoints )
|
||||
, ('csvEUserExerciseNumPasses , MsgCsvColumnExamUserExercisePasses )
|
||||
, ('csvEUserExercisePointsMax , MsgCsvColumnExamUserExercisePointsMax )
|
||||
, ('csvEUserExerciseNumPassesMax, MsgCsvColumnExamUserExercisePassesMax )
|
||||
, ('csvEUserExamResult , MsgCsvColumnExamUserResult )
|
||||
, ('csvEUserCourseNote , MsgCsvColumnExamUserCourseNote )
|
||||
csvColumnsExplanations _ = mconcat
|
||||
[ single "surname" MsgCsvColumnExamUserSurname
|
||||
, single "first-name" MsgCsvColumnExamUserFirstName
|
||||
, single "name" MsgCsvColumnExamUserName
|
||||
, single "matriculation" MsgCsvColumnExamUserMatriculation
|
||||
, single "field" MsgCsvColumnExamUserField
|
||||
, single "degree" MsgCsvColumnExamUserDegree
|
||||
, single "semester" MsgCsvColumnExamUserSemester
|
||||
, single "occurrence" MsgCsvColumnExamUserOccurrence
|
||||
, single "exercise-points" MsgCsvColumnExamUserExercisePoints
|
||||
, single "exercise-num-passes" MsgCsvColumnExamUserExercisePasses
|
||||
, single "exercise-points-max" MsgCsvColumnExamUserExercisePointsMax
|
||||
, single "exercise-num-passes-max" MsgCsvColumnExamUserExercisePassesMax
|
||||
, single "bonus" MsgCsvColumnExamUserBonus
|
||||
, 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
|
||||
| ExamUserAssignOccurrence
|
||||
| ExamUserAcceptComputedResult
|
||||
| ExamUserResetToComputedResult
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
||||
|
||||
instance Universe ExamUserAction
|
||||
@ -169,13 +309,21 @@ embedRenderMessage ''UniWorX ''ExamUserAction id
|
||||
|
||||
data ExamUserActionData = ExamUserDeregisterData
|
||||
| ExamUserAssignOccurrenceData (Maybe ExamOccurrenceId)
|
||||
| ExamUserAcceptComputedResultData
|
||||
| ExamUserResetToComputedResultData
|
||||
{ examUserResetBonus :: Bool
|
||||
}
|
||||
|
||||
data ExamUserCsvActionClass
|
||||
= ExamUserCsvCourseRegister
|
||||
| ExamUserCsvRegister
|
||||
| ExamUserCsvAssignOccurrence
|
||||
| ExamUserCsvSetCourseField
|
||||
| ExamUserCsvSetPartResult
|
||||
| ExamUserCsvSetBonus
|
||||
| ExamUserCsvOverrideBonus
|
||||
| ExamUserCsvSetResult
|
||||
| ExamUserCsvOverrideResult
|
||||
| ExamUserCsvSetCourseNote
|
||||
| ExamUserCsvDeregister
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
@ -202,8 +350,19 @@ data ExamUserCsvAction
|
||||
| ExamUserCsvDeregisterData
|
||||
{ examUserCsvActRegistration :: ExamRegistrationId
|
||||
}
|
||||
| ExamUserCsvSetResultData
|
||||
| ExamUserCsvSetPartResultData
|
||||
{ examUserCsvActUser :: UserId
|
||||
, examUserCsvActExamPart :: ExamPartNumber
|
||||
, examUserCsvActExamPartResult :: Maybe ExamResultPoints
|
||||
}
|
||||
| ExamUserCsvSetBonusData
|
||||
{ examUserCsvIsBonusOverride :: Bool
|
||||
, examUserCsvActUser :: UserId
|
||||
, examUserCsvActExamBonus :: Maybe Points
|
||||
}
|
||||
| ExamUserCsvSetResultData
|
||||
{ examUserCsvIsResultOverride :: Bool
|
||||
, examUserCsvActUser :: UserId
|
||||
, examUserCsvActExamResult :: Maybe ExamResultPassedGrade
|
||||
}
|
||||
| ExamUserCsvSetCourseNoteData
|
||||
@ -230,73 +389,148 @@ embedRenderMessage ''UniWorX ''ExamUserCsvException id
|
||||
getEUsersR, postEUsersR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
|
||||
getEUsersR = postEUsersR
|
||||
postEUsersR tid ssh csh examn = do
|
||||
(registrationResult, examUsersTable) <- runDB $ do
|
||||
exam@(Entity eid Exam{..}) <- fetchExam tid ssh csh examn
|
||||
(((Any computedValues, registrationResult), examUsersTable), Entity eId examVal, bonus) <- runDB $ do
|
||||
exam@(Entity eid examVal@Exam{..}) <- fetchExam tid ssh csh examn
|
||||
examParts <- selectList [ExamPartExam ==. eid] [Asc ExamPartName]
|
||||
bonus <- examBonus exam
|
||||
|
||||
let
|
||||
allBoni :: SheetGradeSummary
|
||||
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 = 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
|
||||
examUsersDBTable = DBTable{..}
|
||||
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
|
||||
E.on $ courseUserNote E.?. CourseUserNoteUser E.==. E.just (user E.^. UserId)
|
||||
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 $ 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, examResult, courseUserNote)
|
||||
dbtSQLQuery = runReaderT $ do
|
||||
examRegistration <- asks queryExamRegistration
|
||||
user <- asks queryUser
|
||||
occurrence <- asks queryExamOccurrence
|
||||
courseParticipant <- asks queryCourseParticipant
|
||||
studyFeatures <- asks queryStudyFeatures
|
||||
studyDegree <- asks queryStudyDegree
|
||||
studyField <- asks queryStudyField
|
||||
examBonus' <- asks queryExamBonus
|
||||
examResult <- asks queryExamResult
|
||||
courseUserNote <- asks queryCourseNote
|
||||
|
||||
lift $ do
|
||||
E.on $ courseUserNote E.?. CourseUserNoteUser E.==. E.just (user E.^. UserId)
|
||||
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)
|
||||
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
|
||||
[ 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 colUserMatriclenr
|
||||
, pure $ colField resultStudyField
|
||||
, pure $ colDegreeShort resultStudyDegree
|
||||
, 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
|
||||
, guardOn showPasses $ sortable Nothing (i18nCell MsgAchievedPasses) $ \(view $ resultUser . _entityKey -> uid) -> fromMaybe mempty $ do
|
||||
SheetGradeSummary{achievedPasses} <- examBonusAchieved uid bonus
|
||||
SheetGradeSummary{numSheetsPasses} <- examBonusPossible uid bonus
|
||||
return $ propCell (getSum achievedPasses) (getSum numSheetsPasses)
|
||||
, guardOn showPoints $ sortable Nothing (i18nCell MsgAchievedPoints) $ \(view $ resultUser . _entityKey -> uid) -> fromMaybe mempty $ do
|
||||
SheetGradeSummary{achievedPoints} <- examBonusAchieved uid bonus
|
||||
SheetGradeSummary{sumSheetsPoints} <- examBonusPossible uid bonus
|
||||
return $ propCell (getSum achievedPoints) (getSum sumSheetsPoints)
|
||||
, guardOn examShowGrades $ sortable (Just "result") (i18nCell MsgExamResult) $ maybe mempty i18nCell . preview (resultExamResult . _entityVal . _examResultResult)
|
||||
, guardOn (not examShowGrades) $ sortable (Just "result-bool") (i18nCell MsgExamResult) $ maybe mempty i18nCell . preview (resultExamResult . _entityVal . _examResultResult . to (over _examResult $ view passingGrade))
|
||||
, guardOn showPasses $ sortable Nothing (i18nCell MsgAchievedPasses) $ \(view $ resultUser . _entityKey -> uid) ->
|
||||
let SheetGradeSummary{achievedPasses} = examBonusAchieved uid bonus
|
||||
SheetGradeSummary{numSheetsPasses} = examBonusPossible uid bonus
|
||||
in propCell (getSum achievedPasses) (getSum numSheetsPasses)
|
||||
, guardOn showPoints $ sortable Nothing (i18nCell MsgAchievedPoints) $ \(view $ resultUser . _entityKey -> uid) ->
|
||||
let SheetGradeSummary{achievedPoints} = examBonusAchieved uid bonus
|
||||
SheetGradeSummary{sumSheetsPoints} = examBonusPossible uid bonus
|
||||
in propCell (getSum achievedPoints) (getSum sumSheetsPoints)
|
||||
, guardOn doBonus $ sortable (Just "bonus") (i18nCell MsgExamBonusAchieved) . automaticCell $ resultExamBonus . _entityVal . _examBonusBonus . to Right <> resultAutomaticExamBonus' . to Left
|
||||
, 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))
|
||||
-> bool mempty (anchorCellM (CourseR tid ssh csh . CUserR <$> encrypt uid) $ hasComment True) hasNote
|
||||
]
|
||||
dbtSorting = Map.fromList
|
||||
[ sortUserNameLink queryUser
|
||||
, sortUserMatriclenr queryUser
|
||||
, sortField queryStudyField
|
||||
, sortDegreeShort queryStudyDegree
|
||||
, sortFeaturesSemester queryStudyFeatures
|
||||
, ("occurrence", SortColumn $ queryExamOccurrence >>> (E.?. ExamOccurrenceName))
|
||||
, ("result", SortColumn $ queryExamResult >>> (E.?. ExamResultResult))
|
||||
, ("result-bool", SortColumn $ queryExamResult >>> (E.?. ExamResultResult) >>> E.orderByList [Just ExamVoided, Just ExamNoShow, Just $ ExamAttended Grade50])
|
||||
, ("note", SortColumn $ queryCourseNote >>> \note -> -- sort by last edit date
|
||||
dbtSorting = mconcat
|
||||
[ uncurry singletonMap $ sortUserNameLink queryUser
|
||||
, uncurry singletonMap $ sortUserMatriclenr queryUser
|
||||
, uncurry singletonMap $ sortField queryStudyField
|
||||
, uncurry singletonMap $ sortDegreeShort queryStudyDegree
|
||||
, uncurry singletonMap $ sortFeaturesSemester queryStudyFeatures
|
||||
, mconcat
|
||||
[ singletonMap (fromText [st|part-#{toPathPiece examPartNumber}|]) . SortColumn . queryExamPart epId $ \_ examPartResult -> return $ examPartResult E.?. ExamPartResultResult
|
||||
| Entity epId ExamPart{..} <- examParts
|
||||
]
|
||||
, 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.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote)
|
||||
return . E.max_ $ edit E.^. CourseUserNoteEditTime
|
||||
)
|
||||
]
|
||||
dbtFilter = Map.fromList
|
||||
[ fltrUserNameEmail queryUser
|
||||
@ -339,40 +573,55 @@ postEUsersR tid ssh csh examn = do
|
||||
, dbParamsFormAdditional = \csrf -> do
|
||||
let
|
||||
actionMap :: Map ExamUserAction (AForm Handler ExamUserActionData)
|
||||
actionMap = Map.fromList
|
||||
[ ( ExamUserDeregister
|
||||
, pure ExamUserDeregisterData
|
||||
)
|
||||
, ( ExamUserAssignOccurrence
|
||||
, ExamUserAssignOccurrenceData
|
||||
actionMap = mconcat
|
||||
[ singletonMap ExamUserDeregister $
|
||||
pure ExamUserDeregisterData
|
||||
, singletonMap ExamUserAssignOccurrence $
|
||||
ExamUserAssignOccurrenceData
|
||||
<$> 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
|
||||
let formRes = (, mempty) . First . Just <$> res
|
||||
return (formRes, formWgt)
|
||||
, dbParamsFormEvaluate = liftHandlerT . runFormPost
|
||||
, dbParamsFormResult = id
|
||||
, dbParamsFormEvaluate = liftHandler . runFormPost
|
||||
, dbParamsFormResult = _2
|
||||
, dbParamsFormIdent = def
|
||||
}
|
||||
dbtIdent :: Text
|
||||
dbtIdent = "exam-users"
|
||||
dbtCsvEncode :: DBTCsvEncode ExamUserTableData ExamUserTableCsv
|
||||
dbtCsvEncode = DictJust . C.map $ ExamUserTableCsv
|
||||
<$> view (resultUser . _entityVal . _userSurname . to Just)
|
||||
<*> view (resultUser . _entityVal . _userFirstName . to Just)
|
||||
<*> view (resultUser . _entityVal . _userDisplayName . to Just)
|
||||
<*> view (resultUser . _entityVal . _userMatrikelnummer)
|
||||
<*> preview (resultStudyField . _entityVal . to (\StudyTerms{..} -> studyTermsName <|> studyTermsShorthand <|> Just (tshow studyTermsKey)) . _Just)
|
||||
<*> preview (resultStudyDegree . _entityVal . to (\StudyDegree{..} -> studyDegreeName <|> studyDegreeShorthand <|> Just (tshow studyDegreeKey)) . _Just)
|
||||
<*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester)
|
||||
<*> preview (resultExamOccurrence . _entityVal . _examOccurrenceName)
|
||||
<*> preview (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPoints . _Wrapped)
|
||||
<*> preview (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPasses . _Wrapped . integral)
|
||||
<*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _sumSheetsPoints . _Wrapped)
|
||||
<*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _numSheetsPasses . _Wrapped . integral)
|
||||
<*> preview (resultExamResult . _entityVal . _examResultResult . to resultView)
|
||||
<*> preview (resultCourseNote . _entityVal . _courseUserNoteNote)
|
||||
dbtCsvEncode = Just DBTCsvEncode
|
||||
{ dbtCsvExportForm = pure ()
|
||||
, dbtCsvDoEncode = \() -> C.map (doEncode' . view _2)
|
||||
, dbtCsvName = unpack csvName
|
||||
, dbtCsvNoExportData = Just id
|
||||
, dbtCsvHeader = const . return . examUserTableCsvHeader allBoni doBonus $ examParts ^.. folded . _entityVal . _examPartNumber
|
||||
}
|
||||
where
|
||||
doEncode' = ExamUserTableCsv
|
||||
<$> view (resultUser . _entityVal . _userSurname . to Just)
|
||||
<*> view (resultUser . _entityVal . _userFirstName . to Just)
|
||||
<*> view (resultUser . _entityVal . _userDisplayName . to Just)
|
||||
<*> view (resultUser . _entityVal . _userMatrikelnummer)
|
||||
<*> preview (resultStudyField . _entityVal . to (\StudyTerms{..} -> studyTermsName <|> studyTermsShorthand <|> Just (tshow studyTermsKey)) . _Just)
|
||||
<*> preview (resultStudyDegree . _entityVal . to (\StudyDegree{..} -> studyDegreeName <|> studyDegreeShorthand <|> Just (tshow studyDegreeKey)) . _Just)
|
||||
<*> 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
|
||||
{ dbtCsvRowKey = \csv -> do
|
||||
uid <- lift $ view _2 <$> guessUser csv
|
||||
@ -381,20 +630,28 @@ postEUsersR tid ssh csh examn = do
|
||||
DBCsvDiffMissing{dbCsvOldKey}
|
||||
-> yield . ExamUserCsvDeregisterData $ E.unValue dbCsvOldKey
|
||||
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
|
||||
(isPart, uid) <- lift $ guessUser dbCsvNew
|
||||
if
|
||||
| isPart -> do
|
||||
yieldM $ ExamUserCsvRegisterData <$> pure uid <*> lookupOccurrence 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) $
|
||||
yield $ ExamUserCsvSetCourseFieldData cpId newFeatures
|
||||
| otherwise ->
|
||||
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) $
|
||||
yield . ExamUserCsvSetResultData uid $ csvEUserExamResult dbCsvNew
|
||||
yield . ExamUserCsvSetResultData False uid $ csvEUserExamResult dbCsvNew
|
||||
|
||||
note <- lift . getBy $ UniqueCourseUserNote uid examCourse
|
||||
when (csvEUserCourseNote dbCsvNew /= note ^? _Just . _entityVal . _courseUserNoteNote) $
|
||||
@ -406,11 +663,56 @@ postEUsersR tid ssh csh examn = do
|
||||
|
||||
newFeatures <- lift $ lookupStudyFeatures dbCsvNew
|
||||
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
|
||||
|
||||
when (csvEUserExamResult dbCsvNew /= dbCsvOld ^? resultExamResult . _entityVal . _examResultResult . to resultView) $
|
||||
yield . ExamUserCsvSetResultData (dbCsvOld ^. resultUser . _entityKey) $ csvEUserExamResult dbCsvNew
|
||||
let uid = dbCsvOld ^. resultUser . _entityKey
|
||||
|
||||
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) $
|
||||
yield . ExamUserCsvSetCourseNoteData (dbCsvOld ^. resultUser . _entityKey) $ csvEUserCourseNote dbCsvNew
|
||||
@ -420,7 +722,13 @@ postEUsersR tid ssh csh examn = do
|
||||
ExamUserCsvDeregisterData{} -> ExamUserCsvDeregister
|
||||
ExamUserCsvAssignOccurrenceData{} -> ExamUserCsvAssignOccurrence
|
||||
ExamUserCsvSetCourseFieldData{} -> ExamUserCsvSetCourseField
|
||||
ExamUserCsvSetResultData{} -> ExamUserCsvSetResult
|
||||
ExamUserCsvSetPartResultData{} -> ExamUserCsvSetPartResult
|
||||
ExamUserCsvSetBonusData{..}
|
||||
| examUserCsvIsBonusOverride -> ExamUserCsvOverrideBonus
|
||||
| otherwise -> ExamUserCsvSetBonus
|
||||
ExamUserCsvSetResultData{..}
|
||||
| examUserCsvIsResultOverride -> ExamUserCsvOverrideResult
|
||||
| otherwise -> ExamUserCsvSetResult
|
||||
ExamUserCsvSetCourseNoteData{} -> ExamUserCsvSetCourseNote
|
||||
, dbtCsvCoarsenActionClass = \case
|
||||
ExamUserCsvCourseRegister -> DBCsvActionNew
|
||||
@ -436,8 +744,9 @@ postEUsersR tid ssh csh examn = do
|
||||
, courseParticipantUser = examUserCsvActUser
|
||||
, courseParticipantRegistration = now
|
||||
, courseParticipantField = examUserCsvActCourseField
|
||||
, courseParticipantAllocated = False
|
||||
, courseParticipantAllocated = Nothing
|
||||
}
|
||||
queueDBJob . JobQueueNotification $ NotificationCourseRegistered examUserCsvActUser examCourse
|
||||
audit $ TransactionCourseParticipantEdit examCourse examUserCsvActUser
|
||||
insert_ ExamRegistration
|
||||
{ examRegistrationExam = eid
|
||||
@ -461,6 +770,34 @@ postEUsersR tid ssh csh examn = do
|
||||
update examUserCsvActCourseParticipant [ CourseParticipantField =. examUserCsvActCourseField ]
|
||||
CourseParticipant{..} <- getJust examUserCsvActCourseParticipant
|
||||
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
|
||||
Nothing -> do
|
||||
deleteBy $ UniqueExamResult eid examUserCsvActUser
|
||||
@ -490,13 +827,13 @@ postEUsersR tid ssh csh examn = do
|
||||
delete nid
|
||||
ExamUserCsvSetCourseNoteData{ examUserCsvActCourseNote = Just note, .. } -> do
|
||||
now <- liftIO getCurrentTime
|
||||
uid <- liftHandlerT requireAuthId
|
||||
uid <- liftHandler requireAuthId
|
||||
Entity nid _ <- upsert (CourseUserNote examCourse examUserCsvActUser note) [ CourseUserNoteNote =. note ]
|
||||
insert_ $ CourseUserNoteEdit uid now nid
|
||||
return $ CExamR tid ssh csh examn EUsersR
|
||||
, dbtCsvRenderKey = \(registeredUserName -> registeredUserName') -> \case
|
||||
ExamUserCsvCourseRegisterData{..} -> do
|
||||
(User{..}, occ) <- liftHandlerT . runDB $ (,) <$> getJust examUserCsvActUser <*> for examUserCsvActOccurrence getJust
|
||||
(User{..}, occ) <- liftHandler . runDB $ (,) <$> getJust examUserCsvActUser <*> for examUserCsvActOccurrence getJust
|
||||
[whamlet|
|
||||
$newline never
|
||||
^{nameWidget userDisplayName userSurname}
|
||||
@ -510,7 +847,7 @@ postEUsersR tid ssh csh examn = do
|
||||
\ (_{MsgExamNoOccurrence})
|
||||
|]
|
||||
ExamUserCsvRegisterData{..} -> do
|
||||
(User{..}, occ) <- liftHandlerT . runDB $ (,) <$> getJust examUserCsvActUser <*> for examUserCsvActOccurrence getJust
|
||||
(User{..}, occ) <- liftHandler . runDB $ (,) <$> getJust examUserCsvActUser <*> for examUserCsvActOccurrence getJust
|
||||
[whamlet|
|
||||
$newline never
|
||||
^{nameWidget userDisplayName userSurname}
|
||||
@ -520,7 +857,7 @@ postEUsersR tid ssh csh examn = do
|
||||
\ (_{MsgExamNoOccurrence})
|
||||
|]
|
||||
ExamUserCsvAssignOccurrenceData{..} -> do
|
||||
occ <- for examUserCsvActOccurrence $ liftHandlerT . runDB . getJust
|
||||
occ <- for examUserCsvActOccurrence $ liftHandler . runDB . getJust
|
||||
[whamlet|
|
||||
$newline never
|
||||
^{registeredUserName' examUserCsvActRegistration}
|
||||
@ -530,7 +867,7 @@ postEUsersR tid ssh csh examn = do
|
||||
\ (_{MsgExamNoOccurrence})
|
||||
|]
|
||||
ExamUserCsvSetCourseFieldData{..} -> do
|
||||
User{..} <- liftHandlerT . runDB $ getJust . courseParticipantUser =<< getJust examUserCsvActCourseParticipant
|
||||
User{..} <- liftHandler . runDB $ getJust . courseParticipantUser =<< getJust examUserCsvActCourseParticipant
|
||||
[whamlet|
|
||||
$newline never
|
||||
^{nameWidget userDisplayName userSurname}
|
||||
@ -539,8 +876,34 @@ postEUsersR tid ssh csh examn = do
|
||||
$nothing
|
||||
, _{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
|
||||
User{..} <- liftHandlerT . runDB $ getJust examUserCsvActUser
|
||||
User{..} <- liftHandler . runDB $ getJust examUserCsvActUser
|
||||
[whamlet|
|
||||
$newline never
|
||||
^{nameWidget userDisplayName userSurname}
|
||||
@ -550,7 +913,7 @@ postEUsersR tid ssh csh examn = do
|
||||
, _{MsgExamResultNone}
|
||||
|]
|
||||
ExamUserCsvSetCourseNoteData{..} -> do
|
||||
User{..} <- liftHandlerT . runDB $ getJust examUserCsvActUser
|
||||
User{..} <- liftHandler . runDB $ getJust examUserCsvActUser
|
||||
[whamlet|
|
||||
$newline never
|
||||
^{nameWidget userDisplayName userSurname}
|
||||
@ -571,22 +934,31 @@ postEUsersR tid ssh csh examn = do
|
||||
guessUser :: ExamUserTableCsv -> DB (Bool, UserId)
|
||||
guessUser ExamUserTableCsv{..} = $cachedHereBinary (csvEUserMatriculation, csvEUserName, csvEUserSurname) $ 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.^. UserDisplayName E.==.) . E.val <$> csvEUserName
|
||||
, (user E.^. UserSurname E.==.) . E.val <$> csvEUserSurname
|
||||
, (user E.^. UserFirstName E.==.) . E.val <$> csvEUserFirstName
|
||||
, (user E.^. UserDisplayName `E.hasInfix`) . E.val <$> csvEUserName
|
||||
, (user E.^. UserSurname `E.hasInfix`) . E.val <$> csvEUserSurname
|
||||
, (user E.^. UserFirstName `E.hasInfix`) . E.val <$> csvEUserFirstName
|
||||
]
|
||||
let isCourseParticipant = E.exists . E.from $ \courseParticipant ->
|
||||
E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. E.val examCourse
|
||||
E.&&. courseParticipant E.^. CourseParticipantUser E.==. user E.^. UserId
|
||||
E.limit 2
|
||||
return (isCourseParticipant, user E.^. UserId)
|
||||
case users of
|
||||
(filter . view $ _1 . _Value -> [(E.Value isPart, E.Value uid)])
|
||||
-> return (isPart, uid)
|
||||
[(E.Value isPart, E.Value uid)]
|
||||
-> return (isPart, uid)
|
||||
return (isCourseParticipant, user)
|
||||
let users' = reverse $ sortBy closeness users
|
||||
closeness :: (E.Value Bool, Entity User) -> (E.Value Bool, Entity User) -> Ordering
|
||||
closeness = mconcat $ catMaybes
|
||||
[ pure $ comparing (preview $ _2 . _entityVal . _userMatrikelnummer . only csvEUserMatriculation)
|
||||
, pure $ comparing (view _1)
|
||||
, 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
|
||||
-> throwM ExamUserCsvExceptionNoMatchingUser
|
||||
|
||||
@ -650,21 +1022,21 @@ postEUsersR tid ssh csh examn = do
|
||||
examUsersDBTableValidator = def & defaultSorting [SortAscBy "user-name"]
|
||||
& 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
|
||||
(First (Just act), regMap) <- inp
|
||||
let regSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) regMap
|
||||
return (act, regSet)
|
||||
over _1 postprocess <$> dbTable examUsersDBTableValidator examUsersDBTable
|
||||
let regMap' = Map.mapMaybe (uncurry guardOn) $ getDBFormResult (False,) regMap
|
||||
return (act, regMap')
|
||||
(, exam, bonus) . over (_1 . _2) postprocess <$> dbTable examUsersDBTableValidator examUsersDBTable
|
||||
|
||||
formResult registrationResult $ \case
|
||||
(ExamUserDeregisterData, selectedRegistrations) -> do
|
||||
(ExamUserDeregisterData, Map.keysSet -> selectedRegistrations) -> do
|
||||
nrDel <- runDB $ deleteWhereCount
|
||||
[ ExamRegistrationId <-. Set.toList selectedRegistrations
|
||||
]
|
||||
addMessageI Success $ MsgExamUsersDeregistered nrDel
|
||||
redirect $ CExamR tid ssh csh examn EUsersR
|
||||
(ExamUserAssignOccurrenceData occId, selectedRegistrations) -> do
|
||||
(ExamUserAssignOccurrenceData occId, Map.keysSet -> selectedRegistrations) -> do
|
||||
nrUpdated <- runDB $ updateWhereCount
|
||||
[ ExamRegistrationId <-. Set.toList selectedRegistrations
|
||||
]
|
||||
@ -672,7 +1044,67 @@ postEUsersR tid ssh csh examn = do
|
||||
]
|
||||
addMessageI Success $ MsgExamUsersOccurrenceUpdated nrUpdated
|
||||
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
|
||||
setTitleI $ prependCourseTitle tid ssh csh MsgExamUsersHeading
|
||||
let computedValuesTip = $(i18nWidgetFile "exam-users/computed-values-tip")
|
||||
$(widgetFile "exam-users")
|
||||
|
||||
8
src/Handler/ExamOffice.hs
Normal file
8
src/Handler/ExamOffice.hs
Normal 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
75
src/Handler/ExamOffice/Course.hs
Normal 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
443
src/Handler/ExamOffice/Exam.hs
Normal 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
200
src/Handler/ExamOffice/Exams.hs
Normal 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
116
src/Handler/ExamOffice/Fields.hs
Normal 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
188
src/Handler/ExamOffice/Users.hs
Normal 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
|
||||
@ -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)
|
||||
case waitResult of
|
||||
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
|
||||
Just healthReports -> do
|
||||
let (Max lastUpdated, Min status) = ofoldMap1 (Max *** Min . healthReportStatus) healthReports
|
||||
|
||||
@ -3,8 +3,6 @@ module Handler.Home where
|
||||
import Import
|
||||
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Table.Cells
|
||||
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import Database.Esqueleto.Utils.TH
|
||||
@ -60,7 +58,7 @@ homeUpcomingSheets uid = do
|
||||
, E.Value UTCTime
|
||||
, E.Value (Maybe SubmissionId)
|
||||
))
|
||||
(DBCell (HandlerT UniWorX IO) ())
|
||||
(DBCell Handler ())
|
||||
colonnade = mconcat
|
||||
[ -- dbRow
|
||||
-- TOOD: sortable (Just "term") (textCell MsgTerm) $ \DBRow{ dbrOutput=(view _1 -> E.Value tid) } ->
|
||||
@ -84,7 +82,7 @@ homeUpcomingSheets uid = do
|
||||
(hasTickmark True)
|
||||
]
|
||||
let validator = def & defaultSorting [SortDescBy "done", SortAscBy "deadline"]
|
||||
sheetTable <- liftHandlerT . runDB $ dbTableWidget' validator DBTable
|
||||
sheetTable <- liftHandler . runDB $ dbTableWidget' validator DBTable
|
||||
{ dbtSQLQuery = tableData
|
||||
, dbtRowKey = \((_ `E.InnerJoin` _ `E.InnerJoin` sheet) `E.LeftOuterJoin` _) -> sheet E.^. SheetId
|
||||
, dbtColonnade = colonnade
|
||||
@ -129,7 +127,7 @@ homeUpcomingSheets uid = do
|
||||
homeUpcomingExams :: UserId -> Widget
|
||||
homeUpcomingExams uid = do
|
||||
now <- liftIO getCurrentTime
|
||||
((Any hasExams, examTable), warningDays) <- liftHandlerT . runDB $ do
|
||||
((Any hasExams, examTable), warningDays) <- liftHandler . runDB $ do
|
||||
User {userWarningDays} <- get404 uid
|
||||
let fortnight = addUTCTime userWarningDays now
|
||||
let -- code copied and slightly adapted from Handler.Course.getCShowR:
|
||||
@ -204,7 +202,7 @@ homeUpcomingExams uid = do
|
||||
isRegistered <- existsBy $ UniqueExamRegistration eId uid
|
||||
if
|
||||
| mayRegister -> do
|
||||
(examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered
|
||||
(examRegisterForm, examRegisterEnctype) <- liftHandler . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered
|
||||
return $ wrapForm examRegisterForm def
|
||||
{ formAction = Just . SomeRoute $ CExamR courseTerm courseSchool courseShorthand examName ERegisterR
|
||||
, formEncoding = examRegisterEnctype
|
||||
|
||||
@ -47,4 +47,23 @@ getInfoLecturerR =
|
||||
siteLayoutMsg' MsgInfoLecturerTitle $ do
|
||||
setTitleI MsgInfoLecturerTitle
|
||||
$(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} |]
|
||||
|
||||
@ -17,8 +17,6 @@ import Database.Esqueleto.Utils.TH
|
||||
import Utils.Form
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Delete
|
||||
import Handler.Utils.Table.Cells
|
||||
import Handler.Utils.Table.Columns
|
||||
|
||||
import Control.Monad.Writer (MonadWriter(..), execWriterT)
|
||||
|
||||
@ -30,7 +28,7 @@ data MaterialForm = MaterialForm
|
||||
, mfType :: Maybe (CI Text)
|
||||
, mfDescription :: Maybe Html
|
||||
, mfVisibleFrom :: Maybe UTCTime
|
||||
, mfFiles :: Maybe (Source Handler (Either FileId File))
|
||||
, mfFiles :: Maybe (ConduitT () (Either FileId File) Handler ())
|
||||
}
|
||||
|
||||
makeMaterialForm :: CourseId -> Maybe MaterialForm -> Form MaterialForm
|
||||
@ -42,7 +40,7 @@ makeMaterialForm cid template = identifyForm FIDmaterial $ \html -> do
|
||||
| Just source <- template >>= mfFiles
|
||||
= runConduit $ source .| C.foldMap setIds
|
||||
| otherwise = return Set.empty
|
||||
typeOptions :: HandlerT UniWorX IO (OptionList (CI Text))
|
||||
typeOptions :: HandlerFor UniWorX (OptionList (CI Text))
|
||||
typeOptions = do
|
||||
let defaults = Set.fromList $ map (CI.mk . mr) [MsgMaterialTypeSlides,MsgMaterialTypeCode,MsgMaterialTypeExample]
|
||||
previouslyUsed <- runDB $
|
||||
@ -63,7 +61,7 @@ makeMaterialForm cid template = identifyForm FIDmaterial $ \html -> do
|
||||
|
||||
flip (renderAForm FormStandard) html $ MaterialForm
|
||||
<$> 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)
|
||||
(mfType <$> template)
|
||||
<*> aopt htmlField (fslpI MsgMaterialDescription "Html")
|
||||
@ -79,8 +77,8 @@ getMaterialKeyBy404 tid ssh csh mnm = do
|
||||
getKeyBy404 $ UniqueMaterial cid mnm
|
||||
|
||||
fetchMaterial :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> DB (Entity Material)
|
||||
fetchMaterial tid ssh csh mnm = do
|
||||
[matEnt] <- E.select . E.from $ -- uniqueness guaranteed by DB constraints
|
||||
fetchMaterial tid ssh csh mnm =
|
||||
maybe notFound return . listToMaybe <=< E.select . E.from $ -- uniqueness guaranteed by DB constraints
|
||||
\(course `E.InnerJoin` material) -> do
|
||||
E.on $ course E.^. CourseId E.==. material E.^. MaterialCourse
|
||||
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.&&. material E.^. MaterialName E.==. E.val mnm
|
||||
return material
|
||||
return matEnt
|
||||
|
||||
|
||||
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.where_ $ matFile E.^. MaterialFileMaterial E.==. E.val (entityKey matEnt)
|
||||
return $ file E.^. FileId
|
||||
return (matEnt, (Left . E.unValue) <$> fileIds)
|
||||
return (matEnt, Left . E.unValue <$> fileIds)
|
||||
-- let cid = materialCourse
|
||||
let template = Just MaterialForm
|
||||
{ mfName = materialName
|
||||
@ -310,14 +307,14 @@ handleMaterialEdit tid ssh csh cid template dbMaterial = do
|
||||
when saveOk $ redirect -- redirect must happen outside of runDB
|
||||
$ 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
|
||||
oldFileIdVals <- E.select . E.from $ \(file `E.InnerJoin` materialFile) -> do
|
||||
E.on $ materialFile E.^. MaterialFileFile E.==. file E.^. FileId
|
||||
E.where_ $ materialFile E.^. MaterialFileMaterial E.==. E.val mid
|
||||
return $ file E.^. FileId
|
||||
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)
|
||||
where
|
||||
finsert (Left fileId) = tell $ singleton fileId
|
||||
|
||||
@ -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 Handler.Utils
|
||||
import Handler.Utils.Table.Cells
|
||||
import Handler.Utils.Profile
|
||||
import Handler.Utils.Tokens
|
||||
|
||||
-- import Colonnade hiding (fromMaybe, singleton)
|
||||
-- import Yesod.Colonnade
|
||||
@ -17,25 +25,33 @@ import qualified Database.Esqueleto.Utils as E
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import Jobs
|
||||
|
||||
|
||||
data SettingsForm = SettingsForm
|
||||
{ stgMaxFavourties :: Int
|
||||
, stgTheme :: Theme
|
||||
, stgDateTime :: DateTimeFormat
|
||||
, stgDate :: DateTimeFormat
|
||||
, stgTime :: DateTimeFormat
|
||||
, stgDownloadFiles :: Bool
|
||||
, stgWarningDays :: NominalDiffTime
|
||||
, stgSchools :: Set SchoolId
|
||||
{ stgDisplayName :: UserDisplayName
|
||||
, stgDisplayEmail :: UserEmail
|
||||
, stgMaxFavourites :: Int
|
||||
, stgMaxFavouriteTerms :: Int
|
||||
, stgTheme :: Theme
|
||||
, stgDateTime :: DateTimeFormat
|
||||
, stgDate :: DateTimeFormat
|
||||
, stgTime :: DateTimeFormat
|
||||
, stgDownloadFiles :: Bool
|
||||
, stgWarningDays :: NominalDiffTime
|
||||
, stgSchools :: Set SchoolId
|
||||
, stgNotificationSettings :: NotificationSettings
|
||||
}
|
||||
makeLenses_ ''SettingsForm
|
||||
|
||||
data NotificationTriggerKind
|
||||
= NTKAll
|
||||
| NTKCourseParticipant
|
||||
| NTKExamParticipant
|
||||
| NTKCorrector
|
||||
| NTKCourseLecturer
|
||||
| NTKAllocationStaff
|
||||
| NTKAllocationParticipant
|
||||
| NTKFunctionary SchoolFunction
|
||||
deriving (Eq, Ord, Generic, Typeable)
|
||||
deriveFinite ''NotificationTriggerKind
|
||||
@ -46,7 +62,9 @@ instance RenderMessage UniWorX NotificationTriggerKind where
|
||||
NTKCourseParticipant -> mr MsgNotificationTriggerKindCourseParticipant
|
||||
NTKExamParticipant -> mr MsgNotificationTriggerKindExamParticipant
|
||||
NTKCorrector -> mr MsgNotificationTriggerKindCorrector
|
||||
NTKCourseLecturer -> mr MsgNotificationTriggerKindCourseLecturer
|
||||
NTKAllocationStaff -> mr MsgNotificationTriggerKindAllocationStaff
|
||||
NTKAllocationParticipant -> mr MsgNotificationTriggerKindAllocationParticipant
|
||||
NTKFunctionary SchoolAdmin -> mr MsgNotificationTriggerKindAdmin
|
||||
NTKFunctionary SchoolLecturer -> mr MsgNotificationTriggerKindLecturer
|
||||
NTKFunctionary SchoolExamOffice -> mr MsgNotificationTriggerKindExamOffice
|
||||
@ -58,9 +76,14 @@ instance RenderMessage UniWorX NotificationTriggerKind where
|
||||
makeSettingForm :: Maybe SettingsForm -> Form SettingsForm
|
||||
makeSettingForm template html = do
|
||||
(result, widget) <- flip (renderAForm FormStandard) html $ SettingsForm
|
||||
<$ aformSection MsgFormCosmetics
|
||||
<*> areq (natFieldI $ MsgNatField "Favoriten") -- TODO: natFieldI not working here
|
||||
(fslpI MsgFavoriten "Anzahl Favoriten") (stgMaxFavourties <$> template)
|
||||
<$ aformSection MsgFormPersonalAppearance
|
||||
<*> areq (textField & cfStrip) (fslI MsgUserDisplayName & setTooltip MsgUserDisplayNameRulesBelow) (stgDisplayName <$> 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)
|
||||
(fslI MsgTheme) { fsId = Just "theme-select" } (stgTheme <$> template)
|
||||
<*> areq (selectField $ dateTimeFormatOptions SelFormatDateTime) (fslI MsgDateTimeFormat) (stgDateTime <$> template)
|
||||
@ -85,7 +108,7 @@ schoolsForm template = formToAForm $ schoolsFormView =<< renderWForm FormStandar
|
||||
where
|
||||
schoolsForm' :: WForm Handler (FormResult (Set SchoolId))
|
||||
schoolsForm' = do
|
||||
allSchools <- liftHandlerT . runDB $ selectList [] [Asc SchoolName]
|
||||
allSchools <- liftHandler . runDB $ selectList [] [Asc SchoolName]
|
||||
|
||||
let
|
||||
schoolForm (Entity ssh School{schoolName})
|
||||
@ -107,7 +130,7 @@ schoolsForm template = formToAForm $ schoolsFormView =<< renderWForm FormStandar
|
||||
|
||||
notificationForm :: Maybe NotificationSettings -> AForm Handler NotificationSettings
|
||||
notificationForm template = wFormToAForm $ do
|
||||
mbUid <- liftHandlerT maybeAuthId
|
||||
mbUid <- liftHandler maybeAuthId
|
||||
isAdmin <- hasReadAccessTo AdminR
|
||||
|
||||
let
|
||||
@ -132,10 +155,14 @@ notificationForm template = wFormToAForm $ do
|
||||
, NTKExamParticipant <- nt
|
||||
= fmap not . E.selectExists . E.from $ \examRegistration ->
|
||||
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
|
||||
= return False
|
||||
|
||||
ntHidden <- liftHandlerT . runDB
|
||||
ntHidden <- liftHandler . runDB
|
||||
$ Set.fromList universeF
|
||||
& Map.fromSet sectionIsHidden
|
||||
& sequenceA
|
||||
@ -151,28 +178,43 @@ notificationForm template = wFormToAForm $ do
|
||||
= apopt checkBoxField (fslI nt) (flip notificationAllowed nt <$> template)
|
||||
|
||||
ntSection = \case
|
||||
NTSubmissionRatedGraded -> Just NTKCourseParticipant
|
||||
NTSubmissionRated -> Just NTKCourseParticipant
|
||||
NTSheetActive -> Just NTKCourseParticipant
|
||||
NTSheetSoonInactive -> Just NTKCourseParticipant
|
||||
NTSheetInactive -> Just $ NTKFunctionary SchoolLecturer
|
||||
NTCorrectionsAssigned -> Just NTKCorrector
|
||||
NTCorrectionsNotDistributed -> Just $ NTKFunctionary SchoolLecturer
|
||||
NTUserRightsUpdate -> Just NTKAll
|
||||
NTUserAuthModeUpdate -> Just NTKAll
|
||||
NTExamResult -> Just NTKExamParticipant
|
||||
NTAllocationStaffRegister -> Just $ NTKFunctionary SchoolLecturer
|
||||
NTAllocationAllocation -> Just NTKAllocationStaff
|
||||
NTAllocationRegister -> Just NTKAll
|
||||
NTAllocationOutdatedRatings -> Just NTKAllocationStaff
|
||||
NTAllocationUnratedApplications -> Just NTKAllocationStaff
|
||||
-- _other -> Nothing
|
||||
NTSubmissionRatedGraded -> Just NTKCourseParticipant
|
||||
NTSubmissionRated -> Just NTKCourseParticipant
|
||||
NTSheetActive -> Just NTKCourseParticipant
|
||||
NTSheetSoonInactive -> Just NTKCourseParticipant
|
||||
NTSheetInactive -> Just NTKCourseLecturer
|
||||
NTCorrectionsAssigned -> Just NTKCorrector
|
||||
NTCorrectionsNotDistributed -> Just NTKCourseLecturer
|
||||
NTUserRightsUpdate -> Just NTKAll
|
||||
NTUserAuthModeUpdate -> Just NTKAll
|
||||
NTExamRegistrationActive -> Just NTKCourseParticipant
|
||||
NTExamRegistrationSoonInactive -> Just NTKCourseParticipant
|
||||
NTExamDeregistrationSoonInactive -> Just NTKCourseParticipant
|
||||
NTExamResult -> Just NTKExamParticipant
|
||||
NTAllocationStaffRegister -> Just $ NTKFunctionary SchoolLecturer
|
||||
NTAllocationAllocation -> Just NTKAllocationStaff
|
||||
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]
|
||||
|
||||
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
|
||||
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
||||
instance Universe ButtonResetTokens
|
||||
@ -195,7 +237,7 @@ nullaryPathPiece ''ProfileAnchor $ camelToPathPiece' 1
|
||||
getProfileR, postProfileR :: Handler Html
|
||||
getProfileR = postProfileR
|
||||
postProfileR = do
|
||||
(uid, User{..}) <- requireAuthPair
|
||||
(uid, user@User{..}) <- requireAuthPair
|
||||
userSchools <- fmap (setOf $ folded . _Value) . runDB . E.select . E.from $ \school -> do
|
||||
E.where_ . E.exists . E.from $ \userSchool ->
|
||||
E.where_ $ E.not_ (userSchool E.^. UserSchoolIsOptOut)
|
||||
@ -203,36 +245,38 @@ postProfileR = do
|
||||
E.&&. userSchool E.^. UserSchoolSchool E.==. school E.^. SchoolId
|
||||
return $ school E.^. SchoolId
|
||||
let settingsTemplate = Just SettingsForm
|
||||
{ stgMaxFavourties = userMaxFavourites
|
||||
, stgTheme = userTheme
|
||||
, stgDateTime = userDateTimeFormat
|
||||
, stgDate = userDateFormat
|
||||
, stgTime = userTimeFormat
|
||||
, stgDownloadFiles = userDownloadFiles
|
||||
, stgSchools = userSchools
|
||||
{ stgDisplayName = userDisplayName
|
||||
, stgDisplayEmail = userDisplayEmail
|
||||
, stgMaxFavourites = userMaxFavourites
|
||||
, stgMaxFavouriteTerms = userMaxFavouriteTerms
|
||||
, stgTheme = userTheme
|
||||
, stgDateTime = userDateTimeFormat
|
||||
, stgDate = userDateFormat
|
||||
, stgTime = userTimeFormat
|
||||
, stgDownloadFiles = userDownloadFiles
|
||||
, stgSchools = userSchools
|
||||
, 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
|
||||
runDB $ do
|
||||
update uid [ UserMaxFavourites =. stgMaxFavourties
|
||||
, UserTheme =. stgTheme
|
||||
, UserDateTimeFormat =. stgDateTime
|
||||
, UserDateFormat =. stgDate
|
||||
, UserTimeFormat =. stgTime
|
||||
, UserDownloadFiles =. stgDownloadFiles
|
||||
, UserWarningDays =. stgWarningDays
|
||||
, UserNotificationSettings =. stgNotificationSettings
|
||||
]
|
||||
when (stgMaxFavourties < userMaxFavourites) $ do
|
||||
-- prune Favourites to user-defined size
|
||||
oldFavs <- selectKeysList [ CourseFavouriteUser ==. uid]
|
||||
[ Desc CourseFavouriteTime
|
||||
, OffsetBy stgMaxFavourties
|
||||
]
|
||||
mapM_ delete oldFavs
|
||||
runDBJobs $ do
|
||||
update uid $
|
||||
[ UserDisplayName =. stgDisplayName
|
||||
, UserMaxFavourites =. stgMaxFavourites
|
||||
, UserMaxFavouriteTerms =. stgMaxFavouriteTerms
|
||||
, UserTheme =. stgTheme
|
||||
, UserDateTimeFormat =. stgDateTime
|
||||
, UserDateFormat =. stgDate
|
||||
, UserTimeFormat =. stgTime
|
||||
, UserDownloadFiles =. stgDownloadFiles
|
||||
, UserWarningDays =. stgWarningDays
|
||||
, UserNotificationSettings =. stgNotificationSettings
|
||||
] ++ [ UserDisplayEmail =. stgDisplayEmail | userDisplayEmail == stgDisplayEmail ]
|
||||
when (stgDisplayEmail /= userDisplayEmail) $ do
|
||||
queueDBJob $ JobChangeUserDisplayEmail uid stgDisplayEmail
|
||||
addMessageI Info $ MsgUserDisplayEmailChangeSent stgDisplayEmail
|
||||
let
|
||||
symDiff = (stgSchools `Set.difference` userSchools) `Set.union` (userSchools `Set.difference` stgSchools)
|
||||
forM_ symDiff $ \ssh -> if
|
||||
@ -252,7 +296,7 @@ postProfileR = do
|
||||
}
|
||||
[ UserSchoolIsOptOut =. True
|
||||
]
|
||||
addMessageI Info MsgSettingsUpdate
|
||||
addMessageI Success MsgSettingsUpdate
|
||||
redirect $ ProfileR :#: ProfileSettings
|
||||
|
||||
((tokenRes, tokenFormWidget), tokenEnctype) <- runFormPost . identifyForm ProfileResetTokens $ buttonForm
|
||||
@ -286,6 +330,7 @@ postProfileR = do
|
||||
, formAnchor = Just ProfileResetTokens
|
||||
}
|
||||
tokenExplanation = $(i18nWidgetFile "profile/tokenExplanation")
|
||||
displayNameRules = $(i18nWidgetFile "profile/displayNameRules")
|
||||
$(widgetFile "profile/profile")
|
||||
|
||||
|
||||
@ -726,3 +771,65 @@ postUserNotificationR cID = do
|
||||
siteLayoutMsg (MsgNotificationSettingsHeading userDisplayName) $ do
|
||||
setTitleI $ MsgNotificationSettingsHeading userDisplayName
|
||||
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 ]
|
||||
}
|
||||
|
||||
@ -2,7 +2,6 @@ module Handler.School where
|
||||
|
||||
import Import
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Table.Columns
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
@ -71,7 +70,7 @@ mkSchoolForm mSsh template = renderAForm FormStandard $ SchoolForm
|
||||
<*> 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))
|
||||
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 $
|
||||
setOf (folded . _entityVal . _schoolLdapOrgUnit) <$> selectList [] []
|
||||
|
||||
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user