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

Merge branch 'master' into 574-aktionen-auf-eeusersr

Browse Source
This commit is contained in:
Gregor Kleen 2020-05-06 13:53:03 +02:00
commit 8008248483
285 changed files with 14266 additions and 6171 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
.dir-locals.el Normal file
View File

@ -0,0 +1,5 @@
;;; Directory Local Variables
;;; For more information see (info "(emacs) Directory Variables")
((nil
(indent-tabs-mode)))

2
.gitignore vendored
View File

@ -40,3 +40,5 @@ tunnel.log
/well-known
/.well-known-cache
/**/tmp-*
/testdata/bigAlloc_*.csv
/sessions

3
.gitlab-ci.yml
View File

@ -203,7 +203,6 @@ hlint:
- stack test --flag uniworx:-library-only --flag uniworx:-dev --flag uniworx:pedantic uniworx:test:hlint
needs:
- frontend:build
- yesod:build # For caching
before_script:
- apt-get update -y
- apt-get install -y --no-install-recommends locales-all
@ -227,7 +226,6 @@ yesod:test:
- stack test --coverage --flag uniworx:-library-only --flag uniworx:-dev --flag uniworx:pedantic --skip hlint
needs:
- frontend:build
- yesod:build # For caching
before_script:
- apt-get update -y
- apt-get install -y --no-install-recommends locales-all
@ -249,6 +247,7 @@ deploy:uniworx3:
- yesod:build
- yesod:test # For sanity
- hlint # For sanity
- frontend:test # For sanity
before_script:
- apt-get update -y
- apt-get install -y --no-install-recommends openssh-client

387
CHANGELOG.md
View File

@ -2,6 +2,393 @@
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.
### [16.0.5](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v16.0.4...v16.0.5) (2020-05-06)
### Bug Fixes
* **migration:** handle deleted courses & users ([35621df](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/35621df))
### [16.0.4](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v16.0.3...v16.0.4) (2020-05-06)
### Bug Fixes
* **migration:** typos ([e508277](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/e508277))
### [16.0.3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v16.0.2...v16.0.3) (2020-05-05)
### Bug Fixes
* **i18n:** s/Typ/Art/ ([0e43851](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/0e43851)), closes [#493](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/493)
* **migration:** typo ([fb7c7ef](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/fb7c7ef))
### [16.0.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v16.0.1...v16.0.2) (2020-05-05)
### Bug Fixes
* **corrections-grade-r:** add get following post ([14f9ab6](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/14f9ab6)), closes [#532](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/532)
* **jobs:** reduce likelihood for multiple queueing of notifications ([970ca78](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/970ca78))
### [16.0.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v16.0.0...v16.0.1) (2020-05-05)
### Bug Fixes
* **exams:** don't show manual bonus as inconsistent ([fb54c84](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/fb54c84))
* **interactive-fieldset:** fix behaviour for nested fieldsets ([65b429a](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/65b429a))
## [16.0.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v15.6.1...v16.0.0) (2020-05-05)
### Features
* **async-table:** history api ([c348b7c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/c348b7c)), closes [#426](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/426)
* **course-participants:** course-deregister-no-show ([bf64eaf](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/bf64eaf)), closes [#499](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/499)
* **course-participants:** introduce CourseParticipantState ([d5b65a1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d5b65a1)), closes [#499](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/499) [#371](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/371)
* **generic-file-field:** prevent multiple session files of same name ([98e1141](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/98e1141))
* **http-client:** baseUrl and defaultUrl ([693189f](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/693189f))
* **i18n:** missing translations ([153bb1f](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/153bb1f))
### BREAKING CHANGES
* **course-participants:** CourseParticipantState
### [15.6.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v15.6.0...v15.6.1) (2020-04-30)
### Bug Fixes
* **submission-groups:** prevent deleting group before insert ([f87cf7a](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f87cf7a))
## [15.6.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v15.5.0...v15.6.0) (2020-04-28)
### Bug Fixes
* **health:** ldap check only admins ([f889ec6](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f889ec6))
* **i18n:** submissionDownloadAnonymous ([e6af788](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/e6af788))
* typo ([52670bc](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/52670bc))
### Features
* **corrections:** non-anonymous download w/ registered groups ([9032f80](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/9032f80))
* **sheets:** submission groups & rework sheet form ([57f1ce9](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/57f1ce9))
* **submission-groups:** invite w/ submission-group & audit ([7f10d44](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/7f10d44))
## [15.5.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v15.4.1...v15.5.0) (2020-04-27)
### Bug Fixes
* **auth:** tutors may see sheet list ([e0c05f3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/e0c05f3))
* **campus:** fix corner case with study features ([76098cc](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/76098cc))
### Features
* **allocations:** switch to csprng ([3ea7371](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3ea7371))
* **ldap:** failover ([0e68b6c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/0e68b6c))
* **news:** timeout sheets after a month ([31aa25a](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/31aa25a))
### [15.4.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v15.4.0...v15.4.1) (2020-04-26)
### Bug Fixes
* **allocation:** don't restart cloneCount when allocating successors ([e1c6fd4](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/e1c6fd4))
## [15.4.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v15.3.0...v15.4.0) (2020-04-24)
### Bug Fixes
* typo ([c06a472](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/c06a472))
* **faqs:** mention mail to set password ([32097d1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/32097d1))
* **faqs:** wording ([02d284f](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/02d284f))
* **navbar:** restore border to language buttons ([a2e9a9c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a2e9a9c))
### Features
* **faqs:** i18n ([a1a0fa3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a1a0fa3))
* **faqs:** initial ([7b53377](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/7b53377))
* **faqs:** more faqs ([18766ed](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/18766ed))
* **faqs:** more links to faq ([10d44d1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/10d44d1))
* **help:** attach last error message ([fdd6b1a](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/fdd6b1a))
## [15.3.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v15.2.0...v15.3.0) (2020-04-23)
### Bug Fixes
* **memcached:** navAccess & quick actions cache invalidations ([d05306a](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d05306a))
* **system-message:** lastChanged & unhide logic error ([36abb3e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/36abb3e))
### Features
* **robots.txt:** disallow ahrefs ([9afee89](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/9afee89))
## [15.2.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v15.1.2...v15.2.0) (2020-04-22)
### Bug Fixes
* **health:** more generous healthchecks ([466203d](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/466203d))
### Features
* **caching:** aggressively cache nav items ([b9b0909](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b9b0909))
* **memcached:** introduce general purpose memcached ([e8c2dc5](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/e8c2dc5))
### [15.1.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v15.1.1...v15.1.2) (2020-04-19)
### Bug Fixes
* **mass-input:** defaultValue is safe ([03f36ae](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/03f36ae))
### [15.1.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v15.1.0...v15.1.1) (2020-04-17)
### Bug Fixes
* **course-users:** deregistration w/ allocation & w/o reason ([4f237e1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/4f237e1))
## [15.1.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v15.0.0...v15.1.0) (2020-04-17)
### Bug Fixes
* **style:** padding of language buttons ([e704b23](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/e704b23))
* **tests:** fix build ([b0f2304](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b0f2304))
### Features
* **course-user:** authorisation checks ([d15792c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d15792c))
* **course-user:** i18n ([da629a8](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/da629a8))
* **course-user:** major improvements ([ced6ef2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ced6ef2)), closes [#126](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/126)
* **mass-input:** automatic add before submit ([7540a4f](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/7540a4f))
* **submissions:** ignore additional filename components ([38f69c3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/38f69c3))
* **submissions:** non-anonymized correction ([fd2c288](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/fd2c288)), closes [#524](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/524) [#292](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/292)
## [15.0.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v14.6.0...v15.0.0) (2020-04-15)
### Bug Fixes
* **allocations:** better handle participants without applications ([05d37fb](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/05d37fb))
* bump changelog & translate ([a75f3eb](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a75f3eb))
### Features
* **system-messages:** hiding ([c81bc23](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/c81bc23))
* **system-messages:** refactor cookies & improve system messages ([ead6015](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ead6015))
### BREAKING CHANGES
* **system-messages:** names of cookies & configuration changed
## [14.6.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v14.5.0...v14.6.0) (2020-04-09)
### Bug Fixes
* fix course duplicate message & name -> title for courses ([d87e8b7](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d87e8b7))
* hlint ([908e6de](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/908e6de))
### Features
* admin interface to issue tokens ([738ab7b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/738ab7b))
## [14.5.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v14.4.0...v14.5.0) (2020-04-09)
### Features
* **news:** show system messages ([0d39924](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/0d39924))
* **tokens:** multiple authorities ([bc47dcf](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/bc47dcf))
## [14.4.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v14.1.1...v14.4.0) (2020-04-07)
### Bug Fixes
* **dbtable:** improve sorting for haskell+sql ([fd8255d](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/fd8255d))
* **exam-form:** allow finished without start ([fbc3680](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/fbc3680))
* **exams:** provide bonus information in return of examBonusGrade ([731231d](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/731231d))
* configure sessions to be strictly same-site ([a7e64bc](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a7e64bc))
* **i18n:** add missing translations ([773c6c5](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/773c6c5))
* fix .dual-heated.degenerate ([6058692](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/6058692))
### Features
* persist bearer tokens in session ([d8040e7](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d8040e7))
* **allocations:** compute & accept allocations ([20ef95c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/20ef95c))
* **allocations:** display new allocations in user table ([bb20062](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/bb20062))
* **allocations:** improve accept ui and logging ([3422fd7](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3422fd7))
* **allocations:** improve acceptance display ([cf03277](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/cf03277))
* **allocations:** improve display ([26f8f39](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/26f8f39))
* **applications-list:** add warning regarding features of study ([cdbe12c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/cdbe12c))
* **course-events:** add HideColumns for course events ([1138f9e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/1138f9e))
* **course-events:** add optional note to course events ([6ad8f2e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/6ad8f2e))
* **course-events:** course event note text -> html ([c8904d1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/c8904d1))
* **course-events:** hide note column if there are no notes to display ([1ac7f4e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/1ac7f4e))
* **course-events:** show notes in course events table ([b2c4125](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b2c4125))
* **exams:** convenience for automatic grade calculation ([ec6a8ae](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ec6a8ae))
* **serversessions:** move session storage to dedicated memcached ([9960059](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/9960059)), closes [#390](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/390)
* more date & time formats ([936c366](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/936c366))
## [14.3.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v14.2.0...v14.3.0) (2020-03-31)
### Bug Fixes
* **exam-form:** allow finished without start ([fbc3680](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/fbc3680))
### Features
* **course-events:** add HideColumns for course events ([1138f9e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/1138f9e))
* **course-events:** add optional note to course events ([6ad8f2e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/6ad8f2e))
* **course-events:** course event note text -> html ([c8904d1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/c8904d1))
* **course-events:** hide note column if there are no notes to display ([1ac7f4e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/1ac7f4e))
* **course-events:** show notes in course events table ([b2c4125](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b2c4125))
## [14.2.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v14.1.1...v14.2.0) (2020-03-22)
### Bug Fixes
* **dbtable:** improve sorting for haskell+sql ([fd8255d](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/fd8255d))
* **exams:** provide bonus information in return of examBonusGrade ([731231d](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/731231d))
* configure sessions to be strictly same-site ([a7e64bc](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a7e64bc))
* **i18n:** add missing translations ([773c6c5](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/773c6c5))
* fix .dual-heated.degenerate ([6058692](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/6058692))
### Features
* **allocations:** compute & accept allocations ([20ef95c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/20ef95c))
* **allocations:** display new allocations in user table ([bb20062](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/bb20062))
* **allocations:** improve accept ui and logging ([3422fd7](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3422fd7))
* **allocations:** improve acceptance display ([cf03277](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/cf03277))
* **allocations:** improve display ([26f8f39](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/26f8f39))
* **applications-list:** add warning regarding features of study ([cdbe12c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/cdbe12c))
* **exams:** convenience for automatic grade calculation ([ec6a8ae](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ec6a8ae))
* **serversessions:** move session storage to dedicated memcached ([9960059](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/9960059)), closes [#390](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/390)
* more date & time formats ([936c366](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/936c366))
### [14.1.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v14.1.0...v14.1.1) (2020-03-06)
### Bug Fixes
* **csv-import:** major usability improvements ([2dc6641](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/2dc6641))
## [14.1.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v14.0.0...v14.1.0) (2020-03-06)
### Bug Fixes
* fix build & minor refactor ([bb9b4f0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/bb9b4f0))
* **course-users:** add missing dbt sorting ([1bc14c9](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/1bc14c9))
* **course-users:** insertUnique and only count and audit true inserts ([1325ff2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/1325ff2))
### Features
* **corrections:** submission filter ([38dbfe7](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/38dbfe7))
* **course-users:** allow for exam registration on CUsersR ([b8acc9b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b8acc9b))
* **course-users:** exams in dbtable and csv ([c23becc](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/c23becc))
* **course-users:** filter by exam registrations ([1d7d0ab](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/1d7d0ab))
* **course-users:** match filter titles with column titles ([ecd7bec](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ecd7bec))
* **course-users:** register exam action with optional occurrence ([34ad1df](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/34ad1df))
* **csv:** export example data & improve zoned-time parsing ([49d9ab9](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/49d9ab9))
## [14.0.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v13.0.1...v14.0.0) (2020-03-03)
### Bug Fixes
* **allocations:** show assignment green ([9d62b3a](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/9d62b3a))
### Features
* **allocations:** explanations & introduce grade-ordinal-proportion ([ee2e504](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ee2e504))
* **allocations:** show & export priority ([7462e03](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/7462e03))
* **allocations:** table of allocation users ([2735d46](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/2735d46))
* **allocations:** tooltips listing courses in users table ([6bca64c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/6bca64c))
* **allocations:** upload of priorities ([a590f45](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a590f45))
### BREAKING CHANGES
* **allocations:** influence of grades on allocation priority now
relative when priorities are ordinal
### [13.0.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v13.0.0...v13.0.1) (2020-02-24)

3
config/robots.txt
View File

@ -1 +1,4 @@
User-agent: *
User-agent: AhrefsBot
Disallow: /

106
config/settings.yml
View File

@ -5,7 +5,7 @@
static-dir: "_env:STATIC_DIR:static"
well-known-dir: "_env:WELL_KNOWN_DIR:well-known"
well-known-link-file: "html_code.html"
well-known-link-file: html_code.html
webpack-manifest: "_env:WEBPACK_MANIFEST:config/webpack.yml"
host: "_env:HOST:*4" # any IPv4 host
@ -31,8 +31,8 @@ notification-rate-limit: 3600
notification-collate-delay: 7200
notification-expiration: 259200
session-timeout: 7200
jwt-expiration: 604800
jwt-encoding: HS256
bearer-expiration: 604800
bearer-encoding: HS256
maximum-content-length: "_env:MAX_UPLOAD_SIZE:134217728"
session-files-expire: 3600
prune-unreferenced-files: 86400
@ -67,9 +67,11 @@ ip-retention-time: 1209600
# Debugging
auth-dummy-login: "_env:DUMMY_LOGIN:false"
allow-deprecated: "_env:ALLOW_DEPRECATED:false"
encrypt-errors: "_env:ENCRYPT_ERRORS:true"
server-session-acid-fallback: "_env:SERVER_SESSION_ACID_FALLBACK:false"
auth-pw-hash:
algorithm: "pbkdf2"
algorithm: pbkdf2
strength: 14
# Optional values with the following production defaults.
@ -77,7 +79,6 @@ auth-pw-hash:
# reload-templates: false
# mutable-static: false
# skip-combining: false
# encrypt-errors: true
database:
user: "_env:PGUSER:uniworx"
@ -91,26 +92,28 @@ database:
auto-db-migrate: '_env:AUTO_DB_MIGRATE:true'
ldap:
host: "_env:LDAPHOST:"
tls: "_env:LDAPTLS:"
port: "_env:LDAPPORT:389"
user: "_env:LDAPUSER:"
pass: "_env:LDAPPASS:"
baseDN: "_env:LDAPBASE:"
scope: "_env:LDAPSCOPE:WholeSubtree"
timeout: "_env:LDAPTIMEOUT:5"
search-timeout: "_env:LDAPSEARCHTIME:5"
pool:
stripes: "_env:LDAPSTRIPES:1"
timeout: "_env:LDAPTIMEOUT:20"
limit: "_env:LDAPLIMIT:10"
- host: "_env:LDAPHOST:"
tls: "_env:LDAPTLS:"
port: "_env:LDAPPORT:389"
user: "_env:LDAPUSER:"
pass: "_env:LDAPPASS:"
baseDN: "_env:LDAPBASE:"
scope: "_env:LDAPSCOPE:WholeSubtree"
timeout: "_env:LDAPTIMEOUT:5"
search-timeout: "_env:LDAPSEARCHTIME:5"
pool:
stripes: "_env:LDAPSTRIPES:1"
timeout: "_env:LDAPTIMEOUT:20"
limit: "_env:LDAPLIMIT:10"
ldap-re-test-failover: 60
smtp:
host: "_env:SMTPHOST:"
port: "_env:SMTPPORT:25"
ssl: "_env:SMTPSSL:starttls"
auth:
type: "login"
type: login
user: "_env:SMTPUSER:"
pass: "_env:SMTPPASS:"
pool:
@ -119,20 +122,65 @@ smtp:
limit: "_env:SMTPLIMIT:10"
widget-memcached:
host: "_env:MEMCACHEDHOST:"
port: "_env:MEMCACHEDPORT:11211"
host: "_env:WIDGET_MEMCACHED_HOST:"
port: "_env:WIDGET_MEMCACHED_PORT:11211"
auth: []
limit: "_env:MEMCACHEDLIMIT:10"
timeout: "_env:MEMCACHEDTIMEOUT:20"
base-url: "_env:MEMCACHEDROOT:"
expiration: "_env:MEMCACHEDEXPIRATION:3600"
limit: "_env:WIDGET_MEMCACHED_LIMIT:1024"
timeout: "_env:WIDGET_MEMCACHED_TIMEOUT:20"
base-url: "_env:WIDGET_MEMCACHED_ROOT:"
expiration: "_env:WIDGET_MEMCACHED_EXPIRATION:3600"
session-memcached:
host: "_env:SESSION_MEMCACHED_HOST:"
port: "_env:SESSION_MEMCACHED_PORT:11211"
auth: []
limit: "_env:SESSION_MEMCACHED_LIMIT:1024"
timeout: "_env:SESSION_MEMCACHED_TIMEOUT:20"
expiration: "_env:SESSION_MEMCACHED_EXPIRATION:28807"
memcached:
host: "_env:MEMCACHED_HOST:"
port: "_env:MEMCACHED_PORT:11211"
auth: []
limit: "_env:MEMCACHED_LIMIT:1024"
timeout: "_env:MEMCACHED_TIMEOUT:20"
expiration: "_env:MEMCACHED_EXPIRATION:300"
server-sessions:
idle-timeout: 28807
absolute-timeout: 604801
timeout-resolution: 601
persistent-cookies: true
session-token-expiration: 28807
session-token-encoding: HS256
cookies:
SESSION:
same-site: lax
http-only: true
secure: "_env:SERVER_SESSION_COOKIES_SECURE:true"
XSRF-TOKEN:
expires: null
same-site: strict
http-only: false
secure: "_env:COOKIES_SECURE:true"
LANG:
expires: 12622780800
same-site: lax
http-only: false
secure: "_env:COOKIES_SECURE:true"
SYSTEM-MESSAGE-STATE:
expires: 12622780800
same-site: lax
http-only: false
secure: "_env:COOKIES_SECURE:true"
user-defaults:
max-favourites: 12
max-favourite-terms: 2
theme: Default
date-time-format: "%a %d %b %Y %R"
date-format: "%d.%m.%Y"
date-format: "%a %d %b %Y"
time-format: "%R"
download-files: false
warning-days: 1209600
@ -150,3 +198,9 @@ allocation-grade-ordinal-proportion: 0.075
instance-id: "_env:INSTANCE_ID:instance"
ribbon: "_env:RIBBON:"
favourites-quick-actions-burstsize: 40
favourites-quick-actions-avg-inverse-rate: 50e3 # µs/token
favourites-quick-actions-timeout: 40e-3 # s
favourites-quick-actions-cache-ttl: 120 # s

5
config/test-settings.yml
View File

@ -4,9 +4,10 @@ database:
log-settings:
detailed: true
all: true
minimum-level: "debug"
destination: "test.log"
minimum-level: debug
destination: test.log
auth-dummy-login: true
server-session-acid-fallback: true
job-workers: 1

2
db.sh
View File

@ -6,4 +6,6 @@ set -e
[ "${FLOCKER}" != "$0" ] && exec env FLOCKER="$0" flock -en .stack-work.lock "$0" "$@" || :
stack build --fast --flag uniworx:-library-only --flag uniworx:dev
export SERVER_SESSION_ACID_FALLBACK=${SERVER_SESSION_ACID_FALLBACK:-true}
stack exec uniworxdb -- $@

233
frontend/src/app.sass
View File

@ -236,17 +236,15 @@ h4
margin-top: 20px
// GENERAL BUTTON STYLES
input[type="submit"],
input[type="button"],
button,
.btn
input[type="submit"]:not(.btn-link),
input[type="button"]:not(.btn-link),
button:not(.btn-link),
.btn:not(.btn-link)
font-family: var(--font-base)
outline: 0
border: 0
box-shadow: 0
background-color: var(--color-dark)
color: white
padding: 10px 17px
min-width: 100px
transition: all .1s
font-size: 16px
@ -254,6 +252,10 @@ button,
display: inline-block
text-decoration: none
&:not(.navbar__container-link)
padding: 10px 17px
border: 0
a:hover
color: white
@ -264,41 +266,67 @@ button,
.buttongroup > &
min-width: 0
&.btn-danger
background-color: var(--color-error-dark)
.buttongroup
display: grid
grid: min-content / auto-flow 1fr
input[type="submit"][disabled],
input[type="button"][disabled],
button[disabled],
.btn[disabled]
input[type="submit"][disabled]:not(.btn-link),
input[type="button"][disabled]:not(.btn-link),
button[disabled]:not(.btn-link),
.btn[disabled]:not(.btn-link)
opacity: 0.3
background-color: var(--color-grey)
cursor: default
input[type="submit"]:not([disabled]):hover,
input[type="button"]:not([disabled]):hover,
button:not([disabled]):hover,
.btn:not([disabled]):hover
input[type="submit"]:not([disabled]):not(.btn-link):hover,
input[type="button"]:not([disabled]):not(.btn-link):hover,
button:not([disabled]):not(.btn-link):hover,
.btn:not([disabled]):not(.btn-link):hover
background-color: var(--color-light)
color: white
.btn-primary
&.btn-danger
background-color: var(--color-error)
.btn-primary:not(.btn-link)
background-color: var(--color-primary)
.btn-info
.btn-info:not(.btn-link)
background-color: var(--color-info)
.btn--small
.btn--small:not(.btn-link)
padding: 4px 7px
background-color: var(--color-darker)
input[type="submit"].btn-info:hover,
input[type="button"].btn-info:hover,
.btn-info:hover
input[type="submit"].btn-info:not(.btn-link):hover,
input[type="button"].btn-info:not(.btn-link):hover,
.btn-info:not(.btn-link):hover
background-color: var(--color-grey)
.btn-link
font-family: var(--font-base)
outline: 0
border: 0
box-shadow: 0
background: none
color: inherit
padding: 0
min-width: unset
font-size: inherit
cursor: pointer
display: inline
text-decoration: underline
font-weight: 600
font-style: inherit
transition: color .2s ease, background-color .2s ease
&:not([disabled]):hover
color: var(--color-link-hover)
// GENERAL TABLE STYLES
.table
margin: 21px 0
@ -312,11 +340,13 @@ input[type="button"].btn-info:hover,
.table--striped
.table__row:not(.no-stripe):not(.table__row--sum):nth-child(even)
background-color: rgba(0, 0, 0, 0.03)
.table__td
background-color: rgba(0, 0, 0, 0.03)
.table--hover
.table__row:not(.no-hover):not(.table__row--sum):not(.table__row--head):not(.table__row--foot):hover
background-color: rgba(0, 0, 0, 0.07)
.table__td
background-color: rgba(0, 0, 0, 0.07)
.table__row--sum td.table__td::before
content: 'Σ'
@ -345,6 +375,19 @@ input[type="button"].btn-info:hover,
padding-right: 10px
max-width: 300px
.table__td--number
width: min-content
padding-left: 0
.table--striped &, .table--hover &
vertical-align: middle
.table__td-content
text-align: right
font-size: 0.9rem
font-weight: 600
color: var(--color-fontsec)
.table__td
font-size: 16px
color: var(--color-font)
@ -390,6 +433,9 @@ input[type="button"].btn-info:hover,
&.table__th-link::before
display: none
.table__th--number
padding: 0
@media (max-width: 1200px)
.table th
padding: 4px 6px
@ -634,11 +680,27 @@ section
.heated
--hotness: 0
--red: calc(var(--hotness) * 200)
--green: calc(255 - calc(var(--hotness) * 255))
--opacity: calc(calc(var(--red) / 600) + 0.1)
font-weight: var(--weight, 600)
background-color: rgba(var(--red), var(--green), 0, var(--opacity))
$hue: calc(120 - var(--hotness) * 120)
$opacity: calc(var(--hotness) * var(--hotness) / 3 + 0.1)
background-color: hsla($hue, 75%, 50%, $opacity) !important
font-weight: calc(var(--hotness) * 200 + 400)
.dual-heated
--hotness: 0
$hue: calc(240 - var(--hotness) * 120)
$opacity: calc(((var(--hotness) - 1) * (var(--hotness) - 1)) / 3 + 0.1)
background-color: hsla($hue, 75%, 50%, $opacity) !important
font-weight: calc(((var(--hotness) - 1) * (var(--hotness) - 1)) * 200 + 400)
&.degenerate
$hue: calc(240 + var(--hotness) * 60)
background-color: hsla($hue, 75%, 50%, $opacity) !important
.uuid
font-family: monospace
@ -791,6 +853,9 @@ th, td
font-style: normal
color: var(--color-font)
.course-event-note--hidden
display: none
.bound_explanation
color: var(--color-fontsec)
font-style: italic
@ -838,7 +903,7 @@ th, td
right: 5px
top: 5px
.occurrence--not-registered, .no-bonus
.occurrence--not-registered, .no-bonus, .allocation-course--excluded, .allocation-course--inactive
text-decoration: line-through
.result
@ -849,11 +914,11 @@ th, td
dt, .dt
font-weight: 600
&.sec
font-style: italic
font-size: 0.9rem
font-weight: 600
color: var(--color-fontsec)
&.sec
font-style: italic
font-size: 0.9rem
font-weight: 600
color: var(--color-fontsec)
dd, .dd
margin-left: 12px
@ -861,6 +926,12 @@ th, td
dd + dt, .dd + dt, dd + .dt, .dd + .dt
margin-top: 17px
.deflist--no-grid
dt, .dt
font-weight: 600
dd, .dd
margin-left: 12px
.explanation
font-style: italic
font-size: 0.9rem
@ -960,6 +1031,9 @@ th, td
justify-content: space-between
margin-bottom: 15px
&:empty
margin: 0
// TABLE FOOTER
.table-footer
display: flex
@ -967,6 +1041,9 @@ th, td
justify-content: space-between
margin-top: 15px
&:empty
margin: 0
// PAGINATION
.pagination
margin-top: 20px
@ -1136,7 +1213,7 @@ a.breadcrumbs__home
font-size: 14px
font-family: monospace
.func-field__wrapper
.func-field__wrapper, .allocation-missing-prios, .allocation-users__accept
max-height: 75vh
overflow: auto
@ -1193,3 +1270,91 @@ a.breadcrumbs__home
text-align: right
.text--center
text-align: center
.course__registration-status
margin-bottom: 12px
.csv-parse-error
white-space: pre-wrap
font-family: monospace
overflow: auto
max-height: 75vh
.labeled-checkbox
display: grid
grid-gap: 0 7px
grid-template-columns: 20px 1fr
grid-template-areas: "checkbox label"
&__checkbox
grid-area: checkbox
place-self: start center
line-height: 0
&__label
grid-area: label
.news__system-messages
overflow-y: auto
max-height: 75vh
.news__system-message-detail
font-style: italic
font-size: 0.9rem
font-weight: 600
color: var(--color-fontsec)
.news__system-message-content + &
margin-top: 10px
.news__system-message
border-left: 3px solid var(--color-info)
padding-left: 17px
background-color: rgba(0,0,0,0.015)
& + .news__system-message
margin-top: 17px
&--info
border-left-color: var(--color-info)
&--error
border-left-color: var(--color-error)
&--warning
border-left-color: var(--color-warning)
&--success
border-left-color: var(--color-success)
.faq__question
font-size: 18px
font-weight: 400
margin: 0
.faq__answer
margin-left: 17px
:not(.show-hide--collapsed) > .faq__answer
margin-top: 7px
.faq__section
padding-bottom: 10px
&:last-child, &.show-hide--collapsed
border-bottom: none
padding-bottom: 0
& + section:not(.faq__section)
border-top: 1px solid #d3d3d3
padding-top: 30px
.faq__section + .faq__section
margin-top: 10px
.faq__question-link
opacity: 0.2
&:hover
opacity: 1

144
frontend/src/lib/storage-manager/storage-manager.js
View File

@ -9,9 +9,10 @@ export const LOCATION = {
LOCAL: 'local',
SESSION: 'session',
WINDOW: 'window',
HISTORY: 'history',
};
const LOCATION_SHADOWING = [ LOCATION.WINDOW, LOCATION.SESSION, LOCATION.LOCAL ];
const LOCATION_SHADOWING = [ LOCATION.HISTORY, LOCATION.WINDOW, LOCATION.SESSION, LOCATION.LOCAL ];
export class StorageManager {
@ -26,7 +27,16 @@ export class StorageManager {
constructor(namespace, version, options) {
this._debugLog('constructor', namespace, version, options);
this.namespace = namespace;
if (typeof namespace === 'object') {
let sep = '_';
const namespace_arr = Array.from(namespace);
while (namespace_arr.some(str => str.includes(sep)))
sep = sep + '_';
this.namespace = Array.from(namespace).join(sep);
} else {
this.namespace = namespace;
}
this.version = semver.valid(version);
if (!namespace) {
@ -48,7 +58,7 @@ export class StorageManager {
throw new Error('Cannot setup StorageManager without window or global');
if (this._options.encryption) {
[LOCATION.LOCAL, LOCATION.SESSION].forEach((location) => {
[LOCATION.LOCAL, LOCATION.SESSION, LOCATION.HISTORY].forEach((location) => {
const encryption = this._options.encryption.all || this._options.encryption[location];
if (encryption) this._requestStorageKey({ location: location, encryption: encryption });
});
@ -70,17 +80,21 @@ export class StorageManager {
switch (location) {
case LOCATION.LOCAL: {
this._saveToLocalStorage(this._updateStorage(this._getFromLocalStorage(options), { [key]: value }, LOCATION.LOCAL, options));
this._saveToLocalStorage({ ...this._getFromLocalStorage(options), [key]: value}, options);
break;
}
case LOCATION.SESSION: {
this._saveToSessionStorage(this._updateStorage(this._getFromSessionStorage(options), { [key]: value }, LOCATION.SESSION, options));
this._saveToSessionStorage({ ...this._getFromSessionStorage(options), [key]: value}, options);
break;
}
case LOCATION.WINDOW: {
this._saveToWindow({ ...this._getFromWindow(), [key]: value });
break;
}
case LOCATION.HISTORY: {
this._saveToHistory({ ...this._getFromHistory(), [key]: value }, options);
break;
}
default:
console.error('StorageManager.save cannot save item with unsupported location');
}
@ -112,6 +126,10 @@ export class StorageManager {
val = this._getFromWindow()[key];
break;
}
case LOCATION.HISTORY: {
val = this._getFromHistory(options)[key];
break;
}
default:
console.error('StorageManager.load cannot load item with unsupported location');
}
@ -138,14 +156,14 @@ export class StorageManager {
delete val[key];
return this._saveToLocalStorage(val);
return this._saveToLocalStorage(val, options);
}
case LOCATION.SESSION: {
let val = this._getFromSessionStorage(options);
delete val[key];
return this._saveToSessionStorage(val);
return this._saveToSessionStorage(val, options);
}
case LOCATION.WINDOW: {
let val = this._getFromWindow();
@ -154,6 +172,14 @@ export class StorageManager {
return this._saveToWindow(val);
}
case LOCATION.HISTORY: {
let val = this._getFromHistory(options);
delete val[key];
return this._saveToHistory(val, options);
}
default:
console.error('StorageManager.load cannot load item with unsupported location');
}
@ -177,6 +203,8 @@ export class StorageManager {
return this._clearSessionStorage();
case LOCATION.WINDOW:
return this._clearWindow();
case LOCATION.HISTORY:
return this._clearHistory(options && options.history);
default:
console.error('StorageManager.clear cannot clear with unsupported location');
}
@ -185,7 +213,7 @@ export class StorageManager {
}
_getFromLocalStorage(options=this._options) {
_getFromLocalStorage(options) {
this._debugLog('_getFromLocalStorage', options);
let state;
@ -210,7 +238,7 @@ export class StorageManager {
}
}
_saveToLocalStorage(state) {
_saveToLocalStorage(state, options) {
this._debugLog('_saveToLocalStorage', state);
if (!state)
@ -223,8 +251,8 @@ export class StorageManager {
} else {
versionedState = { version: this.version, ...state };
}
window.localStorage.setItem(this.namespace, JSON.stringify(versionedState));
window.localStorage.setItem(this.namespace, JSON.stringify(this._updateStorage({}, versionedState, LOCATION.LOCAL, options)));
}
_clearLocalStorage() {
@ -240,10 +268,10 @@ export class StorageManager {
if (!this._global || !this._global.App)
return {};
if (!this._global.App.Storage)
this._global.App.Storage = {};
if (!this._global.App.Storage || !this._global.App.Storage[this.namespace])
return {};
return this._global.App.Storage;
return this._global.App.Storage[this.namespace];
}
_saveToWindow(value) {
@ -274,8 +302,71 @@ export class StorageManager {
}
}
_getFromHistory(options) {
this._debugLog('_getFromHistory');
_getFromSessionStorage(options=this._options) {
if (!this._global || !this._global.history)
return {};
if (!this._global.history.state || !this._global.history.state[this.namespace])
return {};
return this._getFromStorage(this._global.history.state[this.namespace], LOCATION.HISTORY, options);
}
_saveToHistory(value, options) {
this._debugLog('_saveToHistory', options);
if (!this._global || !this._global.history) {
throw new Error('StorageManager._saveToHistory called when window.history is not available');
}
const push = (options.history && typeof options.history.push !== 'undefined') ? !!options.history.push : true;
const title = (options.history && options.history.title) || (this._global.document && this._global.document.title) || '';
const url = (options.history && options.history.url) || (this._global.document && this._global.document.location);
const state = this._global.history.state || {};
state[this.namespace] = this._updateStorage({}, value, LOCATION.HISTORY, options);
this._debugLog('_saveToHistory', { state: state, push: push, title: title, url: url});
if (push)
this._global.history.pushState(state, title, url);
else
this._global.history.replaceState(state, title, url);
}
_clearHistory(options) {
this._debugLog('_clearHistory', options);
if (!this._global || !this._global.history) {
throw new Error('StorageManager._clearHistory called when window.history is not available');
}
const push = (options.history && typeof options.history.push !== 'undefined' ? !!options.history.push : true) || true;
const title = (options.history && options.history.title) || (this._global.document && this._global.document.title) || '';
const url = (options.history && options.history.url) || (this._global.document && this._global.document.location);
const state = this._global.history.state || {};
delete state[this.namespace];
if (push)
this._global.history.pushState(state, title, url);
else
this._global.history.replaceState(state, title, url);
}
addHistoryListener(listener, options=this._options, ...args) {
const modified_listener = (function(event, ...listener_args) { // eslint-disable-line no-unused-vars
this._global.setTimeout(() => listener(this._getFromHistory(options), ...listener_args));
}).bind(this);
this._global.addEventListener('popstate', modified_listener, args);
}
_getFromSessionStorage(options) {
this._debugLog('_getFromSessionStorage', options);
let state;
@ -300,7 +391,7 @@ export class StorageManager {
}
}
_saveToSessionStorage(state) {
_saveToSessionStorage(state, options) {
this._debugLog('_saveToSessionStorage', state);
if (!state)
@ -314,7 +405,7 @@ export class StorageManager {
versionedState = { version: this.version, ...state };
}
window.sessionStorage.setItem(this.namespace, JSON.stringify(versionedState));
window.sessionStorage.setItem(this.namespace, JSON.stringify(this._updateStorage({}, versionedState, LOCATION.SESSION, options)));
}
_clearSessionStorage() {
@ -324,10 +415,10 @@ export class StorageManager {
}
_getFromStorage(storage, location, options=this._options) {
_getFromStorage(storage, location, options) {
this._debugLog('_getFromStorage', storage, location, options);
const encryption = options.encryption && (options.encryption.all || options.encryption[location]);
const encryption = options && options.encryption && (options.encryption.all || options.encryption[location]);
if (encryption && storage.encryption) {
return { ...storage, ...JSON.parse(decrypt(storage.encryption.ciphertext, this._encryptionKey[location]) || null) };
} else {
@ -335,10 +426,10 @@ export class StorageManager {
}
}
_updateStorage(storage, update, location, options=this._options) {
_updateStorage(storage, update, location, options) {
this._debugLog('_updateStorage', storage, update, location, options);
const encryption = options.encryption && (options.encryption.all || options.encryption[location]);
const encryption = options && options.encryption && (options.encryption.all || options.encryption[location]);
if (encryption && storage.encryption) {
const updatedDecryptedStorage = { ...JSON.parse(decrypt(storage.encryption.ciphertext, this._encryptionKey[location]) || null), ...update };
console.log('updatedDecryptedStorage', updatedDecryptedStorage);
@ -357,13 +448,13 @@ export class StorageManager {
const enc = this.load('encryption', { ...options, encryption: false });
const requestBody = {
type : options.encryption,
length : 42,
length : sodium.crypto_secretbox_KEYBYTES,
salt : enc.salt,
timestamp : enc.timestamp,
};
this._global.App.httpClient.post({
url: '../../../../../../user/storage-key', // TODO use APPROOT instead
url: '/user/storage-key',
headers: {
'Content-Type' : HttpClient.ACCEPT.JSON,
'Accept' : HttpClient.ACCEPT.JSON,
@ -381,11 +472,10 @@ export class StorageManager {
}).catch(console.error);
}
_debugLog() {
_debugLog() {}
// _debugLog(fName, ...args) {
// console.log(`[DEBUGLOG] StorageManager.${fName}`, { args: args, instance: this });
}
// console.log(`[DEBUGLOG] StorageManager.${fName}`, { args: args, instance: this });
// }
}

2
frontend/src/services/html-helpers/html-helpers.js
View File

@ -17,7 +17,7 @@ export class HtmlHelpers {
idPrefix = this._getIdPrefix();
this._prefixIds(element, idPrefix);
}
return Promise.resolve({ idPrefix, element });
return Promise.resolve({ idPrefix, element, headers: response.headers });
},
Promise.reject,
).catch(console.error);

28
frontend/src/services/http-client/http-client.js
View File

@ -15,6 +15,27 @@ export class HttpClient {
}
}
_baseUrl;
setBaseUrl(baseUrl) {
if (typeof this._baseUrl !== 'undefined') {
throw new Error('HttpClient baseUrl is already set');
}
this._baseUrl = baseUrl;
}
_defaultUrl;
setDefaultUrl(defaultUrl) {
if (typeof this._defaultUrl !== 'undefined') {
throw new Error('HttpClient defaultUrl is already set');
}
this._defaultUrl = defaultUrl;
}
get(args) {
args.method = 'GET';
return this._fetch(args);
@ -28,12 +49,17 @@ export class HttpClient {
}
_fetch(options) {
options.url = (options.url && options.url.href) || options.url || this._defaultUrl;
if (this._baseUrl && options.url && options.url.substring(0,1) === '/' && options.url.substring(0,2) !== '//')
options.url = this._baseUrl + (this._baseUrl.substring(this._baseUrl.substring.length - 1) === '/' ? '' : '/') + options.url.substring(1,0);
const requestOptions = {
credentials: 'same-origin',
...options,
};
return fetch(options.url, requestOptions)
return fetch(options.url || window.location.href, requestOptions)
.then(
(response) => {
this._responseInterceptors.forEach((interceptor) => interceptor(response, options));

2
frontend/src/utils/alerts/alerts.js
View File

@ -155,7 +155,7 @@ export class Alerts {
alertCloser.classList.add(ALERT_CLOSER_CLASS);
const alertIcon = document.createElement('div');
alertIcon.classList.add(ALERT_ICON_CLASS, 'fas', 'fa-fw', 'fa-' + icon);
alertIcon.classList.add(ALERT_ICON_CLASS, 'fas', 'fa-' + icon);
const alertContent = document.createElement('div');
alertContent.classList.add(ALERT_CONTENT_CLASS);

15
frontend/src/utils/asidenav/asidenav.sass
View File

@ -232,12 +232,22 @@
.asidenav__nested-list
min-width: 200px
.asidenav__nested-list--unavailable
font-size: 0.9rem
color: var(--color-fontsec)
font-weight: 600
padding: 7px
min-width: 200px
@media (max-width: 425px)
.asidenav__list-item
padding-left: 10px
.asidenav__nested-list
display: none
.asidenav__nested-list--unavailable
display: none
.asidenav__nested-list-item
position: relative
@ -317,10 +327,9 @@
color: var(--color-font)
padding: 0
.asidenav__nested-list,
.asidenav__link-label
.asidenav__nested-list, .asidenav__link-label, .asidenav__nested-list--unavailable
display: none
.asidenav__list-item--active
.asidenav__link-wrapper
background-color: var(--color-lightwhite)

103
frontend/src/utils/async-table/async-table.js
View File

@ -13,7 +13,9 @@ const INPUT_DEBOUNCE = 600;
const FILTER_DEBOUNCE = 100;
const HEADER_HEIGHT = 80;
const ASYNC_TABLE_LOCAL_STORAGE_KEY = 'ASYNC_TABLE';
const ASYNC_TABLE_STORAGE_KEY = 'ASYNC_TABLE';
const ASYNC_TABLE_STORAGE_VERSION = '2.0.0';
const ASYNC_TABLE_SCROLLTABLE_SELECTOR = '.scrolltable';
const ASYNC_TABLE_INITIALIZED_CLASS = 'async-table--initialized';
const ASYNC_TABLE_LOADING_CLASS = 'async-table--loading';
@ -47,7 +49,10 @@ export class AsyncTable {
};
_ignoreRequest = false;
_storageManager = new StorageManager(ASYNC_TABLE_LOCAL_STORAGE_KEY, '1.0.0', { location: LOCATION.WINDOW });
_windowStorage;
_historyStorage;
_active = true;
constructor(element, app) {
if (!element) {
@ -79,21 +84,56 @@ export class AsyncTable {
this._cssIdPrefix = findCssIdPrefix(rawTableId);
this._asyncTableId = rawTableId.replace(this._cssIdPrefix, '');
if (!this._asyncTableId) {
throw new Error('Async Table cannot be set up without an ident!');
}
this._windowStorage = new StorageManager([ASYNC_TABLE_STORAGE_KEY, this._asyncTableId], ASYNC_TABLE_STORAGE_VERSION, { location: LOCATION.WINDOW });
this._historyStorage = new StorageManager([ASYNC_TABLE_STORAGE_KEY, this._asyncTableId], ASYNC_TABLE_STORAGE_VERSION, { location: LOCATION.HISTORY });
// find scrolltable wrapper
this._scrollTable = this._element.querySelector(ASYNC_TABLE_SCROLLTABLE_SELECTOR);
if (!this._scrollTable) {
throw new Error('Async Table cannot be set up without a scrolltable element!');
}
this._setupTableFilter();
this._processStorage();
// clear currentTableUrl from previous requests
this._storageManager.remove('currentTableUrl');
this._setupTableFilter();
this._windowStorage.remove('currentTableUrl');
if (!('currentTableUrl' in this._element.dataset)) {
this._element.dataset['currentTableUrl'] = document.location.href;
this._historyStorage.save('currentTableUrl', document.location.href, { location: LOCATION.HISTORY, history: { push: false } });
}
this._historyListener();
this._historyStorage.addHistoryListener(this._historyListener.bind(this));
// mark initialized
this._element.classList.add(ASYNC_TABLE_INITIALIZED_CLASS);
if (this._active)
this._element.classList.add(ASYNC_TABLE_INITIALIZED_CLASS);
}
_historyListener(historyState) {
if (!this._active)
return;
const windowUrl = this._element.dataset['currentTableUrl'];
const historyUrl = historyState ? historyState['currentTableUrl'] : this._historyStorage.load('currentTableUrl');
this._debugLog('_historyListener', historyState, windowUrl, historyUrl);
if (this._isEquivalentUrl(windowUrl, historyUrl))
return;
this._debugLog('_historyListener', historyUrl);
this._updateTableFrom(historyUrl || document.location.href, undefined, true);
}
_isEquivalentUrl(a, b) {
return a === b;
}
start() {
@ -113,7 +153,7 @@ export class AsyncTable {
this._ths.forEach((th) => {
th.clickHandler = (event) => {
this._storageManager.save('horizPos', (this._scrollTable || {}).scrollLeft);
this._windowStorage.save('horizPos', (this._scrollTable || {}).scrollLeft);
this._linkClickHandler(event);
};
th.element.addEventListener('click', th.clickHandler);
@ -135,7 +175,7 @@ export class AsyncTable {
left: this._scrollTable.offsetLeft || 0,
behavior: 'smooth',
};
this._storageManager.save('scrollTo', scrollTo);
this._windowStorage.save('scrollTo', scrollTo);
}
this._linkClickHandler(event);
};
@ -256,7 +296,7 @@ export class AsyncTable {
const prefix = findCssIdPrefix(focusedInput.id);
const focusId = focusedInput.id.replace(prefix, '');
callback = function(wrapper) {
const idPrefix = this._storageManager.load('cssIdPrefix');
const idPrefix = this._windowStorage.load('cssIdPrefix');
const toBeFocused = wrapper.querySelector('#' + idPrefix + focusId);
if (toBeFocused) {
toBeFocused.focus();
@ -268,34 +308,33 @@ export class AsyncTable {
}
_serializeTableFilterToURL(tableFilterForm) {
const url = new URL(this._storageManager.load('currentTableUrl') || window.location.href);
const url = new URL(this._windowStorage.load('currentTableUrl') || window.location.href);
// create new FormData and format any date values
const formData = Datepicker.unformatAll(tableFilterForm, new FormData(tableFilterForm));
for (var k of url.searchParams.keys()) {
url.searchParams.delete(k);
}
this._debugLog('_serializeTableFilterToURL', Array.from(formData.entries()), url.href);
for (var kv of formData.entries()) {
url.searchParams.append(kv[0], kv[1]);
}
const searchParams = new URLSearchParams(Array.from(formData.entries()));
url.search = searchParams.toString();
this._debugLog('_serializeTableFilterToURL', url.href);
return url;
}
_processStorage() {
const scrollTo = this._storageManager.load('scrollTo');
const scrollTo = this._windowStorage.load('scrollTo');
if (scrollTo && this._scrollTable) {
window.scrollTo(scrollTo);
}
this._storageManager.remove('scrollTo');
this._windowStorage.remove('scrollTo');
const horizPos = this._storageManager.load('horizPos');
const horizPos = this._windowStorage.load('horizPos');
if (horizPos && this._scrollTable) {
this._scrollTable.scrollLeft = horizPos;
}
this._storageManager.remove('horizPos');
this._windowStorage.remove('horizPos');
}
_removeListeners() {
@ -330,7 +369,7 @@ export class AsyncTable {
}
_changePagesizeHandler = () => {
const url = new URL(this._storageManager.load('currentTableUrl') || window.location.href);
const url = new URL(this._windowStorage.load('currentTableUrl') || window.location.href);
// create new FormData and format any date values
const formData = Datepicker.unformatAll(this._pagesizeForm, new FormData(this._pagesizeForm));
@ -347,7 +386,9 @@ export class AsyncTable {
}
// fetches new sorted element from url with params and replaces contents of current element
_updateTableFrom(url, callback) {
_updateTableFrom(url, callback, isPopState) {
url = new URL(url);
const cancelPendingUpdates = (() => {
this._cancelPendingUpdates.forEach(f => f());
}).bind(this);
@ -372,23 +413,33 @@ export class AsyncTable {
return false;
}
this._storageManager.save('currentTableUrl', url.href);
if (!isPopState)
this._historyStorage.save('currentTableUrl', url.href, { location: LOCATION.HISTORY, history: { push: true, url: response.headers.get('DB-Table-Canonical-URL') || url.href } });
this._windowStorage.save('currentTableUrl', url.href);
// reset table
this._removeListeners();
this._active = false;
this._element.classList.remove(ASYNC_TABLE_INITIALIZED_CLASS);
this._element.dataset['currentTableUrl'] = url.href;
// update table with new
this._element.innerHTML = response.element.innerHTML;
this._app.utilRegistry.initAll(this._element);
if (callback && typeof callback === 'function') {
this._storageManager.save('cssIdPrefix', response.idPrefix);
this._windowStorage.save('cssIdPrefix', response.idPrefix);
callback(this._element);
this._storageManager.remove('cssIdPrefix');
this._windowStorage.remove('cssIdPrefix');
}
}).catch((err) => console.error(err)
).finally(() => this._element.classList.remove(ASYNC_TABLE_LOADING_CLASS));
}
_debugLog() {}
// _debugLog(fName, ...args) {
// console.log(`[DEBUGLOG] AsyncTable.${fName}`, { args: args, instance: this });
// }
}

1
frontend/src/utils/async-table/async-table.spec.js
View File

@ -20,6 +20,7 @@ describe('AsyncTable', () => {
const element = document.createElement('div');
const scrollTable = document.createElement('div');
const table = document.createElement('table');
table.id = 'ident';
scrollTable.classList.add('scrolltable');
scrollTable.appendChild(table);
element.appendChild(scrollTable);

4
frontend/src/utils/exam-correct/exam-correct.js
View File

@ -7,7 +7,6 @@ import moment from 'moment';
import './exam-correct.sass';
const EXAM_CORRECT_URL_POST = 'correct';
const EXAM_CORRECT_HEADERS = {
'Content-Type': HttpClient.ACCEPT.JSON,
'Accept': HttpClient.ACCEPT.JSON,
@ -198,7 +197,6 @@ export class ExamCorrect {
const body = this._toRequestBody(this._userInput.value);
this._app.httpClient.post({
url: EXAM_CORRECT_URL_POST,
headers: EXAM_CORRECT_HEADERS,
body: JSON.stringify(body),
}).then(
@ -290,7 +288,6 @@ export class ExamCorrect {
const body = this._toRequestBody(userId || user, results, result);
this._app.httpClient.post({
url: EXAM_CORRECT_URL_POST,
headers: EXAM_CORRECT_HEADERS,
body: JSON.stringify(body),
}).then(
@ -522,7 +519,6 @@ export class ExamCorrect {
const body = this._toRequestBody(listItem.getAttribute(EXAM_CORRECT_USER_ATTR), results.partResults, results.result);
this._app.httpClient.post({
url: EXAM_CORRECT_URL_POST,
headers: EXAM_CORRECT_HEADERS,
body: JSON.stringify(body),
}).then(

39
frontend/src/utils/form/interactive-fieldset.js
View File

@ -5,10 +5,13 @@ const INTERACTIVE_FIELDSET_UTIL_TARGET_SELECTOR = '.interactive-fieldset__target
const INTERACTIVE_FIELDSET_INITIALIZED_CLASS = 'interactive-fieldset--initialized';
const INTERACTIVE_FIELDSET_CHILD_SELECTOR = 'input:not([disabled]), select:not([disabled]), textarea:not([disabled]), button:not([disabled])';
let fieldsetCounter = 0;
@Utility({
selector: '[uw-interactive-fieldset]',
})
export class InteractiveFieldset {
fieldsetIdent = (fieldsetCounter++).toString();
_element;
@ -56,21 +59,23 @@ export class InteractiveFieldset {
this.target = this._element;
}
this.childInputs = Array.from(this._element.querySelectorAll(INTERACTIVE_FIELDSET_CHILD_SELECTOR));
this.childInputs = Array.from(this._element.querySelectorAll(INTERACTIVE_FIELDSET_CHILD_SELECTOR)).filter(child => child.closest('[uw-interactive-fieldset]') === this._element);
// add event listener
const observer = new MutationObserver(() => this._updateVisibility());
const observer = new MutationObserver(this._updateVisibility.bind(this));
observer.observe(this.conditionalInput, { attributes: true, attributeFilter: ['data-interactive-fieldset-hidden'] });
this.conditionalInput.addEventListener('input', () => this._updateVisibility());
// initial visibility update
this._updateVisibility();
this.conditionalInput.addEventListener('input', this._updateVisibility.bind(this));
// mark as initialized
this._element.classList.add(INTERACTIVE_FIELDSET_INITIALIZED_CLASS);
}
start() {
// initial visibility update
this._updateVisibility();
}
destroy() {
// TODO
}
@ -78,7 +83,20 @@ export class InteractiveFieldset {
_updateVisibility() {
const active = this._matchesConditionalValue() && !this.conditionalInput.dataset.interactiveFieldsetHidden;
this.target.classList.toggle('hidden', !active);
let hiddenBy = (this.target.dataset.interactiveFieldsetHiddenBy || '').split(',').filter(str => str.length !== 0);
if (active)
hiddenBy = hiddenBy.filter(ident => ident !== this.fieldsetIdent);
else if (hiddenBy.every(ident => ident !== this.fieldsetIdent))
hiddenBy = [ ...hiddenBy, this.fieldsetIdent ];
if (hiddenBy.length !== 0) {
this.target.dataset.interactiveFieldsetHiddenBy = hiddenBy.join(',');
this.target.classList.add('hidden');
} else {
delete this.target.dataset['interactiveFieldsetHiddenBy'];
this.target.classList.remove('hidden');
}
this.childInputs.forEach((el) => this._updateChildVisibility(el, active));
}
@ -98,6 +116,9 @@ export class InteractiveFieldset {
if (this._isCheckbox()) {
matches = this.conditionalInput.checked === true;
} else if (this._isRadio()) {
const radios = Array.from(this.conditionalInput.querySelectorAll('input[type=radio]'));
matches = radios.some(radio => radio.checked && radio.value === this.conditionalValue);
} else {
matches = this.conditionalInput.value === this.conditionalValue;
}
@ -112,4 +133,8 @@ export class InteractiveFieldset {
_isCheckbox() {
return this.conditionalInput.getAttribute('type') === 'checkbox';
}
_isRadio() {
return !!this.conditionalInput.querySelector('input[type=radio]');
}
}

3
frontend/src/utils/hide-columns/hide-columns.sass
View File

@ -58,5 +58,8 @@
display: block
clear: both
&:empty
margin: 0
.hide-columns--hidden-cell
display: none

2
frontend/src/utils/inputs/checkbox.sass
View File

@ -89,7 +89,7 @@
\:checked + label::before
background-color: white
[disabled] + label
[disabled] + label, [readonly] + label
pointer-events: none
border: none
opacity: 0.6

10
frontend/src/utils/inputs/inputs.sass
View File

@ -60,13 +60,21 @@
grid-column: 1
.form-group--has-error
background-color: rgba(255, 0, 0, 0.1)
background-color: rgba(140, 7, 7, 0.05)
.form-group-label
border-left: 2px solid var(--color-error)
align-self: stretch
padding-left: 7px
input, textarea
border-color: var(--color-error) !important
.form-error
display: block
font-weight: 600
color: var(--color-error)
margin: 7px 0
.form-error
display: none

84
frontend/src/utils/inputs/radio-group.sass
View File

@ -4,52 +4,52 @@
.radio-group
display: flex
.radio
position: relative
display: inline-block
.radio
position: relative
display: inline-block
[type='radio']
position: fixed
top: -1px
left: -1px
width: 1px
height: 1px
overflow: hidden
[type='radio']
position: fixed
top: -1px
left: -1px
width: 1px
height: 1px
overflow: hidden
label
display: block
height: 34px
min-width: 42px
line-height: 34px
text-align: center
padding: 0 13px
background-color: #f3f3f3
box-shadow: inset 2px 1px 2px 1px rgba(50, 50, 50, 0.05)
color: var(--color-font)
cursor: pointer
label
display: block
height: 34px
min-width: 42px
line-height: 34px
text-align: center
padding: 0 13px
background-color: #f3f3f3
box-shadow: inset 2px 1px 2px 1px rgba(50, 50, 50, 0.05)
color: var(--color-font)
cursor: pointer
\:checked + label
background-color: var(--color-primary)
color: var(--color-lightwhite)
box-shadow: inset -2px -1px 2px 1px rgba(255, 255, 255, 0.15)
\:checked + label
background-color: var(--color-primary)
color: var(--color-lightwhite)
box-shadow: inset -2px -1px 2px 1px rgba(255, 255, 255, 0.15)
\:focus + label
border-color: #3273dc
box-shadow: 0 0 0.125em 0 rgba(50, 115, 220, 0.8)
outline: 0
\:focus + label
border-color: #3273dc
box-shadow: 0 0 0.125em 0 rgba(50, 115, 220, 0.8)
outline: 0
[disabled] + label
pointer-events: none
border: none
opacity: 0.6
filter: grayscale(1)
[disabled] + label
pointer-events: none
border: none
opacity: 0.6
filter: grayscale(1)
.radio:first-child
label
border-top-left-radius: 4px
border-bottom-left-radius: 4px
.radio:first-child
label
border-top-left-radius: 4px
border-bottom-left-radius: 4px
.radio:last-child
label
border-top-right-radius: 4px
border-bottom-right-radius: 4px
.radio:last-child
label
border-top-right-radius: 4px
border-bottom-right-radius: 4px

2
frontend/src/utils/inputs/radio.sass
View File

@ -38,7 +38,7 @@
box-shadow: 0 0 0.125em 0 rgba(50, 115, 220, 0.8)
outline: 0
[disabled] + label
[disabled] + label, [readonly] + label
pointer-events: none
border: none
opacity: 0.6

113
frontend/src/utils/mass-input/mass-input.js
View File

@ -1,3 +1,5 @@
/* global global:writable */
import { Utility } from '../../core/utility';
import { Datepicker } from '../form/datepicker';
import './mass-input.sass';
@ -7,6 +9,11 @@ const MASS_INPUT_ADD_CELL_SELECTOR = '.massinput__cell--add';
const MASS_INPUT_SUBMIT_BUTTON_CLASS = 'massinput__submit-button';
const MASS_INPUT_INITIALIZED_CLASS = 'mass-input--initialized';
const MASS_INPUT_ADD_CHANGE_FIELD_SELECTOR = 'select, input[type=radio]';
// const MASS_INPUT_SAFETY_SUBMITTED_CLASS = 'massinput--safety-submitted';
// const MASS_INPUT_SAFETY_SUBMITTED_TIMEOUT = 1000;
@Utility({
selector: '[uw-mass-input]',
})
@ -14,11 +21,14 @@ export class MassInput {
_element;
_app;
_global;
_massInputId;
_massInputFormSubmitHandler;
_massInputForm;
_changedAdd = new Array();
constructor(element, app) {
if (!element) {
throw new Error('Mass Input utility cannot be setup without an element!');
@ -27,6 +37,14 @@ export class MassInput {
this._element = element;
this._app = app;
if (global !== undefined)
this._global = global;
else if (window !== undefined)
this._global = window;
else
throw new Error('Cannot setup Mass Input utility without window or global');
if (this._element.classList.contains(MASS_INPUT_INITIALIZED_CLASS)) {
return false;
}
@ -47,8 +65,10 @@ export class MassInput {
this._setupSubmitButton(button);
});
this._massInputForm.addEventListener('submit', this._massInputFormSubmitHandler);
this._massInputForm.addEventListener('keypress', this._keypressHandler);
this._massInputForm.addEventListener('submit', this._massInputFormSubmitHandler.bind(this));
this._massInputForm.addEventListener('keypress', this._keypressHandler.bind(this));
Array.from(this._element.querySelectorAll(MASS_INPUT_ADD_CELL_SELECTOR)).forEach(this._setupChangedHandlers.bind(this));
// mark initialized
this._element.classList.add(MASS_INPUT_INITIALIZED_CLASS);
@ -58,6 +78,26 @@ export class MassInput {
this._reset();
}
_setupChangedHandlers(addCell) {
Array.from(addCell.querySelectorAll(MASS_INPUT_ADD_CHANGE_FIELD_SELECTOR)).forEach(inputElem => {
if (inputElem.closest('[uw-mass-input]') !== this._element)
return;
inputElem.addEventListener('change', () => { this._changedAdd.push(addCell); });
});
}
_unsafeAddCells() {
let changedAdd = this._changedAdd;
Array.from(this._element.querySelectorAll(MASS_INPUT_ADD_CELL_SELECTOR)).forEach(addCell => addCell.querySelectorAll('input:not([type=checkbox]):not([type=radio])').forEach(inputElem => {
if (inputElem.closest('[uw-mass-input]') === this._element && inputElem.value !== '' && (inputElem.defaultValue || inputElem.getAttribute('value')) !== inputElem.value)
changedAdd.push(addCell);
}));
return changedAdd;
}
_makeSubmitHandler() {
const method = this._massInputForm.getAttribute('method') || 'POST';
const url = this._massInputForm.getAttribute('action') || window.location.href;
@ -69,31 +109,58 @@ export class MassInput {
}
return (event) => {
let activeElement;
let submitButton;
let isAddCell;
let isMassInputSubmit = (() => {
let activeElement;
// check if event occured from either a mass input add/delete button or
// from inside one of massinput's inputs (i.e. a child is focused/active)
activeElement = this._element.querySelector(':focus, :active');
// check if event occured from either a mass input add/delete button or
// from inside one of massinput's inputs (i.e. a child is focused/active)
activeElement = this._element.querySelector(':focus, :active');
if (!activeElement) {
return false;
if (!activeElement) {
return false;
}
// find the according massinput cell thats hosts the element that triggered the submit
const massInputCell = activeElement.closest(MASS_INPUT_CELL_SELECTOR);
if (!massInputCell) {
return false;
}
submitButton = massInputCell.querySelector('.' + MASS_INPUT_SUBMIT_BUTTON_CLASS);
if (!submitButton) {
return false;
}
isAddCell = massInputCell.matches(MASS_INPUT_ADD_CELL_SELECTOR);
const submitButtonIsActive = submitButton.matches(':focus, :active');
// if the cell is not an add cell the active element must at least be the cells submit button
if (!isAddCell && !submitButtonIsActive) {
return false;
}
return true;
})();
let unsafeAddCells = this._unsafeAddCells();
if (unsafeAddCells.length > 0 && !isMassInputSubmit) {
let addButtons = Array.from(unsafeAddCells[0].querySelectorAll('.' + MASS_INPUT_SUBMIT_BUTTON_CLASS)).filter(addButton => addButton.closest('[uw-mass-input]') === this._element);
if (addButtons.length > 0) {
submitButton = addButtons[0];
isMassInputSubmit = true;
isAddCell = false;
this._element.scrollIntoView();
// this._element.classList.add(MASS_INPUT_SAFETY_SUBMITTED_CLASS);
// this._global.setTimeout(() => { this._element.classList.remove(MASS_INPUT_SAFETY_SUBMITTED_CLASS) }, MASS_INPUT_SAFETY_SUBMITTED_TIMEOUT)
}
}
// find the according massinput cell thats hosts the element that triggered the submit
const massInputCell = activeElement.closest(MASS_INPUT_CELL_SELECTOR);
if (!massInputCell) {
return false;
}
const submitButton = massInputCell.querySelector('.' + MASS_INPUT_SUBMIT_BUTTON_CLASS);
if (!submitButton) {
return false;
}
const isAddCell = massInputCell.matches(MASS_INPUT_ADD_CELL_SELECTOR);
const submitButtonIsActive = submitButton.matches(':focus, :active');
// if the cell is not an add cell the active element must at least be the cells submit button
if (!isAddCell && !submitButtonIsActive) {
if (!isMassInputSubmit) {
return false;
}

13
frontend/src/utils/mass-input/mass-input.sass
View File

@ -1,3 +1,5 @@
@use "../../app" as *
.massinput-list__wrapper, .massinput-list__cell
display: grid
grid: auto / auto 50px
@ -12,3 +14,14 @@
.massinput-list__cell
grid-column: 1 / 3
/* .massinput--safety-submitted
/* animation: massinput--safety-submitted linear 1s
/* @keyframes massinput--safety-submitted
/* 0%
/* background-color: rgba(252, 153, 0, 0)
/* 50%
/* background-color: rgba(252, 153, 0, 0.8)
/* 100%
/* background-color: rgba(252, 153, 0, 0)

33
frontend/src/utils/show-hide/show-hide.js
View File

@ -57,23 +57,44 @@ export class ShowHide {
this._element.classList.add(SHOW_HIDE_TOGGLE_RIGHT_CLASS);
}
this._checkHash();
window.addEventListener('hashchange', this._checkHash.bind(this));
// mark as initialized
this._element.classList.add(SHOW_HIDE_INITIALIZED_CLASS, SHOW_HIDE_TOGGLE_CLASS);
}
destroy() {
this._element.removeEventListener('click', this._clickHandler);
}
destroy() {}
_addClickListener() {
this._element.addEventListener('click', this._clickHandler);
this._element.addEventListener('click', this._clickHandler.bind(this));
}
_clickHandler = () => {
const newState = this._element.parentElement.classList.toggle(SHOW_HIDE_COLLAPSED_CLASS);
_show() {
this._element.parentElement.classList.remove(SHOW_HIDE_COLLAPSED_CLASS);
}
_toggle() {
return this._element.parentElement.classList.toggle(SHOW_HIDE_COLLAPSED_CLASS);
}
_clickHandler(event) {
if (event.target.closest('a') && event.target.closest('a') !== this._element)
return;
if (event.target.matches('a') && event.target !== this._element)
return;
const newState = this._toggle();
if (this._showHideId) {
this._storageManager.save(this._showHideId, newState);
}
}
_checkHash() {
if (this._element.id && '#' + this._element.id === location.hash) {
this._show();
}
}
}

4
frontend/src/utils/show-hide/show-hide.sass
View File

@ -19,7 +19,7 @@ $show-hide-toggle-size: 6px
border-right: 2px solid currentColor
border-top: 2px solid currentColor
transition: transform .2s ease
transform: translateY(-50%) rotate(-45deg)
transform: translateY(2px) translateY(-50%) rotate(-45deg)
@media (max-width: 768px)
left: auto
@ -33,7 +33,7 @@ $show-hide-toggle-size: 6px
.show-hide--collapsed
.show-hide__toggle::before
transform: translateY(-50%) rotate(135deg)
transform: translateY(-2px) translateY(-50%) rotate(135deg)
& > :not(.show-hide__toggle)
display: block

12
ghci.sh
View File

@ -4,10 +4,16 @@ set -e
[ "${FLOCKER}" != "$0" ] && exec env FLOCKER="$0" flock -en .stack-work.lock "$0" "$@" || :
export DETAILED_LOGGING=${DETAILED_LOGGING:-true}
export LOG_ALL=${LOG_ALL:-false}
export LOGLEVEL=${LOGLEVEL:-info}
export DUMMY_LOGIN=${DUMMY_LOGIN:-true}
export SERVER_SESSION_ACID_FALLBACK=${SERVER_SESSION_ACID_FALLBACK:-true}
export SERVER_SESSION_COOKIES_SECURE=${SERVER_SESSION_COOKIES_SECURE:-false}
export ALLOW_DEPRECATED=${ALLOW_DEPRECATED:-true}
export RIBBON=${RIBBON:-${__HOST:-localhost}}
unset HOST
export DETAILED_LOGGING=true
export LOG_ALL=true
export DUMMY_LOGIN=true
move-back() {
mv -v .stack-work .stack-work-ghci

5
messages/faq/de-de-formal.msg Normal file
View File

@ -0,0 +1,5 @@
FAQNoCampusAccount: Ich habe keine LMU-Benutzerkennung (ehem. Campus-Kennung); kann ich trotzdem Zugang zum System erhalten?
FAQForgottenPassword: Ich habe mein Passwort vergessen
FAQCampusCantLogin: Ich kann mich mit meiner LMU-Benutzerkennung (ehem. Campus-Kennung) nicht anmelden
FAQCourseCorrectorsTutors: Wie kann ich Tutoren oder Korrektoren für meinen Kurs einstellen?
FAQNotLecturerHowToCreateCourses: Wie kann ich einen neuen Kurs anlegen?

5
messages/faq/en-eu.msg Normal file
View File

@ -0,0 +1,5 @@
FAQNoCampusAccount: I don't have a LMU user ID (formerly Campus-ID); can I still get access to Uni2work?
FAQForgottenPassword: I have forgotten my password
FAQCampusCantLogin: I can't log in using my LMU user ID (formerly Campus-ID)
FAQCourseCorrectorsTutors: How can I add tutors or correctors to my course?
FAQNotLecturerHowToCreateCourses: How can I create new courses?

180
messages/uniworx/de-de-formal.msg
View File

@ -32,6 +32,10 @@ BtnLecInvDecline: Ablehnen
BtnCorrInvAccept: Annehmen
BtnCorrInvDecline: Ablehnen
BtnSubmissionsAssign: Abgaben automatisch zuteilen
BtnAllocationCompute: Vergabe berechnen
BtnAllocationAccept: Vergabe akzeptieren
BtnSystemMessageHide: Verstecken
BtnSystemMessageUnhide: Nicht mehr verstecken
Aborted: Abgebrochen
@ -116,11 +120,12 @@ CourseStudyFeatureTip: Dient ausschließlich der Information der Kursverwalter
CourseStudyFeatureUpdated: Assoziiertes Studienfach geändert
CourseStudyFeatureNone: Kein assoziiertes Studienfach
CourseTutorial: Tutorium
CourseExam: Prüfung
CourseSecretWrong: Falsches Passwort
CourseSecret: Zugangspasswort
CourseEditOk tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{tid}-#{ssh}-#{csh} wurde erfolgreich geändert.
CourseNewDupShort tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{tid}-#{ssh}-#{csh} konnte nicht erstellt werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{csh} in diesem Semester und Institut.
CourseEditDupShort tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{tid}-#{ssh}-#{csh} konnte nicht geändert werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{csh} in diesem Semester und Institut.
CourseNewDupShort tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{tid}-#{ssh}-#{csh} konnte nicht erstellt werden: Es gibt bereits einen anderen Kurs mit dem selben Kürzel oder Titel in diesem Semester und Institut.
CourseEditDupShort tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{tid}-#{ssh}-#{csh} konnte nicht geändert werden: Es gibt bereits einen anderen Kurs mit dem selben Kürzel oder Titel in diesem Semester und Institut.
FFSheetName: Name
TermCourseListHeading tid@TermId: Kursübersicht #{tid}
TermSchoolCourseListHeading tid@TermId school@SchoolName: Kursübersicht #{tid} für #{school}
@ -136,7 +141,7 @@ CourseAssociatedWith: assoziiert mit
CourseMembersCount n@Int: #{n}
CourseMembersCountLimited n@Int max@Int: #{n}/#{max}
CourseMembersCountOf n@Int mbNum@IntMaybe: #{n} Kursanmeldungen #{maybeToMessage " von " mbNum " möglichen"}
CourseName: Name
CourseName: Kurstitel
CourseDescription: Beschreibung
CourseHomepageExternal: Externe Homepage
CourseShorthand: Kürzel
@ -157,7 +162,13 @@ CourseFilterNone: —
BoolIrrelevant: —
CourseDeleteQuestion: Wollen Sie den unten aufgeführten Kurs wirklich löschen?
CourseDeleted: Kurs gelöscht
CourseUserTutorial: Angemeldetes Tutorium
CourseUserTutorials: Angemeldete Tutorien
CourseUserExam: Angemeldete Prüfung
CourseUserExams: Angemeldete Prüfungen
CourseSingleUserExams: Prüfungen
CourseSingleUserTutorials: Tutorien
CourseUserCorrections: Abgaben
CourseUserNote: Notiz
CourseUserNoteTooltip: Nur für Verwalter dieses Kurses einsehbar
CourseUserNoteSaved: Notizänderungen gespeichert
@ -166,7 +177,9 @@ CourseUserRegister: Zum Kurs anmelden
CourseUserDeregister: Vom Kurs abmelden
CourseUsersDeregistered count@Int64: #{show count} Teilnehmer vom Kurs abgemeldet
CourseUserRegisterTutorial: Zu einem Tutorium anmelden
CourseUserRegisterExam: Zu einer Prüfung anmelden
CourseUsersTutorialRegistered count@Int64: #{show count} Teilnehmer zum Tutorium angemeldet
CourseUsersExamRegistered count@Int64: #{show count} Teilnehmer zur Prüfung angemeldet
CourseUserSendMail: Mitteilung verschicken
TutorialUserDeregister: Vom Tutorium Abmelden
TutorialUserSendMail: Mitteilung verschicken
@ -311,15 +324,19 @@ SheetSolutionFromTip: Ohne Datum nie für Teilnehmer sichtbar, Korrektoren könn
SheetMarkingTip: Hinweise zur Korrektur, sichtbar nur für Korrektoren
SheetPseudonym: Persönliches Abgabe-Pseudonym
SheetGeneratePseudonym: Generieren
SheetAnonymousCorrection: Anonymisierte Korrektur
SheetAnonymousCorrectionTip: Wenn die Korrektur anonymisiert erfolgt, können Korrektoren die ihnen zugeteilten Abgaben nicht bestimmten Studierenden zuordnen (Name, Matrikelnummer und feste Abgabegruppe der Abgebenden werden versteckt)
SheetFormType: Wertung & Abgabe
SheetFormTimes: Zeiten
SheetFormFiles: Dateien
SheetErrVisibility: "Beginn Abgabezeitraum" muss nach "Sichbar für Teilnehmer ab" liegen
SheetErrDeadlineEarly: "Ende Abgabezeitraum" muss nach "Beginn Abzeitraum" liegen
SheetErrVisibility: "Aktiv ab/Beginn Abgabezeitraum" muss nach "Sichbar für Teilnehmer ab" liegen
SheetErrDeadlineEarly: "Aktiv bis/Ende Abgabezeitraum" muss nach "Aktiv ab/Beginn Abzeitraum" liegen
SheetErrHintEarly: Hinweise dürfen erst nach Beginn des Abgabezeitraums herausgegeben werden
SheetErrSolutionEarly: Lösungen dürfen erst nach Ende der Abgabezeitraums herausgegeben werden
SheetErrVisibleWithoutActive: Wird "Sichtbar für Teilnehmer ab" angegeben, muss auch "Aktiv ab/Beginn Abgabezeitraum" angegeben werden
SheetWarnNoActiveTo: "Aktiv bis/Ende Abgabezeitraum" sollte stets angegeben werden
SheetNoCurrent: Es gibt momentan kein aktives Übungsblatt.
SheetNoOldUnassigned: Alle Abgaben inaktiver Blätter sind bereits einen Korrektor zugeteilt.
SheetsUnassignable name@Text: Momentan keine Abgaben zuteilbar für #{name}
@ -395,6 +412,7 @@ UnauthorizedTokenExpired: Ihr Authorisierungs-Token ist abgelaufen.
UnauthorizedTokenNotStarted: Ihr Authorisierungs-Token ist noch nicht gültig.
UnauthorizedTokenInvalid: Ihr Authorisierungs-Token konnte nicht verarbeitet werden.
UnauthorizedTokenInvalidRoute: Ihr Authorisierungs-Token ist auf dieser Unterseite nicht gültig.
UnauthorizedTokenInvalidNoAuthority: Ihr Authorisierungs-Token nennt keine Nutzer, auf deren Rechten es basiert.
UnauthorizedTokenInvalidAuthority: Ihr Authorisierungs-Token basiert auf den Rechten eines Nutzers, der nicht mehr existiert.
UnauthorizedTokenInvalidAuthorityGroup: Ihr Authorisierungs-Token basiert auf den Rechten einer Gruppe von Nutzern, die nicht mehr existiert.
UnauthorizedTokenInvalidAuthorityValue: Ihr Authorisierungs-Token basiert auf Rechten, deren Spezifikation nicht interpretiert werden konnte.
@ -458,6 +476,8 @@ UnauthorizedLDAP: Angegebener Nutzer meldet sich nicht mit Campus-Kennung an.
UnauthorizedPWHash: Angegebener Nutzer meldet sich nicht mit Uni2work-Kennung an.
UnauthorizedExternalExamListNotEmpty: Liste von externen Prüfungen ist nicht leer
UnauthorizedExternalExamLecturer: Sie sind nicht als Prüfer für diese externe Prüfung eingetragen
UnauthorizedSubmissionSubmissionGroup: Sie sind nicht Mitglied in einer der registrierten Abgabegruppen, die an dieser Abgabe beteiligt sind
UnauthorizedSheetSubmissionGroup: Sie sind nicht Mitglied in einer registrierten Abgabegruppe
UnauthorizedPasswordResetToken: Dieses Authorisierungs-Token kann nicht mehr zum Passwort ändern benutzt werden
@ -514,11 +534,17 @@ NewsOpenAllocations: Offene Zentralanmeldungen
NewsUpcomingSheets: Anstehende Übungsblätter
NewsUpcomingExams: Bevorstehende Prüfungen
NewsHideHiddenSystemMessages: Versteckte Nachrichten nicht mehr anzeigen
NewsShowHiddenSystemMessages: Versteckte Nachrichten anzeigen
NumCourses num@Int64: #{num} #{pluralDE num "Kurs" "Kurse"}
CloseAlert: Schliessen
Name: Name
MatrikelNr: Matrikelnummer
Surname: Nachname(n)
FirstName: Vorname(n)
Title: Titel
LdapSynced: LDAP-Synchronisiert
LdapSyncedBefore: Letzte LDAP-Synchronisation vor
NoMatrikelKnown: Keine Matrikelnummer
@ -545,6 +571,12 @@ DBTablePagesize: Einträge pro Seite
DBTablePagesizeAll: Alle
CorrDownload: Herunterladen
CorrDownloadAnonymous: Anonymisiert
CorrDownloadAnonymousTip: Wenn Abgaben nicht-anonymisiert heruntergeladen werden, werden an die Verzeichnisnamen der einzelnen Abgaben das ausgewählte Merkmal der Abgeber angehängt, sofern erlaubt
SubmissionDownloadAnonymous: Anonymisiert
SubmissionDownloadSurnames: Mit Nachnamen
SubmissionDownloadMatriculations: Mit Matrikelnummern
SubmissionDownloadGroups: Mit festen Abgabegruppen
CorrUploadField: Korrekturen
CorrUpload: Korrekturen hochladen
CorrSetCorrector: Korrektor zuweisen
@ -747,7 +779,7 @@ UploadModeAny: Upload, beliebige Datei(en)
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.
UploadModeUnpackZipsTip: Wenn die Abgabe mehrerer Dateien erlaubt ist, werden auch unterstützte Archiv-Formate zugelassen. Diese werden 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.
@ -756,6 +788,9 @@ 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
GenericFileFieldInvalidExtension file@FilePath: „#{file}” hat keine zulässige Dateiendung
FileUploadOnlySessionTip: Sie haben diese Datei in der aktuellen Session bereits hochgeladen, sie ist allerdings noch nicht gespeichert. Sie müssen zunächst noch das Formular „Senden“, damit die Datei ordnungsgemäß gespeichert wird.
UploadSpecificFiles: Vorgegebene Dateinamen
NoUploadSpecificFilesConfigured: Wenn der Abgabemodus vorgegebene Dateinamen vorsieht, muss mindestens ein vorgegebener Dateiname konfiguriert werden.
UploadSpecificFilesDuplicateNames: Vorgegebene Dateinamen müssen eindeutig sein
@ -769,6 +804,8 @@ CorrectorSubmissions: Abgabe extern mit Pseudonym
UserSubmissions: Direkte Abgabe in Uni2work
BothSubmissions: Abgabe direkt in Uni2work & extern mit Pseudonym
BothSubmissionsTip: Abgabe kann, nach Wahl des Teilnehmers, entweder direkt in Uni2work oder extern mit Pseudonym erfolgen
SheetCorrectorSubmissionsTip: Abgabe erfolgt über ein Uni2work-externes Verfahren (zumeist in Papierform durch Einwurf) unter Angabe eines persönlichen Pseudonyms. Korrektoren können mithilfe des Pseudonyms später Korrekturergebnisse in Uni2work eintragen, damit Sie sie einsehen können.
SubmissionNoUploadExpected: Es ist keine Abgabe von Dateien vorgesehen.
@ -947,8 +984,9 @@ SheetGradingPassBinary': Bestanden/Nicht bestanden
SheetTypeBonus grading@SheetGrading: Bonus
SheetTypeNormal grading@SheetGrading: Normal
SheetTypeInformational grading@SheetGrading: Ohne Anrechung
SheetTypeInformational grading@SheetGrading: Ohne Anrechnung
SheetTypeNotGraded: Keine Korrektur
SheetTypeInfoNormalLecturer: Normale Blätter werden zur Berechnung eines etwaigen Klausurbonus herangezogen. Der Bonus kann sowohl anhand der zu bestehenden Blätter als auch der erreichbaren Maximalpunktzahl automatisch oder manuell berechnet werden.
SheetTypeInfoNotGraded: Keine Korrektur bedeutet, dass es gar kein Feedback gibt.
SheetTypeInfoBonus: Bonus Blätter zählen normal, erhöhen aber nicht die maximal erreichbare Punktzahl bzw. Anzahl zu bestehender Blätter.
SheetTypeInfoInformational: Blätter ohne Anrechnung werden nirgends angerechnet, die Bewertung durch den Korrektor dient lediglich zur Information der Teilnehmer.
@ -1051,10 +1089,23 @@ HelpRequest: Supportanfrage / Verbesserungsvorschlag
HelpProblemPage: Problematische Seite
HelpIntroduction: Wenn Ihnen die Benutzung dieser Webseite Schwierigkeiten bereitet oder Sie einen verbesserbaren Umstand entdecken bitten wir Sie uns das zu melden, auch wenn Sie Ihr Problem bereits selbst lösen konnten. Wir passen die Seite ständig an und versuchen sie auch für zukünftige Benutzer so einsichtig wie möglich zu halten.
HelpSent: Ihre Supportanfrage wurde weitergeleitet.
HelpSendLastError: Letzte Fehlermeldung anhängen
HelpError: Letzte Fehlermeldung
HelpErrorYamlFilename mailId@MailObjectId: fehlermeldung-#{toPathPiece mailId}.yaml
HelpErrorOrRequestRequired: Bitte geben Sie entweder eine Supportanfrage bzw. einen Verbesserungsvorschlag an oder hängen Sie die letzte Fehlermeldung an
InfoLecturerTitle: Hinweise für Veranstalter
SystemMessageNewsOnly: Nur auf "Aktuelles"
SystemMessageRecordChanged: Signifikante Änderung
SystemMessageRecordChangedTip: Soll der "zuletzt geändert"-Zeitstempel gesetzt werden? Nachrichten werden auf "Aktuelles" danach sortiert und bei signifikanten Änderungen erneut als Benachrichtigung unten rechts angezeigt.
SystemMessageUnhide: "Verstecken" ignorieren
SystemMessageUnhideTip: Soll die Nachricht für Benutzer, die sie aktiv versteckt haben, erneut angezeigt werden?
SystemMessageCreated: Erstellt
SystemMessageLastChanged: Zuletzt geändert
SystemMessageLastChangedAt time@Text: Zuletzt geändert: #{time}
SystemMessageLastUnhide: Zuletzt un-versteckt
SystemMessageFrom: Sichtbar ab
SystemMessageTo: Sichtbar bis
SystemMessageAuthenticatedOnly: Nur angemeldet
@ -1147,6 +1198,7 @@ MenuUserPassword: Passwort
MenuAdminTest: Admin-Demo
MenuMessageList: Systemnachrichten
MenuAdminErrMsg: Fehlermeldung entschlüsseln
MenuAdminTokens: Tokens ausstellen
MenuProfileData: Persönliche Daten
MenuTermCreate: Neues Semester anlegen
MenuCourseNew: Neuen Kurs anlegen
@ -1214,6 +1266,9 @@ MenuParticipantsList: Kursteilnehmerlisten
MenuParticipantsIntersect: Überschneidung von Kursteilnehmern
MenuAllocationUsers: Bewerber
MenuAllocationPriorities: Zentrale Dringlichkeiten
MenuAllocationCompute: Platzvergabe berechnen
MenuAllocationAccept: Platzvergabe akzeptieren
MenuFaq: FAQ
BreadcrumbSubmissionFile: Datei
BreadcrumbSubmissionUserInvite: Einladung zur Abgabe
@ -1281,6 +1336,10 @@ BreadcrumbExamAutoOccurrence: Automatische Termin-/Raumverteilung
BreadcrumbStorageKey: Lokalen Schlüssel generieren
BreadcrumbAllocationUsers: Bewerber
BreadcrumbAllocationPriorities: Zentrale Dringlichkeiten
BreadcrumbAllocationCompute: Platzvergabe berechnen
BreadcrumbAllocationAccept: Platzvergabe akzeptieren
BreadcrumbMessageHide: Verstecken
BreadcrumbFaq: FAQ
ExternalExamEdit coursen@CourseName examn@ExamName: Bearbeiten: #{coursen}, #{examn}
ExternalExamGrades coursen@CourseName examn@ExamName: Prüfungsleistungen: #{coursen}, #{examn}
@ -1331,6 +1390,7 @@ AuthTagIsPWHash: Nutzer meldet sich mit Uni2work-Kennung an
AuthTagAuthentication: Nutzer ist angemeldet, falls erforderlich
AuthTagRead: Zugriff ist nur lesend
AuthTagWrite: Zugriff ist i.A. schreibend
AuthTagSubmissionGroup: Nutzer ist Mitglied in registrierter Abgabegruppe
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.
@ -1460,7 +1520,7 @@ ExceptionKindNoOccur: Findet nicht statt
ExceptionExists: Diese Ausnahme existiert bereits
ExceptionNoOccurAt: Termin
TutorialType: Typ
TutorialType: Art
TutorialTypePlaceholder: Tutorium, Zentralübung, ...
TutorialTypeTip: Dient nur der Information der Studierenden
TutorialName: Bezeichnung
@ -1681,6 +1741,7 @@ ExamRegistered: Zur Prüfung angemeldet
ExamNotRegistered: Nicht zur Prüfung angemeldet
ExamRegistration: Prüfungsanmeldung
ExamLoginToRegister: Um sich zum Kurs anzumelden müssen Sie zunächst in Uni2work anmelden
ExamRegistrationTime: Angemeldet seit
ExamRegisterToMustBeAfterRegisterFrom: "Anmeldung ab" muss vor "Anmeldung bis" liegen
ExamDeregisterUntilMustBeAfterRegisterFrom: "Abmeldung bis" muss nach "Anmeldung bis" liegen
@ -1720,6 +1781,20 @@ ExamUsersResultsReset count@Int64: Prüfungsergebnis für #{show count} Teilnehm
ExamUsersPartResultsSet count@Int64: Teilprüfungsergebnis für #{show count} Teilnehmer angepasst
ExamUsersBonusSet count@Int64: Bonuspunkte für #{show count} Teilnehmer angepasst
ExamUsersResultSet count@Int64: Prüfungsergebnis für #{show count} Teilnehmer angepasst
CourseUserTutorialsDeregistered count@Int64: Teilnehmer von #{show count} #{pluralDE count "Tutorium" "Tutorien"} abgemeldet
CourseUserNoTutorialsDeregistered: Teilnehmer ist zu keinem der gewählten Tutorien angemeldet
CourseUserExamsDeregistered count@Int64: Teilnehmer von #{show count} #{pluralDE count "Prüfung" "Prüfungen"} abgemeldet
CourseUserNoExamsDeregistered: Teilnehmer ist zu keiner der gewählten Prüfungen angemeldet
CourseUserExamsResultSet count@Int64: Ergebnis zu #{show count} #{pluralDE count "Prüfung" "Prüfungen"} erfolgreich angepasst
CourseUserExamResultDoesNotMatchMode examn@ExamName: Gewähtes Ergebnis passt nicht zu Bewertungsmodus von Prüfung „#{examn}“.
CourseUserSetSubmissionGroup: Feste Abgabegruppe setzen/entfernen
CourseUsersSubmissionGroupSetNew count@Int64: #{show count} Benutzer der festen Abgabegruppe zugeordnet
CourseUsersSubmissionGroupUnset count@Int64: #{show count} Benutzer aus ihren jeweiligen festen Abgabegruppen entfernt
CourseUsersStateSet count@Int64: Zustand von #{show count} #{pluralDE count "Benutzer" "Benutzern"} angepasst
SubmissionGroup: Feste Abgabegruppe
NoSubmissionGroup: Keine feste Abgabegruppe
SubmissionGroupEmptyIsUnsetTip: Leer lassen um Benutzer aus den jeweiligen Abgabegruppen ersatzlos zu entfernen
ExamUserSynchronised: Synchronisiert
ExamUserSyncOfficeName: Name
@ -1758,6 +1833,7 @@ CsvDeleteMissing: Fehlende Einträge entfernen
BtnCsvExport: CSV-Datei exportieren
BtnCsvImport: CSV-Datei importieren
BtnCsvImportConfirm: CSV-Import abschließen
BtnCsvImportAbort: Abbrechen
CsvImportNotConfigured: CSV-Import nicht vorgesehen
CsvImportConfirmationHeading: CSV-Import Vorschau (noch keine Änderungen importiert)
@ -1766,6 +1842,8 @@ CsvImportUnnecessary: Durch den CSV-Import würden keine Änderungen vorgenommen
CsvImportSuccessful n@Int: CSV-Import erfolgreich, es #{pluralDE n "wurde eine Aktion" (mappend (mappend "wurden " (toMessage n)) " Aktionen")} durchgeführt
CsvImportAborted: CSV-Import abgebrochen
CsvImportExplanationLabel: Hinweise zum CSV-Import
CsvExampleData: Beispiel-Datei
CsvExportExample: Beispiel-CSV exportieren
Proportion c@Text of@Text prop@Rational: #{c}/#{of} (#{rationalToFixed2 (100 * prop)}%)
ProportionNoRatio c@Text of@Text: #{c}/#{of}
@ -1806,6 +1884,8 @@ CsvColumnUserSemester: Fachsemester des Teilnehmers im assoziierten Studienfach
CsvColumnUserRegistration: Zeitpunkt der Anmeldung zum Kurs (ISO 8601)
CsvColumnUserNote: Notizen zum Teilnehmer
CsvColumnUserTutorial: Tutorien zu denen der Teilnehmer angemeldet ist, als Semikolon (;) separierte Liste. Für Registrierungs-Gruppen unter den Tutorien gibt es jeweils eine weitere Spalte. Die Registrierungs-Gruppen-Spalten enthalten jeweils maximal ein Tutorium pro Teilnehmer. Sind alle Tutorien in Registrierungs-Gruppen, so gibt es keine Spalte "tutorial".
CsvColumnUserExam: Prüfungen zu denen der Teilnehmer angemeldet ist, als Semikolon (;) separierte Liste.
CsvColumnUserSubmissionGroup: Registrierte Abgabegruppe
CsvColumnExamOfficeExamUserOccurrenceStart: Prüfungstermin (ISO 8601)
@ -1829,6 +1909,8 @@ DBCsvDuplicateKey: Zwei Zeilen der CSV-Dateien referenzieren den selben internen
DBCsvDuplicateKeyTip: Entfernen Sie eine der unten aufgeführten Zeilen aus Ihren CSV-Dateien und versuchen Sie es erneut.
DBCsvKeyException: Für eine Zeile der CSV-Dateien konnte nicht festgestellt werden, ob sie zu einem bestehenden internen Datensatz korrespondieren.
DBCsvException: Bei der Berechnung der auszuführenden Aktionen für einen Datensatz ist ein Fehler aufgetreten.
DBCsvParseError: Eine hochgeladene Datei konnte nicht korrekt als CSV-Datei im erwarteten Format interpretiert werden.
DBCsvParseErrorTip: Die Uni2work-Komponente, die für das Interpretieren von CSV-Dateien zuständig ist, hat folgende Fehlermeldung produziert:
ExamUserCsvCourseRegister: Benutzer zum Kurs und zur Prüfung anmelden
ExamUserCsvRegister: Kursteilnehmer zur Prüfung anmelden
@ -1845,10 +1927,11 @@ ExamBonusNone: Keine Bonuspunkte
ExamUserCsvCourseNoteDeleted: Notiz wird gelöscht
ExamUserCsvExceptionNoMatchingUser: Kursteilnehmer konnte nicht eindeutig identifiziert werden
ExamUserCsvExceptionNoMatchingStudyFeatures: Das angegebene Studienfach konnte keinem Studienfach des Kursteilnehmers zugeordnet werden
ExamUserCsvExceptionNoMatchingOccurrence: Raum/Termin konnte nicht eindeutig identifiziert werden
ExamUserCsvExceptionNoMatchingUser: Benutzer konnte nicht eindeutig identifiziert werden. Alle Identifikatoren des Benutzers (Vorname(n), Nachname, Voller Name, Matrikelnummer, ...) müssen exakt übereinstimmen. Sie können versuchen für diese Zeile manche der Identifikatoren zu entfernen (also z.B. nur eine Matrikelnummer angeben) um dem System zu erlauben nur Anhand der verbleibenden Identifikatoren zu suchen. Sie sollten dann natürlich besonders kontrollieren, dass das System den fraglichen Benutzer korrekt identifiziert hat.
ExamUserCsvExceptionNoMatchingStudyFeatures: Das angegebene Studienfach konnte keinem Studienfach des Benutzers zugeordnet werden. Sie können versuchen für diese Zeile die Studiengangsdaten zu entfernen um das System automatisch ein Studienfach wählen zu lassen.
ExamUserCsvExceptionNoMatchingOccurrence: Raum/Termin konnte nicht eindeutig identifiziert werden. Überprüfen Sie, dass diese Zeile nur interne Raumbezeichnungen enthält, wie sie auch für die Prüfung konfiguriert wurden.
ExamUserCsvExceptionMismatchedGradingMode expectedGradingMode@ExamGradingMode actualGradingMode@ExamGradingMode: Es wurde versucht eine Prüfungsleistung einzutragen, die zwar vom System interpretiert werden konnte, aber nicht dem für diese Prüfung erwarteten Modus entspricht. Der erwartete Bewertungsmodus kann unter "Prüfung bearbeiten" angepasst werden ("Bestanden/Nicht Bestanden", "Numerische Noten" oder "Gemischt").
ExamUserCsvExceptionNoOccurrenceTime: Es wurde versucht eine Prüfungsleistung ohne einen zugehörigen Zeitpunkt einzutragen. Sie können entweder einen Zeitpunkt pro Student in der entsprechenden Spalte hinterlegen, oder einen voreingestellten Zeitpunkt unter "Bearbeiten" angeben.
ExternalExamUserCsvRegister: Prüfungsleistung hinterlegen
ExternalExamUserCsvSetTime: Zeitpunkt anpassen
@ -2179,8 +2262,13 @@ CourseNewsDeleteQuestion: Wollen Sie die unten aufgeführte Nachricht wirklich l
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.
CourseDeregistrationNoShow: Wenn Sie sich vom Kurs abmelden, wird für alle Prüfungen des Kurses „nicht erschienen“ gemeldet. 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
CourseDeregistrationAllocationNoShow: „Nicht erschienen“ eintragen
CourseDeregistrationAllocationNoShowTip: Soll für alle Prüfungen dieses Kurses „nicht erschienen“ als Prüfungsleistung eingetragen werden? Dies geschieht einmalig bei der Abmeldung (sofern nicht bereits eine Prüfungsleistung existiert) und automatisch beim Anlegen von neuen Prüfungen.
CourseDeregisterNoShow: „Nicht erschienen“ bei Abmeldung
CourseDeregisterNoShowTip: Soll, wenn sich Teilnehmer selbstständig abmelden, für alle Prüfungen dieses Kurses „nicht erschienen“ als Prüfungsleistung eingetragen werden? Dies geschieht einmalig bei der Abmeldung (sofern nicht bereits eine Prüfungsleistung existiert) und automatisch beim Anlegen von neuen Prüfungen.
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.
@ -2202,11 +2290,14 @@ FavouriteParticipant: Ihre Kurse
FavouriteManual: Favoriten
FavouriteCurrent: Aktueller Kurs
FavouritesUnavailableTip: Das Schnellzugriffsmenü für diesen Kurs ist aktuell nicht verfügbar.
CourseEvents: Termine
CourseEventType: Art
CourseEventTypePlaceholder: Vorlesung, Zentralübung, ...
CourseEventTime: Zeit
CourseEventRoom: Regulärer Raum
CourseEventNote: Notiz
CourseEventActions: Aktionen
CourseEventsActionEdit: Bearbeiten
CourseEventsActionDelete: Löschen
@ -2379,3 +2470,70 @@ AllocationPrioritiesFile: CSV-Datei
AllocationPrioritiesSunk num@Int64: Zentrale Prioritäten für #{num} Bewerber erfolgreich hinterlegt
AllocationPrioritiesMissing num@Int64: Für #{num} Bewerber ist keine zentrale Priorität hinterlegt, da in der hochgeladenen CSV-Datei die #{pluralDE num "entsprechende Matrikelnummer" "entsprechenden Matrikelnummern"} nicht gefunden #{pluralDE num "wurde" "wurden"}
AllocationMissingPrioritiesIgnored: Bewerber, für die keine zentrale Priorität angegeben wird, werden bei der Vergabe ignoriert!
ExampleUser1FirstName: Max ZweiterName
ExampleUser1Surname: Mustermann
ExampleUser1DisplayName: Max Mustermann
ExampleUser2FirstName: Martha
ExampleUser2Surname: Musterstudent
ExampleUser2DisplayName: Musterstudent Martha
ExampleUser3FirstName: Maria
ExampleUser3Surname: Beispiel
ExampleUser3DisplayName: Beispiel
AllocationUsersMissingPriorities: Teilnehmer ohne zentrale Dringlichkeit
AllocationUsersMissingPrioritiesTip: Es muss sichergestellt sein, dass keine Teilnehmer unberechtigt aus der Zentralvergabe ausgeschlossen werden, indem ihnen keine zentrale Dringlichkeit zugewiesen wurde.
AllocationUsersMissingPrioritiesOk: Es wurde sichergestellt, dass es für jeden der genannten Benutzer einen zulässigen Grund gibt, warum dieser nicht an der Zentralanmeldung teilnehmen sollte.
AllocationRestrictCourses: Kurse einschränken
AllocationRestrictCoursesTip: Sollen nur Plätze für eine Teilmenge von Kursen zugewiesen werden? So können u.A. Nachrücker verteilt werden. Diese Funktionalität sollte nur verwendet werden, wenn manche Kurse aus zulässigen Gründen ausgeschlossen werden müssen; z.B. weil ein Seminar bereits ein Treffen zur Organisation hatte und nun keine weiteren Teilnehmer mehr akzeptieren kann.
AllocationRestrictCoursesSelection: Kurse
AllocationRestrictCoursesSelectionTip: Teilnehmer werden nur auf die Kurse verteilt, die hier angegeben werden.
AllocationUsersMissingPrioritiesNotOk: Zentralvergabe kann nicht erfolgen, solange nicht allen Teilnehmern, die nicht explizit von der Vergabe ausgeschlossen wurden („Teilnehmer ohne zentrale Dringlichkeit”), eine zentrale Dringlichkeit zugewiesen wurde!
AllocationComputed: Eine mögliche Zentralvergabe wurde berechnet und in Ihrer Session gespeichert. Es wurden noch keine Änderungen vorgenommen!
AllocationOnlyCompute: Durch Senden dieses Formulars wird zunächst nur eine mögliche Zentralvergabe berechnet und zur Kontrolle temporär gespeichert. Es werden keine Änderungen am Stand der Datenbank vorgenommen oder Benachrichtigungen verschickt.
AllocationAcceptFormDoesNotMatchSession: Das Formular zum Akzeptieren der Vergabe wurde für ein anderes Vergabeergebnis erzeugt, als aktuell in Ihrer Session gespeichert ist.
ComputedAllocation: Berechnete Vergabe
AllocationAccepted: Zentralvergabe gespeichert.
AllocationMatchedUsers: Neu zugeteilt
AllocationUnmatchedUsers: Teilnehmer ohne zugeteilte Plätze
AllocationUnmatchedCourses: Kurse ohne zugeteilte Teilnehmer
AllocationTime: Zeitpunkt der Vergabe
AllocationRequestedPlaces: Angefragte Plätze
AllocationOfferedPlaces: Angebotene Plätze
AllocationUserNewMatches: Neue Zuteilungen
AllocationUsersCount: Teilnehmer
AllocationCoursesCount: Kurse
CourseOption tid@TermId ssh@SchoolId coursen@CourseName: #{tid} - #{ssh} - #{coursen}
BearerTokenUsageWarning: Mit diesem Interface können quesi beliebige Rechte als Tokens kodiert und somit ohne wesentliche weitere Beschränkung frei übertragen werden. Benutzen Sie dieses Interface nur, wenn Sie von einem erfahrenen Entwickler über die Auswirkungen des konkreten Tokens, dass sie ausstellen möchten, beraten wurden!
BearerTokenAuthorityGroups: Token-Authorität (Gruppen)
BearerTokenAuthorityGroupsTip: Die primären Benutzer aller angegebenen Gruppen müssen Zugriff auf eine Route haben, damit das Token den Zugriff auf diese Route erlaubt.
BearerTokenAuthorityUsers: Token-Authorität (Benutzer)
BearerTokenAuthorityUsersTip: Alle angegebenen Benutzer müssen Zugriff auf eine Route haben, damit das Token den Zugriff auf diese Route erlaubt. Der Aussteller muss, bei mit diesem Benutzerinterface erzeugten Tokens, auch Zugriff auf die Route haben (er wird automatisch der Menge von Token-Authoritäten hinzugefügt).
BearerTokenAuthorityUnknownUser email@UserEmail: Ein Nutzer mit E-Mail #{email} ist dem System nicht bekannt
BearerTokenRoutes: Erlaubte Routen
BearerTokenRoutesTip: Wenn die Token-Validität nach Routen eingeschränkt und keine Routen angegeben werden, ist das Token nirgends gültig.
BearerTokenRestrictions: Routen-spezifische Einschränkungen
BearerTokenRestrictRoutes: Token-Validität nach Routen einschränken
BearerTokenAdditionalAuth: Zusätzliche Authorisierung
BearerTokenAdditionalAuthTip: Wird hier nichts angegeben, werden keine Einschränkungen daran gesetzt, wer das Token verwenden kann. Es reicht dann der Besitz.
BearerTokenOverrideExpiration: Ablaufzeitpunkt überschreiben
BearerTokenExpires: Ablaufzeitpunkt
BearerTokenExpiresTip: Wird der Ablaufzeitpunkt überschrieben und kein Ablaufzeitpunkt angegeben, ist das Token für immer gültig.
BearerTokenOverrideStart: Startzeitpunkt
BearerTokenOverrideStartTip: Wird kein Startzeitpunkt angegeben, wird bei Verwendung des Tokens nur der Ablaufzeitpunkt überprüft.
FaqTitle: Häufig gestellte Fragen
AdditionalFaqs: Weitere häufig gestellte Fragen
MultiActionUnknownAction: In einem von einem Eingabefeld abhängigen Formular wurde ein Wert gewählt, für den kein Formular verfügbar ist
CourseParticipantStateIsActive: Aktive Teilnehmer
CourseParticipantStateIsInactive: Ehemalige Teilnehmer
CourseParticipantStateIsActiveFilter: Ansicht
CourseUserReRegister: Wieder anmelden
CourseParticipantActive: Teilnehmer
CourseParticipantInactive: Abgemeldet
CourseParticipantNoShow: Nicht erschienen
CourseUserState: Zustand

203
messages/uniworx/en-eu.msg
View File

@ -32,6 +32,10 @@ BtnLecInvDecline: Decline
BtnCorrInvAccept: Accept
BtnCorrInvDecline: Decline
BtnSubmissionsAssign: Assign submissions automatically
BtnAllocationCompute: Compute allocation
BtnAllocationAccept: Accept allocation
BtnSystemMessageHide: Hide
BtnSystemMessageUnhide: Unhide
Aborted: Aborted
@ -116,11 +120,12 @@ CourseStudyFeatureTip: For information purposes only (visible to course administ
CourseStudyFeatureUpdated: Successfully updated associated subject
CourseStudyFeatureNone: No associated subject
CourseTutorial: Tutorial
CourseExam: Exam
CourseSecretWrong: Wrong password
CourseSecret: Access password
CourseEditOk tid ssh csh: Successfully edited course #{tid}-#{ssh}-#{csh}
CourseNewDupShort tid ssh csh: Could not create course #{tid}-#{ssh}-#{csh}. Another course with shorthand #{csh} already exists for the given semester and school.
CourseEditDupShort tid ssh csh: Could not edit course #{tid}-#{ssh}-#{csh}. Another course with shorthand #{csh} already exists for the given semester and school.
CourseNewDupShort tid ssh csh: Could not create course #{tid}-#{ssh}-#{csh}. Another course with the same shorthand or title already exists for the given semester and school.
CourseEditDupShort tid ssh csh: Could not edit course #{tid}-#{ssh}-#{csh}. Another course with the same shorthand or title already exists for the given semester and school.
FFSheetName: Name
TermCourseListHeading tid: Courses #{tid}
TermSchoolCourseListHeading tid school: Courses #{tid}, #{school}
@ -158,7 +163,13 @@ BoolIrrelevant: —
CourseDeleteQuestion: Are you sure you want to delete the below-mentioned course?
CourseDeleted: Course deleted
CourseUserRegister: Enrol for course
CourseUserTutorial: Registered tutorial
CourseUserTutorials: Registered tutorials
CourseUserExam: Registered exam
CourseUserExams: Registered exams
CourseSingleUserExams: Exams
CourseSingleUserTutorials: Tutorials
CourseUserCorrections: Submissions
CourseUserNote: Note
CourseUserNoteTooltip: Only visible to administrators of this course
CourseUserNoteSaved: Successfully saved note changes
@ -167,6 +178,8 @@ CourseUserDeregister: Deregister from course
CourseUsersDeregistered count: Successfully deregistered #{show count} users from course
CourseUserRegisterTutorial: Register for a tutorial
CourseUsersTutorialRegistered count: Successfully registered #{show count} users for tutorial
CourseUserRegisterExam: Register for an exam
CourseUsersExamRegistered count: Successfully registered #{show count} users for exam
CourseUserSendMail: Send mail
TutorialUserDeregister: Deregister from tutorial
TutorialUserSendMail: Send mail
@ -310,6 +323,8 @@ SheetSolutionFromTip: Always invisible for participants if left empty; corrector
SheetMarkingTip: Instructions for correction, visible only to correctors
SheetPseudonym: Personal pseudonym
SheetGeneratePseudonym: Generate
SheetAnonymousCorrection: Anonymized correction
SheetAnonymousCorrectionTip: If correction is anonymized, correctors cannot see which students are involved in submissions that are assigned to them (names, matriculation numbers, and registered submission groups are hidden)
SheetFormType: Valuation & submission
SheetFormTimes: Times
@ -319,6 +334,8 @@ SheetErrVisibility: "Submission period start" must be after "Visible from"
SheetErrDeadlineEarly: "Submission period end" must be after "Submission period start"
SheetErrHintEarly: "Hint from" must be after "Submission period start"
SheetErrSolutionEarly: "Solution from" must be after "Submission period end"
SheetErrVisibleWithoutActive: If “Visible from (for participants)” is specified “Active from/Submission period start” must also be specified
SheetWarnNoActiveTo: “Active to/Submission period end” should always be specified
SheetNoCurrent: There is no currently active exercise sheet
SheetNoOldUnassigned: All submissions for inactive sheets are already assigned to correctors.
SheetsUnassignable name: Submission for #{name} may not currently be assigned to correctors.
@ -393,6 +410,7 @@ UnauthorizedTokenExpired: Your authorisation-token is expired.
UnauthorizedTokenNotStarted: Your authorisation-token is not yet valid.
UnauthorizedTokenInvalid: Your authorisation-token could not be processed.
UnauthorizedTokenInvalidRoute: Your authorisation-token is not valid for this page.
UnauthorizedTokenInvalidNoAuthority: Your authorisation-token does not list any users on whose rights it is based.
UnauthorizedTokenInvalidAuthority: Your authorisation-token is based in an user's rights who does not exist anymore.
UnauthorizedTokenInvalidAuthorityGroup: Your authorisation-token is based in an user groups rights which does not exist anymore.
UnauthorizedTokenInvalidAuthorityValue: The specification of the rights in which your authorisation-token is based, could not be interpreted.
@ -402,6 +420,7 @@ UnauthorizedSchoolAdmin: You are no administrator for this department.
UnauthorizedAdminEscalation: You aren't an administrator for all departments for which this user is an administrator.
UnauthorizedExamOffice: You are not part of an exam office.
UnauthorizedEvaluation: You are not charged with course evaluation.
UnauthorizedAllocationAdmin: You are not charged with the administration of central allocations.
UnauthorizedExamExamOffice: You are not part of the appropriate exam office for any of the participants of this exam.
UnauthorizedExternalExamExamOffice: You are not part of the appropriate exam office for any of the participants of this exam.
UnauthorizedSchoolLecturer: You are no lecturer for this department.
@ -455,6 +474,8 @@ UnauthorizedLDAP: Specified user does not log in with their campus account.
UnauthorizedPWHash: Specified user does not log in with an Uni2work-account.
UnauthorizedExternalExamListNotEmpty: List of external exams is not empty
UnauthorizedExternalExamLecturer: You are not an associated person for this external exam
UnauthorizedSubmissionSubmissionGroup: You are not member in any of the submission groups for this submission
UnauthorizedSheetSubmissionGroup: You are not member in any submission group
UnauthorizedPasswordResetToken: This authorisation-token may no longer be used to change passwords
@ -511,11 +532,17 @@ NewsOpenAllocations: Active central allocations
NewsUpcomingSheets: Upcoming exercise sheets
NewsUpcomingExams: Upcoming exams
NewsHideHiddenSystemMessages: Don't show hidden news items
NewsShowHiddenSystemMessages: Show hidden news items
NumCourses num: #{num} #{pluralEN num "course" "courses"}
CloseAlert: Close
Name: Name
MatrikelNr: Matriculation
Surname: Surname(s)
FirstName: Given name(s)
Title: Title
LdapSynced: LDAP-synchronised
LdapSyncedBefore: Last LDAP-synchronisation before
NoMatrikelKnown: No matriculation
@ -542,6 +569,12 @@ DBTablePagesize: Entries per page
DBTablePagesizeAll: All
CorrDownload: Download
CorrDownloadAnonymous: Anonymized
CorrDownloadAnonymousTip: If submissions are downloaded non-anonymized the selected feature of the submittors are appended to the name of the dirctory for each submission where permitted
SubmissionDownloadAnonymous: Anonymized
SubmissionDownloadSurnames: With surnames
SubmissionDownloadMatriculations: With matriculation numbers
SubmissionDownloadGroups: With registered submission groups
CorrUploadField: Corrections
CorrUpload: Upload corrections
CorrSetCorrector: Assign corrector
@ -752,6 +785,9 @@ UploadModeExtensionRestriction: Allowed file extensions
UploadModeExtensionRestrictionTip: Comma-separated. If no file extensions are specified, uploads are not restricted.
UploadModeExtensionRestrictionEmpty: List of permitted file extensions may not be emptyy
GenericFileFieldInvalidExtension file: “#{file}” does not have an acceptable file extension
FileUploadOnlySessionTip: You have uploaded this file during your current session. It has not yet been saved permanently. The file will be saved permanently if you “Send” as part of this Form.
UploadSpecificFiles: Pre-defined files
NoUploadSpecificFilesConfigured: If pre-defined files are selected, at least one file needs to be configured.
UploadSpecificFilesDuplicateNames: Names of pre-defined files must be unique
@ -765,6 +801,8 @@ CorrectorSubmissions: External submission via pseudonym
UserSubmissions: Direct submission in Uni2work
BothSubmissions: Submission either directly in Uni2work or externally via pseudonym
BothSubmissionsTip: Participants may choose to submit either directly in Uni2work or externally via a pseudonym
SheetCorrectorSubmissionsTip: Submissions are expected to be handed in through some Uni2work-external procedure (usually on paper) marked with your personal pseudonym. Correctors can, using the pseudonym, register the marking in Uni2work for you to review.
SubmissionNoUploadExpected: No upload of files expected.
@ -948,6 +986,7 @@ SheetTypeBonus grading: Bonus
SheetTypeNormal grading: Normal
SheetTypeInformational grading: Informational
SheetTypeNotGraded: Not marked
SheetTypeInfoNormalLecturer: Normal sheets are used to calculate exam bonuses. Bonuses may be calculated from the number of sheets that can be passed or the maximum number of points achievable either manually or automatically.
SheetTypeInfoNotGraded: "Not marked" means that there will be no feedback at all.
SheetTypeInfoBonus: Sheets marked "bonus" count normally but do not increase either the maximum number of points or the count of sheets that can be passed.
SheetTypeInfoInformational: Sheets marked "informational" do not counted anywhere. They are marked only as feedback for participants.
@ -1013,6 +1052,7 @@ NotificationTriggerKindEvaluation: For course evaluations
NotificationTriggerKindAllocationStaff: For central allocations (lecturers)
NotificationTriggerKindAllocationParticipant: For central allocations
NotificationTriggerKindSubmissionUser: For participants in an exercise sheet submission
NotificationTriggerKindAllocationAdmin: For administrators of central allocations
CorrCreate: Register submissions
UnknownPseudonymWord pseudonymWord: Invalid pseudonym-word “#{pseudonymWord}”
@ -1049,9 +1089,22 @@ HelpRequest: Support request / Suggestion
HelpProblemPage: Problematic page
HelpIntroduction: If you have trouble using this website or if you find something that could be improved, please contact us even if you were already able to solve your problem by yourself! We are continually making changes and try to keep the site as intuitive as possible even for new users.
HelpSent: Your support request has been sent.
HelpSendLastError: Attach last error message
HelpError: Last error message
HelpErrorYamlFilename mailId: error-#{toPathPiece mailId}.yaml
HelpErrorOrRequestRequired: Please attach either the last error message or submit a support request or a suggestion
InfoLecturerTitle: Information for lecturers
SystemMessageNewsOnly: Only on "News"
SystemMessageRecordChanged: Signifcant change
SystemMessageRecordChangedTip: Should the "last changed"-timestamp be adjusted? News are sorted by "last changed" on "News". After a significant change news items are displayed once again as a popup in the bottom right.
SystemMessageUnhide: Ignore previously hidden
SystemMessageUnhideTip: Should the news item be display again for users that have actively hidden it?
SystemMessageCreated: Created
SystemMessageLastChanged: Last changed
SystemMessageLastChangedAt time: Last changed: #{time}
SystemMessageLastUnhide: Last unhidden
SystemMessageFrom: Visible from
SystemMessageTo: Visible to
SystemMessageAuthenticatedOnly: Only logged in users
@ -1144,6 +1197,7 @@ MenuUserPassword: Password
MenuAdminTest: Admin-demo
MenuMessageList: System messages
MenuAdminErrMsg: Decrypt error message
MenuAdminTokens: Issue tokens
MenuProfileData: Personal information
MenuTermCreate: Create new semester
MenuCourseNew: Create new course
@ -1209,6 +1263,11 @@ MenuExternalExamNew: New external exam
MenuExternalExamList: External exams
MenuParticipantsList: Lists of course participants
MenuParticipantsIntersect: Common course participants
MenuAllocationUsers: Applicants
MenuAllocationPriorities: Central priorities
MenuAllocationCompute: Compute allocation
MenuAllocationAccept: Accept allocation
MenuFaq: FAQ
BreadcrumbSubmissionFile: File
BreadcrumbSubmissionUserInvite: Invitation to participate in a submission
@ -1274,6 +1333,12 @@ BreadcrumbParticipantsList: Lists of course participants
BreadcrumbParticipants: Course participants
BreadcrumbExamAutoOccurrence: Automatic occurrence/room distribution
BreadcrumbStorageKey: Generate storage key
BreadcrumbAllocationUsers: Applicants
BreadcrumbAllocationPriorities: Central priorities
BreadcrumbAllocationCompute: Compute allocation
BreadcrumbAllocationAccept: Accept allocation
BreadcrumbMessageHide: Hide
BreadcrumbFaq: FAQ
ExternalExamEdit coursen examn: Edit: #{coursen}, #{examn}
ExternalExamGrades coursen examn: Exam achievements: #{coursen}, #{examn}
@ -1288,6 +1353,7 @@ AuthTagFree: Page is freely accessable
AuthTagAdmin: User is administrator
AuthTagExamOffice: User is part of an exam office
AuthTagEvaluation: User is charged with course evaluation
AuthTagAllocationAdmin: User is charged with administration of central allocations
AuthTagToken: User is presenting an authorisation-token
AuthTagNoEscalation: User permissions are not being expanded to other departments
AuthTagDeprecated: Page is not deprecated
@ -1323,6 +1389,7 @@ AuthTagIsPWHash: User logs in using their Uni2work-internal account
AuthTagAuthentication: User is authenticated
AuthTagRead: Access is read only
AuthTagWrite: Access might write
AuthTagSubmissionGroup: User is part of a submission group
DeleteCopyStringIfSure n: If you are sure that you want to permanently delete the #{pluralEN n "object" "objects"} listed below, please copy the shown text.
DeletePressButtonIfSure n: If you are sure that you want to permanently delete the #{pluralEN n "object" "objects"} listed below, please confirm the action by pressing the button.
@ -1673,6 +1740,7 @@ ExamRegistered: Registered for the exam
ExamNotRegistered: Not registered for the exam
ExamRegistration: Exam registration
ExamLoginToRegister: Your need to login to Uni2work before you can register for this course.
ExamRegistrationTime: Registered since
ExamRegisterToMustBeAfterRegisterFrom: "Register to" must be after "register from"
ExamDeregisterUntilMustBeAfterRegisterFrom: "Deregister until" must be after "register from"
@ -1712,6 +1780,20 @@ ExamUsersResultsReset count: Successfully reset result for #{show count} #{plura
ExamUsersPartResultsSet count: Successfully modified exam part result for #{show count} #{pluralEN count "participant" "participants"}
ExamUsersBonusSet count: Successfully modified exam bonus for #{show count} #{pluralEN count "participant" "participants"}
ExamUsersResultSet count: Sucessfully modified exam result for #{show count} #{pluralEN count "participant" "participants"}
CourseUserTutorialsDeregistered count: Sucessfully deregistered participant from #{show count} #{pluralEN count "tutorial" "tutorials"}
CourseUserNoTutorialsDeregistered: Participant is not registered for any of the selected tutorials
CourseUserExamsDeregistered count: Successfully deregistered participant from #{show count} #{pluralEN count "exam" "exams"}
CourseUserNoExamsDeregistered: Participant is not registered for any of the selected exams
CourseUserExamsResultSet count: Successfully adjusted the participant's result for #{show count} #{pluralEN count "exam" "exams"}
CourseUserExamResultDoesNotMatchMode examn: The chosen result does not match the grading mode for exam “#{examn}”
CourseUserSetSubmissionGroup: Set/Unset registered submission group
CourseUsersSubmissionGroupSetNew count: Successfully added #{show count} #{pluralEN count "user" "users"} to submission group
CourseUsersSubmissionGroupUnset count: Successfully removed #{show count} #{pluralEN count "user" "users"} from their #{pluralEN count "submission group" "respective submission groups"}
CourseUsersStateSet count: Successfully changed state of #{show count} #{pluralEN count "user" "users"}
SubmissionGroup: Registered submission group
NoSubmissionGroup: No registered submission group
SubmissionGroupEmptyIsUnsetTip: Leave empty to remove users from their respective submission groups
ExamUserSynchronised: Synchronised
ExamUserSyncOfficeName: Name
@ -1750,6 +1832,7 @@ CsvDeleteMissing: Delete missing entries
BtnCsvExport: Export CSV file
BtnCsvImport: Import CSV file
BtnCsvImportConfirm: Finalise CSV import
BtnCsvImportAbort: Abort
CsvImportNotConfigured: CSV import not configured
CsvImportConfirmationHeading: CSV import preview (no changes have been made yet)
@ -1758,6 +1841,8 @@ CsvImportUnnecessary: Importing the given CSV file does not correspond to perfor
CsvImportSuccessful n: Successfully imported CSV file. #{n} #{pluralEN n "edit" "edits"} have been performed.
CsvImportAborted: CSV import aborted
CsvImportExplanationLabel: Informating regarding CSV import
CsvExampleData: Example data
CsvExportExample: Export example CSV
Proportion c of prop: #{c}/#{of} (#{rationalToFixed2 (100 * prop)}%)
ProportionNoRatio c of: #{c}/#{of}
@ -1798,6 +1883,8 @@ CsvColumnUserSemester: Semester the participant is in wrt. to their associated f
CsvColumnUserRegistration: Time of participant's enrollment (ISO 8601)
CsvColumnUserNote: Course notes for the participant
CsvColumnUserTutorial: Tutorials which the user is registered for, separated by semicolon (;). For each registration group among the tutorials there is a separate column. The registration group columns contain at most one tutorial per participant. If every tutorial has a registration group there is no column "tutorial".
CsvColumnUserExam: Exams which the user is registered for, separated by semicolon (;).
CsvColumnUserSubmissionGroup: Registered submission group
CsvColumnExamOfficeExamUserOccurrenceStart: Exam occurrence (ISO 8601)
@ -1821,6 +1908,8 @@ DBCsvDuplicateKey: Two rows in the CSV file reference the same database entry an
DBCsvDuplicateKeyTip: Please remove one of the lines listed below and try again.
DBCsvKeyException: For a row in the CSV file it could not be determined whether it references any database entry.
DBCsvException: An error occurred hile computing the set of edits this CSV import corresponds to.
DBCsvParseError: An uploaded file could not be interpreted as CSV of the expected format.
DBCsvParseErrorTip: The Uni2work-component that handles CSV decoding has reported the following error:
ExamUserCsvCourseRegister: Register users for the exam and enroll them in the course
ExamUserCsvRegister: Register users for the exam
@ -1837,10 +1926,11 @@ ExamBonusNone: No bonus points
ExamUserCsvCourseNoteDeleted: Course note will be deleted
ExamUserCsvExceptionNoMatchingUser: Course participant could not be identified uniquely
ExamUserCsvExceptionNoMatchingStudyFeatures: The specified field did not match with any of the participant's fields of study
ExamUserCsvExceptionNoMatchingOccurrence: Occurrence/room could not be identified uniquely
ExamUserCsvExceptionNoMatchingUser: Course participant could not be identified uniquely. All identifiers (given name(s), surname, display name, matriculation, ..) must match exactly. You can try to remove some of the identifiers for the given line (i.e. all but matriculation). Uni2work will then search for users using only the remaining identifiers. In this case special care should be taken that Uni2work correctly identifies the intended user.
ExamUserCsvExceptionNoMatchingStudyFeatures: The specified field did not match with any of the participant's fields of study. You can try to remove the field of study for the given line. Uni2work will then automatically choose a field of study.
ExamUserCsvExceptionNoMatchingOccurrence: Occurrence/room could not be identified uniquely. Please ensure that the given line only contains internal room identifiers exactly as they have been configured for this exam.
ExamUserCsvExceptionMismatchedGradingMode expectedGradingMode actualGradingMode: The imported data contained an exam achievement which does not match the grading mode for this exam. The expected grading mode can be changed at "Edit exam" ("Passed/Failed", "Numeric grades", or "Mixed").
ExamUserCsvExceptionNoOccurrenceTime: The imported data contained an exam achievement without an associated time. You can either enter a time for each student in the appropriate column or you can set a default time for the entire exam under "Edit".
ExternalExamUserCsvRegister: Store exam achievement
ExternalExamUserCsvSetTime: Adjust exam time
@ -2011,6 +2101,7 @@ SchoolAdmin: Admin
SchoolLecturer: Lecturer
SchoolEvaluation: Course evaluation
SchoolExamOffice: Exam office
SchoolAllocation: Administration of central allocations
ApplicationEditTip: During the application period you may edit and retract your applications at will.
@ -2171,8 +2262,13 @@ CourseNewsDeleteQuestion: Are you sure you want to delete the item of course new
CourseNewsDeleted: Successfully deleted item of course news
CourseDeregistrationAllocationLog: Your enrollment in this course is due to a central allocation. If you leave the course, this will be permanently recorded and might affect you negatively in future central allocations. If you have good reasons why you should not be held accountable for leaving the course, please contact a course administrator. Course administrators can deregister you without incurring a permanent record.
CourseDeregistrationNoShow: If you deregister from this course “no show” will be recorded as your exam achievement for all exams associated with this course. If you have good reasons why you shold not be held accountable for leaving the course, please contact a course administrator. Course administrators can deregister you without incurring a permanent record.
CourseDeregistrationAllocationReason: Reason
CourseDeregistrationAllocationReasonTip: The specified reason will be permanently stored and might be the only information available during conflict resolution
CourseDeregistrationAllocationNoShow: Record as “no show”
CourseDeregistrationAllocationNoShowTip: Should, for all exams associated with this course, “no show” be recorded as the exam achievement automatically? This would be done once immediately (if no other achievement exists for the given exam) and automatically whenever a new exam is created.
CourseDeregisterNoShow: Record “no show” when deregistering
CourseDeregisterNoShowTip: Should “no show” be recorded as the exam achievement for all exams associated with this course automatically whenever a course participant deregisters themselves? This would be done once upon deregistration (if no other achievement exists for the given exam) and automatically whenever a new exam is created.
CourseDeregistrationAllocationShouldLog: Self imposed
CourseDeregistrationAllocationShouldLogTip: If the participant was enrolled in this course due to a central allocation, it is intended that a permanent record be made that might affect the student negatively in future central allocations. As a course administrator you have the right to prevent this if the participant can present good reasons why them leaving the course is not self imposed.
@ -2194,11 +2290,14 @@ FavouriteParticipant: Your courses
FavouriteManual: Favourites
FavouriteCurrent: Current course
FavouritesUnavailableTip: Quick Actions for this course are currently not available.
CourseEvents: Occurrences
CourseEventType: Type
CourseEventTypePlaceholder: Lecture, Exercise discussion, ...
CourseEventTime: Time
CourseEventRoom: Regular room
CourseEventNote: Note
CourseEventActions: Actions
CourseEventsActionEdit: Edit
CourseEventsActionDelete: Delete
@ -2344,3 +2443,97 @@ InfoLecturerAllocations: Central allocations
ParticipantsIntersectCourseOption tid@TermId ssh@SchoolId coursen@CourseName: #{tid} - #{ssh} - #{coursen}
ParticipantsIntersectCourses: Courses
AllocationUsersTitle tid ssh ash: #{tid}-#{ssh}-#{ash}: Applicants
AllocationUsersApplied: Applications
AllocationUsersAssigned: Assignments
AllocationUsersVetoed: Vetos
AllocationUsersRequested: Requested assignments
AllocationUsersPriority: Central priority
CsvColumnAllocationUserSurname: Applicant's surname(s)
CsvColumnAllocationUserFirstName: Applicants's first name(s)
CsvColumnAllocationUserName: Applicant's full name
CsvColumnAllocationUserMatriculation: Applicant's matriculation
CsvColumnAllocationUserRequested: Maximum number of placements the applicant is prepared to accept
CsvColumnAllocationUserApplied: Number of applications the applicant has provided
CsvColumnAllocationUserVetos: Number of applications that have received a veto from a course administrator or have been rated with a grade that is equivalent to "failed" (5.0)
CsvColumnAllocationUserAssigned: Number of assignments the applicant has already received
CsvColumnAllocationUserPriority: Central priority of this applicant; either a number based on the applicants position in the list sorted by priority (higher numbers mean a higher priority) or a comma-separated list of numerical priorities in square brackets (e.g. [1, 2, 3])
AllocationUsersCsvName tid ssh ash: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase ash}-applicants
AllocationPrioritiesMode: Mode
AllocationPrioritiesNumeric: Numeric priorities
AllocationPrioritiesOrdinal: Priorities based on sorted list
AllocationPrioritiesTitle tid ssh ash: #{tid}-#{ssh}-#{ash}: Central priorities
AllocationPrioritiesFile: CSV file
AllocationPrioritiesSunk num: Successfully registered central priorities for #{num} #{pluralEN num "applicant" "applicants"}
AllocationPrioritiesMissing num: Could not register central priorities for #{num} #{pluralEN num "applicant" "applicants"} because their matriculation was not found in the uploaded CSV file
AllocationMissingPrioritiesIgnored: Applicants for whom no central priority has been registered will be ignored during assignment!
ExampleUser1FirstName: Max SecondName
ExampleUser1Surname: Mustermann
ExampleUser1DisplayName: Max Mustermann
ExampleUser2FirstName: Martha
ExampleUser2Surname: Musterstudent
ExampleUser2DisplayName: Musterstudent Martha
ExampleUser3FirstName: Maria
ExampleUser3Surname: Example
ExampleUser3DisplayName: Example
AllocationUsersMissingPriorities: Participants without central priority
AllocationUsersMissingPrioritiesTip: Care must be taken, that no participant is excluded from the allocation by not having been assigned a central priority.
AllocationUsersMissingPrioritiesOk: It was ensured, that all participants mentioned above, are excluded from the allocation on valid grounds.
AllocationRestrictCourses: Restrict courses
AllocationRestrictCoursesTip: Should places be assigned only in a subset of courses? This functionality can be used to make alternate placements in the case that some participants withdraw from their assigned courses. This functionality should only be used to exclude courses on valid grounds. E.g. if a seminar already had a planning meeting and is thus unable to accept new participants.
AllocationRestrictCoursesSelection: Courses
AllocationRestrictCoursesSelectionTip: Participants will only be assigned to courses listed here.
AllocationUsersMissingPrioritiesNotOk: Central allocation cannot occur until all participants, that were not excluded explicitly (“Participants without central priority”), have been assigned a central priority!
AllocationComputed: A possible allocation has been computed and stored in your session. No changes have yet been made!
AllocationOnlyCompute: By sending this form a possible allocation will be computed and saved temporarily. You can then check that the computed allocation is as expected. No changes will yet be made to the state of the database and no notifications will be sent.
AllocationAcceptFormDoesNotMatchSession: The form to accept the computed allocation was generated for a different result than the one, that is currently saved in your session.
ComputedAllocation: Computed allocation
AllocationAccepted: Successfully saved allocation
AllocationMatchedUsers: Newly assigned
AllocationUnmatchedUsers: Participants without assigned places
AllocationUnmatchedCourses: Courses without assigned participants
AllocationTime: Time of allocation
AllocationRequestedPlaces: Requested places
AllocationOfferedPlaces: Offered places
AllocationUserNewMatches: New allocations
AllocationUsersCount: Participants
AllocationCoursesCount: Courses
CourseOption tid ssh coursen: #{tid} - #{ssh} - #{coursen}
BearerTokenUsageWarning: Using this interface you are able to encode essentially arbitrary permissions inte bearer tokens. This allows you to freely hand permissions off arbitrarily and without relevant restrictions. Only use this interface if you have discussed the consequences of the specific token, that you want to issue, with an experienced developer!
BearerTokenAuthorityGroups: Authority (groups)
BearerTokenAuthorityGroupsTip: All primary users of the groups listed here need to have the requisite permissions to access a route in order for the created token to grant permission to do so as well.
BearerTokenAuthorityUsers: Authority (users
BearerTokenAuthorityUsersTip: All users listed here need to have the requisite permissions to access a route in order for the created token to grant permission to do so as well. The user issuing the token using this interface also needs to have permission to access that route (they are automatically added to the list of authorities).
BearerTokenAuthorityUnknownUser email: Could not find any user with email #{email}
BearerTokenRoutes: Permitted routes
BearerTokenRoutesTip: If the token is restricted to certain routes and no routes are listed, the token is valid nowhere.
BearerTokenRestrictions: Route-specific restrictions
BearerTokenRestrictRoutes: Restrict token to certain routes
BearerTokenAdditionalAuth: Additional authorisation
BearerTokenAdditionalAuthTip: If nothing is entered, no additional authorisation will be performed when the token is used. Mere posession of the token will be sufficient.
BearerTokenOverrideExpiration: Override expiration time
BearerTokenExpires: Expiration time
BearerTokenExpiresTip: If no expiration time is given, the token will not expire. It will be valid forever.
BearerTokenOverrideStart: Start time
BearerTokenOverrideStartTip: If no start time is given, only the expiration time will be checked when the token is used.
FaqTitle: Frequently asked questions
AdditionalFaqs: More frequently asked questions
MultiActionUnknownAction: In a form dependent on the value of a field a value was given for which no form is available
CourseParticipantStateIsActive: Active participants
CourseParticipantStateIsInactive: Former participants
CourseParticipantStateIsActiveFilter: View
CourseUserReRegister: Re-register
CourseParticipantActive: Participant
CourseParticipantInactive: Deregistered
CourseParticipantNoShow: No show
CourseUserState: State

86
missing-translations.sh
View File

@ -6,6 +6,17 @@ typeset -a requiredLangs
requiredLangs=(de en)
fix=1
while getopts ':f' arg; do
case $arg in
f) fix=0 ;;
\*) print nothing: $OPTARG; exit 2;;
\?) print invalid option: $OPTARG; exit 2;;
esac
done
shift $OPTIND-1
function translations() {
msgFile=$1
@ -67,8 +78,32 @@ for msgDirectory (${msgDirectories}); do
done
# printf ">>> %s\n" ${msgDirectory}
diff -u0 --suppress-common-lines -wB ${diffArgs} | grep -vE '^@@.*@@'
if [[ $fix != 0 ]]; then
if [[ ${#dirMsgFiles} -gt 1 ]]; then
diff -u0 --suppress-common-lines -wB ${diffArgs} | grep -vE '^@@.*@@'
diffStatus=$pipestatus[0]
else
diffStatus=1
fi
else
if [[ ${#dirMsgFiles} -gt 1 ]]; then
diff -u0 --suppress-common-lines -wB ${diffArgs} >/dev/null
diffStatus=$?
else
diffStatus=1
fi
if [[ ${diffStatus} == 1 ]]; then
./translate.hs msgs ${dirMsgFiles} && diffStatus=0
fi
fi
return ${diffStatus}
) || msgDifference=1
if [[ $fix == 0 && $msgDifference != 0 ]]; then
exit 1
fi
done
@ -89,19 +124,46 @@ for templateDirectory (templates/i18n/**/*(FN)); do
fi
done
typeset -a templatePrefixes
templatePrefixes=()
for templateFile (${templateFiles}); do
[[ ${templateFile:h} == ${templateDirectory} ]] || continue
templatePrefix=$(sed -r 's/^(.*\.)?[^.]+\.[^.]+$/\1/' <<<"${templateFile:t}")
if ! ((${templatePrefixes[(Ie)${templatePrefix}]})); then
templatePrefixes+=("${templatePrefix}")
fi
done
# printf "%d %s\n" ${#templatePrefixes} "${templatePrefixes}"
for ext (${templateExtensions}); do
for lang (${requiredLangs}); do
foundLang=0
for templateFile (${templateDirectory}/*.${ext}); do
[[ ${templateFile:t} =~ "(^|.)${lang}[-.]" ]] || continue
foundLang=1
break
done
if [[ $foundLang -ne 1 ]]; then
templateDifference=1
printf "%s: %s (%s)\n" $templateDirectory $lang $ext
fi
for prefixQ (${(q)templatePrefixes}); do
prefix=${(Q)prefixQ}
# printf ">> %s %s %s\n" ${prefix} ${lang} ${ext}
foundLang=1
for templateFile (${templateDirectory}/*.${ext}); do
# printf "%s\n" ${templateFile}
[[ ${templateFile:t} =~ "^${prefix}${lang}[-.]" ]] || continue
# printf "match\n"
foundLang=0
break
done
# printf ">> %s\n" ${foundLang}
if [[ $foundLang -ne 0 ]]; then
templateDifference=1
[[ $fix != 0 ]] && printf "%s: %s*.%s (%s)\n" "$templateDirectory" "$prefix" "$ext" "$lang"
if [[ $fix == 0 ]]; then
./translate.hs dir $templateDirectory && templateDifference=0
fi
fi
done
done
done
done

2
models/allocations.model
View File

@ -21,6 +21,7 @@ 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
matchingSeed ByteString default='\x'::bytea
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
@ -28,6 +29,7 @@ Allocation -- attributes with prefix staff- affect lecturers only, but are invis
AllocationMatching
allocation AllocationId
fingerprint AllocationFingerprint
time UTCTime
log FileId
AllocationCourse

3
models/courses.model
View File

@ -15,6 +15,7 @@ Course -- Information about a single course; contained info is always visible
registerFrom UTCTime Maybe -- enrolement allowed from a given day onwwards or prohibited
registerTo UTCTime Maybe -- enrolement may be prohibited from a given date onwards
deregisterUntil UTCTime Maybe -- unenrolement may be prohibited from a given date onwards
deregisterNoShow Bool default=false
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 default=false
@ -30,6 +31,7 @@ CourseEvent
course CourseId
room Text
time Occurrences
note Html Maybe
lastChanged UTCTime default=now()
CourseAppInstructionFile
@ -52,6 +54,7 @@ CourseParticipant -- course enrolement
registration UTCTime -- time of last enrolement for this course
field StudyFeaturesId Maybe -- associated degree course, user-defined; required for communicating grades
allocated AllocationId Maybe -- participant was centrally allocated
state CourseParticipantState
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

2
models/files.model
View File

@ -8,7 +8,5 @@ File
deriving Show Eq Generic
SessionFile
user UserId
reference SessionFileReference
file FileId
touched UTCTime

1
models/sheets.model
View File

@ -12,6 +12,7 @@ Sheet -- exercise sheet for a given course
solutionFrom UTCTime Maybe -- Solution is made available
submissionMode SubmissionMode -- Submission upload by students and/or through tutors?
autoDistribute Bool default=false -- Should correctors be assigned submissions automagically?
anonymousCorrection Bool default=true
CourseSheet course name
deriving Generic
SheetEdit -- who edited when a row in table "Course", kept indefinitely

9
models/submissions.model
View File

@ -23,12 +23,9 @@ SubmissionUser -- which submission belongs to whom
UniqueSubmissionUser user submission -- multiple users may share same submission, in case of (ad-hoc) submission groups
SubmissionGroup -- pre-defined submission groups; some courses only allow pre-defined submission groups
course CourseId
name Text Maybe
SubmissionGroupEdit -- who edited a submissionGroup when?
user UserId
time UTCTime
submissionGroup SubmissionGroupId
name SubmissionGroupName
UniqueSubmissionGroup course name
SubmissionGroupUser -- Registered submission groups, just for checking upon submission, but independent of actual SubmissionUser
submissionGroup SubmissionGroupId
user UserId
UniqueSubmissionGroupUser submissionGroup user
UniqueSubmissionGroupUser submissionGroup user

10
models/system-messages.model
View File

@ -3,8 +3,12 @@
SystemMessage
from UTCTime Maybe -- Message is not shown before this date has passed (never shown, if null)
to UTCTime Maybe -- Message is shown until this date has passed (shown forever, if null)
newsOnly Bool default=false
authenticatedOnly Bool -- Show message to all users upon visiting the site or only upon login?
severity MessageStatus -- Success, Warning, Error, Info, ...
created UTCTime default=now()
lastChanged UTCTime default=now()
lastUnhide UTCTime default=now()
defaultLanguage Lang -- Language of @content@ and @summary@
content Html -- Detailed message shown when clicking on the @summary@-popup or when no @summary@ is specified
summary Html Maybe
@ -14,3 +18,9 @@ SystemMessageTranslation -- Translation of a @SystemMessage@ into another langua
content Html
summary Html Maybe
UniqueSystemMessageTranslation message language
SystemMessageHidden
message SystemMessageId
user UserId
time UTCTime
UniqueSystemMessageHidden user message

5408
package-lock.json generated
View File

File diff suppressed because it is too large Load Diff

56
package.json
View File

@ -1,6 +1,6 @@
{
"name": "uni2work",
"version": "13.0.1",
"version": "16.0.5",
"description": "",
"keywords": [],
"author": "",
@ -53,28 +53,28 @@
"defaults"
],
"devDependencies": {
"@babel/cli": "^7.7.5",
"@babel/core": "^7.7.5",
"@babel/plugin-proposal-class-properties": "^7.7.4",
"@babel/plugin-proposal-decorators": "^7.7.4",
"@babel/plugin-transform-runtime": "^7.7.6",
"@babel/preset-env": "^7.7.6",
"@commitlint/cli": "^8.2.0",
"@commitlint/config-conventional": "^8.2.0",
"@fortawesome/fontawesome-pro": "^5.12.0",
"autoprefixer": "^9.7.3",
"@babel/cli": "^7.8.4",
"@babel/core": "^7.9.6",
"@babel/plugin-proposal-class-properties": "^7.8.3",
"@babel/plugin-proposal-decorators": "^7.8.3",
"@babel/plugin-transform-runtime": "^7.9.6",
"@babel/preset-env": "^7.9.6",
"@commitlint/cli": "^8.3.5",
"@commitlint/config-conventional": "^8.3.4",
"@fortawesome/fontawesome-pro": "^5.13.0",
"autoprefixer": "^9.7.6",
"babel-core": "^6.26.3",
"babel-eslint": "^10.0.3",
"babel-loader": "^8.0.6",
"babel-eslint": "^10.1.0",
"babel-loader": "^8.1.0",
"babel-plugin-syntax-dynamic-import": "^6.18.0",
"babel-plugin-transform-decorators-legacy": "^1.3.5",
"babel-preset-es2015": "^6.24.1",
"cbt_tunnels": "^1.2.2",
"clean-webpack-plugin": "^3.0.0",
"copy-webpack-plugin": "^5.1.0",
"copy-webpack-plugin": "^5.1.1",
"css-loader": "^2.1.1",
"eslint": "^5.16.0",
"file-loader": "^5.0.2",
"file-loader": "^5.1.0",
"fs-extra": "^8.1.0",
"glob": "^7.1.6",
"html-webpack-plugin": "^3.2.0",
@ -85,45 +85,45 @@
"karma-chrome-launcher": "^2.2.0",
"karma-cli": "^2.0.0",
"karma-jasmine": "^2.0.1",
"karma-jasmine-html-reporter": "^1.4.2",
"karma-jasmine-html-reporter": "^1.5.3",
"karma-mocha-reporter": "^2.2.5",
"karma-webpack": "^3.0.5",
"lint-staged": "^8.2.1",
"lodash.debounce": "^4.0.8",
"mini-css-extract-plugin": "^0.8.0",
"mini-css-extract-plugin": "^0.8.2",
"npm-run-all": "^4.1.5",
"null-loader": "^2.0.0",
"optimize-css-assets-webpack-plugin": "^5.0.3",
"postcss-loader": "^3.0.0",
"postcss-preset-env": "^6.7.0",
"real-favicon-webpack-plugin": "^0.2.3",
"remove-files-webpack-plugin": "^1.1.3",
"request": "^2.88.0",
"remove-files-webpack-plugin": "^1.4.1",
"request": "^2.88.2",
"request-promise": "^4.2.5",
"resolve-url-loader": "^3.1.1",
"sass": "^1.23.7",
"sass": "^1.26.5",
"sass-loader": "^7.3.1",
"semver": "^6.3.0",
"standard-version": "^6.0.1",
"style-loader": "^0.23.1",
"terser-webpack-plugin": "^2.2.3",
"terser-webpack-plugin": "^2.3.6",
"tmp": "^0.1.0",
"typeface-roboto": "0.0.75",
"typeface-source-sans-pro": "0.0.75",
"webpack": "^4.41.2",
"webpack-cli": "^3.3.10",
"webpack": "^4.43.0",
"webpack-cli": "^3.3.11",
"webpack-manifest-plugin": "^2.2.0",
"webpack-plugin-hash-output": "^3.2.1"
},
"dependencies": {
"@babel/runtime": "^7.7.6",
"@babel/runtime": "^7.9.6",
"@juggle/resize-observer": "^2.5.0",
"core-js": "^3.4.8",
"core-js": "^3.6.5",
"js-cookie": "^2.2.1",
"lodash.throttle": "^4.1.1",
"moment": "^2.24.0",
"npm": "^6.13.7",
"sodium-javascript": "^0.5.5",
"moment": "^2.25.3",
"npm": "^6.14.5",
"sodium-javascript": "^0.5.6",
"tail.datetime": "git+ssh://git@gitlab2.rz.ifi.lmu.de/uni2work/tail.DateTime.git#master",
"whatwg-fetch": "^3.0.0"
}

19
package.yaml
View File

@ -1,5 +1,5 @@
name: uniworx
version: 13.0.1
version: 16.0.5
dependencies:
- base
@ -61,6 +61,7 @@ dependencies:
- cryptoids
- cryptoids-class
- binary
- binary-instances
- cereal
- mtl
- esqueleto >=3.1.0
@ -103,7 +104,9 @@ dependencies:
- postgresql-simple
- word24
- mmorph
- clientsession
- serversession
- serversession-backend-acid-state
- acid-state
- monad-memo
- xss-sanitize
- text-metrics
@ -138,7 +141,12 @@ dependencies:
- wai-middleware-prometheus
- extended-reals
- rfc5051
- unidecode
- pandoc
- token-bucket
- async
- pointedlist
- clock
other-extensions:
- GeneralizedNewtypeDeriving
@ -185,8 +193,10 @@ default-extensions:
- DeriveFunctor
- DeriveFoldable
- DeriveTraversable
- DeriveAnyClass
- DerivingStrategies
- DerivingVia
- GeneralizedNewtypeDeriving
- DataKinds
- BinaryLiterals
- PolyKinds
@ -227,6 +237,8 @@ library:
- -ddump-splices
- -ddump-to-file
cpp-options: -DDEVELOPMENT
ghc-prof-options:
- -fprof-auto
else:
ghc-options:
- -O2
@ -249,7 +261,8 @@ executables:
source-dirs: test
dependencies:
- uniworx
other-modules: []
other-modules:
- Database.Fill
when:
- condition: flag(library-only)
buildable: false

13
records.json
View File

@ -815,18 +815,5 @@
"usedIds": []
}
}
],
"mini-css-extract-plugin node_modules/css-loader/dist/cjs.js??ref--6-1!node_modules/postcss-loader/src/index.js??ref--6-2!node_modules/resolve-url-loader/index.js??ref--6-3!node_modules/sass-loader/dist/cjs.js??ref--6-4!frontend/src/utils/inputs/radiobox.sass": [
{
"modules": {
"byIdentifier": {},
"usedIds": {}
},
"chunks": {
"byName": {},
"bySource": {},
"usedIds": []
}
}
]
}

19
routes
View File

@ -55,6 +55,7 @@
/admin/features AdminFeaturesR GET POST
/admin/test AdminTestR GET POST
/admin/errMsg AdminErrMsgR GET POST
/admin/tokens AdminTokensR GET POST
/health HealthR GET !free
/instance InstanceR GET !free
@ -63,6 +64,7 @@
/info/legal LegalR GET !free
/info/allocation InfoAllocationR GET !free
/info/glossary GlossaryR GET !free
/info/faq FaqR GET !free
/version VersionR GET !free
/help HelpR GET POST !free
@ -110,6 +112,8 @@
/course/#CryptoUUIDCourse/apply AApplyR POST !timeANDallocation-registered
/users AUsersR GET POST !allocation-admin
/priorities APriosR GET POST !allocation-admin
/compute AComputeR GET POST !allocation-admin
/accept AAcceptR GET POST !allocation-admin
/participants ParticipantsListR GET !evaluation
/participants/#TermId/#SchoolId ParticipantsR GET !evaluation
@ -137,9 +141,9 @@
/exam-office CExamOfficeR GET POST !course-registered
/subs CCorrectionsR GET POST
/subs/assigned CAssignR GET POST
/sheet SheetListR GET !course-registered !materials !corrector
/sheet SheetListR GET !course-registered !materials !corrector !tutor
/sheet/new SheetNewR GET POST
/sheet/current SheetCurrentR GET !course-registered !materials !corrector
/sheet/current SheetCurrentR GET !course-registered !materials !corrector !tutor
/sheet/unassigned SheetOldUnassignedR GET
/sheet/#SheetName SheetR:
/show SShowR GET !timeANDcourse-registered !timeANDmaterials !corrector !timeANDtutor
@ -147,15 +151,15 @@
/edit SEditR GET POST
/delete SDelR GET POST
/subs SSubsR GET POST -- for lecturer only
!/subs/new SubmissionNewR GET POST !timeANDcourse-registeredANDuser-submissions
!/subs/new SubmissionNewR GET POST !timeANDcourse-registeredANDuser-submissionsANDsubmission-group
!/subs/own SubmissionOwnR GET !free -- just redirect
!/subs/assign SAssignR GET POST !lecturerANDtime
/subs/#CryptoFileNameSubmission SubmissionR:
/ SubShowR GET POST !ownerANDtimeANDuser-submissions !ownerANDread !correctorANDread
/ SubShowR GET POST !ownerANDtimeANDuser-submissionsANDsubmission-group !ownerANDread !correctorANDread
/delete SubDelR GET POST !ownerANDtimeANDuser-submissions
/assign SubAssignR GET POST !lecturerANDtime
/correction CorrectionR GET POST !corrector !ownerANDreadANDrated
/invite SInviteR GET POST !ownerANDtimeANDuser-submissions
/invite SInviteR GET POST !ownerANDtimeANDuser-submissionsANDsubmission-group
!/#SubmissionFileType SubArchiveR GET !owner !corrector
!/#SubmissionFileType/*FilePath SubDownloadR GET !owner !corrector
/iscorrector SIsCorrR GET !corrector -- Route is used to check for corrector access to this sheet
@ -219,8 +223,9 @@
/subs/download CorrectionsDownloadR GET !corrector !lecturer
/msgs MessageListR GET POST
/msg/#{CryptoUUIDSystemMessage} MessageR GET POST !timeANDreadANDauthentication
/msgs MessageListR GET POST
/msg/#{CryptoUUIDSystemMessage} MessageR GET POST !timeANDreadANDauthentication
/msg/#{CryptoUUIDSystemMessage}/hide MessageHideR POST !timeANDauthentication
!/#UUID CryptoUUIDDispatchR GET !free -- just redirect
-- !/*{CI FilePath} CryptoFileNameDispatchR GET !free -- Disabled until preliminary check for valid cID exists

62
shell.nix
View File

@ -19,11 +19,22 @@ let
'';
override = oldAttrs: {
nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ nodejs-13_x postgresql openldap google-chrome exiftool ]) ++ (with pkgs.haskellPackages; [ stack yesod-bin hlint cabal-install weeder ]);
nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ nodejs-13_x postgresql openldap google-chrome exiftool memcached ]) ++ (with pkgs.haskellPackages; [ stack yesod-bin hlint cabal-install weeder profiteur ]);
shellHook = ''
export PROMPT_INFO="${oldAttrs.name}"
export CHROME_BIN=$(which google-chrome-stable)
export EDITOR=emacsclient
cleanup() {
set +e -x
type cleanup_postgres &>/dev/null && cleanup_postgres
type cleanup_widget_memcached &>/dev/null && cleanup_widget_memcached
type cleanup_session_memcached &>/dev/null && cleanup_session_memcached
type cleanup_cache_memcached &>/dev/null && cleanup_cache_memcached
set +x
}
trap cleanup EXIT
if [[ -z "$PGHOST" ]]; then
set -xe
@ -37,14 +48,57 @@ let
psql -f ${postgresSchema} postgres
printf "Postgres logfile is %s\nPostgres socket directory is %s\n" ''${pgLogFile} ''${pgSockDir}
cleanup() {
cleanup_postgres() {
set +e -x
pg_ctl stop -D ''${pgDir}
rm -rvf ''${pgDir} ''${pgSockDir} ''${pgLogFile}
set +x
}
trap cleanup EXIT
set +xe
fi
if [[ -z "$WIDGET_MEMCACHED_HOST" ]]; then
set -xe
memcached -l localhost -p 11211 &>/dev/null &
widget_memcached_pid=$?
cleanup_widget_memcached() {
[[ -n "$widget_memcached_pid" ]] && kill $widget_memcached_pid
}
export WIDGET_MEMCACHED_HOST=localhost WIDGET_MEMCACHED_PORT=11211
set +xe
fi
if [[ -z "$SESSION_MEMCACHED_HOST" ]]; then
set -xe
memcached -l localhost -p 11212 &>/dev/null &
session_memcached_pid=$?
cleanup_session_memcached() {
[[ -n "$session_memcached_pid" ]] && kill $session_memcached_pid
}
export SESSION_MEMCACHED_HOST=localhost SESSION_MEMCACHED_PORT=11212
set +xe
fi
if [[ -z "MEMCACHED_HOST" ]]; then
set -xe
memcached -l localhost -p 11213 &>/dev/null &
memcached_pid=$?
cleanup_session_memcached() {
[[ -n "memcached_pid" ]] && kill memcached_pid
}
export MEMCACHED_HOST=localhost MEMCACHED_PORT=11212
set +xe
fi

103
src/Application.hs
View File

@ -18,10 +18,11 @@ module Application
import Control.Monad.Logger (liftLoc, LoggingT(..), MonadLoggerIO(..))
import Database.Persist.Postgresql (createPostgresqlPool, pgConnStr,
pgPoolSize, runSqlPool)
import Import hiding (cancel)
pgPoolSize, runSqlPool, ConnectionPool)
import Import hiding (cancel, respond)
import Language.Haskell.TH.Syntax (qLocation)
import Network.Wai (Middleware)
import qualified Network.Wai as Wai
import Network.Wai.Handler.Warp (Settings, defaultSettings,
defaultShouldDisplayException,
runSettings, runSettingsSocket, setHost,
@ -40,6 +41,9 @@ import Handler.Utils (runAppLoggingT)
import Foreign.Store
import Web.Cookie
import Network.HTTP.Types.Header (hSetCookie)
import qualified Data.UUID as UUID
import qualified Data.UUID.V4 as UUID
@ -88,6 +92,9 @@ import qualified Data.Set as Set
import Handler.Utils.Routes (classifyHandler)
import qualified Data.Acid.Memory as Acid
import qualified Web.ServerSession.Backend.Acid as Acid
-- Import all relevant handler modules here.
-- (HPack takes care to add new modules to our cabal file nowadays.)
import Handler.News
@ -125,7 +132,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, MonadUnliftIO m) => AppSettings -> m UniWorX
makeFoundation :: (MonadResource m, MonadUnliftIO m, MonadThrow m) => AppSettings -> m UniWorX
makeFoundation appSettings'@AppSettings{..} = do
registerGHCMetrics
@ -168,7 +175,7 @@ makeFoundation appSettings'@AppSettings{..} = do
-- logging function. To get out of this loop, we initially create a
-- temporary foundation without a real connection pool, get a log function
-- from there, and then create the real foundation.
let mkFoundation appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID = UniWorX {..}
let mkFoundation appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached = UniWorX {..}
-- The UniWorX {..} syntax is an example of record wild cards. For more
-- information, see:
-- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html
@ -177,11 +184,12 @@ makeFoundation appSettings'@AppSettings{..} = do
(error "smtpPool forced in tempFoundation")
(error "ldapPool forced in tempFoundation")
(error "cryptoIDKey forced in tempFoundation")
(error "sessionKey forced in tempFoundation")
(error "sessionStore forced in tempFoundation")
(error "secretBoxKey forced in tempFoundation")
(error "widgetMemcached forced in tempFoundation")
(error "JSONWebKeySet forced in tempFoundation")
(error "ClusterID forced in tempFoundation")
(error "memcached forced in tempFoundation")
runAppLoggingT tempFoundation $ do
$logInfoS "InstanceID" $ UUID.toText appInstanceID
@ -191,9 +199,9 @@ makeFoundation appSettings'@AppSettings{..} = do
$logDebugS "setup" "SMTP-Pool"
createSmtpPool c
appWidgetMemcached <- for appWidgetMemcachedConf $ \c -> do
appWidgetMemcached <- for appWidgetMemcachedConf $ \WidgetMemcachedConf{ widgetMemcachedConf } -> do
$logDebugS "setup" "Widget-Memcached"
createWidgetMemcached c
createMemcached widgetMemcachedConf
-- Create the database connection pool
$logDebugS "setup" "PostgreSQL-Pool"
@ -201,9 +209,9 @@ makeFoundation appSettings'@AppSettings{..} = do
(pgConnStr appDatabaseConf)
(pgPoolSize appDatabaseConf)
ldapPool <- for appLdapConf $ \LdapConf{..} -> do
$logDebugS "setup" "LDAP-Pool"
createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) ldapTimeout (poolLimit ldapPool)
ldapPool <- traverse mkFailover <=< forOf (traverse . traverse) appLdapConf $ \conf@LdapConf{..} -> do
$logDebugS "setup" $ "LDAP-Pool " <> tshow ldapHost
(conf,) <$> createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) ldapTimeout (poolLimit ldapPool)
-- Perform database migration using our application's logging settings.
if
@ -215,17 +223,48 @@ makeFoundation appSettings'@AppSettings{..} = do
liftIO . exitWith $ ExitFailure 2
$logDebugS "setup" "Cluster-Config"
appCryptoIDKey <- clusterSetting (Proxy :: Proxy 'ClusterCryptoIDKey) `runSqlPool` sqlPool
appSessionKey <- clusterSetting (Proxy :: Proxy 'ClusterClientSessionKey) `runSqlPool` sqlPool
appSecretBoxKey <- clusterSetting (Proxy :: Proxy 'ClusterSecretBoxKey) `runSqlPool` sqlPool
appJSONWebKeySet <- clusterSetting (Proxy :: Proxy 'ClusterJSONWebKeySet) `runSqlPool` sqlPool
appClusterID <- clusterSetting (Proxy :: Proxy 'ClusterId) `runSqlPool` sqlPool
let foundation = mkFoundation sqlPool smtpPool ldapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID
appMemcached <- for appMemcachedConf $ \memcachedConf -> do
$logDebugS "setup" "Memcached"
memcachedKey <- clusterSetting (Proxy :: Proxy 'ClusterMemcachedKey) `runSqlPool` sqlPool
memcached <- createMemcached memcachedConf
return (memcachedKey, memcached)
appSessionStore <- mkSessionStore appSettings' sqlPool `runSqlPool` sqlPool
let foundation = mkFoundation sqlPool smtpPool ldapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached
-- Return the foundation
$logDebugS "setup" "Done"
return foundation
data SessionStoreException
= SessionStoreNotAvailable
deriving (Eq, Ord, Read, Show, Generic, Typeable)
instance Exception SessionStoreException
mkSessionStore :: forall m.
( MonadIO m
, MonadLogger m
, MonadThrow m
, MonadResource m
)
=> AppSettings -> ConnectionPool -> ReaderT SqlBackend m SomeSessionStorage
mkSessionStore AppSettings{..} mcdSqlConnPool
| Just mcdConf@MemcachedConf{..} <- appSessionMemcachedConf = do
mcdSqlMemcachedKey <- clusterSetting (Proxy :: Proxy 'ClusterServerSessionKey)
$logDebugS "setup" "Session-Memcached"
mcdSqlMemcached <- createMemcached mcdConf
let mcdSqlMemcachedExpiration = memcachedExpiry
return $ _SessionStorageMemcachedSql # MemcachedSqlStorage{..}
| appServerSessionAcidFallback = liftIO $
review _SessionStorageAcid . Acid.AcidStorage <$> Acid.openMemoryState Acid.emptyState
| otherwise = throwM SessionStoreNotAvailable
clusterSetting :: forall key m p.
( MonadIO m
, ClusterSetting key
@ -285,8 +324,8 @@ createSmtpPool SmtpConf{ smtpPool = ResourcePoolConf{..}, .. } = do
return conn
liftIO $ createPool (mkConnection >>= maybe return applyAuth smtpAuth) reapConnection poolStripes poolTimeout poolLimit
createWidgetMemcached :: (MonadLogger m, MonadResource m) => WidgetMemcachedConf -> m Memcached.Connection
createWidgetMemcached WidgetMemcachedConf{widgetMemcachedConnectInfo} = snd <$> allocate (Memcached.connect widgetMemcachedConnectInfo) Memcached.close
createMemcached :: (MonadLogger m, MonadResource m) => MemcachedConf -> m Memcached.Connection
createMemcached MemcachedConf{memcachedConnectInfo} = snd <$> allocate (Memcached.connect memcachedConnectInfo) Memcached.close
-- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
-- applying some additional middlewares.
@ -295,7 +334,33 @@ makeApplication foundation = liftIO $ do
logWare <- makeLogWare foundation
-- Create the WAI application and apply middlewares
appPlain <- toWaiAppPlain foundation
return . observeHTTPRequestLatency classifyHandler . logWare $ defaultMiddlewaresNoLogging appPlain
return . observeHTTPRequestLatency classifyHandler . logWare . normalizeCookies $ defaultMiddlewaresNoLogging appPlain
where
normalizeCookies :: Wai.Middleware
normalizeCookies app req respond = app req $ \res -> do
resHdrs' <- go $ Wai.responseHeaders res
respond $ Wai.mapResponseHeaders (const resHdrs') res
where parseSetCookie' :: ByteString -> IO (Maybe SetCookie)
parseSetCookie' = fmap (either (\(_ :: SomeException) -> Nothing) Just) . try . evaluate . force . parseSetCookie
go [] = return []
go (hdr@(hdrName, hdrValue) : hdrs)
| hdrName == hSetCookie = do
mcookieHdr <- parseSetCookie' hdrValue
case mcookieHdr of
Nothing -> (hdr :) <$> go hdrs
Just cookieHdr -> do
let cookieHdrMatches hdrValue' = maybeT (return False) $ do
cookieHdr' <- MaybeT $ parseSetCookie' hdrValue'
-- See https://tools.ietf.org/html/rfc6265
guard $ setCookiePath cookieHdr' == setCookiePath cookieHdr
guard $ setCookieName cookieHdr' == setCookieName cookieHdr
guard $ setCookieDomain cookieHdr' == setCookieDomain cookieHdr
return True
others <- filterM (\(hdrName', hdrValue') -> and2M (pure $ hdrName' == hSetCookie) (cookieHdrMatches hdrValue')) hdrs
if | null others -> (hdr :) <$> go hdrs
| otherwise -> go hdrs
| otherwise = (hdr :) <$> go hdrs
makeLogWare :: MonadIO m => UniWorX -> m Middleware
makeLogWare app = do
@ -432,12 +497,12 @@ appMain = runResourceT $ do
case watchdogMicroSec of
Just wInterval
| maybe True (== myProcessID) watchdogProcess
-> let notifyWatchdog :: forall a. IO a
notifyWatchdog = runAppLoggingT foundation $ go Nothing
-> let notifyWatchdog :: forall a m'. ( MonadLogger m', MonadIO m') => m' a
notifyWatchdog = go Nothing
where
go :: Maybe (Set (UTCTime, HealthReport)) -> LoggingT IO a
go :: Maybe (Set (UTCTime, HealthReport)) -> m' a
go pResults = do
let delay = floor $ wInterval % 2
let delay = floor $ wInterval % 4
d <- liftIO $ newDelay delay
$logDebugS "Notify" $ "Waiting up to " <> tshow delay <> "µs..."

10
src/Audit/Types.hs
View File

@ -178,6 +178,16 @@ data Transaction
, transactionUser :: UserId
}
| TransactionSubmissionGroupSet
{ transactionCourse :: CourseId
, transactionUser :: UserId
, transactionSubmissionGroup :: SubmissionGroupName
}
| TransactionSubmissionGroupUnset
{ transactionCourse :: CourseId
, transactionUser :: UserId
}
deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriveJSON defaultOptions

47
src/Auth/LDAP.hs
View File

@ -3,6 +3,7 @@ module Auth.LDAP
, campusLogin
, CampusUserException(..)
, campusUser, campusUser'
, campusUserReTest, campusUserReTest'
, campusUserMatr, campusUserMatr'
, CampusMessage(..)
, ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName
@ -102,8 +103,18 @@ instance Exception CampusUserException
makePrisms ''CampusUserException
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
campusUserWith :: MonadUnliftIO m
=> ( Lens (LdapConf, LdapPool) (LdapConf, Ldap) LdapPool Ldap
-> Failover (LdapConf, LdapPool)
-> FailoverMode
-> ((LdapConf, Ldap) -> IO (Ldap.AttrList []))
-> IO (Either LdapPoolError (Ldap.AttrList []))
)
-> Failover (LdapConf, LdapPool)
-> FailoverMode
-> Creds site
-> m (Ldap.AttrList [])
campusUserWith withLdap' pool mode Creds{..} = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdap' _2 pool mode $ \(conf@LdapConf{..}, ldap) -> do
Ldap.bind ldap ldapDn ldapPassword
results <- case lookup "DN" credsExtra of
Just userDN -> do
@ -121,13 +132,23 @@ campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $
, Exc.Handler $ \(HostCannotConnect host excs) -> throwM $ CampusUserHostCannotConnect host excs
]
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) [])
campusUserReTest :: MonadUnliftIO m => Failover (LdapConf, LdapPool) -> (Nano -> Bool) -> FailoverMode -> Creds site -> m (Ldap.AttrList [])
campusUserReTest pool doTest = campusUserWith (\l -> flip (withLdapFailoverReTest l) doTest) pool
campusUserReTest' :: (MonadCatch m, MonadUnliftIO m) => Failover (LdapConf, LdapPool) -> (Nano -> Bool) -> FailoverMode -> User -> m (Maybe (Ldap.AttrList []))
campusUserReTest' pool doTest mode User{userIdent}
= runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUserReTest pool doTest mode (Creds apLdap (CI.original userIdent) [])
campusUser :: MonadUnliftIO m => Failover (LdapConf, LdapPool) -> FailoverMode -> Creds site -> m (Ldap.AttrList [])
campusUser = campusUserWith withLdapFailover
campusUser' :: (MonadCatch m, MonadUnliftIO m) => Failover (LdapConf, LdapPool) -> FailoverMode -> User -> m (Maybe (Ldap.AttrList []))
campusUser' pool mode User{userIdent}
= runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUser pool mode (Creds apLdap (CI.original userIdent) [])
campusUserMatr :: MonadUnliftIO m => LdapConf -> LdapPool -> UserMatriculation -> m (Ldap.AttrList [])
campusUserMatr conf@LdapConf{..} pool userMatr = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdap pool $ \ldap -> do
campusUserMatr :: MonadUnliftIO m => Failover (LdapConf, LdapPool) -> FailoverMode -> UserMatriculation -> m (Ldap.AttrList [])
campusUserMatr pool mode userMatr = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdapFailover _2 pool mode $ \(conf@LdapConf{..}, ldap) -> do
Ldap.bind ldap ldapDn ldapPassword
results <- findUserMatr conf ldap userMatr []
case results of
@ -140,9 +161,9 @@ campusUserMatr conf@LdapConf{..} pool userMatr = liftIO . (`catches` errHandlers
, Exc.Handler $ \(HostCannotConnect host excs) -> throwM $ CampusUserHostCannotConnect host excs
]
campusUserMatr' :: (MonadCatch m, MonadUnliftIO m) => LdapConf -> LdapPool -> UserMatriculation -> m (Maybe (Ldap.AttrList []))
campusUserMatr' conf pool
= runMaybeT . catchIfMaybeT (is _CampusUserNoResult) . campusUserMatr conf pool
campusUserMatr' :: (MonadCatch m, MonadUnliftIO m) => Failover (LdapConf, LdapPool) -> FailoverMode -> UserMatriculation -> m (Maybe (Ldap.AttrList []))
campusUserMatr' pool mode
= runMaybeT . catchIfMaybeT (is _CampusUserNoResult) . campusUserMatr pool mode
@ -168,8 +189,8 @@ campusLogin :: forall site.
, RenderMessage site CampusMessage
, RenderMessage site AFormMessage
, Button site ButtonSubmit
) => LdapConf -> LdapPool -> AuthPlugin site
campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
) => Failover (LdapConf, LdapPool) -> FailoverMode -> AuthPlugin site
campusLogin pool mode = AuthPlugin{..}
where
apName :: Text
apName = apLdap
@ -184,7 +205,7 @@ campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
redirect $ tp LoginR
FormMissing -> redirect $ tp LoginR
FormSuccess CampusLogin{ campusIdent = CI.original -> campusIdent, ..} -> do
ldapResult <- withLdap pool $ \ldap -> liftIO $ do
ldapResult <- withLdapFailover _2 pool mode $ \(conf@LdapConf{..}, ldap) -> liftIO $ do
Ldap.bind ldap ldapDn ldapPassword
searchResults <- findUser conf ldap campusIdent [ldapUserPrincipalName]
case searchResults of

3
src/Crypto/Hash/Instances.hs
View File

@ -43,3 +43,6 @@ instance HashAlgorithm hash => ToJSON (Digest hash) where
instance HashAlgorithm hash => FromJSON (Digest hash) where
parseJSON = withText "Digest" $ either (fail . unpack) return . parseUrlPiece
instance Hashable (Digest hash) where
hashWithSalt s = (hashWithSalt s :: ByteString -> Int) . convert

19
src/Crypto/Random/Instances.hs Normal file
View File

@ -0,0 +1,19 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Crypto.Random.Instances
(
) where
import ClassyPrelude
import Crypto.Random
import System.Random (RandomGen(..))
import qualified Data.ByteArray as BA
import Data.Bits
instance RandomGen ChaChaDRG where
next g = withRandomBytes g (finiteBitSize (maxBound :: Int) `div` 8) (foldr (\x acc -> acc `shiftL` 8 .|. fromIntegral x) zeroBits . BA.unpack @BA.Bytes)
split g = withDRG g drgNew

28
src/CryptoID.hs
View File

@ -15,9 +15,9 @@ import Model
import CryptoID.TH
import qualified Data.CryptoID as E
import Data.CryptoID.Poly.ImplicitNamespace
import Data.UUID.Cryptographic.ImplicitNamespace
import System.FilePath.Cryptographic.ImplicitNamespace
import Data.CryptoID.Poly.ImplicitNamespace hiding (decrypt, encrypt)
import Data.UUID.Cryptographic.ImplicitNamespace hiding (decrypt, encrypt)
import System.FilePath.Cryptographic.ImplicitNamespace hiding (decrypt, encrypt)
import qualified Data.Text as Text
@ -28,6 +28,28 @@ import Data.Aeson.Encoding (text)
import Text.Blaze (ToMarkup(..))
import qualified Data.CryptoID.Class.ImplicitNamespace as I
encrypt :: forall plaintext ciphertext m.
( I.HasCryptoID ciphertext plaintext m
, KnownSymbol (CryptoIDNamespace ciphertext plaintext)
, MonadHandler m
, Typeable ciphertext
, PathPiece plaintext
)
=> plaintext -> m (I.CryptoID ciphertext plaintext)
encrypt plain = $cachedHereBinary (toPathPiece plain) $ I.encrypt plain
decrypt :: forall plaintext ciphertext m.
( I.HasCryptoID ciphertext plaintext m
, MonadHandler m
, Typeable plaintext
, PathPiece ciphertext
)
=> I.CryptoID ciphertext plaintext -> m plaintext
decrypt cipher = $cachedHereBinary (toPathPiece $ ciphertext cipher) $ I.decrypt cipher
instance {-# OVERLAPPING #-} MonadThrow m => MonadCrypto (ReaderT CryptoIDKey m) where
type MonadCryptoKey (ReaderT CryptoIDKey m) = CryptoIDKey

7
src/Data/Aeson/Types/Instances.hs
View File

@ -9,11 +9,6 @@ import ClassyPrelude
import Data.Aeson.Types (Parser, Value)
import Control.Monad.Catch
import Data.Binary (Binary)
import Data.HashMap.Strict.Instances ()
import Data.Vector.Instances ()
import Model.Types.TH.JSON (derivePersistFieldJSON)
import Control.Monad.Fail
@ -22,7 +17,5 @@ import Control.Monad.Fail
instance MonadThrow Parser where
throwM = fail . show
instance Binary Value
derivePersistFieldJSON ''Value

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

@ -26,9 +26,6 @@ import qualified Database.Esqueleto as E
import Web.HttpApiData
import Data.Binary (Binary)
import qualified Data.Binary as Binary
import qualified Data.Csv as Csv
@ -99,11 +96,6 @@ instance (CI.FoldCase s, PathMultiPiece s) => PathMultiPiece (CI s) where
fromPathMultiPiece = fmap CI.mk . fromPathMultiPiece
toPathMultiPiece = toPathMultiPiece . CI.original
instance (CI.FoldCase s, Binary s) => Binary (CI s) where
get = CI.mk <$> Binary.get
put = Binary.put . CI.original
putList = Binary.putList . map CI.original
instance Csv.ToField s => Csv.ToField (CI s) where
toField = Csv.toField . CI.original

15
src/Data/HashMap/Strict/Instances.hs
View File

@ -1,15 +0,0 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.HashMap.Strict.Instances
(
) where
import ClassyPrelude
import Data.Binary (Binary(..))
import qualified Data.HashMap.Strict as HashMap
instance (Binary k, Binary v, Hashable k, Eq k) => Binary (HashMap k v) where
put = put . HashMap.toList
get = HashMap.fromList <$> get

16
src/Data/HashSet/Instances.hs
View File

@ -1,16 +0,0 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.HashSet.Instances
(
) where
import ClassyPrelude
import qualified Data.HashSet as HashSet
import Data.Binary (Binary(..))
instance (Binary a, Hashable a, Eq a) => Binary (HashSet a) where
get = HashSet.fromList <$> get
put = put . HashSet.toList

38
src/Data/MonoTraversable/Instances.hs Normal file
View File

@ -0,0 +1,38 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.MonoTraversable.Instances
() where
import ClassyPrelude
import Data.Monoid (Any(..), All(..))
type instance Element Any = Bool
type instance Element All = Bool
instance MonoFunctor Any where
omap f = Any . f . getAny
instance MonoFunctor All where
omap f = All . f . getAll
instance MonoPointed Any where
opoint = Any
instance MonoPointed All where
opoint = All
instance MonoFoldable Any where
ofoldMap f = f . getAny
ofoldr f x (Any b) = f b x
ofoldl' f x (Any b) = f x b
ofoldr1Ex _ = getAny
ofoldl1Ex' _ = getAny
instance MonoFoldable All where
ofoldMap f = f . getAll
ofoldr f x (All b) = f b x
ofoldl' f x (All b) = f x b
ofoldr1Ex _ = getAll
ofoldl1Ex' _ = getAll

4
src/Data/NonNull/Instances.hs
View File

@ -28,3 +28,7 @@ instance Hashable a => Hashable (NonNull a) where
instance (Binary a, MonoFoldable a) => Binary (NonNull a) where
get = Binary.get >>= maybe (fail "Expected non-empty structure") return . fromNullable
put = Binary.put . toNullable
instance NFData a => NFData (NonNull a) where
rnf = rnf . toNullable

2
src/Data/Time/Calendar/Instances.hs
View File

@ -6,7 +6,6 @@ module Data.Time.Calendar.Instances
) where
import ClassyPrelude
import Data.Binary (Binary)
import Data.Time.Calendar
@ -14,7 +13,6 @@ import Data.Universe
deriving newtype instance Hashable Day
deriving newtype instance Binary Day
deriving instance Ord DayOfWeek
instance Universe DayOfWeek where

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

@ -1,8 +1,7 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.Time.Clock.Instances
( iso8601OutputFormat, iso8601ParseFormat
) where
() where
import ClassyPrelude
@ -10,19 +9,21 @@ import Database.Persist.Sql
import Data.Proxy
import Data.Binary (Binary)
import qualified Data.Binary as Binary
import Data.Time.Clock
import Data.Time.Calendar.Instances ()
import Web.PathPieces
import qualified Data.Csv as Csv
import Data.Time.Format.ISO8601
instance Hashable DiffTime where
hashWithSalt s = hashWithSalt s . toRational
instance Hashable NominalDiffTime where
hashWithSalt s = hashWithSalt s . toRational
instance PersistField NominalDiffTime where
toPersistValue = toPersistValue . toRational
fromPersistValue = fmap fromRational . fromPersistValue
@ -31,27 +32,15 @@ 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 iso8601OutputFormat
fromPathPiece = parseTimeM False defaultTimeLocale iso8601ParseFormat . unpack
toPathPiece = pack . iso8601Show
fromPathPiece = iso8601ParseM . unpack
instance Csv.ToField UTCTime where
toField = Csv.toField . formatTime defaultTimeLocale iso8601OutputFormat
toField = Csv.toField . iso8601Show
instance Csv.FromField UTCTime where
parseField = parseTimeM False defaultTimeLocale iso8601ParseFormat <=< Csv.parseField
instance Binary DiffTime where
get = fromRational <$> Binary.get
put = Binary.put . toRational
instance Binary UTCTime
parseField = iso8601ParseM <=< Csv.parseField

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

@ -8,28 +8,13 @@ import ClassyPrelude
import Data.Time.LocalTime
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
instance Hashable TimeOfDay
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

17
src/Data/Vector/Instances.hs
View File

@ -1,17 +0,0 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.Vector.Instances
(
) where
import ClassyPrelude
import qualified Data.Vector as Vector
import Data.Binary (Binary)
import qualified Data.Binary as Binary
instance Binary a => Binary (Vector a) where
get = Vector.fromList <$> Binary.get
put = Binary.put . Vector.toList

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

@ -13,6 +13,7 @@ import Database.Persist.Sql
import Data.Binary (Binary)
import qualified Data.Binary as Binary
import Data.Binary.Instances ()
import qualified Data.Map as Map

1
src/Database/Persist/Types/Instances.hs
View File

@ -11,6 +11,7 @@ import Database.Persist.Types
import Data.Time.Calendar.Instances ()
import Data.Time.LocalTime.Instances ()
import Data.Time.Clock.Instances ()
import Data.Binary.Instances ()
import Data.Binary (Binary)

746
src/Foundation.hs
View File

File diff suppressed because it is too large Load Diff

9
src/Foundation/I18n.hs
View File

@ -277,6 +277,15 @@ instance RenderMessage UniWorX (Either ExamPassed ExamGrade) where
mr :: RenderMessage UniWorX msg => msg -> Text
mr = renderMessage foundation ls
instance RenderMessage UniWorX CourseParticipantState where
renderMessage foundation ls = \case
CourseParticipantActive -> mr MsgCourseParticipantActive
CourseParticipantInactive False -> mr MsgCourseParticipantInactive
CourseParticipantInactive True -> mr MsgCourseParticipantNoShow
where
mr :: RenderMessage UniWorX msg => msg -> Text
mr = renderMessage foundation ls
-- ToMessage instances for converting raw numbers to Text (no internationalization)
instance ToMessage Int where

52
src/Foundation/Type.hs
View File

@ -1,19 +1,20 @@
module Foundation.Type
( UniWorX(..)
, SomeSessionStorage(..)
, _SessionStorageMemcachedSql, _SessionStorageAcid
, SMTPPool
, _appSettings', _appStatic, _appConnPool, _appSmtpPool, _appLdapPool, _appWidgetMemcached, _appHttpManager, _appLogger, _appLogSettings, _appCryptoIDKey, _appClusterID, _appInstanceID, _appJobState, _appSessionKey, _appSecretBoxKey, _appJSONWebKeySet, _appHealthReport
, _appSettings', _appStatic, _appConnPool, _appSmtpPool, _appLdapPool, _appWidgetMemcached, _appHttpManager, _appLogger, _appLogSettings, _appCryptoIDKey, _appClusterID, _appInstanceID, _appJobState, _appSessionStore, _appSecretBoxKey, _appJSONWebKeySet, _appHealthReport
) where
import Import.NoFoundation
import Database.Persist.Sql (ConnectionPool)
import qualified Web.ClientSession as ClientSession
import Jobs.Types
import Yesod.Core.Types (Logger)
import qualified Crypto.Saltine.Core.SecretBox as SecretBox
import qualified Crypto.Saltine.Core.AEAD as AEAD
import qualified Jose.Jwk as Jose
import qualified Database.Memcached.Binary.IO as Memcached
@ -21,36 +22,47 @@ import qualified Database.Memcached.Binary.IO as Memcached
type SMTPPool = Pool SMTPConnection
data SomeSessionStorage
= SessionStorageMemcachedSql { sessionStorageMemcachedSql :: MemcachedSqlStorage SessionMap }
| SessionStorageAcid { sessionStorageAcid :: AcidStorage SessionMap }
makePrisms ''SomeSessionStorage
-- | The foundation datatype for your application. This can be a good place to
-- keep settings and values requiring initialization before your application
-- starts running, such as database connections. Every handler will have
-- access to the data present here.
data UniWorX = UniWorX
{ appSettings' :: AppSettings
, appStatic :: EmbeddedStatic -- ^ Settings for static file serving.
, appConnPool :: ConnectionPool -- ^ Database connection pool.
, appSmtpPool :: Maybe SMTPPool
, appLdapPool :: Maybe LdapPool
, appWidgetMemcached :: Maybe Memcached.Connection -- ^ Actually a proper pool
, appHttpManager :: Manager
, appLogger :: (ReleaseKey, TVar Logger)
, appLogSettings :: TVar LogSettings
, appCryptoIDKey :: CryptoIDKey
, appClusterID :: ClusterId
, appInstanceID :: InstanceId
, appJobState :: TMVar JobState
, appSessionKey :: ClientSession.Key
, appSecretBoxKey :: SecretBox.Key
, appJSONWebKeySet :: Jose.JwkSet
, appHealthReport :: TVar (Set (UTCTime, HealthReport))
{ appSettings' :: AppSettings
, appStatic :: EmbeddedStatic -- ^ Settings for static file serving.
, appConnPool :: ConnectionPool -- ^ Database connection pool.
, appSmtpPool :: Maybe SMTPPool
, appLdapPool :: Maybe (Failover (LdapConf, LdapPool))
, appWidgetMemcached :: Maybe Memcached.Connection -- ^ Actually a proper pool
, appHttpManager :: Manager
, appLogger :: (ReleaseKey, TVar Logger)
, appLogSettings :: TVar LogSettings
, appCryptoIDKey :: CryptoIDKey
, appClusterID :: ClusterId
, appInstanceID :: InstanceId
, appJobState :: TMVar JobState
, appSessionStore :: SomeSessionStorage
, appSecretBoxKey :: SecretBox.Key
, appJSONWebKeySet :: Jose.JwkSet
, appHealthReport :: TVar (Set (UTCTime, HealthReport))
, appMemcached :: Maybe (AEAD.Key, Memcached.Connection)
}
makeLenses_ ''UniWorX
instance HasInstanceID UniWorX InstanceId where
instanceID = _appInstanceID
instance HasClusterID UniWorX ClusterId where
clusterID = _appClusterID
instance HasJSONWebKeySet UniWorX Jose.JwkSet where
jsonWebKeySet = _appJSONWebKeySet
instance HasHttpManager UniWorX Manager where
httpManager = _appHttpManager
instance HasAppSettings UniWorX where
appSettings = _appSettings'
instance HasCookieSettings RegisteredCookie UniWorX where
getCookieSettings = appCookieSettings . appSettings'

17
src/Foundation/Types.hs Normal file
View File

@ -0,0 +1,17 @@
module Foundation.Types
( UpsertCampusUserMode(..)
, _UpsertCampusUser, _UpsertCampusUserDummy, _UpsertCampusUserOther
, _upsertCampusUserIdent
) where
import Import.NoFoundation
data UpsertCampusUserMode
= UpsertCampusUser
| UpsertCampusUserDummy { upsertCampusUserIdent :: UserIdent }
| UpsertCampusUserOther { uspertCampusUserIdent :: UserIdent }
deriving (Eq, Ord, Read, Show, Generic, Typeable)
makeLenses_ ''UpsertCampusUserMode
makePrisms ''UpsertCampusUserMode

1
src/Handler/Admin.hs
View File

@ -9,6 +9,7 @@ import Handler.Utils
import Handler.Admin.Test as Handler.Admin
import Handler.Admin.ErrorMessage as Handler.Admin
import Handler.Admin.StudyFeatures as Handler.Admin
import Handler.Admin.Tokens as Handler.Admin
getAdminR :: Handler Html

2
src/Handler/Admin/ErrorMessage.hs
View File

@ -6,8 +6,6 @@ import Import
import Handler.Utils
import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder)
import Control.Monad.Trans.Except
getAdminErrMsgR, postAdminErrMsgR :: Handler Html
getAdminErrMsgR = postAdminErrMsgR

15
src/Handler/Admin/StudyFeatures.hs
View File

@ -330,7 +330,6 @@ postAdminFeaturesR = do
[ sortable (Just "key") (i18nCell MsgGenericKey) (numCell . view (_dbrOutput . _entityVal . _studyDegreeKey))
, sortable (Just "name") (i18nCell MsgDegreeName) (textInputCell _1 (_dbrOutput . _entityVal . _studyDegreeName) (_dbrOutput . _entityKey))
, sortable (Just "short") (i18nCell MsgDegreeShort) (textInputCell _2 (_dbrOutput . _entityVal . _studyDegreeShorthand) (_dbrOutput . _entityKey))
, dbRow
]
dbtSorting = Map.fromList
[ ("key" , SortColumn (E.^. StudyDegreeKey))
@ -356,13 +355,13 @@ postAdminFeaturesR = do
dbtSQLQuery = return
dbtRowKey = (E.^. StudyTermsKey)
dbtProj field@(view _dbrOutput -> Entity fId _) = do
fieldSchools <- fmap (setOf $ folded . _Value) . lift . E.select . E.from $ \school -> do
fieldSchools <- fmap (setOf $ folded . _Value) . E.select . E.from $ \school -> do
E.where_ . E.exists . E.from $ \schoolTerms ->
E.where_ $ schoolTerms E.^. SchoolTermsSchool E.==. school E.^. SchoolId
E.&&. schoolTerms E.^. SchoolTermsTerms E.==. E.val fId
E.where_ $ school E.^. SchoolShorthand `E.in_` E.valList (toListOf (folded . _entityKey . _SchoolId) schools)
return $ school E.^. SchoolId
fieldParents <- fmap (setOf folded) . lift . E.select . E.from $ \terms -> do
fieldParents <- fmap (setOf folded) . E.select . E.from $ \terms -> do
E.where_ . E.exists . E.from $ \subTerms ->
E.where_ $ subTerms E.^. StudySubTermsChild E.==. E.val fId
E.&&. subTerms E.^. StudySubTermsParent E.==. terms E.^. StudyTermsId
@ -379,7 +378,6 @@ postAdminFeaturesR = do
, sortable (Just "field-type") (i18nCell MsgStudyTermsDefaultFieldType) (fieldTypeCell _6 (_dbrOutput . _1 . _entityVal . _studyTermsDefaultType) _dbrKey')
, flip foldMap schools $ \(Entity ssh School{schoolName}) ->
sortable Nothing (cell $ toWidget schoolName) (checkboxCell (_3 . at ssh . _Maybe) (_dbrOutput . _3 . at ssh . _Maybe) _dbrKey')
, dbRow
]
dbtSorting = Map.fromList
[ ("key" , SortColumn $ queryField >>> (E.^. StudyTermsKey))
@ -416,8 +414,7 @@ postAdminFeaturesR = do
dbtRowKey = (E.^. StudyTermNameCandidateId)
dbtProj = return
dbtColonnade = dbColonnade $ mconcat
[ dbRow
, sortable (Just "key") (i18nCell MsgStudyTermsKey) (numCell . view (_dbrOutput . _entityVal . _studyTermNameCandidateKey))
[ sortable (Just "key") (i18nCell MsgStudyTermsKey) (numCell . view (_dbrOutput . _entityVal . _studyTermNameCandidateKey))
, sortable (Just "name") (i18nCell MsgStudyTermsName) (textCell . view (_dbrOutput . _entityVal . _studyTermNameCandidateName))
, sortable (Just "incidence") (i18nCell MsgStudyCandidateIncidence) (pathPieceCell . view (_dbrOutput . _entityVal . _studyTermNameCandidateIncidence))
]
@ -459,8 +456,7 @@ postAdminFeaturesR = do
dbtRowKey = queryCandidate >>> (E.^. StudySubTermParentCandidateId)
dbtProj = return
dbtColonnade = dbColonnade $ mconcat
[ dbRow
, sortable (Just "child") (i18nCell MsgStudySubTermsChildKey) (numCell . view (_dbrOutput . _1 . _entityVal . _studySubTermParentCandidateKey))
[ sortable (Just "child") (i18nCell MsgStudySubTermsChildKey) (numCell . view (_dbrOutput . _1 . _entityVal . _studySubTermParentCandidateKey))
, sortable (Just "child-name") (i18nCell MsgStudySubTermsChildName) (maybe mempty i18nCell . preview (_dbrOutput . _3 . _Just . _entityVal . _studyTermsName . _Just))
, sortable (Just "parent") (i18nCell MsgStudySubTermsParentKey) (numCell . view (_dbrOutput . _1 . _entityVal . _studySubTermParentCandidateParent))
, sortable (Just "parent-name") (i18nCell MsgStudySubTermsParentName) (maybe mempty i18nCell . preview (_dbrOutput . _2 . _Just . _entityVal . _studyTermsName . _Just))
@ -501,8 +497,7 @@ postAdminFeaturesR = do
dbtRowKey = queryCandidate >>> (E.^. StudyTermStandaloneCandidateId)
dbtProj = return
dbtColonnade = formColonnade $ mconcat
[ dbRow
, sortable (Just "key") (i18nCell MsgStudyTermsKey) (numCell . view (_dbrOutput . _1 . _entityVal . _studyTermStandaloneCandidateKey))
[ sortable (Just "key") (i18nCell MsgStudyTermsKey) (numCell . view (_dbrOutput . _1 . _entityVal . _studyTermStandaloneCandidateKey))
, sortable (Just "name") (i18nCell MsgStudyTermsName) (maybe mempty i18nCell . preview (_dbrOutput . _2 . _Just . _entityVal . _studyTermsName . _Just))
, sortable (Just "incidence") (i18nCell MsgStudyCandidateIncidence) (pathPieceCell . view (_dbrOutput . _1 . _entityVal . _studyTermStandaloneCandidateIncidence))
, sortable Nothing (i18nCell MsgStudyTermsDefaultDegree) (degreeCell _1 (pre $ _dbrOutput . _2 . _Just . _studyTermsDefaultDegree . _Just) _dbrKey')

101
src/Handler/Admin/Tokens.hs Normal file
View File

@ -0,0 +1,101 @@
module Handler.Admin.Tokens
( getAdminTokensR, postAdminTokensR
) where
import Import
import Handler.Utils
import qualified Data.HashSet as HashSet
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Set as Set
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Encode.Pretty as Aeson
import Data.Map ((!), (!?))
import qualified Data.Text as Text
data BearerTokenForm = BearerTokenForm
{ btfAuthority :: HashSet (Either UserGroupName UserId)
, btfRoutes :: Maybe (HashSet (Route UniWorX))
, btfRestrict :: HashMap (Route UniWorX) Value
, btfAddAuth :: Maybe AuthDNF
, btfExpiresAt :: Maybe (Maybe UTCTime)
, btfStartsAt :: Maybe UTCTime
}
bearerTokenForm :: WForm Handler (FormResult BearerTokenForm)
bearerTokenForm = do
muid <- maybeAuthId
btfAuthorityGroups <- aFormToWForm $ HashSet.fromList . map Left <$> massInputListA pathPieceField (const "") (\p -> Just . SomeRoute $ AdminTokensR :#: p) ("token-groups" :: Text) (fslI MsgBearerTokenAuthorityGroups & setTooltip MsgBearerTokenAuthorityGroupsTip) False Nothing
btfAuthorityUsers <- fmap (fmap . ofoldMap $ HashSet.singleton . Right) <$> wopt (checkMap (foldMapM $ fmap Set.singleton . left MsgBearerTokenAuthorityUnknownUser) (Set.map Right) $ multiUserField False Nothing) (fslI MsgBearerTokenAuthorityUsers & setTooltip MsgBearerTokenAuthorityUsersTip) (Just $ Set.singleton <$> muid)
let btfAuthority' :: FormResult (HashSet (Either UserGroupName UserId))
btfAuthority'
= (<>) <$> btfAuthorityGroups <*> ((hoistMaybe =<< btfAuthorityUsers) <|> pure HashSet.empty)
let btfRoutesForm = HashSet.fromList <$> massInputListA routeField (const "") (\p -> Just . SomeRoute $ AdminTokensR :#: p) ("token-routes" :: Text) (fslI MsgBearerTokenRoutes & setTooltip MsgBearerTokenRoutesTip) True Nothing
btfRoutes' <- optionalActionW btfRoutesForm (fslI MsgBearerTokenRestrictRoutes) (Just True)
let btfRestrictForm = massInputAccumEditW miAdd' miCell' (\p -> Just . SomeRoute $ AdminTokensR :#: p) miLayout' ("token-restrictions" :: Text) (fslI MsgBearerTokenRestrictions) False Nothing
where miAdd' nudge = fmap (over (mapped . _1) tweakRes) . miForm nudge . Left
where tweakRes res = res <&> \(newRoute, newRestr) oldRestrs -> pure (bool [(newRoute, newRestr)] [] $ newRoute `HashMap.member` HashMap.fromList oldRestrs)
miCell' nudge = miForm nudge . Right
miForm :: (Text -> Text)
-> Either (FieldView UniWorX) (Route UniWorX, Value)
-> Form (Route UniWorX, Value)
miForm nudge mode csrf = do
(routeRes, routeView) <- mpreq routeField ("" & addName (nudge "route")) (mode ^? _Right . _1)
(restrRes, restrView) <- mpreq (checkMap (left Text.pack . Aeson.eitherDecode . encodeUtf8 . fromStrict . unTextarea) (Textarea . toStrict . decodeUtf8 . Aeson.encodePretty) textareaField) ("" & addName (nudge "restr")) (mode ^? _Right . _2)
return ((,) <$> routeRes <*> restrRes, case mode of
Left btn -> $(widgetFile "widgets/massinput/token-restrictions/add")
Right _ -> $(widgetFile "widgets/massinput/token-restrictions/cell")
)
miLayout' :: MassInputLayout ListLength (Route UniWorX, Value) (Route UniWorX, Value)
miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/token-restrictions/layout")
btfRestrict' <- fmap HashMap.fromList <$> btfRestrictForm
btfAddAuth' <- fmap (assertM $ not . Set.null . dnfTerms) <$> wopt pathPieceField (fslI MsgBearerTokenAdditionalAuth & setTooltip MsgBearerTokenAdditionalAuthTip) Nothing
btfExpiresAt' <- optionalActionW (aopt utcTimeField (fslI MsgBearerTokenExpires & setTooltip MsgBearerTokenExpiresTip) Nothing) (fslI MsgBearerTokenOverrideExpiration) (Just False)
btfStartsAt' <- wopt utcTimeField (fslI MsgBearerTokenOverrideStart & setTooltip MsgBearerTokenOverrideStartTip) Nothing
return $ BearerTokenForm
<$> btfAuthority'
<*> btfRoutes'
<*> btfRestrict'
<*> btfAddAuth'
<*> btfExpiresAt'
<*> btfStartsAt'
getAdminTokensR, postAdminTokensR :: Handler Html
getAdminTokensR = postAdminTokensR
postAdminTokensR = do
((bearerReq, bearerView), bearerEnc) <- runFormPost $ renderWForm FormStandard bearerTokenForm
mjwt <- formResultMaybe bearerReq $ \BearerTokenForm{..} -> do
uid <- requireAuthId
let btfAuthority' = btfAuthority
& HashSet.insert (Right uid)
& HashSet.map (left toJSON)
fmap Just . encodeBearer . set _bearerRestrictions btfRestrict =<< bearerToken btfAuthority' btfRoutes btfAddAuth btfExpiresAt btfStartsAt
siteLayoutMsg' MsgMenuAdminTokens $ do
setTitleI MsgMenuAdminTokens
let bearerForm = wrapForm bearerView def
{ formMethod = POST
, formAction = Just $ SomeRoute AdminTokensR
, formEncoding = bearerEnc
}
warning <- notification NotificationBroad <$> messageI Warning MsgBearerTokenUsageWarning
$(widgetFile "admin-tokens")

2
src/Handler/Allocation.hs
View File

@ -9,3 +9,5 @@ import Handler.Allocation.Register as Handler.Allocation
import Handler.Allocation.List as Handler.Allocation
import Handler.Allocation.Users as Handler.Allocation
import Handler.Allocation.Prios as Handler.Allocation
import Handler.Allocation.Compute as Handler.Allocation
import Handler.Allocation.Accept as Handler.Allocation

162
src/Handler/Allocation/Accept.hs Normal file
View File

@ -0,0 +1,162 @@
module Handler.Allocation.Accept
( SessionDataAllocationResults(..)
, AllocationAcceptButton(..)
, allocationAcceptForm
, getAAcceptR, postAAcceptR
) where
import Import
import Handler.Utils
import Handler.Utils.Allocation
import Data.Map ((!?))
import qualified Data.Map as Map
import qualified Database.Esqueleto as E
import qualified Control.Monad.State.Class as State
import Data.Sequence (Seq((:|>)))
newtype SessionDataAllocationResults = SessionDataAllocationResults
{ getSessionDataAllocationResults :: Map ( TermId
, SchoolId
, AllocationShorthand
)
( UTCTime
, AllocationFingerprint
, Set (UserId, CourseId)
, Seq MatchingLogRun
)
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriving newtype (ToJSON, FromJSON)
deriving (Monoid, Semigroup) via Dual (Map (TermId, SchoolId, AllocationShorthand) (UTCTime, AllocationFingerprint, Set (UserId, CourseId), Seq MatchingLogRun))
makeWrapped ''SessionDataAllocationResults
data AllocationAcceptButton
= BtnAllocationAccept
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
deriving anyclass (Universe, Finite)
nullaryPathPiece ''AllocationAcceptButton $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''AllocationAcceptButton id
instance Button UniWorX AllocationAcceptButton where
btnClasses BtnAllocationAccept = [BCIsButton, BCPrimary]
allocationAcceptForm :: AllocationId -> DB (Maybe (Form (UTCTime, AllocationFingerprint, Set (UserId, CourseId), Seq MatchingLogRun)))
allocationAcceptForm aId = runMaybeT $ do
Allocation{..} <- MaybeT $ get aId
SessionDataAllocationResults allocMap <- MaybeT $ lookupSessionJson SessionAllocationResults
allocRes@(allocTime, allocFp, allocMatching, _ :|> MatchingLogRun{..}) <- hoistMaybe $ allocMap !? (allocationTerm, allocationSchool, allocationShorthand)
allocationUsers <- fmap (map $ bimap E.unValue E.unValue) . lift . E.select . E.from $ \allocationUser -> do
E.where_ $ allocationUser E.^. AllocationUserAllocation E.==. E.val aId
E.&&. E.not_ (E.isNothing $ allocationUser E.^. AllocationUserPriority)
let applications = E.subSelectCount . E.from $ \courseApplication ->
E.where_ $ courseApplication E.^. CourseApplicationAllocation E.==. E.val (Just aId)
E.&&. courseApplication E.^. CourseApplicationUser E.==. allocationUser E.^. AllocationUserUser
return . (allocationUser E.^. AllocationUserUser, ) $ E.case_
[ E.when_ (E.castNum (allocationUser E.^. AllocationUserTotalCourses) E.>. applications)
E.then_ (applications :: E.SqlExpr (E.Value Int))
]
(E.else_ . E.castNum $ allocationUser E.^. AllocationUserTotalCourses)
let allocationPlacesRequested = sumOf (folded . _2) allocationUsers
userAllocations = ofoldr (\(uid, _cid) -> Map.insertWith (+) uid 1) Map.empty allocMatching
allocationUsers' <- hoistMaybe $
let (res, leftoverAllocs) = foldr (\user@(uid, _) (acc, allocCounts)
-> ( (user, Map.findWithDefault 0 uid allocCounts) : acc
, Map.delete uid allocCounts
))
([] , userAllocations) allocationUsers
in guardOn (null leftoverAllocs) res :: Maybe [((UserId, Int), Integer)]
let unmatchedUsers = olength $ filter ((<= 0) . view _2) allocationUsers'
allocationCourses <- fmap (map $ over _3 E.unValue) . lift . E.select . E.from $ \(allocationCourse `E.InnerJoin` course) -> do
E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId
let participants = E.subSelectCount . E.from $ \courseParticipant ->
E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
return (allocationCourse, course, participants)
let allocationCapacity = sumOf (folded . _2 . _entityVal . _courseCapacity . _Just) allocationCourses
let courseAllocations = ofoldr (\(_uid, cid) -> Map.insertWith (+) cid 1) Map.empty allocMatching
allocationCourses' <- hoistMaybe $
let (res, leftoverAllocs) = foldr (\course@(_, Entity cid _, _) (acc, allocCounts)
-> ( (course, Map.findWithDefault 0 cid allocCounts) : acc
, Map.delete cid allocCounts
))
([] , courseAllocations) allocationCourses
in guardOn (null leftoverAllocs) res :: Maybe [((Entity AllocationCourse, Entity Course, Int), Int)]
let unmatchedCourses = olength $ filter ((<= 0) . view _2) allocationCourses'
let validateMatches =
guardValidation MsgAllocationAcceptFormDoesNotMatchSession =<< State.get
return . set (mapped . mapped . _1 . mapped) allocRes . validateForm validateMatches . identifyForm FIDAllocationAccept $ \csrf -> do
(prevAllocRes, prevAllocView) <- mreq hiddenField "" $ Just allocFp
let prevAllocMatches = (== allocFp) <$> prevAllocRes
let
showTerms
| [_] <- nubOn (view $ _1 . _2 . _entityVal . _courseTerm) allocationCourses'
= False
| otherwise
= True
showSchools
| [_] <- nubOn (view $ _1 . _2 . _entityVal . _courseSchool) allocationCourses'
= False
| otherwise
= True
optimumAllocated = round . (* optimumProportion) . fromIntegral
where optimumProportion :: Rational
optimumProportion
| allocationCapacity == 0 = 0
| otherwise = fromIntegral allocationPlacesRequested % fromIntegral allocationCapacity
allocHeat capN
= invDualHeat (optimumAllocated capN) capN
degenerateHeat capN
= capN <= optimumAllocated capN
return (prevAllocMatches, $(widgetFile "allocation/accept"))
getAAcceptR, postAAcceptR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html
getAAcceptR = postAAcceptR
postAAcceptR tid ssh ash = do
(((_, acceptView), acceptEnctype), didStore) <- runDB $ do
aId <- getKeyBy404 $ TermSchoolAllocationShort tid ssh ash
acceptForm <- maybe (redirect $ AllocationR tid ssh ash AComputeR) return =<< allocationAcceptForm aId
formRes@((acceptRes, _), _) <- liftHandler $ runFormPost acceptForm
didStore <- formResultMaybe acceptRes $ \(now, allocFp, allocMatchings, allocLog) -> do
modifySessionJson SessionAllocationResults . fmap (assertM $ not . views _Wrapped onull) . over (mapped . _Wrapped :: Setter' (Maybe SessionDataAllocationResults) _) $
Map.filterWithKey (\(tid', ssh', ash') (_, allocFp', _, _) ->
or [ tid' /= tid
, ssh' /= ssh
, ash' /= ash
, allocFp' /= allocFp
])
storeAllocationResult aId now (allocFp, allocMatchings, allocLog)
return $ Just ()
return (formRes, is _Just didStore)
when didStore $ do
addMessageI Success MsgAllocationAccepted
redirect $ AllocationR tid ssh ash AUsersR
siteLayoutMsg MsgMenuAllocationAccept $ do
setTitleI MsgMenuAllocationAccept
wrapForm' BtnAllocationAccept acceptView def
{ formEncoding = acceptEnctype
}

131
src/Handler/Allocation/Compute.hs Normal file
View File

@ -0,0 +1,131 @@
module Handler.Allocation.Compute
( getAComputeR
, postAComputeR
) where
import Import
import Handler.Utils
import Handler.Utils.Allocation
import Handler.Allocation.Accept (SessionDataAllocationResults(..))
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Database.Esqueleto as E
import qualified Control.Monad.State.Class as State
data AllocationComputeForm = AllocationComputeForm
{ acfMissingPrioritiesOk :: Set UserId
, acfRestrictCourses :: Maybe (Set CourseId)
}
data AllocationComputeButton
= BtnAllocationCompute
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
deriving anyclass (Universe, Finite)
nullaryPathPiece ''AllocationComputeButton $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''AllocationComputeButton id
instance Button UniWorX AllocationComputeButton where
btnClasses BtnAllocationCompute = [BCIsButton, BCPrimary]
missingPrioritiesUsers :: AllocationId -> DB (Map UserId User)
missingPrioritiesUsers aId = $cachedHereBinary aId $ do
usersWithoutPrio <- E.select . E.from $ \(user `E.InnerJoin` allocationUser) -> do
E.on $ user E.^. UserId E.==. allocationUser E.^. AllocationUserUser
E.&&. allocationUser E.^. AllocationUserAllocation E.==. E.val aId
-- Ignore users without applications
E.where_ . E.exists . E.from $ \courseApplication -> do
E.where_ $ courseApplication E.^. CourseApplicationAllocation E.==. E.just (E.val aId)
E.&&. courseApplication E.^. CourseApplicationUser E.==. user E.^. UserId
E.where_ . E.exists . E.from $ \allocationCourse ->
E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. courseApplication E.^. CourseApplicationCourse
E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId
E.where_ . E.isNothing $ allocationUser E.^. AllocationUserPriority
return user
return $ toMapOf (folded .> _entityVal) usersWithoutPrio
missingPriorities :: AllocationId -> AForm DB (Set UserId)
missingPriorities aId = wFormToAForm $ do
usersWithoutPrio <- lift . lift $ missingPrioritiesUsers aId
let missingPriosField = checkBoxField { fieldView = missingPriosFieldView }
where
missingPriosFieldView theId name attrs res isReq
= $(i18nWidgetFile "allocation-confirm-missing-prios")
where checkBoxFieldView = labeledCheckBoxView (i18n MsgAllocationUsersMissingPrioritiesOk) theId name attrs res isReq
if
| null usersWithoutPrio
-> return $ pure Set.empty
| otherwise
-> fmap (bool Set.empty $ Map.keysSet usersWithoutPrio) <$> wpreq missingPriosField (fslI MsgAllocationUsersMissingPriorities & setTooltip MsgAllocationUsersMissingPrioritiesTip) (Just False)
restrictCourses :: (MonadHandler m, HandlerSite m ~ UniWorX) => AllocationId -> AForm m (Maybe (Set CourseId))
restrictCourses aId = hoistAForm liftHandler $
optionalActionA selectCourses (fslI MsgAllocationRestrictCourses & setTooltip MsgAllocationRestrictCoursesTip) (Just False)
where
selectCourses = courseSelectForm query coursePred miButtonAction' miIdent' fSettings fRequired mPrev
where
query = E.from $ \(course `E.InnerJoin` allocationCourse) -> do
E.on $ course E.^. CourseId E.==. allocationCourse E.^. AllocationCourseCourse
E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId
return course
coursePred _ = return True
mPrev = Nothing
fRequired = True
fSettings = fslI MsgAllocationRestrictCoursesSelection & setTooltip MsgAllocationRestrictCoursesSelectionTip
miIdent' :: Text
miIdent' = "course-selection"
miButtonAction' _ = Nothing
allocationComputeForm :: AllocationId -> AForm DB AllocationComputeForm
allocationComputeForm aId = wFormToAForm $ do
onlyComputeMsg <- messageI Info MsgAllocationOnlyCompute
aFormToWForm $ AllocationComputeForm
<$ aformMessage onlyComputeMsg
<*> missingPriorities aId
<*> restrictCourses aId
validateAllocationComputeForm :: AllocationId -> FormValidator AllocationComputeForm DB ()
validateAllocationComputeForm aId = do
usersWithoutPrio <- lift $ missingPrioritiesUsers aId
missingOk <- State.gets acfMissingPrioritiesOk
guardValidation MsgAllocationUsersMissingPrioritiesNotOk $
Map.keysSet usersWithoutPrio `Set.isSubsetOf` missingOk
getAComputeR, postAComputeR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html
getAComputeR = postAComputeR
postAComputeR tid ssh ash = do
(_, ((_computeFormRes, computeFormView), computeFormEnctype)) <- runDB $ do
aEnt@(Entity aId _) <- getBy404 $ TermSchoolAllocationShort tid ssh ash
formRes@((computeFormRes, _), _) <- runFormPost . validateForm (validateAllocationComputeForm aId) . renderAForm FormStandard $ allocationComputeForm aId
formResult computeFormRes $ \AllocationComputeForm{..} -> do
now <- liftIO getCurrentTime
(allocFp, allocMatching, allocLog) <- computeAllocation aEnt acfRestrictCourses
tellSessionJson SessionAllocationResults . SessionDataAllocationResults $
Map.singleton (tid, ssh, ash) (now, allocFp, allocMatching, allocLog)
addMessageI Success MsgAllocationComputed
redirect $ AllocationR tid ssh ash AUsersR -- Redirect aborts transaction for safety
return (aEnt, formRes)
siteLayoutMsg MsgMenuAllocationCompute $ do
setTitleI MsgMenuAllocationCompute
wrapForm' BtnAllocationCompute computeFormView def
{ formEncoding = computeFormEnctype
}

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

@ -69,7 +69,7 @@ getAllocationListR = do
<*> view queryAvailable
<*> view (maybe (to . const $ E.val 0) queryApplied muid)
dbtProj :: DBRow _ -> MaybeT (YesodDB UniWorX) AllocationTableData
dbtProj :: DBRow _ -> DB AllocationTableData
dbtProj = return . over (_dbrOutput . _2) E.unValue . over (_dbrOutput . _3) E.unValue
dbtRowKey = view $ queryAllocation . to (E.^. AllocationId)

14
src/Handler/Allocation/Prios.hs
View File

@ -57,8 +57,8 @@ postAPriosR tid ssh ash = do
formResult priosRes $ \(mode, fInfo) -> do
let sourcePrios = case mode of
AllocationPrioritiesNumeric -> fileSourceCsvPositional Csv.NoHeader fInfo
AllocationPrioritiesOrdinal -> fileSourceCsvPositional Csv.NoHeader fInfo .| C.map Csv.fromOnly .| ordinalPriorities
AllocationPrioritiesNumeric -> transPipe liftHandler fInfo .| fileSourceCsvPositional Csv.NoHeader
AllocationPrioritiesOrdinal -> transPipe liftHandler fInfo .| fileSourceCsvPositional Csv.NoHeader .| C.map Csv.fromOnly .| ordinalPriorities
(matrSunk, matrMissing) <- runDB $ do
Entity aId _ <- getBy404 $ TermSchoolAllocationShort tid ssh ash
@ -66,7 +66,15 @@ postAPriosR tid ssh ash = do
[ AllocationUserAllocation ==. aId ]
[ AllocationUserPriority =. Nothing ]
matrSunk <- runConduit $ sourcePrios .| sinkAllocationPriorities aId
matrMissing <- fromIntegral <$> count [ AllocationUserAllocation ==. aId, AllocationUserPriority ==. Nothing ]
matrMissing <- E.selectCountRows . E.from $ \allocationUser -> do
E.where_ $ allocationUser E.^. AllocationUserAllocation E.==. E.val aId
E.&&. E.isNothing (allocationUser E.^. AllocationUserPriority)
E.where_ . E.exists . E.from $ \(courseApplication `E.InnerJoin` allocationCourse) -> do
E.on $ allocationCourse E.^. AllocationCourseCourse E.==. courseApplication E.^. CourseApplicationCourse
E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.just (allocationCourse E.^. AllocationCourseAllocation)
E.where_ $ courseApplication E.^. CourseApplicationUser E.==. allocationUser E.^. AllocationUserUser
E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.just (E.val aId)
return (matrSunk, matrMissing)
when (matrSunk > 0) $

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

@ -33,6 +33,7 @@ getAShowR tid ssh ash = 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.&&. registration E.?. CourseParticipantState E.==. E.just (E.val CourseParticipantActive)
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)

116
src/Handler/Allocation/Users.hs
View File

@ -6,6 +6,8 @@ module Handler.Allocation.Users
import Import
import Handler.Allocation.Accept
import Handler.Utils
import Handler.Utils.Allocation
@ -14,6 +16,12 @@ import qualified Database.Esqueleto.Utils as E
import qualified Data.Csv as Csv
import Data.Map ((!?))
import qualified Data.Map as Map
import qualified Data.Set as Set
import Text.Blaze (toMarkup)
type UserTableExpr = E.SqlExpr (Entity User)
`E.InnerJoin` E.SqlExpr (Entity AllocationUser)
@ -26,7 +34,9 @@ queryAllocationUser = to $(E.sqlIJproj 2 2)
queryAppliedCourses :: Getter UserTableExpr (E.SqlExpr (E.Value Int))
queryAppliedCourses = queryAllocationUser . to queryAppliedCourses'
where queryAppliedCourses' allocationUser = E.subSelectCount . E.from $ \courseApplication ->
where queryAppliedCourses' allocationUser = E.subSelectCount . E.from $ \(courseApplication `E.InnerJoin` allocationCourse) -> do
E.on $ allocationCourse E.^. AllocationCourseCourse E.==. courseApplication E.^. CourseApplicationCourse
E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.just (allocationCourse E.^. AllocationCourseAllocation)
E.where_ $ courseApplication E.^. CourseApplicationUser E.==. allocationUser E.^. AllocationUserUser
E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.just (allocationUser E.^. AllocationUserAllocation)
@ -35,10 +45,13 @@ queryAssignedCourses = queryAllocationUser . to queryAssignedCourses'
where queryAssignedCourses' allocationUser = E.subSelectCount . E.from $ \courseParticipant ->
E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. allocationUser E.^. AllocationUserUser
E.&&. courseParticipant E.^. CourseParticipantAllocated E.==. E.just (allocationUser E.^. AllocationUserAllocation)
E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
queryVetoedCourses :: Getter UserTableExpr (E.SqlExpr (E.Value Int))
queryVetoedCourses = queryAllocationUser . to queryVetoedCourses'
where queryVetoedCourses' allocationUser = E.subSelectCount . E.from $ \courseApplication -> do
where queryVetoedCourses' allocationUser = E.subSelectCount . E.from $ \(courseApplication `E.InnerJoin` allocationCourse) -> do
E.on $ allocationCourse E.^. AllocationCourseCourse E.==. courseApplication E.^. CourseApplicationCourse
E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.just (allocationCourse E.^. AllocationCourseAllocation)
E.where_ $ courseApplication E.^. CourseApplicationUser E.==. allocationUser E.^. AllocationUserUser
E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.just (allocationUser E.^. AllocationUserAllocation)
E.where_ $ courseApplication E.^. CourseApplicationRatingVeto
@ -103,10 +116,13 @@ instance CsvColumnsExplained AllocationUserTableCsv where
getAUsersR, postAUsersR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html
getAUsersR = postAUsersR
postAUsersR tid ssh ash = do
usersTable <- runDB $ do
(usersTable, acceptForm) <- runDB $ do
Entity aId _ <- getBy404 $ TermSchoolAllocationShort tid ssh ash
now <- liftIO getCurrentTime
resultsDone <- (<= NTop (Just now)) . NTop <$> allocationDone aId
resultsDone <- is _Just <$> allocationStarted aId
allocMatching <- runMaybeT $ do
SessionDataAllocationResults allocMap <- MaybeT $ lookupSessionJson SessionAllocationResults
allocMatching <- fmap (view _3) . hoistMaybe $ allocMap !? (tid, ssh, ash)
return $ Map.fromListWith (<>) [ (uid, opoint cid) | (uid, cid) <- Set.toList allocMatching ] :: _ (Map UserId (NonNull (Set CourseId)))
csvName <- getMessageRender <*> pure (MsgAllocationUsersCsvName tid ssh ash)
@ -136,48 +152,75 @@ postAUsersR tid ssh ash = do
(,,,,)
<$> view _1 <*> view _2 <*> view (_3 . _Value) <*> view (_4 . _Value) <*> view (_5 . _Value)
dbtColonnade :: Colonnade Sortable _ _
dbtColonnade = mconcat
[ colUserDisplayName $ resultUser . _entityVal . $(multifocusL 2) _userDisplayName _userSurname
, colUserMatriculation $ resultUser . _entityVal . _userMatrikelnummer
, colAllocationRequested $ resultAllocationUser . _entityVal . _allocationUserTotalCourses
, coursesModalApplied $ colAllocationApplied resultAppliedCourses
, coursesModalVetoed $ colAllocationVetoed resultVetoedCourses
, coursesModalAssigned . assignedHeated $ colAllocationAssigned resultAssignedCourses
, emptyOpticColonnade' emptyPriorityCell (resultAllocationUser . _entityVal . _allocationUserPriority . _Just) colAllocationPriority
dbtColonnade = mconcat . catMaybes $
[ pure $ colUserDisplayName (resultUser . _entityVal . $(multifocusL 2) _userDisplayName _userSurname)
, pure $ colUserMatriculation (resultUser . _entityVal . _userMatrikelnummer)
, pure $ colAllocationRequested (resultAllocationUser . _entityVal . _allocationUserTotalCourses)
, pure . coursesModalApplied $ colAllocationApplied resultAppliedCourses
, pure . coursesModalVetoed $ colAllocationVetoed resultVetoedCourses
, guardOn resultsDone . coursesModalAssigned . bool id (assignedHeated $ view resultAssignedCourses) resultsDone $ colAllocationAssigned resultAssignedCourses
, coursesModalNewAssigned <$> do
allocMatching' <- allocMatching
let newAssigned uid = maybe 0 olength $ allocMatching' !? uid
pure . assignedHeated (views (resultUser . _entityKey) newAssigned) . sortable (Just "new-assigned") (i18nCell MsgAllocationUserNewMatches) .
views (resultUser . _entityKey) $ cell . toWidget . toMarkup . newAssigned
, pure $ emptyOpticColonnade' emptyPriorityCell (resultAllocationUser . _entityVal . _allocationUserPriority . _Just) colAllocationPriority
]
where
emptyPriorityCell = addCellClass ("table__td--center" :: Text) . cell $
messageTooltip =<< messageIconI Error IconMissingAllocationPriority MsgAllocationMissingPrioritiesIgnored
assignedHeated
| resultsDone = imapColonnade assignedHeated'
| otherwise = id
assignedHeated fAssigned = imapColonnade assignedHeated'
where
assignedHeated' res
= let maxAssign = min (res ^. resultAllocationUser . _entityVal . _allocationUserTotalCourses . to fromIntegral)
(res ^. resultAppliedCourses)
assigned = maxAssign - res ^. resultAssignedCourses
assigned = fAssigned res
in cellAttrs <>~ [ ("class", "heated")
, ("style", [st|--hotness: #{tshow (heat maxAssign assigned)}|])
, ("style", [st|--hotness: #{tshow (coHeat maxAssign assigned)}|])
]
coursesModalApplied = coursesModal $ \res -> E.from $ \(course `E.InnerJoin` courseApplication) -> do
E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse
E.where_ $ courseApplication E.^. CourseApplicationAllocation E.==. E.val (Just aId)
E.&&. courseApplication E.^. CourseApplicationUser E.==. E.val (res ^. resultUser . _entityKey)
E.orderBy [E.desc $ courseApplication E.^. CourseApplicationAllocationPriority]
return course
return ( course
, courseApplication E.^. CourseApplicationRatingPoints
, E.just $ courseApplication E.^. CourseApplicationRatingVeto
, E.exists . E.from $ \allocationCourse ->
E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId
)
coursesModalVetoed = coursesModal $ \res -> E.from $ \(course `E.InnerJoin` courseApplication) -> do
E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse
E.where_ $ courseApplication E.^. CourseApplicationAllocation E.==. E.val (Just aId)
E.&&. courseApplication E.^. CourseApplicationUser E.==. E.val (res ^. resultUser . _entityKey)
E.where_ $ courseApplication E.^. CourseApplicationRatingVeto
E.||. courseApplication E.^. CourseApplicationRatingPoints `E.in_` E.valList (map Just $ filter (view $ passingGrade . _Wrapped . to not) universeF)
return course
return ( course
, E.nothing
, E.nothing
, E.exists . E.from $ \allocationCourse ->
E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId
)
coursesModalAssigned = coursesModal $ \res -> E.from $ \(course `E.InnerJoin` courseParticipant) -> do
E.on $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
E.&&. courseParticipant E.^. CourseParticipantAllocated E.==. E.val (Just aId)
E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val (res ^. resultUser . _entityKey)
E.orderBy [E.asc $ courseParticipant E.^. CourseParticipantRegistration]
return course
return ( course
, E.nothing
, E.nothing
, courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
)
coursesModalNewAssigned = coursesModal $ \res -> E.from $ \course -> do
E.where_ $ course E.^. CourseId `E.in_` E.valList (maybe [] otoList $ Map.lookup (res ^. resultUser . _entityKey) =<< allocMatching)
return ( course
, E.nothing
, E.nothing
, E.true
)
coursesModal :: (_ -> E.SqlQuery (E.SqlExpr (Entity Course), E.SqlExpr (E.Value (Maybe ExamGrade)), E.SqlExpr (E.Value (Maybe Bool)), E.SqlExpr (E.Value Bool))) -> _ -> _
coursesModal courseSel = imapColonnade coursesModal'
where
coursesModal' res innerCell = review dbCell . (innerCell ^. cellAttrs, ) $ do
@ -185,19 +228,22 @@ postAUsersR tid ssh ash = do
contents <- innerCell ^. cellContents
return $ if
| null courses -> contents
| otherwise -> $(widgetFile "table/cell/allocation-courses")
| otherwise -> let tooltipContent = $(widgetFile "table/cell/allocation-courses")
in $(widgetFile "widgets/tooltip_no-handle")
dbtSorting = mconcat
[ sortUserName' $ queryUser . $(multifocusG 2) (to (E.^. UserDisplayName)) (to (E.^. UserSurname))
, sortUserMatriculation $ queryUser . (to (E.^. UserMatrikelnummer))
, sortUserMatriculation $ queryUser . to (E.^. UserMatrikelnummer)
, sortAllocationApplied queryAppliedCourses
, sortAllocationAssigned queryAssignedCourses
, sortAllocationRequested $ queryAllocationUser . (to (E.^. AllocationUserTotalCourses))
, sortAllocationRequested $ queryAllocationUser . to (E.^. AllocationUserTotalCourses)
, sortAllocationVetoed queryVetoedCourses
, sortAllocationPriority $ queryAllocationUser . (to (E.^. AllocationUserPriority))
, sortAllocationPriority $ queryAllocationUser . to (E.^. AllocationUserPriority)
, singletonMap "new-assigned" $
SortProjected . comparing $ (\uid -> maybe 0 olength $ Map.lookup uid =<< allocMatching) . view (resultUser . _entityKey)
]
dbtFilter = mconcat
[ fltrUserName' $ queryUser . (to (E.^. UserDisplayName))
, fltrUserMatriculation $ queryUser . (to (E.^. UserMatrikelnummer))
[ fltrUserName' $ queryUser . to (E.^. UserDisplayName)
, fltrUserMatriculation $ queryUser . to (E.^. UserMatrikelnummer)
]
dbtFilterUI = mconcat
[ fltrUserNameUI'
@ -220,12 +266,22 @@ postAUsersR tid ssh ash = do
dbtCsvDecode = Nothing
allocationUsersDBTableValidator = def
& defaultSorting [SortAscBy "priority", SortAscBy "user-matriculation"]
& defaultPagesize PagesizeAll
& defaultPagesize (PagesizeLimit 500)
usersTable <- dbTableDB' allocationUsersDBTableValidator allocationUsersDBTable
return usersTable
acceptForm <- allocationAcceptForm aId
return (usersTable, acceptForm)
acceptView <- for acceptForm $ \acceptForm' -> do
(acceptWgt, acceptEnctype) <- generateFormPost acceptForm'
return $ wrapForm' BtnAllocationAccept acceptWgt def
{ formAction = Just . SomeRoute $ AllocationR tid ssh ash AAcceptR
, formEncoding = acceptEnctype
}
siteLayoutMsg MsgMenuAllocationUsers $ do
setTitleI $ MsgAllocationUsersTitle tid ssh ash
usersTable
$(widgetFile "allocation/users")

289
src/Handler/Corrections.hs
View File

@ -1,4 +1,19 @@
module Handler.Corrections where
module Handler.Corrections
( getCorrectionsR, postCorrectionsR
, getCCorrectionsR, postCCorrectionsR
, getSSubsR, postSSubsR
, getCorrectionR, postCorrectionR
, getCorrectionsUploadR, postCorrectionsUploadR
, getCorrectionsCreateR, postCorrectionsCreateR
, getCorrectionsGradeR, postCorrectionsGradeR
, getCAssignR, postCAssignR
, getSAssignR, postSAssignR
, correctionsR'
, ratedBy, courseIs, sheetIs, userIs
, colTerm, colSchool, colCourse, colSheet, colCorrector, colSubmissionLink, colSelect, colSubmittors, colSMatrikel, colRating, colAssigned, colRated, colPseudonyms, colRatedField, colPointsField, colMaxPointsField, colCommentField, colLastEdit
, makeCorrectionsTable
, ActionCorrections(..), downloadAction, deleteAction, assignAction, autoAssignAction
) where
import Import hiding (link)
-- import System.FilePath (takeFileName)
@ -52,7 +67,7 @@ import qualified Data.Conduit.List as C
type CorrectionTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
type CorrectionTableWhere = CorrectionTableExpr -> E.SqlExpr (E.Value Bool)
type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (CourseName, CourseShorthand, Key Term, Key School), Maybe (Entity User), Maybe UTCTime, Map UserId (User, Maybe Pseudonym))
type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (CourseName, CourseShorthand, Key Term, Key School), Maybe (Entity User), Maybe UTCTime, Map UserId (User, Maybe Pseudonym, Maybe SubmissionGroupName), CryptoFileNameSubmission, Bool {- Access to non-anonymous submission data -})
correctionsTableQuery :: CorrectionTableWhere -> (CorrectionTableExpr -> v) -> CorrectionTableExpr -> E.SqlQuery v
correctionsTableQuery whereClause returnStatement t@((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) = do
@ -71,9 +86,6 @@ lastEditQuery submission = E.subSelectMaybe $ E.from $ \edit -> do
queryCourse :: CorrectionTableExpr -> E.SqlExpr (Entity Course)
queryCourse = $(sqlIJproj 3 1) . $(sqlLOJproj 2 1)
querySheet :: CorrectionTableExpr -> E.SqlExpr (Entity Sheet)
querySheet = $(sqlIJproj 3 2) . $(sqlLOJproj 2 1)
querySubmission :: CorrectionTableExpr -> E.SqlExpr (Entity Submission)
querySubmission = $(sqlIJproj 3 3) . $(sqlLOJproj 2 1)
@ -90,6 +102,12 @@ courseIs cid (( course `E.InnerJoin` _sheet `E.InnerJoin` _submission) `E.LeftO
sheetIs :: Key Sheet -> CorrectionTableWhere
sheetIs shid ((_course `E.InnerJoin` sheet `E.InnerJoin` _submission) `E.LeftOuterJoin` _corrector) = sheet E.^. SheetId E.==. E.val shid
userIs :: Key User -> CorrectionTableWhere
userIs uid ((_course `E.InnerJoin` _sheet `E.InnerJoin` submission) `E.LeftOuterJoin` _corrector) = E.exists . E.from $ \submissionUser ->
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
E.&&. submissionUser E.^. SubmissionUserUser E.==. E.val uid
-- Columns
colTerm :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
@ -104,7 +122,7 @@ colSchool = sortable (Just "school") (i18nCell MsgCourseSchool)
colCourse :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
colCourse = sortable (Just "course") (i18nCell MsgCourse)
$ \DBRow{ dbrOutput=(_, _, (_,csh,tid,sid),_ , _, _) } -> courseCellCL (tid,sid,csh)
$ \DBRow{ dbrOutput=(_, _, (_,csh,tid,sid),_ , _, _, _, _) } -> courseCellCL (tid,sid,csh)
colSheet :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
colSheet = sortable (Just "sheet") (i18nCell MsgSheet) $ \row ->
@ -116,51 +134,54 @@ colSheet = sortable (Just "sheet") (i18nCell MsgSheet) $ \row ->
shn = sheetName $ entityVal sheet
in anchorCell (CSheetR tid ssh csh shn SShowR) [whamlet|_{shn}|]
colSheetType :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
colSheetType = sortable (toNothing "sheetType") (i18nCell MsgSheetType) $
i18nCell . sheetType <$> view (_dbrOutput . _2 . _entityVal)
-- \DBRow{ dbrOutput=(_, sheet, _, _, _, _) } -> i18nCell . sheetType $ entityVal sheet
colCorrector :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector) $ \case
DBRow{ dbrOutput = (_, _, _, Nothing , _, _) } -> cell mempty
DBRow{ dbrOutput = (_, _, _, Just (Entity _ User{..}), _, _) } -> userCell userDisplayName userSurname
DBRow{ dbrOutput = (_, _, _, Nothing , _, _, _, _) } -> cell mempty
DBRow{ dbrOutput = (_, _, _, Just (Entity _ User{..}), _, _, _, _) } -> userCell userDisplayName userSurname
colSubmissionLink :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
colSubmissionLink = sortable Nothing (i18nCell MsgSubmission)
$ \DBRow{ dbrOutput=(submission, sheet, course, _, _,_) } ->
colSubmissionLink = sortable (Just "submission") (i18nCell MsgSubmission)
$ \DBRow{ dbrOutput=(_, sheet, course, _, _,_, cid, _) } ->
let csh = course ^. _2
tid = course ^. _3
ssh = course ^. _4
shn = sheetName $ entityVal sheet
mkCid = encrypt (entityKey submission :: SubmissionId) -- TODO: executed twice
mkRoute = do
cid <- mkCid
return $ CSubmissionR tid ssh csh shn cid SubShowR
in anchorCellM mkRoute (mkCid >>= \cid -> [whamlet|#{cid}|])
in anchorCellC $cacheIdentHere (CSubmissionR tid ssh csh shn cid SubShowR) (toPathPiece cid)
colSelect :: forall act h. (Semigroup act, Monoid act, Headedness h) => Colonnade h CorrectionTableData (DBCell _ (FormResult (act, DBFormResult CryptoFileNameSubmission Bool CorrectionTableData), SheetTypeSummary))
colSelect = dbSelect (_1 . applying _2) id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _) } -> encrypt subId
colSelect = dbSelect (_1 . applying _2) id $ \DBRow{ dbrOutput=(_, _, _, _, _, _, cid, _) } -> return cid
colSubmittors :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, _, course, _, _, users) } -> let
csh = course ^. _2
tid = course ^. _3
ssh = course ^. _4
link cid = CourseR tid ssh csh $ CUserR cid
protoCell = listCell (Map.toList users) $ \(userId, (User{..}, mPseudo)) ->
anchorCellM (link <$> encrypt userId) $ case mPseudo of
Nothing -> nameWidget userDisplayName userSurname
Just p -> [whamlet|^{nameWidget userDisplayName userSurname} (#{review _PseudonymText p})|]
in protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, Entity _ Sheet{..}, course, _, _, users, _, hasAccess) } ->
let
csh = course ^. _2
tid = course ^. _3
ssh = course ^. _4
link cid = CourseR tid ssh csh $ CUserR cid
protoCell = listCell (Map.toList users) $ \(userId, (User{..}, mPseudo, _)) ->
anchorCellCM $cacheIdentHere (link <$> encrypt userId) $ case mPseudo of
Nothing -> nameWidget userDisplayName userSurname
Just p -> [whamlet|^{nameWidget userDisplayName userSurname} (#{review _PseudonymText p})|]
in if | hasAccess -> protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
| otherwise -> mempty
colSMatrikel :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
colSMatrikel = sortable Nothing (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput=(_, _, _, _, _, users) } -> let
protoCell = listCell (Map.toList users) $ \(userId, (User{..}, _)) -> anchorCellM (AdminUserR <$> encrypt userId) (fromMaybe mempty userMatrikelnummer)
in protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
colSMatrikel = sortable (Just "submittors-matriculation") (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput=(_, Entity _ Sheet{..}, (_, csh, tid, ssh), _, _, users, _, hasAccess) } ->
let protoCell = listCell (Map.toList $ Map.mapMaybe (\x@(User{..}, _, _) -> (x,) <$> assertM (not . null) userMatrikelnummer) users) $ \(userId, ((User{..}, _, _), matr)) -> anchorCellCM $cacheIdentHere (CourseR tid ssh csh . CUserR <$> encrypt userId) matr
in if | hasAccess -> protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
| otherwise -> mempty
colSGroups :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
colSGroups = sortable (Just "submittors-group") (i18nCell MsgSubmissionGroup) $ \DBRow{ dbrOutput=(_, Entity _ Sheet{..}, _, _, _, users, _, hasAccess) } ->
let protoCell = listCell (nubOn (view _2) . Map.toList $ Map.mapMaybe (view _3) users) $ \(_, sGroup) -> cell $ toWidget sGroup
in if | hasAccess
, is _RegisteredGroups sheetGrouping
-> protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
| otherwise
-> mempty
colRating :: forall m a. IsDBTable m (a, SheetTypeSummary) => Colonnade Sortable CorrectionTableData (DBCell m (a, SheetTypeSummary))
colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(Entity subId sub@Submission{..}, Entity _ Sheet{..}, course, _, _, _) } ->
colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(Entity subId sub@Submission{..}, Entity _ Sheet{..}, course, _, _, _, _, _) } ->
let csh = course ^. _2
tid = course ^. _3
ssh = course ^. _4
@ -171,7 +192,7 @@ colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(E
return $ CSubmissionR tid ssh csh sheetName cid CorrectionR
mTuple mA mB = (,) <$> mA <*> mB -- Hamlet does not support enough haskell-syntax for this
in mconcat
[ anchorCellM mkRoute $(widgetFile "widgets/rating/rating")
[ anchorCellCM $cacheIdentHere mkRoute $(widgetFile "widgets/rating/rating")
, writerCell $ do
let
summary :: SheetTypeSummary
@ -180,48 +201,48 @@ colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(E
]
colAssigned :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
colAssigned = sortable (Just "assignedtime") (i18nCell MsgAssignedTime) $ \DBRow{ dbrOutput=(Entity _subId Submission{..}, _sheet, _course, _, _, _) } ->
colAssigned = sortable (Just "assignedtime") (i18nCell MsgAssignedTime) $ \DBRow{ dbrOutput=(Entity _subId Submission{..}, _sheet, _course, _, _, _, _, _) } ->
maybe mempty dateTimeCell submissionRatingAssigned
colRated :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
colRated = sortable (Just "ratingtime") (i18nCell MsgRatingTime) $ \DBRow{ dbrOutput=(Entity _subId Submission{..}, _sheet, _course, _, _, _) } ->
colRated = sortable (Just "ratingtime") (i18nCell MsgRatingTime) $ \DBRow{ dbrOutput=(Entity _subId Submission{..}, _sheet, _course, _, _, _, _, _) } ->
maybe mempty dateTimeCell submissionRatingTime
colPseudonyms :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
colPseudonyms = sortable Nothing (i18nCell MsgPseudonyms) $ \DBRow{ dbrOutput=(_, _, _, _, _, users) } -> let
lCell = listCell (catMaybes $ snd . snd <$> Map.toList users) $ \pseudo ->
colPseudonyms = sortable Nothing (i18nCell MsgPseudonyms) $ \DBRow{ dbrOutput=(_, _, _, _, _, users, _, _) } -> let
lCell = listCell (catMaybes $ view (_2 . _2) <$> Map.toList users) $ \pseudo ->
cell [whamlet|#{review _PseudonymText pseudo}|]
in lCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
colRatedField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (Bool, a, b) CorrectionTableData)))
colRatedField = sortable Nothing (i18nCell MsgRatingDone) $ formCell id
(\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _) } -> return subId)
(\DBRow{ dbrOutput=(Entity _ (submissionRatingDone -> done), _, _, _, _, _) } mkUnique -> over (_1.mapped) (_1 .~) . over _2 fvInput <$> mreq checkBoxField (fsUniq mkUnique "rated") (Just done))
(\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _, _, _) } -> return subId)
(\DBRow{ dbrOutput=(Entity _ (submissionRatingDone -> done), _, _, _, _, _, _, _) } mkUnique -> over (_1.mapped) (_1 .~) . over _2 fvInput <$> mreq checkBoxField (fsUniq mkUnique "rated") (Just done))
colPointsField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, Maybe Points, b) CorrectionTableData)))
colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ formCell id
(\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _) } -> return subId)
(\DBRow{ dbrOutput=(Entity _ Submission{..}, Entity _ Sheet{..}, _, _, _, _) } mkUnique -> case sheetType of
(\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _, _, _) } -> return subId)
(\DBRow{ dbrOutput=(Entity _ Submission{..}, Entity _ Sheet{..}, _, _, _, _, _, _) } mkUnique -> case sheetType of
NotGraded -> over (_1.mapped) (_2 .~) <$> pure (FormSuccess Nothing, mempty)
_other -> over (_1.mapped) (_2 .~) . over _2 fvInput <$> mopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType) (fsUniq mkUnique "points") (Just submissionRatingPoints)
)
colMaxPointsField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, Maybe Points, b) CorrectionTableData)))
colMaxPointsField = sortable (Just "sheet-type") (i18nCell MsgSheetType) $ i18nCell . (\DBRow{ dbrOutput=(_, Entity _ Sheet{sheetType}, _, _, _, _) } -> sheetType)
colMaxPointsField = sortable (Just "sheet-type") (i18nCell MsgSheetType) $ i18nCell . (\DBRow{ dbrOutput=(_, Entity _ Sheet{sheetType}, _, _, _, _, _, _) } -> sheetType)
colCommentField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, b, Maybe Text) CorrectionTableData)))
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))
(\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))
colLastEdit :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
colLastEdit = sortable (Just "last-edit") (i18nCell MsgLastEdit) $
\DBRow{ dbrOutput=(_, _, _, _, mbLastEdit, _) } -> maybe mempty dateTimeCell mbLastEdit
\DBRow{ dbrOutput=(_, _, _, _, mbLastEdit, _, _, _) } -> maybe mempty dateTimeCell mbLastEdit
makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h )
=> CorrectionTableWhere -> Colonnade h CorrectionTableData (DBCell m x) -> _ -> PSValidator m x -> _ -> DBParams m x -> DB (DBResult m x)
makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' dbtParams = do
=> CorrectionTableWhere -> Colonnade h CorrectionTableData (DBCell m x) -> _ -> PSValidator m x -> DBParams m x -> DB (DBResult m x)
makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtParams = do
let dbtSQLQuery :: CorrectionTableExpr -> E.SqlQuery _
dbtSQLQuery = correctionsTableQuery whereClause
(\((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) ->
@ -232,18 +253,27 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d
)
in (submission, sheet, crse, corrector, lastEditQuery submission)
)
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
dbtProj :: DBRow _ -> DB CorrectionTableData
dbtProj = traverse $ \(submission@(Entity sId _), sheet@(Entity shId Sheet{..}), (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector, E.Value mbLastEdit) -> do
submittors <- E.select . E.from $ \((submissionUser `E.InnerJoin` user) `E.LeftOuterJoin` pseudonym) -> do
E.on $ pseudonym E.?. SheetPseudonymUser E.==. E.just (user E.^. UserId)
E.&&. pseudonym E.?. SheetPseudonymSheet E.==. E.just (E.val shId)
E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val sId
E.orderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName]
return (user, pseudonym E.?. SheetPseudonymPseudonym)
let submissionGroup' = E.subSelectMaybe . E.from $ \(submissionGroup `E.InnerJoin` submissionGroupUser) -> do
E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup
E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val sheetCourse
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. user E.^. UserId
return . E.just $ submissionGroup E.^. SubmissionGroupName
return (user, pseudonym E.?. SheetPseudonymPseudonym, submissionGroup')
let
submittorMap = List.foldr (\(Entity userId user, E.Value pseudo) -> Map.insert userId (user, pseudo)) Map.empty submittors
dbtProj' (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, mbLastEdit, submittorMap)
submittorMap = List.foldr (\(Entity userId user, E.Value pseudo, E.Value sGroup) -> Map.insert userId (user, pseudo, sGroup)) Map.empty submittors
nonAnonymousAccess <- or2M
(return $ not sheetAnonymousCorrection)
(hasReadAccessTo $ CourseR courseTerm courseSchool courseShorthand CCorrectionsR)
cid <- encrypt sId
return (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, mbLastEdit, submittorMap, cid, nonAnonymousAccess)
dbTable psValidator DBTable
{ dbtSQLQuery
, dbtRowKey = \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) -> submission E.^. SubmissionId
@ -285,13 +315,13 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d
, SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingAssigned
)
, ( "submittors"
, SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) ->
E.subSelectUnsafe . E.from $ \(submissionUser `E.InnerJoin` user) -> do
E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
E.orderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName]
E.limit 1
return (user E.^. UserSurname)
, SortProjected . comparing $ \DBRow{ dbrOutput = (_, _, _, _, _, submittors, _, hasAccess) } -> guardOn @Maybe hasAccess . fmap ((userSurname &&& userDisplayName) . view _1) $ Map.elems submittors
)
, ( "submittors-matriculation"
, SortProjected . comparing $ \DBRow{ dbrOutput = (_, _, _, _, _, submittors, _, hasAccess) } -> guardOn @Maybe hasAccess . fmap (view $ _1 . _userMatrikelnummer) $ Map.elems submittors
)
, ( "submittors-group"
, SortProjected . comparing $ \DBRow{ dbrOutput = (_, _, _, _, _, submittors, _, hasAccess) } -> guardOn @Maybe hasAccess . fmap (view _3) $ Map.elems submittors
)
, ( "comment" -- sorting by comment specifically requested by correctors to easily see submissions to be done
, SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingComment
@ -299,6 +329,9 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d
, ( "last-edit"
, SortColumn $ \((_course `E.InnerJoin` _sheet `E.InnerJoin` submission) `E.LeftOuterJoin` _corrector) -> lastEditQuery submission
)
, ( "submission"
, SortProjected . comparing $ toPathPiece . view (_dbrOutput . _7)
)
]
, dbtFilter = Map.fromList
[ ( "term"
@ -368,6 +401,13 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d
E.where_ $ (\f -> f user $ Set.singleton needle) $
E.mkContainsFilter (E.^. UserMatrikelnummer)
)
, ( "submission-group"
, FilterColumn $ E.mkExistsFilter $ \table needle -> E.from $ \(submissionGroup `E.InnerJoin` submissionGroupUser) -> do
E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup
E.where_ $ queryCourse table E.^. CourseId E.==. submissionGroup E.^. SubmissionGroupCourse
E.where_ $ (\f -> f submissionGroup $ Set.singleton needle) $
E.mkContainsFilter (E.^. SubmissionGroupName)
)
, ( "rating-visible"
, FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) criterion -> case getLast (criterion :: Last Bool) of
Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
@ -384,6 +424,12 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d
Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
Just needle -> E.maybe (E.val False :: E.SqlExpr (E.Value Bool)) (E.isInfixOf $ E.val needle) (submission E.^. SubmissionRatingComment)
)
, ( "submission"
, FilterProjected $ \(DBRow{..} :: CorrectionTableData) (criteria :: Set Text) ->
let cid = map CI.mk . unpack . toPathPiece $ dbrOutput ^. _7
criteria' = map CI.mk . unpack <$> Set.toList criteria
in any (\c -> c `isInfixOf` cid) criteria'
)
]
, dbtFilterUI = fromMaybe mempty dbtFilterUI
, dbtStyle = def { dbsFilterLayout = maybe (\_ _ _ -> id) (\_ -> defaultDBSFilterLayout) dbtFilterUI }
@ -405,13 +451,21 @@ instance Finite ActionCorrections
nullaryPathPiece ''ActionCorrections $ camelToPathPiece' 1
embedRenderMessage ''UniWorX ''ActionCorrections id
data ActionCorrectionsData = CorrDownloadData
data ActionCorrectionsData = CorrDownloadData SubmissionDownloadAnonymous
| CorrSetCorrectorData (Maybe UserId)
| CorrAutoSetCorrectorData SheetId
| CorrDeleteData
correctionsR :: _ -> _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerFor UniWorX) ActionCorrectionsData) -> Handler TypedContent
correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do
(table, statistics) <- correctionsR' whereClause displayColumns dbtFilterUI psValidator actions
fmap toTypedContent . defaultLayout $ do
setTitleI MsgCourseCorrectionsTitle
$(widgetFile "corrections")
correctionsR' :: _ -> _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerFor UniWorX) ActionCorrectionsData) -> Handler (Widget, SheetTypeSummary)
correctionsR' whereClause displayColumns dbtFilterUI psValidator actions = do
currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler
postDeleteR $ \drRecords -> (submissionDeleteRoute drRecords)
@ -420,7 +474,7 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do
}
((actionRes', statistics), table) <- runDB $
makeCorrectionsTable whereClause displayColumns dbtFilterUI psValidator return DBParamsForm
makeCorrectionsTable whereClause displayColumns dbtFilterUI psValidator DBParamsForm
{ dbParamsFormMethod = POST
, dbParamsFormAction = Just $ SomeRoute currentRoute
, dbParamsFormAttrs = []
@ -445,14 +499,12 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do
& mapped._1 %~ fromMaybe (error "By consctruction the form should always return an action") . getLast
auditAllSubEdit = mapM_ $ \sId -> getJust sId >>= \sub -> audit $ TransactionSubmissionEdit sId $ sub ^. _submissionSheet
case actionRes of
FormFailure errs -> mapM_ (addMessage Warning . toHtml) errs
FormMissing -> return ()
FormSuccess (CorrDownloadData, subs) -> do
formResult actionRes $ \case
(CorrDownloadData nonAnonymous, subs) -> do
ids <- Set.fromList <$> forM (Set.toList subs) decrypt -- Set is not traversable
addHeader "Content-Disposition" [st|attachment; filename="corrections.zip"|]
sendResponse =<< submissionMultiArchive ids
FormSuccess (CorrSetCorrectorData (Just uid), subs') -> do
sendResponse =<< submissionMultiArchive nonAnonymous ids
(CorrSetCorrectorData (Just uid), subs') -> do
subs <- mapM decrypt $ Set.toList subs'
now <- liftIO getCurrentTime
runDB $ do
@ -485,7 +537,7 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do
return (E.countRows :: E.SqlExpr (E.Value Int64))
when (selfCorrectors > 0) $ addMessageI Warning $ MsgSelfCorrectors selfCorrectors
redirect currentRoute
FormSuccess (CorrSetCorrectorData Nothing, subs') -> do -- delete corrections
(CorrSetCorrectorData Nothing, subs') -> do -- delete corrections
subs <- mapM decrypt $ Set.toList subs'
runDB $ do
num <- updateWhereCount [SubmissionId <-. subs]
@ -498,7 +550,7 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do
addMessageI Success $ MsgRemovedCorrections num
auditAllSubEdit subs
redirect currentRoute
FormSuccess (CorrAutoSetCorrectorData shid, subs') -> do
(CorrAutoSetCorrectorData shid, subs') -> do
subs <- mapM decrypt $ Set.toList subs'
let
assignExceptions :: AssignSubmissionException -> Handler ()
@ -535,16 +587,14 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do
unassigned' <- forM (Set.toList stillUnassigned) $ \sid -> encrypt sid :: DB CryptoFileNameSubmission
addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsNotAssignedAuto.hamlet") mr)
redirect currentRoute
FormSuccess (CorrDeleteData, subs) -> do
(CorrDeleteData, subs) -> do
subs' <- Set.fromList <$> forM (Set.toList subs) decrypt -- Set is not traversable
getDeleteR (submissionDeleteRoute subs')
{ drAbort = SomeRoute currentRoute
, drSuccess = SomeRoute currentRoute
}
fmap toTypedContent . defaultLayout $ do
setTitleI MsgCourseCorrectionsTitle
$(widgetFile "corrections")
return (table, statistics)
where
authorizedToAssign :: SubmissionId -> DB Bool
@ -559,11 +609,22 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do
let route = CSubmissionR tid ssh csh shn cID SubAssignR
(== Authorized) <$> evalAccessDB route True
restrictAnonymous :: PSValidator m x -> PSValidator m x
restrictAnonymous = restrictFilter (\k _ -> k /= "user-matriclenumber")
. restrictFilter (\k _ -> k /= "user-name-email")
. restrictFilter (\k _ -> k /= "submission-group")
. restrictSorting (\k _ -> k /= "last-edit")
restrictCorrector :: PSValidator m x -> PSValidator m x
restrictCorrector = restrictFilter (\k _ -> k /= "corrector")
. restrictFilter (\k _ -> k /= "corrector-name-email")
. restrictSorting (\k _ -> k /= "corrector")
type ActionCorrections' = (ActionCorrections, AForm (HandlerFor UniWorX) ActionCorrectionsData)
downloadAction, deleteAction :: ActionCorrections'
downloadAction = ( CorrDownload
, pure CorrDownloadData
, CorrDownloadData <$> apopt (selectField optionsFinite) (fslI MsgCorrDownloadAnonymous & setTooltip MsgCorrDownloadAnonymousTip) (Just SubmissionDownloadAnonymous)
)
deleteAction = ( CorrDelete
, pure CorrDeleteData
@ -601,11 +662,13 @@ postCorrectionsR = do
let whereClause = ratedBy uid
colonnade = mconcat
[ colSelect
, dbRow -- very useful, since correction statistics are still missing.
, colSchool
, colTerm
, colCourse
, colSheet
, colSMatrikel
, colSubmittors
, colSGroups
, colPseudonyms
, colSubmissionLink
, colAssigned
@ -618,6 +681,7 @@ postCorrectionsR = do
, prismAForm (singletonFilter "school" ) mPrev $ aopt (lift `hoistField` selectField schoolOptions) (fslI MsgCourseSchool)
, Map.singleton "sheet-search" . maybeToList <$> aopt (lift `hoistField` textField) (fslI MsgSheet) (Just <$> listToMaybe =<< ((Map.lookup "sheet-search" =<< mPrev) <|> (Map.lookup "sheet" =<< mPrev)))
, prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgRatingTime)
, prismAForm (singletonFilter "submission") mPrev $ aopt (lift `hoistField` textField) (fslI MsgSubmission)
]
courseOptions = runDB $ do
courses <- selectList [] [Asc CourseShorthand] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand)
@ -630,8 +694,8 @@ postCorrectionsR = do
optionsPairs $ map (id &&& id) $ nub $ map (CI.original . unSchoolKey . courseSchool . entityVal) courses
psValidator = def
& restrictFilter (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
& restrictSorting (\name _ -> name /= "corrector")
& restrictCorrector
& restrictAnonymous
& defaultSorting [SortAscBy "israted", SortDescBy "ratingTime", SortAscBy "assignedtime" ]
-- & defaultFilter (Map.fromList [("israted",[toPathPiece False])]) -- DEPENDS ON ISSUE #371 UNCOMMENT THEN
correctionsR whereClause colonnade filterUI psValidator $ Map.fromList
@ -645,10 +709,10 @@ postCCorrectionsR tid ssh csh = do
let whereClause = courseIs cid
colonnade = mconcat -- should match getSSubsR for consistent UX
[ colSelect
, dbRow
, colSheet
, colSMatrikel
, colSubmittors
, colSGroups
, colSubmissionLink
, colLastEdit
, colRating
@ -664,6 +728,8 @@ postCCorrectionsR tid ssh csh = do
, prismAForm (singletonFilter "corrector-name-email") mPrev $ aopt textField (fslI MsgCorrector)
, prismAForm (singletonFilter "isassigned" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgHasCorrector)
, prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgRatingTime)
, prismAForm (singletonFilter "submission-group") mPrev $ aopt textField (fslI MsgSubmissionGroup)
, prismAForm (singletonFilter "submission") mPrev $ aopt (lift `hoistField` textField) (fslI MsgSubmission)
]
psValidator = def & defaultPagesize PagesizeAll -- Assisstant always want to see them all at once anyway
correctionsR whereClause colonnade filterUI psValidator $ Map.fromList
@ -679,7 +745,6 @@ postSSubsR tid ssh csh shn = do
let whereClause = sheetIs shid
colonnade = mconcat -- should match getCCorrectionsR for consistent UX
[ colSelect
, dbRow
, colSMatrikel
, colSubmittors
, colSubmissionLink
@ -695,6 +760,8 @@ postSSubsR tid ssh csh shn = do
, prismAForm (singletonFilter "corrector-name-email") mPrev $ aopt textField (fslI MsgCorrector)
, prismAForm (singletonFilter "isassigned" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgHasCorrector)
, prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgRatingTime)
, prismAForm (singletonFilter "submission-group") mPrev $ aopt textField (fslI MsgSubmissionGroup)
, prismAForm (singletonFilter "submission") mPrev $ aopt (lift `hoistField` textField) (fslI MsgSubmission)
-- "pseudonym" TODO DB only stores Word24
]
psValidator = def & defaultPagesize PagesizeAll -- Assisstant always want to see them all at once anyway
@ -1025,6 +1092,9 @@ postCorrectionsGradeR = do
, colTerm
, colCourse
, colSheet
, colSMatrikel
, colSubmittors
, colSGroups
, colPseudonyms
, colSubmissionLink
, colRated
@ -1053,37 +1123,33 @@ postCorrectionsGradeR = do
courses <- selectList [] [Asc CourseSchool] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand)
optionsPairs $ map (id &&& id) $ nub $ map (CI.original . unSchoolKey . courseSchool . entityVal) courses
psValidator = def
& restrictAnonymous
& restrictCorrector
& 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
void . assertM (== Authorized) . lift $ evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) True
return i
unFormResult = getDBFormResult $ \DBRow{ dbrOutput = (Entity _ sub@Submission{..}, _, _, _, _, _, _, _) } -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment)
(fmap unFormResult -> tableRes, table) <- runDB $ makeCorrectionsTable whereClause displayColumns filterUI psValidator dbtProj' $ def
(fmap unFormResult -> tableRes, table) <- runDB $ makeCorrectionsTable whereClause displayColumns filterUI psValidator $ def
{ dbParamsFormAction = Just $ SomeRoute CorrectionsGradeR
}
case tableRes of
FormMissing -> return ()
FormFailure errs -> forM_ errs $ addMessage Error . toHtml
FormSuccess resMap -> do
now <- liftIO getCurrentTime
subs <- fmap catMaybes . runDB . forM (Map.toList resMap) $ \(subId, (rated, mPoints, mComment)) -> do
s@Submission{..} <- get404 subId
if
| submissionRatingPoints /= mPoints || submissionRatingComment /= mComment || rated /= submissionRatingDone s
-> do audit $ TransactionSubmissionEdit subId $ s ^. _submissionSheet
Just subId <$ update subId [ SubmissionRatingPoints =. mPoints
, SubmissionRatingComment =. mComment
, SubmissionRatingBy =. Just uid
, SubmissionRatingTime =. now <$ guard rated
]
| otherwise -> return Nothing
subs' <- traverse (\x -> (,) <$> encrypt x <*> encrypt x) subs :: Handler [(CryptoFileNameSubmission, CryptoUUIDSubmission)]
let trigger = [whamlet|_{MsgCorrectionsUploaded (genericLength subs')}|]
content = Right $(widgetFile "messages/correctionsUploaded")
unless (null subs') $ addMessageModal Success trigger content
formResult tableRes $ \resMap -> do
now <- liftIO getCurrentTime
subs <- fmap catMaybes . runDB . forM (Map.toList resMap) $ \(subId, (rated, mPoints, mComment)) -> do
s@Submission{..} <- get404 subId
if
| submissionRatingPoints /= mPoints || submissionRatingComment /= mComment || rated /= submissionRatingDone s
-> do audit $ TransactionSubmissionEdit subId $ s ^. _submissionSheet
Just subId <$ update subId [ SubmissionRatingPoints =. mPoints
, SubmissionRatingComment =. mComment
, SubmissionRatingBy =. Just uid
, SubmissionRatingTime =. now <$ guard rated
]
| otherwise -> return Nothing
subs' <- traverse (\x -> (,) <$> encrypt x <*> encrypt x) subs :: Handler [(CryptoFileNameSubmission, CryptoUUIDSubmission)]
let trigger = [whamlet|_{MsgCorrectionsUploaded (genericLength subs')}|]
content = Right $(widgetFile "messages/correctionsUploaded")
unless (null subs') $ addMessageModal Success trigger content
redirect CorrectionsGradeR
siteLayoutMsg MsgCorrectionsGrade $ do
setTitleI MsgCorrectionsGrade
@ -1099,9 +1165,6 @@ embedRenderMessage ''UniWorX ''ButtonSubmissionsAssign id
instance Button UniWorX ButtonSubmissionsAssign where
btnClasses BtnSubmissionsAssign = [BCIsButton, BCPrimary]
-- | DEPRECATED use CorrectorInfo instead. Gather info about corrector assignment per sheet
data SubAssignInfo = SubAssignInfo { saiName :: SheetName, saiSubmissionNr, saiCorrectorNr, saiUnassignedNr :: Int }
getCAssignR, postCAssignR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCAssignR = postCAssignR
postCAssignR tid ssh csh = do
@ -1140,7 +1203,7 @@ assignHandler tid ssh csh cid assignSids = do
-- gather data
(orderedSheetNames, assignSheetNames, nrParticipants, groupsPossible, infoMap, correctorMap, assignment) <- runDB $ do
-- cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
nrParticipants <- count [CourseParticipantCourse ==. cid]
nrParticipants <- count [CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ]
sheetList <- selectList [SheetCourse ==. cid] [Desc SheetActiveTo, Desc SheetActiveFrom]
let orderedSheetNames = fmap (\(Entity _ Sheet{sheetName}) -> sheetName) sheetList

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

@ -257,6 +257,7 @@ getCApplicationsR, postCApplicationsR :: TermId -> SchoolId -> CourseShorthand -
getCApplicationsR = postCApplicationsR
postCApplicationsR tid ssh csh = do
(table, allocationsBounds, mayAccept) <- runDB $ do
now <- liftIO getCurrentTime
Entity cid Course{..} <- getBy404 $ TermSchoolCourseShort tid ssh csh
csvName <- getMessageRender <*> pure (MsgCourseApplicationsTableCsvName tid ssh csh)
@ -264,13 +265,13 @@ postCApplicationsR tid ssh csh = do
allocationLink :: Allocation -> SomeRoute UniWorX
allocationLink Allocation{..} = SomeRoute $ AllocationR allocationTerm allocationSchool allocationShorthand AShowR
participantLink :: MonadCrypto m => UserId -> m (SomeRoute UniWorX)
participantLink uid = do
participantLink :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m (SomeRoute UniWorX)
participantLink uid = liftHandler $ do
cID <- encrypt uid
return . SomeRoute . CourseR tid ssh csh $ CUserR cID
applicationLink :: MonadCrypto m => CourseApplicationId -> m (SomeRoute UniWorX)
applicationLink appId = do
applicationLink :: (MonadHandler m, HandlerSite m ~ UniWorX) => CourseApplicationId -> m (SomeRoute UniWorX)
applicationLink appId = liftHandler $ do
cID <- encrypt appId
return . SomeRoute $ CApplicationR tid ssh csh cID CAEditR
@ -288,6 +289,7 @@ postCApplicationsR tid ssh csh = do
lift $ do
E.on $ E.just (user E.^. UserId) E.==. courseParticipant E.?. CourseParticipantUser
E.&&. courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val cid)
E.&&. courseParticipant E.?. CourseParticipantState E.==. E.just (E.val CourseParticipantActive)
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
@ -295,6 +297,8 @@ postCApplicationsR tid ssh csh = do
E.on $ user E.^. UserId E.==. courseApplication E.^. CourseApplicationUser
E.&&. courseApplication E.^. CourseApplicationCourse E.==. E.val cid
E.where_ $ E.maybe E.true (E.maybe E.false (E.<=. E.val now)) (allocation E.?. AllocationStaffAllocationFrom)
return ( courseApplication
, user
, hasFiles
@ -305,14 +309,8 @@ postCApplicationsR tid ssh csh = do
, E.not_ . E.isNothing $ courseParticipant E.?. CourseParticipantId
)
dbtProj :: DBRow _ -> MaybeT (YesodDB UniWorX) CourseApplicationsTableData
dbtProj = runReaderT $ do
appId <- view $ _dbrOutput . _1 . _entityKey
cID <- encrypt appId
guardM . hasReadAccessTo $ CApplicationR tid ssh csh cID CAEditR
asks $ over (_dbrOutput . _3) E.unValue . over (_dbrOutput . _8) E.unValue
dbtProj :: DBRow _ -> DB CourseApplicationsTableData
dbtProj = traverse $ return . over _3 E.unValue . over _8 E.unValue
dbtRowKey = view $ queryCourseApplication . to (E.^. CourseApplicationId)
@ -431,7 +429,6 @@ postCApplicationsR tid ssh csh = do
CourseApplicationsTableCsvSetCommentData{} -> CourseApplicationsTableCsvSetComment
, dbtCsvCoarsenActionClass = const DBCsvActionExisting
, dbtCsvExecuteActions = do
now <- liftIO getCurrentTime
C.mapM_ $ \case
CourseApplicationsTableCsvSetFieldData{..} -> do
CourseApplication{..} <- updateGet caCsvActApplication [ CourseApplicationField =. caCsvActField
@ -591,7 +588,7 @@ postCApplicationsR tid ssh csh = do
psValidator = def
& defaultSorting [SortAscBy "user-name"]
participants <- count [ CourseParticipantCourse ==. cid ]
participants <- count [ CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ]
let remainingCapacity = subtract participants <$> courseCapacity
allocationsBounds' <- E.select . E.from $ \(allocation `E.InnerJoin` allocationCourse) -> do
@ -647,7 +644,7 @@ postCApplicationsR tid ssh csh = do
formResult acceptRes $ \(invMode, appsSecOrder) -> do
runDBJobs $ do
Entity cid Course{..} <- getBy404 $ TermSchoolCourseShort tid ssh csh
participants <- count [ CourseParticipantCourse ==. cid ]
participants <- count [ CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ]
let openCapacity = subtract participants <$> courseCapacity
applications <- E.select . E.from $ \(user `E.InnerJoin` application) -> do
@ -661,6 +658,7 @@ postCApplicationsR tid ssh csh = do
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
E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
return (user, application)
@ -684,6 +682,8 @@ postCApplicationsR tid ssh csh = do
mapM_ addMessage' <=< execWriterT $ registerUsers cid applicants
redirect $ CourseR tid ssh csh CUsersR
let
studyFeaturesWarning = $(i18nWidgetFile "applications-list-info")
siteLayoutMsg title $ do
setTitleI title

1
src/Handler/Course/Communication.hs
View File

@ -40,6 +40,7 @@ postCCommR tid ssh csh = do
, E.from $ \(user `E.InnerJoin` participant) -> do
E.on $ user E.^. UserId E.==. participant E.^. CourseParticipantUser
E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid
E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
return user
)
, ( RGCourseLecturers

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

@ -55,10 +55,11 @@ data CourseForm = CourseForm
data AllocationCourseForm = AllocationCourseForm
{ acfAllocation :: AllocationId
, acfMinCapacity :: Int
, acfDeregisterNoShow :: Bool
}
courseToForm :: Entity Course -> [Lecturer] -> Map UserEmail (InvitationDBData Lecturer) -> Maybe (Entity AllocationCourse) -> CourseForm
courseToForm (Entity cid Course{..}) lecs lecInvites alloc = CourseForm
courseToForm cEnt@(Entity cid Course{..}) lecs lecInvites alloc = CourseForm
{ cfCourseId = Just cid
, cfName = courseName
, cfDesc = courseDescription
@ -69,7 +70,7 @@ courseToForm (Entity cid Course{..}) lecs lecInvites alloc = CourseForm
, cfCapacity = courseCapacity
, cfSecret = courseRegisterSecret
, cfMatFree = courseMaterialFree
, cfAllocation = allocationCourseToForm <$> alloc
, cfAllocation = allocationCourseToForm cEnt <$> alloc
, cfAppRequired = courseApplicationsRequired
, cfAppInstructions = courseApplicationsInstructions
, cfAppInstructionFiles
@ -89,10 +90,11 @@ courseToForm (Entity cid Course{..}) lecs lecInvites alloc = CourseForm
return $ courseAppInstructionFile E.^. CourseAppInstructionFileFile
allocationCourseToForm :: Entity AllocationCourse -> AllocationCourseForm
allocationCourseToForm (Entity _ AllocationCourse{..}) = AllocationCourseForm
allocationCourseToForm :: Entity Course -> Entity AllocationCourse -> AllocationCourseForm
allocationCourseToForm (Entity _ Course{..}) (Entity _ AllocationCourse{..}) = AllocationCourseForm
{ acfAllocation = allocationCourseAllocation
, acfMinCapacity = allocationCourseMinCapacity
, acfDeregisterNoShow = courseDeregisterNoShow
}
makeCourseForm :: (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)) -> Maybe CourseForm -> Form CourseForm
@ -251,6 +253,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
in AllocationCourseForm
<$> ainp (selectField' Nothing $ return allocationOptions) (fslI MsgCourseAllocation) (fmap acfAllocation $ template >>= cfAllocation)
<*> ainp (natFieldI MsgCourseAllocationMinCapacityMustBeNonNegative) (fslI MsgCourseAllocationMinCapacity & setTooltip MsgCourseAllocationMinCapacityTip) (fmap acfMinCapacity $ template >>= cfAllocation)
<*> apopt checkBoxField (fslI MsgCourseDeregisterNoShow & setTooltip MsgCourseDeregisterNoShowTip) ((<|> Just True) . fmap acfDeregisterNoShow $ template >>= cfAllocation)
optionalActionW' (bool mforcedJust mpopt mayChange) allocationForm' (fslI MsgCourseAllocationParticipate & setTooltip MsgCourseAllocationParticipateTip) (is _Just . cfAllocation <$> template)
@ -459,6 +462,7 @@ courseEditHandler miButtonAction mbCourseForm = do
, courseRegisterFrom = cfRegFrom
, courseRegisterTo = cfRegTo
, courseDeregisterUntil = cfDeRegUntil
, courseDeregisterNoShow = maybe False acfDeregisterNoShow cfAllocation
}
whenIsJust insertOkay $ \cid -> do
let (invites, adds) = partitionEithers $ cfLecturers res
@ -506,6 +510,7 @@ courseEditHandler miButtonAction mbCourseForm = do
, courseRegisterFrom = cfRegFrom
, courseRegisterTo = cfRegTo
, courseDeregisterUntil = cfDeRegUntil
, courseDeregisterNoShow = maybe False acfDeregisterNoShow cfAllocation
}
case updOkay of
(Just _) -> addMessageI Warning (MsgCourseEditDupShort tid ssh csh) $> False

1
src/Handler/Course/Events/Edit.hs
View File

@ -24,6 +24,7 @@ postCEvEditR tid ssh csh cID = do
, courseEventType = cefType
, courseEventRoom = cefRoom
, courseEventTime = cefTime
, courseEventNote = cefNote
, courseEventLastChanged = now
}
addMessageI Success MsgCourseEventEdited

4
src/Handler/Course/Events/Form.hs
View File

@ -15,6 +15,7 @@ data CourseEventForm = CourseEventForm
{ cefType :: CI Text
, cefRoom :: Text
, cefTime :: Occurrences
, cefNote :: Maybe Html
}
courseEventForm :: Maybe CourseEventForm -> Form CourseEventForm
@ -34,15 +35,18 @@ courseEventForm template = identifyForm FIDCourseEvent . renderWForm FormStandar
cefType' <- wreq (textField & cfStrip & cfCI & addDatalist courseEventTypes) (fslI MsgCourseEventType & addPlaceholder (mr MsgCourseEventTypePlaceholder)) (cefType <$> template)
cefRoom' <- wreq (textField & cfStrip & addDatalist courseEventRooms) (fslI MsgCourseEventRoom) (cefRoom <$> template)
cefTime' <- aFormToWForm $ occurrencesAForm ("time" :: Text) (cefTime <$> template)
cefNote' <- wopt htmlField (fslI MsgCourseEventNote) (cefNote <$> template)
return $ CourseEventForm
<$> cefType'
<*> cefRoom'
<*> cefTime'
<*> cefNote'
courseEventToForm :: CourseEvent -> CourseEventForm
courseEventToForm CourseEvent{..} = CourseEventForm
{ cefType = courseEventType
, cefRoom = courseEventRoom
, cefTime = courseEventTime
, cefNote = courseEventNote
}

1
src/Handler/Course/Events/New.hs
View File

@ -22,6 +22,7 @@ postCEventsNewR tid ssh csh = do
, courseEventType = cefType
, courseEventRoom = cefRoom
, courseEventTime = cefTime
, courseEventNote = cefNote
, courseEventLastChanged = now
}
encrypt eId :: DB CryptoUUIDCourseEvent

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

@ -17,6 +17,8 @@ import Data.Aeson hiding (Result(..))
import Text.Hamlet (ihamlet)
import qualified Data.HashSet as HashSet
instance IsInvitableJunction Lecturer where
type InvitationFor Lecturer = Course
@ -65,7 +67,7 @@ lecturerInvitationConfig = InvitationConfig{..}
invitationHeading (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseLecInviteHeading $ CI.original courseName
invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgCourseLecInviteExplanation}|]
invitationTokenConfig _ _ = do
itAuthority <- Right <$> liftHandler requireAuthId
itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
invitationRestriction _ _ = return Authorized
invitationForm _ (InvDBDataLecturer mlType, _) _ = hoistAForm liftHandler $ toJunction <$> case mlType of

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

@ -61,11 +61,13 @@ type CourseTableExpr = E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity
course2Participants :: CourseTableExpr -> E.SqlExpr (E.Value Int)
course2Participants (course `E.InnerJoin` _school) = E.subSelectCount . E.from $ \courseParticipant ->
E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
course2Registered :: Maybe UserId -> CourseTableExpr -> E.SqlExpr (E.Value Bool)
course2Registered muid (course `E.InnerJoin` _school) = E.exists . E.from $ \courseParticipant ->
E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
E.&&. E.just (courseParticipant E.^. CourseParticipantUser) E.==. E.val muid
E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
makeCourseTable :: ( IsDBTable m x, ToSortable h, Functor h, DBResult m x ~ ((), Widget) )
=> _ -> Colonnade h CourseTableData (DBCell m x) -> PSValidator m x -> DB Widget
@ -83,10 +85,10 @@ 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 DB CourseTableData
dbtProj :: DBRow _ -> 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)
lecturerList <- E.select $ E.from $ lecturerQuery $ E.val $ entityKey course
courseAlloc <- getBy (UniqueAllocationCourse $ entityKey course)
>>= traverse (getJustEntity . allocationCourseAllocation . entityVal)
return (course, participants, registered, school, lecturerList, courseAlloc)
snd <$> dbTable psValidator DBTable

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

@ -7,6 +7,7 @@ module Handler.Course.ParticipantInvite
, AddParticipantsResult(..)
, addParticipantsResultMessages
, registerUsers, registerUser
, registerUsers', registerUser'
) where
import Import
@ -14,10 +15,12 @@ import Import
import Utils.Form
import Handler.Utils
import Handler.Utils.Invitations
import Handler.Utils.Course
import qualified Data.CaseInsensitive as CI
import qualified Data.Set as Set
import qualified Data.Map as Map
import Jobs.Queue
@ -29,6 +32,8 @@ import Control.Monad.Except (MonadError(..))
import Generics.Deriving.Monoid (memptydefault, mappenddefault)
import qualified Data.HashSet as HashSet
-- Invitations for ordinary participants of this course
instance IsInvitableJunction CourseParticipant where
@ -37,16 +42,19 @@ instance IsInvitableJunction CourseParticipant where
{ jParticipantRegistration :: UTCTime
, jParticipantField :: Maybe StudyFeaturesId
, jParticipantAllocated :: Maybe AllocationId
, jParticipantState :: CourseParticipantState
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
data InvitationDBData CourseParticipant = InvDBDataParticipant
-- no data needed in DB to manage participant invitation
deriving (Eq, Ord, Read, Show, Generic, Typeable)
data InvitationTokenData CourseParticipant = InvTokenDataParticipant
{ invTokenParticipantSubmissionGroup :: Maybe SubmissionGroupName
}
deriving (Eq, Ord, Read, Show, Generic, Typeable)
_InvitableJunction = iso
(\CourseParticipant{..} -> (courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField courseParticipantAllocated))
(\(courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField courseParticipantAllocated) -> CourseParticipant{..})
(\CourseParticipant{..} -> (courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField courseParticipantAllocated courseParticipantState))
(\(courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField courseParticipantAllocated courseParticipantState) -> CourseParticipant{..})
instance ToJSON (InvitableJunction CourseParticipant) where
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
@ -61,10 +69,10 @@ instance FromJSON (InvitationDBData CourseParticipant) where
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
instance ToJSON (InvitationTokenData CourseParticipant) where
toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3, omitNothingFields = True }
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3, omitNothingFields = True }
instance FromJSON (InvitationTokenData CourseParticipant) where
parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3, omitNothingFields = True }
participantInvitationConfig :: InvitationConfig CourseParticipant
participantInvitationConfig = InvitationConfig{..}
@ -81,17 +89,19 @@ participantInvitationConfig = InvitationConfig{..}
invitationHeading (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseParticipantInviteHeading $ CI.original courseName
invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgCourseParticipantInviteExplanation}|]
invitationTokenConfig _ _ = do
itAuthority <- Right <$> liftHandler requireAuthId
itAuthority <- HashSet.singleton . Right <$> 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 Nothing
invitationInsertHook _ _ _ CourseParticipant{..} _ act = do
res <- act
return . fmap (, ()) $ JunctionParticipant <$> pure now <*> studyFeatures <*> pure Nothing <*> pure CourseParticipantActive
invitationInsertHook _ _ (_, InvTokenDataParticipant{..}) CourseParticipant{..} _ act = do
deleteBy $ UniqueParticipant courseParticipantUser courseParticipantCourse -- there are no foreign key references to @{CourseParticipant}; therefor we can delete and recreate to simulate upsert
res <- act -- insertUnique
audit $ TransactionCourseParticipantEdit courseParticipantCourse courseParticipantUser
void $ setUserSubmissionGroup courseParticipantCourse courseParticipantUser invTokenParticipantSubmissionGroup
return res
invitationSuccessMsg (Entity _ Course{..}) _ =
return . SomeMessage $ MsgCourseParticipantInvitationAccepted (CI.original courseName)
@ -116,11 +126,17 @@ postCAddUserR tid ssh csh = do
cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
((usersToEnlist,formWgt),formEncoding) <- runFormPost . renderWForm FormStandard $ do
enlist <- wreq checkBoxField (fslI MsgCourseParticipantEnlistDirectly) (Just False)
wreq (multiUserField (maybe True not $ formResultToMaybe enlist) Nothing)
(fslI MsgCourseParticipantInviteField & setTooltip MsgMultiEmailFieldTip) Nothing
let submissionGroupOpts = optionsPersist [SubmissionGroupCourse ==. cid] [Asc SubmissionGroupName] submissionGroupName <&> fmap (submissionGroupName . entityVal)
mbGrp <- wopt (textField & cfStrip & cfCI & addDatalist submissionGroupOpts) (fslI MsgSubmissionGroup & setTooltip MsgSubmissionGroupEmptyIsUnsetTip) Nothing
users <- wreq (multiUserField (maybe True not $ formResultToMaybe enlist) Nothing)
(fslI MsgCourseParticipantInviteField & setTooltip MsgMultiEmailFieldTip) Nothing
return $ Map.fromSet . const <$> mbGrp <*> users
formResultModal usersToEnlist (CourseR tid ssh csh CUsersR) $
hoist runDBJobs . registerUsers cid
hoist runDBJobs . registerUsers' cid
let heading = prependCourseTitle tid ssh csh MsgCourseParticipantsRegisterHeading
@ -133,13 +149,16 @@ postCAddUserR tid ssh csh = do
}
registerUsers :: CourseId -> Set (Either UserEmail UserId) -> WriterT [Message] (YesodJobDB UniWorX) ()
registerUsers cid users = do
let (emails,uids) = partitionEithers $ Set.toList users
registerUsers cid = registerUsers' cid . Map.fromSet (const Nothing)
registerUsers' :: CourseId -> Map (Either UserEmail UserId) (Maybe SubmissionGroupName) -> WriterT [Message] (YesodJobDB UniWorX) ()
registerUsers' cid users = do
let (emails,uids) = partitionKeysEither users
-- send Invitation eMails to unkown users
lift $ sinkInvitationsF participantInvitationConfig [(mail,cid,(InvDBDataParticipant,InvTokenDataParticipant)) | mail <- emails]
lift $ sinkInvitationsF participantInvitationConfig [(mail,cid,(InvDBDataParticipant,InvTokenDataParticipant{..})) | (mail, invTokenParticipantSubmissionGroup) <- Map.toList emails]
-- register known users
tell <=< lift . addParticipantsResultMessages <=< lift . execWriterT $ mapM_ (registerUser cid) uids
tell <=< lift . addParticipantsResultMessages <=< lift . execWriterT $ imapM_ (registerUser' cid) uids
unless (null emails) $
tell . pure <=< messageI Success . MsgCourseParticipantsInvited $ length emails
@ -170,8 +189,14 @@ addParticipantsResultMessages AddParticipantsResult{..} = execWriterT $ do
registerUser :: CourseId
-> UserId
-> WriterT AddParticipantsResult (YesodJobDB UniWorX) ()
registerUser cid uid = exceptT tell tell $ do
whenM (lift . lift . existsBy $ UniqueParticipant uid cid) $
registerUser cid uid = registerUser' cid uid Nothing
registerUser' :: CourseId
-> UserId
-> Maybe SubmissionGroupName
-> WriterT AddParticipantsResult (YesodJobDB UniWorX) ()
registerUser' cid uid mbGrp = exceptT tell tell $ do
whenM (lift . lift $ exists [CourseParticipantCourse ==. cid, CourseParticipantUser ==. uid, CourseParticipantState ==. CourseParticipantActive]) $
throwError $ mempty { aurAlreadyRegistered = Set.singleton uid }
features <- lift . lift $ selectKeysList [ StudyFeaturesUser ==. uid, StudyFeaturesValid ==. True, StudyFeaturesType ==. FieldPrimary ] []
@ -187,15 +212,24 @@ registerUser cid uid = exceptT tell tell $ do
= Nothing
courseParticipantRegistration <- liftIO getCurrentTime
void . lift . lift . insert $ CourseParticipant
{ courseParticipantCourse = cid
, courseParticipantUser = uid
, courseParticipantAllocated = Nothing
, ..
}
void . lift . lift $ upsert
CourseParticipant
{ courseParticipantCourse = cid
, courseParticipantUser = uid
, courseParticipantAllocated = Nothing
, courseParticipantState = CourseParticipantActive
, ..
}
[ CourseParticipantRegistration =. courseParticipantRegistration
, CourseParticipantField =. courseParticipantField
, CourseParticipantAllocated =. Nothing
, CourseParticipantState =. CourseParticipantActive
]
lift . lift . audit $ TransactionCourseParticipantEdit cid uid
lift . lift . queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cid
void . lift . lift $ setUserSubmissionGroup cid uid mbGrp
return $ case courseParticipantField of
Nothing -> mempty { aurNoUniquePrimaryField = Set.singleton uid }
Just _ -> mempty { aurSuccess = Set.singleton uid }

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

@ -48,7 +48,7 @@ courseRegisterForm :: (MonadHandler m, HandlerSite m ~ UniWorX) => Entity Course
courseRegisterForm (Entity cid Course{..}) = liftHandler $ do
muid <- maybeAuthId
(registration, application) <- runDB $ do
registration <- fmap join . for muid $ getBy . flip UniqueParticipant cid
registration <- fmap join . for muid $ fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy . flip UniqueParticipant cid
application <- fmap (listToMaybe =<<) . for muid $ \uid -> selectList [CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid, CourseApplicationAllocation ==. Nothing] []
return (registration, application)
let btn | courseApplicationsRequired
@ -142,6 +142,8 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do
-> aFormToWForm $ fileUploadForm False (fslI . mkFs) courseApplicationsFiles
when (is _Just $ registration >>= courseParticipantAllocated . entityVal) $
wformMessage =<< messageIconI Warning IconExamRegisterFalse MsgCourseDeregistrationNoShow
when (is _Just (registration >>= courseParticipantAllocated . entityVal) && courseDeregisterNoShow) $
wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationAllocationLog
return $ CourseRegisterForm
@ -160,7 +162,7 @@ getCRegisterR tid ssh csh = do
Nothing -> addMessageI Info MsgLoginNecessary
(Just uid) -> runDB $ do
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
registration <- getBy (UniqueParticipant uid cid)
registration <- fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid
when (isNothing registration) $ addMessageI Warning MsgRegisterRetry
redirect $ CourseR tid ssh csh CShowR
@ -199,22 +201,40 @@ postCRegisterR tid ssh csh = do
= return $ Just ()
mkRegistration = do
audit $ TransactionCourseParticipantEdit cid uid
insertUnique $ CourseParticipant cid uid cTime crfStudyFeatures Nothing
entityKey <$> upsert
(CourseParticipant cid uid cTime crfStudyFeatures Nothing CourseParticipantActive)
[ CourseParticipantRegistration =. cTime
, CourseParticipantField =. crfStudyFeatures
, CourseParticipantAllocated =. Nothing
, CourseParticipantState =. CourseParticipantActive
]
case courseRegisterButton of
BtnCourseRegister -> runDB $ do
regOk <- (\app reg -> (,) <$> app <*> reg) <$> mkApplication <*> mkRegistration
regOk <- (\app reg -> (, reg) <$> app) <$> mkApplication <*> mkRegistration
case regOk of
Nothing -> transactionUndo
Just _ -> addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk
BtnCourseDeregister -> runDB $ do
part <- getBy $ UniqueParticipant uid cid
part <- fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid
forM_ part $ \(Entity _partId CourseParticipant{..}) -> do
deregisterParticipant uid cid
when (is _Just courseParticipantAllocated) $ do
updateBy (UniqueParticipant uid cid) [ CourseParticipantState =. CourseParticipantInactive courseDeregisterNoShow ]
now <- liftIO getCurrentTime
insert_ $ AllocationDeregister courseParticipantUser (Just courseParticipantCourse) now Nothing
deregisterParticipant uid cid
let recordNoShow eId = do
didRecord <- is _Just <$> insertUnique ExamResult
{ examResultExam = eId
, examResultUser = uid
, examResultResult = ExamNoShow
, examResultLastChanged = now
}
when didRecord $
audit $ TransactionExamResultEdit eId uid
when courseDeregisterNoShow . runConduit $ selectKeys [ ExamCourse ==. cid ] [] .| C.mapM_ recordNoShow
addMessageIconI Info IconEnrolFalse MsgCourseDeregisterOk
BtnCourseApply -> runDB $ do
@ -243,9 +263,9 @@ deleteApplicationFiles appId = do
deregisterParticipant :: UserId -> CourseId -> DB ()
deregisterParticipant uid cid = do
deleteApplications uid cid
part <- getBy $ UniqueParticipant uid cid
part <- fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid
forM_ part $ \(Entity partId CourseParticipant{..}) -> do
delete $ partId
update partId [CourseParticipantState =. CourseParticipantInactive False]
audit $ TransactionCourseParticipantDeleted cid uid
examRegistrations <- E.select . E.from $ \(examRegistration `E.InnerJoin` exam) -> do

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

@ -20,16 +20,19 @@ import Handler.Course.Register
import qualified Data.Conduit.List as C
import Handler.Exam.List (mkExamTable)
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,news,events) <- runDB . maybeT notFound $ do
(cid,course,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news,events,submissionGroup) <- 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
E.on $ E.just (course E.^. CourseId) E.==. participant E.?. CourseParticipantCourse
E.&&. E.val mbAid E.==. participant E.?. CourseParticipantUser
E.&&. participant E.?. CourseParticipantState E.==. E.just (E.val CourseParticipantActive)
E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId
E.where_ $ course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
@ -38,6 +41,7 @@ getCShowR tid ssh csh = do
let numParticipants :: E.SqlExpr (E.Value Int)
numParticipants = E.subSelectCount . E.from $ \part ->
E.where_ $ part E.^. CourseParticipantCourse E.==. course E.^. CourseId
E.&&. part E.^. CourseParticipantState E.==. E.val CourseParticipantActive
return (course,school E.^. SchoolName, numParticipants, participant)
staff <- lift . E.select $ E.from $ \(lecturer `E.InnerJoin` user) -> do
E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId
@ -89,8 +93,19 @@ getCShowR tid ssh csh = do
events' <- fmap (sortOn $ courseEventTime . entityVal) . lift $ selectList [ CourseEventCourse ==. cid ] []
events <- mapM (\(Entity evId ev) -> (, ev) <$> encrypt evId) events'
hasSubmissionGroups <- lift . E.selectExists . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup) -> do
E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val cid
submissionGroup' <- lift . for mbAid $ \uid ->
fmap (listToMaybe . fmap E.unValue) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup) -> do
E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val cid
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid
return $ submissionGroup E.^. SubmissionGroupName
let submissionGroup = guardOnM (hasSubmissionGroups && is _Just registration) submissionGroup'
return (cid,course,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news,events)
return (cid,course,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news,events,submissionGroup)
let mDereg' = maybe id min (allocationOverrideDeregister =<< mAllocation) <$> courseDeregisterUntil course
mDereg <- traverse (formatTime SelFormatDateTime) mDereg'
@ -125,7 +140,7 @@ getCShowR tid ssh csh = do
dbtColonnade = dbColonnade $ mconcat
[ sortable (Just "type") (i18nCell MsgTutorialType) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> textCell $ CI.original tutorialType
, sortable (Just "name") (i18nCell MsgTutorialName) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> indicatorCell <> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) [whamlet|#{tutorialName}|]
, sortable Nothing (i18nCell MsgTutorialTutors) $ \DBRow{ dbrOutput = Entity tutid _ } -> sqlCell $ do
, sortable (Just "tutors") (i18nCell MsgTutorialTutors) $ \DBRow{ dbrOutput = Entity tutid _ } -> sqlCell $ do
tutTutors <- fmap (map $(unValueN 3)) . E.select . E.from $ \(tutor `E.InnerJoin` user) -> do
E.on $ tutor E.^. TutorUser E.==. user E.^. UserId
E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid
@ -174,6 +189,12 @@ getCShowR tid ssh csh = do
, ("register-from", SortColumn $ \tutorial -> tutorial E.^. TutorialRegisterFrom )
, ("register-to", SortColumn $ \tutorial -> tutorial E.^. TutorialRegisterTo )
, ("deregister-until", SortColumn $ \tutorial -> tutorial E.^. TutorialDeregisterUntil )
, ( "tutors"
, SortColumn $ \tutorial -> E.subSelectMaybe . E.from $ \(tutor `E.InnerJoin` user) -> do
E.on $ tutor E.^. TutorUser E.==. user E.^. UserId
E.where_ $ tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial
return . E.min_ $ user E.^. UserSurname
)
]
dbtFilter = Map.empty
dbtFilterUI = const mempty
@ -188,73 +209,7 @@ getCShowR tid ssh csh = do
& defaultSorting [SortAscBy "type", SortAscBy "name"]
(Any hasTutorials, tutorialTable) <- runDB $ dbTable tutorialDBTableValidator tutorialDBTable
let
examDBTable = DBTable{..}
where
dbtSQLQuery exam = do
E.where_ $ exam E.^. ExamCourse E.==. E.val cid
return exam
dbtRowKey = (E.^. ExamId)
dbtProj r@DBRow{ dbrOutput = Entity _ Exam{..} } = do
guardM . hasReadAccessTo $ CExamR tid ssh csh examName EShowR
return r
dbtColonnade = dbColonnade $ mconcat
[ sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> indicatorCell <> anchorCell (CExamR tid ssh csh examName EShowR) examName
, sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom
, sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo
, sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> maybe mempty (cell . flip (formatTimeRangeW SelFormatDateTime) examEnd) examStart
, sortable (Just "registered") (i18nCell MsgExamRegistration ) $ \DBRow{ dbrOutput = Entity eId Exam{..} } -> sqlCell $ do
mayRegister <- (== Authorized) <$> evalAccessDB (CExamR tid ssh csh examName ERegisterR) True
isRegistered <- case mbAid of
Nothing -> return False
Just uid -> existsBy $ UniqueExamRegistration eId uid
let label = bool MsgExamNotRegistered MsgExamRegistered isRegistered
examUrl = CExamR tid ssh csh examName EShowR
if | mayRegister -> return $ simpleLinkI (SomeMessage label) examUrl
| otherwise -> return [whamlet|_{label}|]
-- , sortable Nothing mempty $ \DBRow{ dbrOutput = Entity eId Exam{..} } -> sqlCell $ do
-- mayRegister <- (== Authorized) <$> evalAccessDB (CExamR tid ssh csh examName ERegisterR) True
-- isRegistered <- case mbAid of
-- Nothing -> return False
-- Just uid -> existsBy $ UniqueExamRegistration eId uid
-- if
-- | mayRegister -> do
-- (examRegisterForm, examRegisterEnctype) <- liftHandler . generateFormPost . buttonForm' $ bool [BtnExamRegister] [BtnExamDeregister] isRegistered
-- return $ wrapForm examRegisterForm def
-- { formAction = Just . SomeRoute $ CExamR tid ssh csh examName ERegisterR
-- , formEncoding = examRegisterEnctype
-- , formSubmit = FormNoSubmit
-- }
-- | isRegistered -> return [whamlet|_{MsgExamRegistered}|]
-- | otherwise -> return mempty
]
dbtSorting = Map.fromList
[ ("name", SortColumn $ \exam -> exam E.^. ExamName )
, ("time", SortColumn $ \exam -> exam E.^. ExamStart )
, ("register-from", SortColumn $ \exam -> exam E.^. ExamRegisterFrom )
, ("register-to", SortColumn $ \exam -> exam E.^. ExamRegisterTo )
, ("visible", SortColumn $ \exam -> exam E.^. ExamVisibleFrom )
, ("registered", SortColumn $ \exam ->
case mbAid of
Nothing -> E.false
Just uid ->
E.exists $ E.from $ \reg -> do
E.where_ $ reg E.^. ExamRegistrationUser E.==. E.val uid
E.where_ $ reg E.^. ExamRegistrationExam E.==. exam E.^. ExamId
)
]
dbtFilter = Map.empty
dbtFilterUI = const mempty
dbtStyle = def
dbtParams = def
dbtIdent :: Text
dbtIdent = "exams"
dbtCsvEncode = noCsvEncode
dbtCsvDecode = Nothing
examDBTableValidator = def
& defaultSorting [SortAscBy "time"]
(Any hasExams, examTable) <- runDB $ dbTable examDBTableValidator examDBTable
(Any hasExams, examTable) <- runDB . mkExamTable $ Entity cid course
let visibleNews = any (view _3) news
showNewsFiles fs = and
@ -262,6 +217,7 @@ getCShowR tid ssh csh = do
, length fs <= 3
, all (notElem pathSeparator . view _2) fs
]
hiddenEventNotes = all (\(_,CourseEvent{..}) -> is _Nothing courseEventNote) events
mayCreateNews <- hasWriteAccessTo $ CourseR tid ssh csh CNewsNewR
mayCreateEvents <- hasWriteAccessTo $ CourseR tid ssh csh CEventsNewR

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

@ -6,9 +6,13 @@ import Import
import Utils.Form
import Handler.Utils
import Handler.Utils.SheetType
import Database.Esqueleto.Utils.TH
import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E
import Database.Persist.Sql (deleteWhereCount)
import Text.Blaze.Html.Renderer.Text (renderHtml)
@ -16,29 +20,196 @@ import Handler.Course.Register
import Jobs.Queue
import Handler.Corrections
import qualified Data.Map as Map
import qualified Data.Text as Text
import qualified Data.CaseInsensitive as CI
import qualified Data.Conduit.Combinators as C
data ExamAction = ExamDeregister
| ExamSetResult
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
deriving anyclass (Universe, Finite)
nullaryPathPiece ''ExamAction $ camelToPathPiece' 1
embedRenderMessage ''UniWorX ''ExamAction $ Text.replace "Exam" "ExamUser"
data ExamActionData = ExamDeregisterData
| ExamSetResultData (Maybe ExamResultPassedGrade)
data TutorialAction = TutorialDeregister
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
deriving anyclass (Universe, Finite)
nullaryPathPiece ''TutorialAction $ camelToPathPiece' 1
embedRenderMessage ''UniWorX ''TutorialAction $ Text.replace "Tutorial" "TutorialUser"
data TutorialActionData = TutorialDeregisterData
getCUserR, postCUserR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDUser -> Handler Html
getCUserR = postCUserR
postCUserR tid ssh csh uCId = do
-- Has authorization checks (OR):
--
-- - User is current member of course
-- - User has submitted in course
-- - User is member of registered group for course
-- - User is member of a tutorial for course
-- - User is corrector for course
-- - User is a tutor for course
-- - User is a lecturer for course
let currentRoute = CourseR tid ssh csh (CUserR uCId)
Entity dozentId (userShowSex -> showSex) <- requireAuth
uid <- decrypt uCId
-- DB reads
(cid, User{..}, mRegistration, thisUniqueNote, noteText, noteEdits, studies) <- runDB $ do
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
-- Abfrage Benutzerdaten
showSex <- maybe False (userShowSex . entityVal) <$> maybeAuth
(course, user@(Entity _ User{..}), registered) <- runDB $ do
uid <- decrypt uCId
course@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh
user <- get404 uid
registration <- getBy (UniqueParticipant uid cid)
-- Abfrage Teilnehmernotiz
registered <- exists [ CourseParticipantCourse ==. cid, CourseParticipantUser ==. uid, CourseParticipantState ==. CourseParticipantActive ]
return (course, Entity uid user, registered)
sections <- mapM (runMaybeT . ($ user) . ($ course))
[ courseUserProfileSection
, courseUserNoteSection
, courseUserExamsSection
, courseUserTutorialsSection
, courseUserSubmissionsSection
]
-- generate output
let headingLong
| registered
, Just sex <- guardOn showSex =<< userSex
= [whamlet|^{nameWidget userDisplayName userSurname} (_{ShortSex sex}), _{MsgCourseMemberOf} #{csh} #{tid}|]
| registered
= [whamlet|^{nameWidget userDisplayName userSurname}, _{MsgCourseMemberOf} #{csh} #{tid}|]
| Just sex <- guardOn showSex =<< userSex
= [whamlet|^{nameWidget userDisplayName userSurname} (_{ShortSex sex}), _{MsgCourseAssociatedWith} #{csh} #{tid}|]
| otherwise
= [whamlet|^{nameWidget userDisplayName userSurname}, _{MsgCourseAssociatedWith} #{csh} #{tid}|]
headingShort = prependCourseTitle tid ssh csh $ SomeMessage userDisplayName
siteLayout headingLong $ do
setTitleI headingShort
forM_ sections . fromMaybe $ return ()
courseUserProfileSection :: Entity Course -> Entity User -> MaybeT Handler Widget
courseUserProfileSection (Entity cid Course{..}) (Entity uid User{ userShowSex = _, ..}) = do
showSex <- maybe False (userShowSex . entityVal) <$> maybeAuth
currentRoute <- MaybeT getCurrentRoute
(mRegistration, studies) <- lift . runDB $ do
registration <- fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid
studies <- E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do
E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId
E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId
return (studyfeat, studydegree, studyterms)
return (registration, studies)
((regFieldRes, regFieldView), regFieldEnctype) <- lift . runFormPost . identifyForm FIDcRegField $ \csrf ->
let currentField :: Maybe (Maybe StudyFeaturesId)
currentField = courseParticipantField . entityVal <$> mRegistration
in over _2 ((toWidget csrf <>) . fvInput) <$> mreq (studyFeaturesFieldFor Nothing True (maybeToList $ join currentField) $ Just uid) ("" & addAutosubmit) currentField
let registrationFieldFrag :: Text
registrationFieldFrag = "registration-field"
regFieldWidget = wrapForm regFieldView FormSettings
{ formMethod = POST
, formAction = Just . SomeRoute $ currentRoute :#: registrationFieldFrag
, formEncoding = regFieldEnctype
, formAttrs = []
, formSubmit = FormAutoSubmit
, formAnchor = Just registrationFieldFrag
}
for_ mRegistration $ \(Entity pId CourseParticipant{..}) ->
formResult regFieldRes $ \courseParticipantField' -> do
lift . runDB $ do
update pId [ CourseParticipantField =. courseParticipantField' ]
audit $ TransactionCourseParticipantEdit cid uid
addMessageI Success MsgCourseStudyFeatureUpdated
redirect $ currentRoute :#: registrationFieldFrag
mayRegister <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CAddUserR
let regButton
| is _Just mRegistration = BtnCourseDeregister
| otherwise = BtnCourseRegister
((regButtonRes, regButtonView), regButtonEnctype) <- lift . 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
<*> apopt checkBoxField (fslI MsgCourseDeregistrationAllocationNoShow & setTooltip MsgCourseDeregistrationAllocationNoShowTip) Nothing
) (fslI MsgCourseDeregistrationAllocationShouldLog) (Just True)
| otherwise
-> \csrf -> pure (FormSuccess (regButton, Nothing), toWidget csrf)
let registrationButtonFrag :: Text
registrationButtonFrag = "registration-button"
regButtonWidget = wrapForm' regButton regButtonView FormSettings
{ formMethod = POST
, formAction = Just . SomeRoute $ currentRoute :#: registrationButtonFrag
, formEncoding = regButtonEnctype
, formAttrs = []
, formSubmit = FormSubmit
, formAnchor = Just registrationButtonFrag
}
formResult regButtonRes $ \case
_
| not mayRegister
-> permissionDenied "User may not be registered"
(BtnCourseDeregister, mbReason)
| Just (Entity _pId CourseParticipant{..}) <- mRegistration
-> do
lift . runDB $ do
deregisterParticipant courseParticipantUser courseParticipantCourse
whenIsJust mbReason $ \(reason, noShow) -> do
updateBy (UniqueParticipant uid cid) [ CourseParticipantState =. CourseParticipantInactive noShow ]
now <- liftIO getCurrentTime
insert_ $ AllocationDeregister courseParticipantUser (Just cid) now (Just reason)
let recordNoShow eId = do
didRecord <- is _Just <$> insertUnique ExamResult
{ examResultExam = eId
, examResultUser = uid
, examResultResult = ExamNoShow
, examResultLastChanged = now
}
when didRecord $
audit $ TransactionExamResultEdit eId uid
when noShow . runConduit $ selectKeys [ ExamCourse ==. cid ] [] .| C.mapM_ recordNoShow
addMessageIconI Info IconEnrolFalse MsgCourseDeregisterOk
redirect $ CourseR courseTerm courseSchool courseShorthand CUsersR
| otherwise
-> invalidArgs ["User not registered"]
(BtnCourseRegister, _) -> do
now <- liftIO getCurrentTime
let field
| [(Entity featId _, _, _)] <- filter (\(Entity _ StudyFeatures{..}, _, _) -> studyFeaturesValid) studies
= Just featId
| otherwise
= Nothing
lift . runDBJobs $ do
void $ upsert
(CourseParticipant cid uid now field Nothing CourseParticipantActive)
[ CourseParticipantRegistration =. now
, CourseParticipantField =. field
, CourseParticipantAllocated =. Nothing
, CourseParticipantState =. CourseParticipantActive
]
queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cid
audit $ TransactionCourseParticipantEdit cid uid
addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk
redirect currentRoute
_other -> error "Invalid @regButton@"
mRegAt <- for (courseParticipantRegistration . entityVal <$> mRegistration) $ formatTime SelFormatDateTime
return $(widgetFile "course/user/profile")
courseUserNoteSection :: Entity Course -> Entity User -> MaybeT Handler Widget
courseUserNoteSection (Entity cid Course{..}) (Entity uid _) = do
guardM . hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CUsersR
currentRoute <- MaybeT getCurrentRoute
(thisUniqueNote, noteText, noteEdits) <- lift . runDB $ do
let thisUniqueNote = UniqueCourseUserNote uid cid
mbNoteEnt <- getBy thisUniqueNote
(noteText,noteEdits) <- case mbNoteEnt of
@ -51,13 +222,7 @@ postCUserR tid ssh csh uCId = do
E.limit 1 -- more will be shown, if changed here
return (edit E.^. CourseUserNoteEditTime, usr E.^. UserEmail, usr E.^. UserDisplayName, usr E.^. UserSurname)
return (Just courseUserNoteNote, $(unValueN 4) <$> noteEdits)
-- Abfrage Studiengänge
studies <- E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do
E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId
E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId
return (studyfeat, studydegree, studyterms)
return (cid, user, registration, thisUniqueNote, noteText, noteEdits, studies)
return (thisUniqueNote, noteText, noteEdits)
let editByWgt = [whamlet|
$newline never
<ul .list--iconless>
@ -80,7 +245,7 @@ postCUserR tid ssh csh uCId = do
}
formResult noteRes $ \mbNote -> do
now <- liftIO getCurrentTime
runDB $ case mbNote of
lift . runDB $ case mbNote of
Nothing -> do
-- must delete all edits due to foreign key constraints, which does not make sense -> refactor!
maybeM (return ()) (\nk -> deleteWhere [CourseUserNoteEditNote ==. nk]) (getKeyBy thisUniqueNote)
@ -88,107 +253,291 @@ postCUserR tid ssh csh uCId = do
addMessageI Info MsgCourseUserNoteDeleted
_ | (renderHtml <$> mbNote) == (renderHtml <$> noteText) -> return () -- no changes
(Just note) -> do
dozentId <- requireAuthId
(Entity noteKey _) <- upsertBy thisUniqueNote (CourseUserNote cid uid note) [CourseUserNoteNote =. note]
void . insert $ CourseUserNoteEdit dozentId now noteKey
addMessageI Success MsgCourseUserNoteSaved
redirect $ currentRoute :#: noteFrag -- reload page after post
((regFieldRes, regFieldView), regFieldEnctype) <- runFormPost . identifyForm FIDcRegField $ \csrf ->
let currentField :: Maybe (Maybe StudyFeaturesId)
currentField = courseParticipantField . entityVal <$> mRegistration
in over _2 ((toWidget csrf <>) . fvInput) <$> mreq (studyFeaturesFieldFor Nothing True (maybeToList $ join currentField) $ Just uid) ("" & addAutosubmit) currentField
return $(widgetFile "course/user/note")
let registrationFieldFrag :: Text
registrationFieldFrag = "registration-field"
regFieldWidget = wrapForm regFieldView FormSettings
{ formMethod = POST
, formAction = Just . SomeRoute $ currentRoute :#: registrationFieldFrag
, formEncoding = regFieldEnctype
, formAttrs = []
, formSubmit = FormAutoSubmit
, formAnchor = Just registrationFieldFrag
}
for_ mRegistration $ \(Entity pId CourseParticipant{..}) ->
formResult regFieldRes $ \courseParticipantField' -> do
runDB $ do
update pId [ CourseParticipantField =. courseParticipantField' ]
audit $ TransactionCourseParticipantEdit cid uid
addMessageI Success MsgCourseStudyFeatureUpdated
redirect $ currentRoute :#: registrationFieldFrag
mayRegister <- hasWriteAccessTo $ CourseR tid ssh csh CAddUserR
let regButton
| is _Just mRegistration = BtnCourseDeregister
| otherwise = BtnCourseRegister
((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)
courseUserSubmissionsSection :: Entity Course -> Entity User -> MaybeT Handler Widget
courseUserSubmissionsSection (Entity cid Course{..}) (Entity uid _) = do
guardM . hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CCorrectionsR
let registrationButtonFrag :: Text
registrationButtonFrag = "registration-button"
regButtonWidget = wrapForm' regButton regButtonView FormSettings
{ formMethod = POST
, formAction = Just . SomeRoute $ currentRoute :#: registrationButtonFrag
, formEncoding = regButtonEnctype
, formAttrs = []
, formSubmit = FormSubmit
, formAnchor = Just registrationButtonFrag
}
formResult regButtonRes $ \case
_
| not mayRegister
-> permissionDenied "User may not be registered"
(BtnCourseDeregister, mbReason)
| Just (Entity _pId CourseParticipant{..}) <- mRegistration
-> do
runDB $ do
deregisterParticipant courseParticipantUser courseParticipantCourse
let whereClause = (E.&&.) <$> courseIs cid <*> userIs uid
colonnade = mconcat -- should match getSSubsR for consistent UX
[ colSelect
, colSheet
, colSMatrikel
, colSubmittors
, colSubmissionLink
, colLastEdit
, colRating
, colRated
, colCorrector
, colAssigned
] -- Continue here
filterUI = Just $ \mPrev -> mconcat
[ prismAForm (singletonFilter "user-name-email") mPrev $ aopt textField (fslI MsgCourseMembers)
, prismAForm (singletonFilter "user-matriclenumber") mPrev $ aopt textField (fslI MsgMatrikelNr)
-- "pseudonym" TODO DB only stores Word24
, Map.singleton "sheet-search" . maybeToList <$> aopt textField (fslI MsgSheet) (Just <$> listToMaybe =<< ((Map.lookup "sheet-search" =<< mPrev) <|> (Map.lookup "sheet" =<< mPrev)))
, prismAForm (singletonFilter "corrector-name-email") mPrev $ aopt textField (fslI MsgCorrector)
, prismAForm (singletonFilter "isassigned" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgHasCorrector)
, prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgRatingTime)
, prismAForm (singletonFilter "submission") mPrev $ aopt (lift `hoistField` textField) (fslI MsgSubmission)
]
psValidator = def & defaultPagesize PagesizeAll -- Assisstant always want to see them all at once anyway
(cWdgt, statistics) <- lift . correctionsR' whereClause colonnade filterUI psValidator $ Map.fromList
[ downloadAction
, assignAction (Left cid)
, deleteAction
]
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
guard $ statistics /= mempty
return $(widgetFile "course/user/corrections")
courseUserExamsSection :: Entity Course -> Entity User -> MaybeT Handler Widget
courseUserExamsSection (Entity cid Course{..}) (Entity uid _) = do
guardM . hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CExamNewR
uCID <- encrypt uid
let
examDBTable = DBTable{..}
where
dbtSQLQuery exam = do
E.where_ $ exam E.^. ExamCourse E.==. E.val cid
E.where_ $ E.or
[ E.exists . E.from $ \examRegistration ->
E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val uid
E.&&. examRegistration E.^. ExamRegistrationExam E.==. exam E.^. ExamId
, E.exists . E.from $ \(examPart `E.InnerJoin` examPartResult) -> do
E.on $ examPart E.^. ExamPartId E.==. examPartResult E.^. ExamPartResultExamPart
E.where_ $ examPartResult E.^. ExamPartResultUser E.==. E.val uid
E.&&. examPart E.^. ExamPartExam E.==. exam E.^. ExamId
, E.exists . E.from $ \examBonus ->
E.where_ $ examBonus E.^. ExamBonusUser E.==. E.val uid
E.&&. examBonus E.^. ExamBonusExam E.==. exam E.^. ExamId
, E.exists . E.from $ \examResult ->
E.where_ $ examResult E.^. ExamResultUser E.==. E.val uid
E.&&. examResult E.^. ExamResultExam E.==. exam E.^. ExamId
]
return exam
dbtRowKey = (E.^. ExamId)
dbtProj = traverse $ \exam@(Entity eId _) -> do
registration <- getBy $ UniqueExamRegistration eId uid
occurrence <- runMaybeT $ do
Entity _ ExamRegistration{..} <- hoistMaybe registration
occId <- hoistMaybe examRegistrationOccurrence
MaybeT $ getEntity occId
bonus <- getBy $ UniqueExamBonus eId uid
result <- getBy $ UniqueExamResult eId uid
return ( exam
, occurrence
, bonus
, result
, registration
)
dbtColonnade = mconcat
[ dbSelect (_2 . applying _2) _1 $ return . view (_dbrOutput . _1 . _entityKey)
, sortable (Just "name") (i18nCell MsgExamName) $ tellCell (Any True, mempty) . anchorCell' (\(view $ _dbrOutput . _1 . _entityVal -> Exam{..}) -> CExamR courseTerm courseSchool courseShorthand examName EShowR) (view $ _dbrOutput . _1 . _entityVal . _examName)
, sortable (Just "occurrence") (i18nCell MsgExamOccurrence) $ maybe mempty (cell . toWidget) . preview (_dbrOutput . _2 . _Just . _entityVal . _examOccurrenceName)
, sortable (Just "registration-time") (i18nCell MsgExamRegistrationTime) $ maybe mempty (cell . formatTimeW SelFormatDateTime) . preview (_dbrOutput . _5 . _Just . _entityVal . _examRegistrationTime)
, sortable (Just "bonus") (i18nCell MsgExamBonusAchieved) $ maybe mempty i18nCell . preview (_dbrOutput . _3 . _Just . _entityVal . _examBonusBonus)
, sortable (Just "result") (i18nCell MsgExamResult) $ maybe mempty i18nCell . preview (_dbrOutput . _4 . _Just . _entityVal . _examResultResult)
]
dbtSorting = mconcat
[ singletonMap "name" . SortColumn $ \exam -> exam E.^. ExamName
, singletonMap "occurrence" . SortColumn $ \exam -> E.subSelectMaybe . E.from $ \(examOccurrence `E.InnerJoin` examRegistration) -> do
E.on $ examRegistration E.^. ExamRegistrationOccurrence E.==. E.just (examOccurrence E.^. ExamOccurrenceId)
E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. exam E.^. ExamId
E.&&. examRegistration E.^. ExamRegistrationUser E.==. E.val uid
return . E.just $ examOccurrence E.^. ExamOccurrenceName
, singletonMap "registration-time" . SortColumn $ \exam -> E.subSelectMaybe . E.from $ \examRegistration -> do
E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. exam E.^. ExamId
E.&&. examRegistration E.^. ExamRegistrationUser E.==. E.val uid
return . E.just $ examRegistration E.^. ExamRegistrationTime
, singletonMap "bonus" . SortColumn $ \exam -> E.subSelectMaybe . E.from $ \examBonus -> do
E.where_ $ examBonus E.^. ExamBonusExam E.==. exam E.^. ExamId
E.&&. examBonus E.^. ExamBonusUser E.==. E.val uid
return . E.just $ examBonus E.^. ExamBonusBonus
, singletonMap "result" . SortColumn $ \exam -> E.subSelectMaybe . E.from $ \examResult -> do
E.where_ $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId
E.&&. examResult E.^. ExamResultUser E.==. E.val uid
return . E.just $ examResult E.^. ExamResultResult
]
dbtFilter = mempty
dbtFilterUI _mPrev = mempty
dbtStyle = def
dbtParams = DBParamsForm
{ dbParamsFormMethod = POST
, dbParamsFormAction = Just . SomeRoute . CourseR courseTerm courseSchool courseShorthand $ CUserR uCID
, dbParamsFormAttrs = []
, dbParamsFormSubmit = FormSubmit
, dbParamsFormAdditional = \csrf -> do
let
actionMap :: Map ExamAction (AForm Handler ExamActionData)
actionMap = mconcat
[ singletonMap ExamDeregister $
pure ExamDeregisterData
, singletonMap ExamSetResult $
ExamSetResultData <$> aopt (examResultModeField (Just $ SomeMessage MsgExamResultNone) ExamGradingMixed) (fslI MsgExamResult) Nothing
]
(res, formWgt) <- multiActionM actionMap (fslI MsgAction) Nothing csrf
let formRes = (, mempty) . First . Just <$> res
return (formRes, formWgt)
, dbParamsFormEvaluate = liftHandler . runFormPost
, dbParamsFormResult = _2
, dbParamsFormIdent = def
}
dbtIdent :: Text
dbtIdent = "course-user-exams"
dbtCsvEncode = noCsvEncode
dbtCsvDecode = Nothing
examDBTableValidator = def & defaultSorting [SortAscBy "registration-time"]
postprocess :: FormResult (First ExamActionData, DBFormResult ExamId (Bool, _) _) -> FormResult (ExamActionData, Map ExamId _)
postprocess inp = do
(First (Just act), regMap) <- inp
let regMap' = Map.mapMaybe (uncurry guardOn) $ getDBFormResult (False,) regMap
return (act, regMap')
((Any hasExams, actRes), examTable) <- lift . runDB $ over (_1 . _2) postprocess <$> dbTable examDBTableValidator examDBTable
lift . formResult actRes $ \case
(ExamDeregisterData, Map.keys -> selectedExams) -> do
nrDel <- runDB $ deleteWhereCount
[ ExamRegistrationUser ==. uid
, ExamRegistrationExam <-. selectedExams
]
if | nrDel > 0 -> addMessageI Success $ MsgCourseUserExamsDeregistered nrDel
| otherwise -> addMessageI Info MsgCourseUserNoExamsDeregistered
redirect . CourseR courseTerm courseSchool courseShorthand $ CUserR uCID
(ExamSetResultData mRes, selectedExams) -> do
now <- liftIO getCurrentTime
let field
| [(Entity featId _, _, _)] <- filter (\(Entity _ StudyFeatures{..}, _, _) -> studyFeaturesValid) studies
= Just featId
| otherwise
= Nothing
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
Just _ -> do
addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk
redirect currentRoute
Nothing -> invalidArgs ["User already registered"]
_other -> error "Invalid @regButton@"
Sum nrUpdated <- runDB . flip ifoldMapM selectedExams $ \eId (view $ _dbrOutput . _1 . _entityVal -> Exam{..}) -> if
| hasExamGradingGrades examGradingMode || isn't (_Just . _ExamAttended . _Right) mRes
, hasExamGradingPass examGradingMode || isn't (_Just . _ExamAttended . _Left ) mRes
-> do
oldResult <- getBy $ UniqueExamResult eId uid
case mRes of
Just res
| maybe True ((/= res) . examResultResult . entityVal) oldResult -> do
void $ upsert
ExamResult
{ examResultExam = eId
, examResultUser = uid
, examResultResult = res
, examResultLastChanged = now
}
[ ExamResultResult =. res, ExamResultLastChanged =. now ]
audit $ TransactionExamResultEdit eId uid
return $ Sum 1
Nothing
| is _Just oldResult -> do
deleteBy $ UniqueExamResult eId uid
audit $ TransactionExamResultDeleted eId uid
return $ Sum 1
_other -> return mempty
| otherwise -> mempty <$ addMessageI Error (MsgCourseUserExamResultDoesNotMatchMode examName)
when (nrUpdated > 0) . addMessageI Success $ MsgCourseUserExamsResultSet nrUpdated
redirect . CourseR courseTerm courseSchool courseShorthand $ CUserR uCID
mRegAt <- for (courseParticipantRegistration . entityVal <$> mRegistration) $ formatTime SelFormatDateTime
guard hasExams
-- generate output
let headingLong
| is _Just mRegistration
, Just sex <- guardOn showSex =<< userSex
= [whamlet|^{nameWidget userDisplayName userSurname} (_{ShortSex sex}), _{MsgCourseMemberOf} #{csh} #{tid}|]
| is _Just mRegistration
= [whamlet|^{nameWidget userDisplayName userSurname}, _{MsgCourseMemberOf} #{csh} #{tid}|]
| Just sex <- guardOn showSex =<< userSex
= [whamlet|^{nameWidget userDisplayName userSurname} (_{ShortSex sex}), _{MsgCourseAssociatedWith} #{csh} #{tid}|]
| otherwise
= [whamlet|^{nameWidget userDisplayName userSurname}, _{MsgCourseAssociatedWith} #{csh} #{tid}|]
headingShort = prependCourseTitle tid ssh csh $ SomeMessage userDisplayName
siteLayout headingLong $ do
setTitleI headingShort
$(widgetFile "course-user")
return $(widgetFile "course/user/exams")
courseUserTutorialsSection :: Entity Course -> Entity User -> MaybeT Handler Widget
courseUserTutorialsSection (Entity cid Course{..}) (Entity uid _) = do
uCID <- encrypt uid
let
tutorialDBTable = DBTable{..}
where
dbtSQLQuery (tutorial `E.InnerJoin` tutorialParticipant) = do
E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. E.val uid
return (tutorial, tutorialParticipant)
dbtRowKey (_ `E.InnerJoin` tutorialParticipant) = tutorialParticipant E.^. TutorialParticipantId
dbtProj = traverse $ \(tutorial, tutorialParticipant) -> do
tutors <- E.select . E.from $ \(tutor `E.InnerJoin` user) -> do
E.on $ tutor E.^. TutorUser E.==. user E.^. UserId
E.where_ $ tutor E.^. TutorTutorial E.==. E.val (tutorial ^. _entityKey)
return user
return (tutorial, tutorialParticipant, tutors)
dbtColonnade = mconcat
[ dbSelect (_2 . applying _2) _1 $ return . view (_dbrOutput . _2 . _entityKey)
, sortable (Just "type") (i18nCell MsgTutorialType) $ textCell . CI.original . view (_dbrOutput . _1 . _entityVal . _tutorialType)
, sortable (Just "name") (i18nCell MsgTutorialName) $ tellCell (Any True, mempty) . anchorCell' (\(view $ _dbrOutput . _1 . _entityVal . _tutorialName -> tutn) -> CTutorialR courseTerm courseSchool courseShorthand tutn TUsersR) (view $ _dbrOutput . _1 . _entityVal . _tutorialName)
, sortable (Just "tutors") (i18nCell MsgTutorialTutors) $ \(view $ _dbrOutput . _3 -> tutors) -> cell
[whamlet|
$newline never
<ul .list--iconless .list--inline .list--comma-separated>
$forall (Entity _ User{userEmail, userDisplayName, userSurname}) <- tutors
<li>
^{nameEmailWidget userEmail userDisplayName userSurname}
|]
, sortable (Just "room") (i18nCell MsgTutorialRoom) $ maybe mempty textCell . view (_dbrOutput . _1 . _entityVal . _tutorialRoom)
, sortable Nothing (i18nCell MsgTutorialTime) $ occurrencesCell . view (_dbrOutput . _1 . _entityVal . _tutorialTime)
]
dbtSorting = mconcat
[ singletonMap "type" . SortColumn $ \(tutorial `E.InnerJoin` _) -> tutorial E.^. TutorialType
, singletonMap "name" . SortColumn $ \(tutorial `E.InnerJoin` _) -> tutorial E.^. TutorialName
, singletonMap "room" . SortColumn $ \(tutorial `E.InnerJoin` _) -> tutorial E.^. TutorialRoom
, singletonMap "tutors" . SortColumn $ \(tutorial `E.InnerJoin` _) -> E.subSelectMaybe . E.from $ \(tutor `E.InnerJoin` user) -> do
E.on $ tutor E.^. TutorUser E.==. user E.^. UserId
E.where_ $ tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial
return . E.min_ $ user E.^. UserSurname
]
dbtFilter = mempty
dbtFilterUI _mPrev = mempty
dbtStyle = def
dbtParams = DBParamsForm
{ dbParamsFormMethod = POST
, dbParamsFormAction = Just . SomeRoute . CourseR courseTerm courseSchool courseShorthand $ CUserR uCID
, dbParamsFormAttrs = []
, dbParamsFormSubmit = FormSubmit
, dbParamsFormAdditional = \csrf -> do
let
actionMap :: Map TutorialAction (AForm Handler TutorialActionData)
actionMap = mconcat
[ singletonMap TutorialDeregister $
pure TutorialDeregisterData
]
(res, formWgt) <- multiActionM actionMap (fslI MsgAction) Nothing csrf
let formRes = (, mempty) . First . Just <$> res
return (formRes, formWgt)
, dbParamsFormEvaluate = liftHandler . runFormPost
, dbParamsFormResult = _2
, dbParamsFormIdent = def
}
dbtIdent :: Text
dbtIdent = "tutorials"
dbtCsvEncode = noCsvEncode
dbtCsvDecode = Nothing
tutorialDBTableValidator = def & defaultSorting [SortAscBy "type", SortAscBy "name"]
postprocess :: FormResult (First TutorialActionData, DBFormResult TutorialParticipantId (Bool, _) _) -> FormResult (TutorialActionData, Map TutorialParticipantId _)
postprocess inp = do
(First (Just act), regMap) <- inp
let regMap' = Map.mapMaybe (uncurry guardOn) $ getDBFormResult (False,) regMap
return (act, regMap')
((Any hasTutorials, actRes), tutorialTable) <- lift . runDB $ over (_1 . _2) postprocess <$> dbTable tutorialDBTableValidator tutorialDBTable
lift . formResult actRes $ \case
(TutorialDeregisterData, Map.keys -> selectedTutParts) -> do
nrDel <- runDB $ deleteWhereCount [ TutorialParticipantId <-. selectedTutParts ]
if | nrDel > 0 -> addMessageI Success $ MsgCourseUserTutorialsDeregistered nrDel
| otherwise -> addMessageI Info MsgCourseUserNoTutorialsDeregistered
redirect . CourseR courseTerm courseSchool courseShorthand $ CUserR uCID
guard hasTutorials
return $(widgetFile "course/user/tutorials")

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

@ -11,6 +11,7 @@ import Import
import Utils.Form
import Handler.Utils
import Handler.Utils.Course
import qualified Database.Esqueleto.Utils as E
import Database.Esqueleto.Utils.TH
@ -29,6 +30,8 @@ import qualified Data.Conduit.List as C
import qualified Data.CaseInsensitive as CI
import Database.Persist.Sql (updateWhereCount)
type UserTableExpr = ( E.SqlExpr (Entity User)
`E.InnerJoin` E.SqlExpr (Entity CourseParticipant)
@ -38,6 +41,9 @@ type UserTableExpr = ( E.SqlExpr (Entity User)
`E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree))
`E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms))
)
`E.LeftOuterJoin` ( E.SqlExpr (Maybe (Entity SubmissionGroup))
`E.InnerJoin` E.SqlExpr (Maybe (Entity SubmissionGroupUser))
)
-- forceUserTableType :: (UserTableExpr -> a) -> (UserTableExpr -> a)
-- forceUserTableType = id
@ -45,54 +51,66 @@ type UserTableExpr = ( E.SqlExpr (Entity User)
-- Sql-Getters for this query, used for sorting and filtering (cannot be lenses due to being Esqueleto expressions)
-- This ought to ease refactoring the query
queryUser :: UserTableExpr -> E.SqlExpr (Entity User)
queryUser = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
queryUser = $(sqlIJproj 2 1) . $(sqlLOJproj 4 1)
queryParticipant :: UserTableExpr -> E.SqlExpr (Entity CourseParticipant)
queryParticipant = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1)
queryParticipant = $(sqlIJproj 2 2) . $(sqlLOJproj 4 1)
queryUserNote :: UserTableExpr -> E.SqlExpr (Maybe (Entity CourseUserNote))
queryUserNote = $(sqlLOJproj 3 2)
queryUserNote = $(sqlLOJproj 4 2)
queryFeaturesStudy :: UserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures))
queryFeaturesStudy = $(sqlIJproj 3 1) . $(sqlLOJproj 3 3)
queryFeaturesStudy = $(sqlIJproj 3 1) . $(sqlLOJproj 4 3)
queryFeaturesDegree :: UserTableExpr -> E.SqlExpr (Maybe (Entity StudyDegree))
queryFeaturesDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 3 3)
queryFeaturesDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 4 3)
queryFeaturesField :: UserTableExpr -> E.SqlExpr (Maybe (Entity StudyTerms))
queryFeaturesField = $(sqlIJproj 3 3) . $(sqlLOJproj 3 3)
queryFeaturesField = $(sqlIJproj 3 3) . $(sqlLOJproj 4 3)
querySubmissionGroup :: UserTableExpr -> E.SqlExpr (Maybe (Entity SubmissionGroup))
querySubmissionGroup = $(sqlIJproj 2 1) . $(sqlLOJproj 4 4)
userTableQuery :: CourseId -> UserTableExpr -> E.SqlQuery ( E.SqlExpr (Entity User)
, E.SqlExpr (E.Value UTCTime)
, E.SqlExpr (Entity CourseParticipant)
, E.SqlExpr (E.Value (Maybe (Key CourseUserNote)))
, StudyFeaturesDescription')
userTableQuery cid ((user `E.InnerJoin` participant) `E.LeftOuterJoin` note `E.LeftOuterJoin` studyFeatures) = do
, StudyFeaturesDescription'
, E.SqlExpr (Maybe (Entity SubmissionGroup))
)
userTableQuery cid ((user `E.InnerJoin` participant) `E.LeftOuterJoin` note `E.LeftOuterJoin` studyFeatures `E.LeftOuterJoin` (subGroup `E.InnerJoin` subGroupUser)) = do
-- Note that order of E.on for nested joins is seemingly right-to-left, ignoring nesting paranthesis
E.on $ subGroup E.?. SubmissionGroupId E.==. subGroupUser E.?. SubmissionGroupUserSubmissionGroup
E.on $ subGroupUser E.?. SubmissionGroupUserUser E.==. E.just (user E.^. UserId)
E.&&. subGroup E.?. SubmissionGroupCourse E.==. E.just (E.val cid)
features <- studyFeaturesQuery' (participant E.^. CourseParticipantField) studyFeatures
E.on $ (note E.?. CourseUserNoteUser E.==. E.just (participant E.^. CourseParticipantUser))
E.&&. (note E.?. CourseUserNoteCourse E.==. E.just (E.val cid))
E.on $ participant E.^. CourseParticipantUser E.==. user E.^. UserId
E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid
return (user, participant E.^. CourseParticipantRegistration, note E.?. CourseUserNoteId, features)
return (user, participant, note E.?. CourseUserNoteId, features, subGroup)
type UserTableData = DBRow ( Entity User
, UTCTime
, Entity CourseParticipant
, Maybe CourseUserNoteId
, (Maybe StudyFeatures, Maybe StudyDegree, Maybe StudyTerms)
, ([Entity Tutorial], Map (CI Text) (Maybe (Entity Tutorial)))
, [Entity Exam]
, Maybe (Entity SubmissionGroup)
)
instance HasEntity UserTableData User where
hasEntity = _dbrOutput . _1
instance HasUser UserTableData where
-- hasUser = _entityVal
hasUser = _dbrOutput . _1 . _entityVal
_userTableParticipant :: Lens' UserTableData (Entity CourseParticipant)
_userTableParticipant = _dbrOutput . _2
_userTableRegistration :: Lens' UserTableData UTCTime
_userTableRegistration = _dbrOutput . _2
_userTableRegistration = _userTableParticipant . _entityVal . _courseParticipantRegistration
_userTableNote :: Lens' UserTableData (Maybe CourseUserNoteId)
_userTableNote = _dbrOutput . _3
@ -106,11 +124,17 @@ _rowUserSemester = _userTableFeatures . _1 . _Just . _studyFeaturesSemester
_userTutorials :: Lens' UserTableData ([Entity Tutorial], Map (CI Text) (Maybe (Entity Tutorial)))
_userTutorials = _dbrOutput . _5
_userExams :: Lens' UserTableData [Entity Exam]
_userExams = _dbrOutput . _6
_userSubmissionGroup :: Traversal' UserTableData (Entity SubmissionGroup)
_userSubmissionGroup = _dbrOutput . _7 . _Just
colUserComment :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c)
colUserComment tid ssh csh =
sortable (Just "note") (i18nCell MsgCourseUserNote)
$ \DBRow{ dbrOutput=(Entity uid _, _, mbNoteKey, _, _) } ->
$ \DBRow{ dbrOutput=(Entity uid _, _, mbNoteKey, _, _, _, _) } ->
maybeEmpty mbNoteKey $ const $
anchorCellM (courseLink <$> encrypt uid) (hasComment True)
where
@ -124,6 +148,14 @@ colUserTutorials tid ssh csh = sortable (Just "tutorials") (i18nCell MsgCourseUs
(\(Entity _ Tutorial{..}) -> CTutorialR tid ssh csh tutorialName TUsersR)
(tutorialName . entityVal)
colUserExams :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c)
colUserExams tid ssh csh = sortable (Just "exams") (i18nCell MsgCourseUserExams)
$ \(view _userExams -> exams') ->
let exams = sortOn (examName . entityVal) exams'
in (cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) . listCell exams $ anchorCell'
(\(Entity _ Exam{..}) -> CExamR tid ssh csh examName EUsersR)
(examName . entityVal)
colUserSemester :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
colUserSemester = sortable (Just "semesternr") (i18nCell MsgStudyFeatureAge) $
foldMap numCell . preview _rowUserSemester
@ -147,6 +179,10 @@ colUserDegreeShort = sortable (Just "degree-short") (i18nCell MsgStudyFeatureDeg
colUserSex' :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
colUserSex' = colUserSex $ hasUser . _userSex
colUserSubmissionGroup :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
colUserSubmissionGroup = sortable (Just "submission-group") (i18nCell MsgSubmissionGroup) $
foldMap (cell . toWidget) . preview (_userSubmissionGroup . _entityVal . _submissionGroupName)
data UserTableCsvStudyFeature = UserTableCsvStudyFeature
{ csvUserField :: Text
@ -162,9 +198,11 @@ data UserTableCsv = UserTableCsv
, csvUserMatriculation :: Maybe Text
, csvUserEmail :: CI Email
, csvUserStudyFeatures :: Either (Maybe UserTableCsvStudyFeature) (Set UserTableCsvStudyFeature)
, csvUserSubmissionGroup :: Maybe SubmissionGroupName
, csvUserRegistration :: UTCTime
, csvUserNote :: Maybe Html
, csvUserTutorials :: ([TutorialName], Map (CI Text) (Maybe TutorialName))
, csvUserExams :: [ExamName]
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
makeLenses_ ''UserTableCsv
@ -187,12 +225,17 @@ instance Csv.ToNamedRecord UserTableCsv where
in [ "study-features" Csv..= featsStr
]
++
[ "submission-group" Csv..= csvUserSubmissionGroup
] ++
[ let tutsStr = Text.intercalate "; " . map CI.original $ csvUserTutorials ^. _1
in "tutorial" Csv..= tutsStr
] ++
[ encodeUtf8 (CI.foldedCase regGroup) Csv..= (CI.original <$> mTut)
| (regGroup, mTut) <- Map.toList $ csvUserTutorials ^. _2
] ++
[ let examsStr = Text.intercalate "; " $ map CI.original csvUserExams
in "exams" Csv..= examsStr
] ++
[ "registration" Csv..= csvUserRegistration
, "note" Csv..= csvUserNote
]
@ -206,7 +249,9 @@ instance CsvColumnsExplained UserTableCsv where
, single "field" MsgCsvColumnUserField
, single "degree" MsgCsvColumnUserDegree
, single "semester" MsgCsvColumnUserSemester
, single "submission-group" MsgCsvColumnUserSubmissionGroup
, single "tutorial" MsgCsvColumnUserTutorial
, single "exams" MsgCsvColumnUserExam
, single "registration" MsgCsvColumnUserRegistration
, single "note" MsgCsvColumnUserNote
]
@ -228,7 +273,7 @@ userTableCsvHeader showSex UserCsvExportData{..} tuts = Csv.header $
] ++ bool (pure "study-features") ["field", "degree", "semester"] csvUserSimplifiedFeaturesOfStudy ++
[ "tutorial" | hasEmptyRegGroup ] ++
map (encodeUtf8 . CI.foldedCase) regGroups ++
[ "registration", "note"
[ "exams", "registration", "note"
]
where
hasEmptyRegGroup = has (folded . _entityVal . _tutorialRegGroup . _Nothing) tuts
@ -238,6 +283,9 @@ userTableCsvHeader showSex UserCsvExportData{..} tuts = Csv.header $
data CourseUserAction = CourseUserSendMail
| CourseUserDeregister
| CourseUserRegisterTutorial
| CourseUserRegisterExam
| CourseUserSetSubmissionGroup
| CourseUserReRegister
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
instance Universe CourseUserAction
@ -247,11 +295,18 @@ embedRenderMessage ''UniWorX ''CourseUserAction id
data CourseUserActionData = CourseUserSendMailData
| CourseUserDeregisterData
{ deregisterReason :: Maybe Text
{ deregisterSelfImposed :: Maybe (Text, Bool {- no-show -})
}
| CourseUserRegisterTutorialData
{ registerTutorial :: TutorialId
}
| CourseUserRegisterExamData
{ registerExam :: (ExamId, Maybe ExamOccurrenceId)
}
| CourseUserSetSubmissionGroupData
{ setSubmissionGroup :: Maybe SubmissionGroupName
}
| CourseUserReRegisterData
deriving (Eq, Ord, Read, Show, Generic, Typeable)
@ -271,19 +326,22 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
Course{..} <- getJust cid
csvName <- getMessageRender <*> pure (MsgCourseUserCsvName courseTerm courseSchool courseShorthand)
tutorials <- selectList [ TutorialCourse ==. cid ] []
exams <- selectList [ ExamCourse ==. cid ] []
-- -- psValidator has default sorting and filtering
showSex <- getShowSex
let dbtIdent = "courseUsers" :: Text
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
dbtSQLQuery q = userTableQuery cid q <* E.where_ (restrict q)
dbtRowKey = queryUser >>> (E.^. UserId)
dbtProj = traverse $ \(user, E.Value registrationTime , E.Value userNoteId, (feature,degree,terms)) -> do
tuts'' <- lift $ selectList [ TutorialParticipantUser ==. entityKey user, TutorialParticipantTutorial <-. map entityKey tutorials ] []
dbtProj = traverse $ \(user, participant, E.Value userNoteId, (feature,degree,terms), subGroup) -> do
tuts'' <- selectList [ TutorialParticipantUser ==. entityKey user, TutorialParticipantTutorial <-. map entityKey tutorials ] []
exams' <- selectList [ ExamRegistrationUser ==. entityKey user ] []
let
regGroups = setOf (folded . _entityVal . _tutorialRegGroup . _Just) tutorials
tuts' = filter (\(Entity tutId _) -> any ((== tutId) . tutorialParticipantTutorial . entityVal) tuts'') tutorials
tuts = foldr (\tut@(Entity _ Tutorial{..}) -> maybe (over _1 $ cons tut) (over _2 . flip (Map.insertWith (<|>)) (Just tut)) tutorialRegGroup) ([], Map.fromSet (const Nothing) regGroups) tuts'
return (user, registrationTime, userNoteId, (entityVal <$> feature, entityVal <$> degree, entityVal <$> terms), tuts)
exs = filter (\(Entity eId _) -> any ((== eId) . examRegistrationExam . entityVal) exams') exams
return (user, participant, userNoteId, (entityVal <$> feature, entityVal <$> degree, entityVal <$> terms), tuts, exs, subGroup)
dbtColonnade = colChoices
dbtSorting = mconcat
[ single $ sortUserNameLink queryUser -- slower sorting through clicking name column header
@ -310,6 +368,15 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
E.where_ $ participant E.^. TutorialParticipantUser E.==. user E.^. UserId
return . E.min_ $ tutorial E.^. TutorialName
)
, single $ ("exams" , SortColumn $ queryUser >>> \user ->
E.subSelectMaybe . E.from $ \(exam `E.InnerJoin` examRegistration) -> do
E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
E.&&. exam E.^. ExamCourse E.==. E.val cid
E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId
return . E.min_ $ exam E.^. ExamName
)
, single $ ("submission-group", SortColumn $ querySubmissionGroup >>> (E.?. SubmissionGroupName))
, single $ ("state", SortColumn $ queryParticipant >>> (E.^. CourseParticipantState))
]
where single = uncurry Map.singleton
dbtFilter = mconcat
@ -339,18 +406,30 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
E.&&. E.hasInfix (tutorial E.^. TutorialName) (E.val criterion :: E.SqlExpr (E.Value (CI Text)))
E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser row E.^. UserId
)
, single $ ("exam" , FilterColumn $ E.mkExistsFilter $ \row criterion ->
E.from $ \(exam `E.InnerJoin` examRegistration) -> do
E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
E.where_ $ exam E.^. ExamCourse E.==. E.val cid
E.&&. E.hasInfix (exam E.^. ExamName) (E.val criterion :: E.SqlExpr (E.Value (CI Text)))
E.&&. examRegistration E.^. ExamRegistrationUser E.==.queryUser row E.^. UserId
)
-- , ("course-registration", error "TODO") -- TODO
-- , ("course-user-note", error "TODO") -- TODO
, single $ ("submission-group", FilterColumn $ E.mkContainsFilter $ querySubmissionGroup >>> (E.?. SubmissionGroupName))
, single $ ("active", FilterColumn $ E.mkExactFilter $ queryParticipant >>> (E.==. E.val CourseParticipantActive) . (E.^. CourseParticipantState))
]
where single = uncurry Map.singleton
dbtFilterUI mPrev = mconcat $
[ fltrUserNameEmailUI mPrev
[ prismAForm (singletonFilter "active" . maybePrism _PathPiece) mPrev $ aopt (courseParticipantStateIsActiveField . Just $ SomeMessage MsgNoFilter) (fslI MsgCourseParticipantStateIsActiveFilter)
, fltrUserNameEmailUI mPrev
, fltrUserMatriclenrUI mPrev
] ++
[ fltrUserSexUI mPrev | showSex ] ++
[ prismAForm (singletonFilter "degree") mPrev $ aopt textField (fslI MsgStudyFeatureDegree)
, prismAForm (singletonFilter "field") mPrev $ aopt textField (fslI MsgCourseStudyFeature)
, prismAForm (singletonFilter "tutorial") mPrev $ aopt textField (fslI MsgCourseTutorial)
, prismAForm (singletonFilter "submission-group") mPrev $ aopt textField (fslI MsgSubmissionGroup)
, prismAForm (singletonFilter "tutorial") mPrev $ aopt textField (fslI MsgCourseUserTutorial)
, prismAForm (singletonFilter "exam") mPrev $ aopt textField (fslI MsgCourseUserExam)
]
dbtParams = DBParamsForm
{ dbParamsFormMethod = POST
@ -406,12 +485,16 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
, csvUserSemester = studyFeaturesSemester
, csvUserType = studyFeaturesType
}
<*> preview (_userSubmissionGroup . _entityVal . _submissionGroupName)
<*> view _userTableRegistration
<*> userNote
<*> (over (_2.traverse._Just) (tutorialName . entityVal) . over (_1.traverse) (tutorialName . entityVal) <$> view _userTutorials)
-- <*> (over (_2.traverse._Just) (examName . entityVal) . over (_1.traverse) (examName . entityVal) <$> view _userExams)
<*> (over traverse (examName . entityVal) <$> view _userExams)
, dbtCsvName = unpack csvName
, dbtCsvNoExportData = Nothing
, dbtCsvHeader = return . Vector.filter csvColumns' . flip (userTableCsvHeader showSex) tutorials . fromMaybe def
, dbtCsvExampleData = Nothing
}
where
userNote = runMaybeT $ do
@ -432,9 +515,13 @@ 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)
E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
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)
let selfImposedForm = (,)
<$> apreq (textField & cfStrip & guardField (not . null)) (fslI MsgCourseDeregistrationAllocationReason & setTooltip MsgCourseDeregistrationAllocationReasonTip) Nothing
<*> apopt checkBoxField (fslI MsgCourseDeregistrationAllocationNoShow & setTooltip MsgCourseDeregistrationAllocationNoShowTip) Nothing
fmap CourseUserDeregisterData <$> optionalActionW selfImposedForm (fslI MsgCourseDeregistrationAllocationShouldLog) (Just True)
| otherwise -> pure . pure $ CourseUserDeregisterData Nothing
getCUsersR, postCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
@ -445,6 +532,16 @@ postCUsersR tid ssh csh = do
mayRegister <- hasWriteAccessTo $ CourseR tid ssh csh CAddUserR
ent@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh
hasTutorials <- exists [TutorialCourse ==. cid]
examOccurrencesPerExam <- E.select . E.from $ \(exam `E.LeftOuterJoin` examOccurrence) -> do
E.on $ E.just (exam E.^. ExamId) E.==. examOccurrence E.?. ExamOccurrenceExam
E.where_ $ exam E.^. ExamCourse E.==. E.val cid
return (exam, examOccurrence)
hasSubmissionGroups <- E.selectExists . E.from $ \(submissionGroup `E.InnerJoin` submissionGroupUser `E.InnerJoin` courseParticipant) -> do
E.on $ courseParticipant E.^. CourseParticipantUser E.==. submissionGroupUser E.^. SubmissionGroupUserUser
E.&&. courseParticipant E.^. CourseParticipantCourse E.==. submissionGroup E.^. SubmissionGroupCourse
E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val cid
let exams = nubOn entityKey $ examOccurrencesPerExam ^.. folded . _1
let colChoices = mconcat $ catMaybes
[ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
, pure $ colUserNameLink (CourseR tid ssh csh . CUserR)
@ -454,24 +551,56 @@ postCUsersR tid ssh csh = do
, pure $ colUserDegreeShort
, pure $ colUserField
, pure $ colUserSemester
, guardOn hasSubmissionGroups colUserSubmissionGroup
, guardOn hasTutorials $ colUserTutorials tid ssh csh
, pure $ sortable (Just "registration") (i18nCell MsgRegisteredSince) (dateCell . view _userTableRegistration)
, guardOn hasExams $ colUserExams tid ssh csh
, pure $ sortable (Just "registration") (i18nCell MsgRegisteredSince) (maybe mempty dateCell . preview (_Just . _userTableRegistration) . assertM' (has $ _userTableParticipant . _entityVal . _courseParticipantState . _CourseParticipantActive))
, pure $ sortable (Just "state") (i18nCell MsgCourseUserState) (i18nCell . view (_userTableParticipant . _entityVal . _courseParticipantState))
, pure $ colUserComment tid ssh csh
]
psValidator = def & defaultSortingByName
acts = mconcat
[ singletonMap CourseUserSendMail $ pure CourseUserSendMailData
, singletonMap CourseUserRegisterTutorial $ CourseUserRegisterTutorialData <$>
apopt (selectField' Nothing . fmap (fmap entityKey) $ optionsPersistCryptoId [TutorialCourse ==. cid] [Asc TutorialName] tutorialName)
(fslI MsgCourseTutorial)
Nothing
, if
| mayRegister
-> singletonMap CourseUserDeregister $ courseUserDeregisterForm cid
| otherwise
-> mempty
& defaultFilter (singletonMap "active" [toPathPiece True])
hasExams = not $ null exams
examOccActs :: Map ExamId (AForm Handler (ExamId, Maybe ExamOccurrenceId))
examOccActs = examOccurrencesPerExam
& (map (bimap entityKey hoistMaybe))
& Map.fromListWith (<>)
& imap (\k v -> case v of
[] -> pure (k, Nothing)
_ -> (k,) <$> aopt (selectField' (Just $ SomeMessage MsgExamNoOccurrence) $ examOccOpts v) (fslI MsgExamOccurrence) (Just Nothing)
)
where
examOccOpts :: [Entity ExamOccurrence] -> Handler (OptionList ExamOccurrenceId)
examOccOpts examOccs = fmap mkOptionList . forM examOccs $ \Entity{..} -> do
optionExternalValue' <- encrypt entityKey :: Handler CryptoUUIDExamOccurrence
let
optionExternalValue = toPathPiece optionExternalValue'
optionInternalValue = entityKey
optionDisplay = CI.original $ examOccurrenceName entityVal
return Option{..}
examActs :: Handler (OptionList ExamId)
examActs = fmap mkOptionList . forM exams $ \Entity{..} -> do
optionExternalValue' <- encrypt entityKey :: Handler CryptoUUIDExam
let
optionExternalValue = toPathPiece optionExternalValue'
optionInternalValue = entityKey
optionDisplay = CI.original $ examName entityVal
return Option{..}
submissionGroupOpts = optionsPersist [SubmissionGroupCourse ==. cid] [Asc SubmissionGroupName] submissionGroupName <&> fmap (submissionGroupName . entityVal)
acts = mconcat $ catMaybes
[ pure . singletonMap CourseUserSendMail $ pure CourseUserSendMailData
, pure . singletonMap CourseUserRegisterTutorial $ CourseUserRegisterTutorialData
<$> apopt (selectField' Nothing . fmap (fmap entityKey) $ optionsPersistCryptoId [TutorialCourse ==. cid] [Asc TutorialName] tutorialName)
(fslI MsgCourseTutorial)
Nothing
, pure . singletonMap CourseUserRegisterExam $ CourseUserRegisterExamData <$>
multiActionAOpts examOccActs examActs (fslI MsgCourseExam) Nothing
, pure . singletonMap CourseUserSetSubmissionGroup $ CourseUserSetSubmissionGroupData . assertM (not . Text.null . CI.original)
<$> aopt (textField & cfStrip & cfCI & addDatalist submissionGroupOpts) (fslI MsgSubmissionGroup & setTooltip MsgSubmissionGroupEmptyIsUnsetTip) Nothing
, guardOn mayRegister . singletonMap CourseUserDeregister $ courseUserDeregisterForm cid
, guardOn mayRegister . singletonMap CourseUserReRegister $ pure CourseUserReRegisterData
]
numParticipants <- count [CourseParticipantCourse ==. cid]
numParticipants <- count [CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive]
table <- makeCourseUserTable cid acts (const E.true) colChoices psValidator (Just $ const True)
return (ent, numParticipants, table)
formResult participantRes $ \case
@ -481,12 +610,23 @@ postCUsersR tid ssh csh = do
(CourseUserDeregisterData{..}, selectedUsers) -> do
Sum nrDel <- fmap mconcat . runDB . forM (Set.toList selectedUsers) $ \uid -> fmap (maybe mempty Sum) . runMaybeT $ do
now <- liftIO getCurrentTime
Entity _ CourseParticipant{..} <- MaybeT . getBy $ UniqueParticipant uid cid
Entity _ CourseParticipant{..} <- MaybeT . fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid
lift $ deregisterParticipant courseParticipantUser courseParticipantCourse
case deregisterReason of
Just reason
| is _Just courseParticipantAllocated ->
lift . insert_ $ AllocationDeregister uid (Just cid) now (Just reason)
case deregisterSelfImposed of
Just (reason, noShow)
| is _Just courseParticipantAllocated -> lift $ do
insert_ $ AllocationDeregister uid (Just cid) now (Just reason)
updateBy (UniqueParticipant uid cid) [ CourseParticipantState =. CourseParticipantInactive noShow ]
let recordNoShow eId = do
didRecord <- is _Just <$> insertUnique ExamResult
{ examResultExam = eId
, examResultUser = uid
, examResultResult = ExamNoShow
, examResultLastChanged = now
}
when didRecord $
audit $ TransactionExamResultEdit eId uid
when noShow . runConduit $ selectKeys [ ExamCourse ==. cid ] [] .| C.mapM_ recordNoShow
_other -> return ()
return 1
addMessageI Success $ MsgCourseUsersDeregistered nrDel
@ -496,6 +636,52 @@ postCUsersR tid ssh csh = do
void . insertUnique . TutorialParticipant registerTutorial
addMessageI Success . MsgCourseUsersTutorialRegistered . fromIntegral $ Set.size selectedUsers
redirect $ CourseR tid ssh csh CUsersR
(CourseUserRegisterExamData{..}, selectedUsers) -> do
Sum nrReg <- fmap mconcat . runDB . forM (Set.toList selectedUsers) $ \uid -> maybeT (return mempty) $ do
guardM . lift $ exists [ CourseParticipantUser ==. uid, CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ]
now <- liftIO getCurrentTime
let (exam, mOccurrence) = registerExam
mExamReg <- lift $ insertUnique ExamRegistration
{ examRegistrationExam = exam
, examRegistrationUser = uid
, examRegistrationOccurrence = mOccurrence
, examRegistrationTime = now
}
case mExamReg of
Just _ -> do
lift . audit $ TransactionExamRegister exam uid
return 1
Nothing ->
return mempty
addMessageI Success $ MsgCourseUsersExamRegistered nrReg
redirect $ CourseR tid ssh csh CUsersR
(CourseUserSetSubmissionGroupData{..}, selectedUsers) -> do
nrSet <- runDB $ setUsersSubmissionGroup cid selectedUsers setSubmissionGroup
case setSubmissionGroup of
Nothing -> addMessageI Success $ MsgCourseUsersSubmissionGroupUnset nrSet
Just _ -> addMessageI Success $ MsgCourseUsersSubmissionGroupSetNew nrSet
redirect $ CourseR tid ssh csh CUsersR
(CourseUserReRegisterData, selectedUsers) -> do
now <- liftIO getCurrentTime
Sum nrSet <- runDB . flip foldMapM selectedUsers $ \uid -> maybeT (return mempty) $ do
didUpdate <- lift $ updateWhereCount
[ CourseParticipantUser ==. uid
, CourseParticipantCourse ==. cid
, CourseParticipantState !=. CourseParticipantActive
]
[ CourseParticipantState =. CourseParticipantActive
, CourseParticipantRegistration =. now
, CourseParticipantAllocated =. Nothing
]
guard $ didUpdate > 0
lift $ deleteWhere [ AllocationDeregisterCourse ==. Just cid, AllocationDeregisterUser ==. uid ]
lift . audit $ TransactionCourseParticipantEdit cid uid
return $ Sum didUpdate
addMessageI Success $ MsgCourseUsersStateSet nrSet
redirect $ CourseR tid ssh csh CUsersR
let headingLong = [whamlet|_{MsgMenuCourseMembers} #{courseName course} #{tid}|]
headingShort = prependCourseTitle tid ssh csh MsgCourseMembers
siteLayout headingLong $ do

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

@ -127,7 +127,7 @@ postEAddUserR tid ssh csh examn = do
whenM (lift . lift . existsBy $ UniqueExamRegistration eid uid) $
throwError $ mempty { aurAlreadyRegistered = pure userEmail }
whenM (lift . lift . existsBy $ UniqueParticipant uid cid) $ do
whenM (lift . lift $ exists [ CourseParticipantCourse ==. cid, CourseParticipantUser ==. uid, CourseParticipantState ==. CourseParticipantActive ]) $ do
lift $ lift examRegister
throwError $ mempty { aurSuccess = pure userEmail }
@ -142,13 +142,20 @@ postEAddUserR tid ssh csh examn = do
| [f] <- features = Just f
| otherwise = Nothing
lift . lift . insert_ $ CourseParticipant
{ courseParticipantCourse = cid
, courseParticipantUser = uid
, courseParticipantRegistration = now
, courseParticipantAllocated = Nothing
, ..
}
lift . lift . void $ upsert
CourseParticipant
{ courseParticipantCourse = cid
, courseParticipantUser = uid
, courseParticipantRegistration = now
, courseParticipantAllocated = Nothing
, courseParticipantState = CourseParticipantActive
, ..
}
[ CourseParticipantRegistration =. now
, CourseParticipantAllocated =. Nothing
, CourseParticipantField =. courseParticipantField
, CourseParticipantState =. CourseParticipantActive
]
lift . lift . audit $ TransactionCourseParticipantEdit cid uid
lift . lift . queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cid
lift $ lift examRegister

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

@ -16,6 +16,8 @@ import Text.Hamlet (ihamlet)
import Data.Aeson hiding (Result(..))
import qualified Data.HashSet as HashSet
instance IsInvitableJunction ExamCorrector where
type InvitationFor ExamCorrector = Exam
@ -67,7 +69,7 @@ examCorrectorInvitationConfig = InvitationConfig{..}
invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamCorrectorInviteHeading examName
invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamCorrectorInviteExplanation}|]
invitationTokenConfig _ _ = do
itAuthority <- Right <$> liftHandler requireAuthId
itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
invitationRestriction _ _ = return Authorized
invitationForm _ _ _ = pure (JunctionExamCorrector, ())

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

@ -339,7 +339,7 @@ validateExam = do
guardValidation MsgExamStartMustBeAfterPublishOccurrenceAssignments . fromMaybe True $ (>=) <$> efStart <*> efPublishOccurrenceAssignments
guardValidation MsgExamEndMustBeAfterStart $ NTop efEnd >= NTop efStart
guardValidation MsgExamFinishedMustBeAfterEnd . fromMaybe True $ (>=) <$> efFinished <*> efEnd
guardValidation MsgExamFinishedMustBeAfterStart $ NTop efFinished >= NTop efStart
guardValidation MsgExamFinishedMustBeAfterStart . fromMaybe True $ (>=) <$> efFinished <*> efStart
forM_ efOccurrences $ \ExamOccurrenceForm{..} -> do
guardValidation (MsgExamOccurrenceEndMustBeAfterStart eofName) $ NTop eofEnd >= NTop (Just eofStart)

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

@ -1,5 +1,6 @@
module Handler.Exam.List
( getCExamListR
( mkExamTable
, getCExamListR
) where
import Import
@ -9,12 +10,16 @@ import Handler.Utils
import qualified Data.Map as Map
import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E
getCExamListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCExamListR tid ssh csh = do
Entity cid Course{..} <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
mkExamTable :: Entity Course -> DB (Any, Widget)
mkExamTable (Entity cid Course{..}) = do
let tid = courseTerm
ssh = courseSchool
csh = courseShorthand
now <- liftIO getCurrentTime
mbAid <- maybeAuthId
mayCreate <- hasWriteAccessTo $ CourseR tid ssh csh CExamNewR
let
@ -24,15 +29,22 @@ getCExamListR tid ssh csh = do
E.where_ $ exam E.^. ExamCourse E.==. E.val cid
return exam
dbtRowKey = (E.^. ExamId)
dbtProj x@DBRow{ dbrOutput = Entity _ Exam{..} } = do
guardM . hasReadAccessTo $ CExamR tid ssh csh examName EShowR
return x
dbtProj = return
dbtColonnade = dbColonnade . mconcat $ catMaybes
[ Just . sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> anchorCell (CExamR tid ssh csh examName EShowR) examName
[ Just . sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> indicatorCell <> anchorCell (CExamR tid ssh csh examName EShowR) examName
, (<$ guard mayCreate) . sortable (Just "visible") (i18nCell MsgExamVisibleFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty (dateTimeCellVisible now) examVisibleFrom
, Just . sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom
, Just . sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo
, Just . sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> maybe mempty (cell . flip (formatTimeRangeW SelFormatDateTime) examEnd) examStart
, Just . sortable (Just "registered") (i18nCell MsgExamRegistration ) $ \DBRow{ dbrOutput = Entity eId Exam{..} } -> sqlCell $ do
mayRegister <- (== Authorized) <$> evalAccessDB (CExamR tid ssh csh examName ERegisterR) True
isRegistered <- case mbAid of
Nothing -> return False
Just uid -> existsBy $ UniqueExamRegistration eId uid
let label = bool MsgExamNotRegistered MsgExamRegistered isRegistered
examUrl = CExamR tid ssh csh examName EShowR
if | mayRegister -> return $ simpleLinkI (SomeMessage label) examUrl
| otherwise -> return [whamlet|_{label}|]
]
dbtSorting = Map.fromList
[ ("name", SortColumn $ \exam -> exam E.^. ExamName )
@ -40,8 +52,18 @@ getCExamListR tid ssh csh = do
, ("register-from", SortColumn $ \exam -> exam E.^. ExamRegisterFrom )
, ("register-to", SortColumn $ \exam -> exam E.^. ExamRegisterTo )
, ("visible", SortColumn $ \exam -> exam E.^. ExamVisibleFrom )
, ("registered", SortColumn $ \exam ->
case mbAid of
Nothing -> E.false
Just uid ->
E.exists $ E.from $ \reg -> do
E.where_ $ reg E.^. ExamRegistrationUser E.==. E.val uid
E.where_ $ reg E.^. ExamRegistrationExam E.==. exam E.^. ExamId
)
]
dbtFilter = Map.empty
dbtFilter = singletonMap "may-read" . FilterProjected $
\(Any b) DBRow{ dbrOutput = Entity _ Exam{..} }
-> (== b) <$> hasReadAccessTo (CExamR tid ssh csh examName EShowR) :: DB Bool
dbtFilterUI = const mempty
dbtStyle = def
dbtParams = def
@ -52,7 +74,17 @@ getCExamListR tid ssh csh = do
examDBTableValidator = def
& defaultSorting [SortAscBy "time"]
((), examTable) <- runDB $ dbTable examDBTableValidator examDBTable
& forceFilter "may-read" (Any True)
dbTable examDBTableValidator examDBTable
getCExamListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCExamListR tid ssh csh = do
(Entity _ Course{..}, examTable) <- runDB $ do
c <- getBy404 $ TermSchoolCourseShort tid ssh csh
(_, examTable) <- mkExamTable c
return (c, examTable)
siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamsHeading) $ do
setTitleI $ prependCourseTitle tid ssh csh MsgExamsHeading

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

@ -12,6 +12,8 @@ import Handler.Utils
import Handler.Utils.Invitations
import Jobs.Queue
import qualified Data.Conduit.Combinators as C
getCExamNewR, postCExamNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
@ -26,6 +28,8 @@ postCExamNewR tid ssh csh = do
formResult newExamResult $ \ExamForm{..} -> do
insertRes <- runDBJobs $ do
now <- liftIO getCurrentTime
insertRes <- insertUnique Exam
{ examName = efName
, examCourse = cid
@ -75,6 +79,18 @@ postCExamNewR tid ssh csh = do
, examCorrectorUser <- adds
]
sinkInvitationsF examCorrectorInvitationConfig $ map (, examid, (InvDBDataExamCorrector, InvTokenDataExamCorrector)) invites
let recordNoShow (Entity _ CourseParticipant{..}) = do
didRecord <- is _Just <$> insertUnique ExamResult
{ examResultExam = examid
, examResultUser = courseParticipantUser
, examResultResult = ExamNoShow
, examResultLastChanged = now
}
when didRecord $
audit $ TransactionExamResultEdit examid courseParticipantUser
runConduit $ selectSource [ CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantInactive True ] [] .| C.mapM_ recordNoShow
return insertRes
case insertRes of
Nothing -> addMessageI Error $ MsgExamNameTaken efName

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

@ -20,6 +20,8 @@ import Text.Hamlet (ihamlet)
import Data.Aeson hiding (Result(..))
import Jobs.Queue
import qualified Data.HashSet as HashSet
instance IsInvitableJunction ExamRegistration where
@ -77,7 +79,7 @@ examRegistrationInvitationConfig = InvitationConfig{..}
invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamRegistrationInviteHeading examName
invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamRegistrationInviteExplanation}|]
invitationTokenConfig _ (InvDBDataExamRegistration{..}, _) = do
itAuthority <- Right <$> liftHandler requireAuthId
itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId
let itExpiresAt = Just $ Just invDBExamRegistrationDeadline
itAddAuth
| not invDBExamRegistrationCourseRegister
@ -88,7 +90,7 @@ examRegistrationInvitationConfig = InvitationConfig{..}
return InvitationTokenConfig{..}
invitationRestriction _ _ = return Authorized
invitationForm (Entity _ Exam{..}) (InvDBDataExamRegistration{..}, _) uid = hoistAForm liftHandler . wFormToAForm $ do
isRegistered <- fmap (is _Just) . liftHandler . runDB . getBy $ UniqueParticipant uid examCourse
isRegistered <- fmap (is _Just) . liftHandler . runDB . fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive). getBy $ UniqueParticipant uid examCourse
now <- liftIO getCurrentTime
case (isRegistered, invDBExamRegistrationCourseRegister) of
@ -99,7 +101,13 @@ 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 Nothing
void $ upsert
(CourseParticipant examCourse examRegistrationUser examRegistrationTime cpField Nothing CourseParticipantActive)
[ CourseParticipantRegistration =. examRegistrationTime
, CourseParticipantField =. cpField
, CourseParticipantAllocated =. Nothing
, CourseParticipantState =. CourseParticipantActive
]
queueDBJob . JobQueueNotification $ NotificationCourseRegistered examRegistrationUser examCourse
audit $ TransactionCourseParticipantEdit examCourse examRegistrationUser

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

@ -165,7 +165,7 @@ 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'))
resultAutomaticExamBonus exam examBonus' = resultUser . _entityKey . folding (\uid -> join $ examResultBonus <$> examBonusRule exam <*> pure (examBonusPossible uid examBonus') <*> pure (examBonusAchieved uid examBonus'))
resultAutomaticExamResult :: Exam -> Map UserId SheetTypeSummary -> Fold ExamUserTableData ExamResultPassedGrade
resultAutomaticExamResult exam@Exam{..} examBonus' = folding . runReader $ do
@ -471,6 +471,7 @@ postEUsersR tid ssh csh examn = do
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.&&. courseParticipant E.?. CourseParticipantState E.==. E.just (E.val CourseParticipantActive)
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
@ -485,10 +486,10 @@ postEUsersR tid ssh csh examn = do
<*> getExamParts
<*> view _9
where
getExamParts :: ReaderT _ (MaybeT (YesodDB UniWorX)) (Map ExamPartId (ExamPart, Maybe (Entity ExamPartResult)))
getExamParts :: ReaderT _ DB (Map ExamPartId (ExamPart, Maybe (Entity ExamPartResult)))
getExamParts = do
uid <- view $ _2 . _entityKey
rawResults <- lift . lift . E.select . E.from $ \(examPart `E.LeftOuterJoin` examPartResult) -> do
rawResults <- 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
@ -617,6 +618,7 @@ postEUsersR tid ssh csh examn = do
, dbtCsvName = unpack csvName
, dbtCsvNoExportData = Just id
, dbtCsvHeader = const . return . examUserTableCsvHeader allBoni doBonus $ examParts ^.. folded . _entityVal . _examPartNumber
, dbtCsvExampleData = Nothing
}
where
doEncode' = ExamUserTableCsv
@ -757,13 +759,20 @@ postEUsersR tid ssh csh examn = do
C.mapM_ $ \case
ExamUserCsvCourseRegisterData{..} -> do
now <- liftIO getCurrentTime
insert_ CourseParticipant
{ courseParticipantCourse = examCourse
, courseParticipantUser = examUserCsvActUser
, courseParticipantRegistration = now
, courseParticipantField = examUserCsvActCourseField
, courseParticipantAllocated = Nothing
}
void $ upsert
CourseParticipant
{ courseParticipantCourse = examCourse
, courseParticipantUser = examUserCsvActUser
, courseParticipantRegistration = now
, courseParticipantField = examUserCsvActCourseField
, courseParticipantAllocated = Nothing
, courseParticipantState = CourseParticipantActive
}
[ CourseParticipantRegistration =. now
, CourseParticipantField =. examUserCsvActCourseField
, CourseParticipantAllocated =. Nothing
, CourseParticipantState =. CourseParticipantActive
]
queueDBJob . JobQueueNotification $ NotificationCourseRegistered examUserCsvActUser examCourse
audit $ TransactionCourseParticipantEdit examCourse examUserCsvActUser
insert_ ExamRegistration
@ -970,7 +979,7 @@ postEUsersR tid ssh csh examn = do
, GuessUserFirstName <$> csvEUserFirstName
]
pid <- maybe (throwM ExamUserCsvExceptionNoMatchingUser) return =<< guessUser criteria
(,) <$> existsBy (UniqueParticipant pid examCourse) <*> pure pid
(,) <$> exists [CourseParticipantCourse ==. examCourse, CourseParticipantUser ==. pid, CourseParticipantState ==. CourseParticipantActive] <*> pure pid
lookupOccurrence :: ExamUserTableCsv -> DB (Maybe ExamOccurrenceId)
lookupOccurrence ExamUserTableCsv{..} = $cachedHereBinary (CI.foldedCase <$> csvEUserOccurrence) . for csvEUserOccurrence $ \occName -> do

12
src/Handler/ExamOffice/Exam.hs
View File

@ -204,8 +204,8 @@ postEGradesR tid ssh csh examn = do
userFunctions <- selectList [ UserFunctionUser ==. uid, UserFunctionFunction ==. SchoolExamOffice ] []
let
participantLink :: MonadCrypto m => UserId -> m (SomeRoute UniWorX)
participantLink partId = do
participantLink :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m (SomeRoute UniWorX)
participantLink partId = liftHandler $ do
cID <- encrypt partId
return . SomeRoute . CourseR tid ssh csh $ CUserR cID
@ -261,6 +261,7 @@ postEGradesR tid ssh csh examn = do
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.&&. courseParticipant E.?. CourseParticipantState E.==. E.just (E.val CourseParticipantActive)
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)
@ -276,16 +277,16 @@ postEGradesR tid ssh csh examn = do
return (examResult, user, occurrence, studyFeatures, studyDegree, studyField, examRegistration, isSynced)
dbtRowKey = views queryExamResult (E.^. ExamResultId)
dbtProj :: DBRow _ -> MaybeT (YesodDB UniWorX) ExamUserTableData
dbtProj :: DBRow _ -> DB 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 :: ReaderT _ DB [(UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand)]
getSynchronised = do
resId <- view $ _1 . _entityKey
syncs <- lift . lift . E.select . E.from $ \(examOfficeResultSynced `E.InnerJoin` user) -> do
syncs <- 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
@ -412,6 +413,7 @@ postEGradesR tid ssh csh examn = do
, dbtCsvName = unpack csvName
, dbtCsvNoExportData = Nothing
, dbtCsvHeader = const . return $ Csv.headerOrder (error "headerOrder" :: ExamUserTableCsv)
, dbtCsvExampleData = Nothing
}
dbtCsvDecode = Nothing

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