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

Merge remote-tracking branch 'origin/fradrive/jost'into 'fradrive/merge-jost-new-build'

Browse Source
This commit is contained in:
Steffen Jost 2024-10-28 12:05:37 +01:00
commit c92ddb9081
238 changed files with 10334 additions and 5099 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

177
CHANGELOG.md
View File

@ -18,6 +18,183 @@ All notable changes to this project will be documented in this file. See [standa
* **Makefile:** add missing dependency on well-known for backend-builds ([a09dc59](https://fraport@dev.azure.com/fraport/Fahrerausbildung/_git/FRADrive/commit/a09dc59f260843f8815c382576bb5254d21104bf))
* **frontend:** fixed icon colour in table headers ([4c4571d](https://fraport@dev.azure.com/fraport/Fahrerausbildung/_git/FRADrive/commit/4c4571d2d0879e89f2572eba6015d34a7f4794c8))
* **doc:** minor haddock problems ([d4f8a6c](https://fraport@dev.azure.com/fraport/Fahrerausbildung/_git/FRADrive/commit/d4f8a6c77b2a4a4540935f7f0beca0d0605508c8))
## [27.4.76](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.75...v27.4.76) (2024-08-08)
### Bug Fixes
* **ap:** disambiguate action message ([8b0466e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/8b0466e74e36e1d0d07518fd317d46b00ab53eff))
* **avs:** fix [#173](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/173) by not using firm superior email as display email ([43f5c5f](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/43f5c5f4854d1ab2af27b479e72a58e2818a5696))
* **avs:** towards [#117](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/117) update if current value is Nothing even if oldval == newval ([d1fa01f](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d1fa01fcc5125c4adee8849f9c944884926f78ad))
* **avs:** using firm superior as UserEmail is a no-go due to uniqueness constraints ([507a7e0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/507a7e02fc68476d01031dc9f9ee1a669a453ed1))
* **build:** linter likes it ([f929e03](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f929e03129378e08c8a08ed4bd6f8e8716401813))
* **course:** fix [#150](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/150) course edit for associated qualifications requires school admin or lecturer rights ([5b6e4e6](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/5b6e4e60e7d2957fbce93ee2e2d6d3464b4e3db7))
* **course:** fix [#148](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/148) course qualification ordering ([cfd2534](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/cfd25348ad3b63ac6bc5031467a3c4ead2e07eed)), closes [#150](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/150)
* **course:** fix [#149](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/149) course cloning proposes associated qualifications ([e141976](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/e1419766f3a06f702abad0ea42f6552305504ba0))
* **course:** fix [#150](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/150) no longer allow duplicated associated qualifications and orders due to editing existing ([ec02767](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ec027675525b30198378745ed281f60a42471807))
* **course:** WIP course cloning should propose same associated qualifications, towards [#149](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/149) ([bc47387](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/bc47387c91dda60a2f12e52dba28ea7b079316f0))
* **lms:** max e-learning tries default removed and info added to lms overview ([11fdcf0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/11fdcf0d445b8cfe97c3a3c26513a9229937c536))
* **user:** format userDisplayNames having umlaut substitutes with respect to userSurname correctly ([e35a5e9](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/e35a5e99a6cea0976fd1c28f919e7d0ac0338503))
## [27.4.75](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.74...v27.4.75) (2024-07-12)
### Bug Fixes
* **build:** make linter happy again ([c17c18f](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/c17c18f9247ef322bc051602a3cb4a52cd50affa))
* **build:** minor ([ab28c8c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ab28c8c2437680023d80e6ab43113d4328b3a151))
* **firm:** fix [#157](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/157) by removing redundant duplicated code in firm user and supervision handling ([28e2739](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/28e2739e515700d15c75647c0efe2fe9a9cf15b1))
* **job:** change some queueJob' to queueJob instead ([fa0541a](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/fa0541aa4eaf10f98535a0959593b148b8346109))
* **lms:** allow 2nd reminders to be independent of renewal period ([d853e85](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d853e8559b753865ee818bf24764f5c8d2e2303f))
* **lms:** move lms reuse info from QualificationR to LmsR ([468af9d](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/468af9de9da44a8ad685ca4bb6890a3e630b58be))
* **lms:** send second reminder indepentently from renewal period ([a97c3a5](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a97c3a5c9d3cb9dddf90f561712f0845400893bd))
* **nix:** workaround parsing port numbers failed in nix-shell ([b5215cc](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b5215cc7e8df3a7ad636271c8e6950979b2b8e42))
* **users:** nameHtml no longer complains about differing case for surname and displayname ([a1668f8](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a1668f891a36b887439afb098f016ef22535af42))
* **users:** remove users with company post address from list of unreachable users ([c813c66](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/c813c665ed306135b7813d91d23310341c689f41))
## [27.4.74](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.73...v27.4.74) (2024-07-04)
### Bug Fixes
* **lms:** fix [#161](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/161) lms for multiple joint qualifications ([f869a82](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f869a829d2c1a726930864b3af62d1f0fbebe955))
## [27.4.73](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.72...v27.4.73) (2024-07-03)
### Bug Fixes
* **letter:** rephrase some minor letter parts ([0ac75e0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/0ac75e0d5948cb90855d0e36ca8e99c22a0f6fcb))
## [27.4.72](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.71...v27.4.72) (2024-07-02)
### Bug Fixes
* **avs:** do not associate users by AvsInfoPersonEmail ([9e2f221](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/9e2f2214ce5c7ee1e8d80e6fa75298b7a70d9043))
* **avs:** fix superfluous quotes for matriculation numbers on newly created users ([ff9014c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ff9014ce05d197c1dc0fce0774a640789cb38b26))
* **avs:** towards [#169](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/169) - superiors are elevated to max priority for that company ([5bf8539](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/5bf85394d4db6de8f10b4e318d667130d37601ac))
* **firm:** supervisor secondary did not work as intended ([d4f3ce7](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d4f3ce7bf3d208b16f95ab81971b47dfa752939a))
## [27.4.71](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.70...v27.4.71) (2024-06-27)
### Bug Fixes
* **avs:** company superior emails become company wide supervisors ([37efc89](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/37efc89e0723452e6d271ba5b43d6bd026642190))
* **avs:** match mobile number better between LDAP and AVS ([f108c6c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f108c6cfec2d94d866e7c1605b0abe5471fd0f2b))
* **avs:** new AVS from existing LDAP user no longer misses fields ([2559346](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/2559346d963ede802321dfc8cbd2088d9a5de685))
* **avs:** priority for picking primary email demote superior ([e4fa1dd](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/e4fa1ddd6873910bef82d569fe16aca936efc567))
* **build:** add missing license file ([8721bdb](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/8721bdb3f349658baab144d64c19942bfd7fa49a))
* **build:** hlint wants a newtype instead ([18cdc52](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/18cdc52df094b9dbccd4f015561367cea59e33fe))
* **doc:** fix erroneous unintentional haddock annotations ([3dfc7f8](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3dfc7f8c8b12dd6ef87848a75f1669d700fffe4c))
* **i18n:** add missing translation for new primary company ([c212f2e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/c212f2e8d735616e59c9b8111a34118e3a48fd47))
* **i18n:** add missing translation for new primary company ([2cc529b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/2cc529be39655c317ca028f8f09fa80826ec668d))
* **ldap:** match mobile number better between LDAP and AVS ([47e5628](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/47e56280fce4ad37e6bc3b9f1c61cb7867069cc5))
* **letter:** adjust spacing, pin location and interpolation ([d4a0e1f](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d4a0e1f201151f76e8e9afd67b456cc878d2afde))
* **letter:** convenience links working again ([5f1af13](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/5f1af130edae7ada2f0c7f7829890bbe0d4f395a))
* **letter:** expiry and valid dates were wrong ([f8c3663](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f8c36636ff1f2591507e993af32ed01af94cf1fc))
* **letter:** switch markdown for renewal letter too ([c38e87e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/c38e87e1e0e9285a10c00521b7440cd8246af88a))
* **print:** fix [#167](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/167) by sotring affected user in PrintJob ([73aecc2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/73aecc2df833bdeed93a113b6c756e36b50491b7))
## [27.4.70](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.69...v27.4.70) (2024-06-21)
### Bug Fixes
* **build:** hlint wants a newtype instead ([0766351](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/07663516e520814e26740d671325b7cd10855dd4))
## [27.4.69](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.68...v27.4.69) (2024-06-21)
### Bug Fixes
* **avs:** fix type causing avs surname upate not working ([822c43c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/822c43c8a7db2086954ad187502ec2c4f1811d17))
* **avs:** keep company on unchange address/email only if either is non-empty ([766b858](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/766b8589d6945df21fc6ce90d35a004655ffa471))
* **avs:** synch job deletes used row instead of truncation ([d7acc7a](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d7acc7a2d0fe5fc18929a8cb2d9c9f8a259c9944))
## [27.4.68](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.67...v27.4.68) (2024-06-19)
### Bug Fixes
* **letter:** minor ([2ae11dc](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/2ae11dc25c000486af9acc26439a0580f5c687f2))
## [27.4.67](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.66...v27.4.67) (2024-06-17)
### Bug Fixes
* **avs:** fix rare avs update bug involving values optional in avs but compulsory in user entity ([a6d0105](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a6d0105903caba0eb47715eeb217ea2c53d99e23))
## [27.4.66](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.65...v27.4.66) (2024-06-12)
### Bug Fixes
* **avs:** fix [#164](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/164) by removing companyPersonalNumber and companyDepartment upon ldap sync expiry ([da74b95](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/da74b957295caefb010c90297af557f997b18e7c))
* **avs:** fix [#165](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/165) by updating userCompanyDepartmen and userCompanyPersonalNumer ([76e0710](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/76e0710c7b54a40d2c236299ea4fabd009d3f35a))
* **avs:** repeated avs sync enqueue no longe violates duplicate db uniqueness constraints ([996e6a0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/996e6a0ce563bda96638863efd40ce38fce8ac2b))
* **avs:** update email on manual company switch ([9fd80f2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/9fd80f25526eefce217c659f6ea2991771c11ece)), closes [#164](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/164)
## [27.4.65](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.64...v27.4.65) (2024-06-10)
### Bug Fixes
* **avs:** company update no longer fails on duplicate key ([bb101de](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/bb101dee7b40cd3d8ba10a559af642396d5b87b5))
* **avs:** profile page correctly indicates automatic email and postal addresses ([e553ad4](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/e553ad4358a71fc96fa946533f0441d4af5202c9))
* **avs:** steps towards [#164](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/164) ([aa1d230](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/aa1d230e497f0e59dbea9f4fd5c7da773f5a4280))
* **lette:** adjust window for new pin letters ([6acfd84](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/6acfd849aeb473a018f7a9c34e69f61b3c22b6f8))
## [27.4.64](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.63...v27.4.64) (2024-05-27)
## [27.4.63](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.62...v27.4.63) (2024-05-23)
### Bug Fixes
* **avs:** company update checks uniques and ignores those updates if necessary ([9451d90](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/9451d90a9e00d08a2a7d169c4674d99ff1018ee9))
## [27.4.62](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.61...v27.4.62) (2024-05-19)
### Bug Fixes
* **avs:** avs update on company shorthands working now ([ff2347b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ff2347b1c950c7a2bb281cdcd07a52925e23b9f0))
* **avs:** deal gracefully with empty card status results ([ccf9340](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ccf934044938277d821eb4b9ea08a8a134e84189))
## [27.4.61](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.60...v27.4.61) (2024-05-06)
### Bug Fixes
* **avs:** fix [#76](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/76) allowing company changes and fix [#69](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/69) ([3c4a0b8](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3c4a0b86c1e3d8a28405ab73b964ba1b988d2822))
* **build:** add missing tex packages ([6750798](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/6750798920dc76882f4e8ef39b47018fb7b77e44))
* **build:** workaround non modal form result handler ([2fbd281](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/2fbd28154cd7aea282eaa2604a42263ac90e3b1e))
## [27.4.60](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.59...v27.4.60) (2024-04-26)
### Bug Fixes
* **avs:** disable caching by 0s no longer causes an exception ([d578e80](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d578e80282c8bf6872fa6040514a9d2c85582707))
* **avs:** fix [#152](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/152) by providing new online avs card filter throughout ([ad2375b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ad2375b338866f37c8b7825a9eab12fa6c9abccb))
* **avs:** fix [#36](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/36) and remove dead code ([4f8850b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/4f8850b3b4f710f9cf59163175b27599c97ac5c0))
* **avs:** fix [#69](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/69) by redesigning live avs status page ([697979c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/697979c277ce7198f4573d6cea30373a1fcc17da))
* **avs:** invalidate contact cache after licence writes ([c382be9](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/c382be9325fcc92e13cb5dc2ad7c20b198db26fc))
* **avs:** several minor bugfixes ([a52c8a6](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a52c8a6ad709029a8822d383370b0d2bdd25e7d7)), closes [#158](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/158)
* **build:** add import needed for production only ([724e4a0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/724e4a0bec343ab9c6d172d8e93b8040bbe3fe7d))
* **build:** migration needs to check for table existens first ([f439ea4](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f439ea45af9b1c4a029fc1b9b6383f3c97194ed0))
* **build:** minor error non-development code ([66eaa4f](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/66eaa4f7dcc124b631414d4a1adbe555a4029100))
* **build:** missing parameters added ([83afdf7](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/83afdf760f93fc1a553de3a122b444412ed84ba4))
* **build:** simple type error ([d56a1cd](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d56a1cdd46259418faa737b9bb0a9d9ffba442e0))
* **build:** type error in test db fill data ([f465cc9](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f465cc972367233a4944dd0aeb81b223a187bb85))
* **doc:** minor haddock problems ([d4f8a6c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d4f8a6c77b2a4a4540935f7f0beca0d0605508c8))
* **firm:** supervisor filter acts weird in test environment ([b566e59](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b566e59eb1325485fe26dc4f0b5cb63165c58f74))
* **i18n:** fix some bad plurals ([890f8ad](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/890f8ad8b60115533faa6b99f4c4504243cbfb1d))
* **lint:** remove minor superfluous dollar ([64a1233](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/64a123387f3539b73649d02a6ecd97de577097e6))
* **qualification:** fix [#159](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/159) by removing an misleadingly named column for user qualification table ([fd6a538](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/fd6a5384d3517958a3c7726e32eed3bad197a591))
## [27.4.59](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.58...v27.4.59) (2024-02-13)

21
config/develop-settings.yml Normal file
View File

@ -0,0 +1,21 @@
# SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
#
# SPDX-License-Identifier: AGPL-3.0-or-later
# Values formatted like "_env:ENV_VAR_NAME:default_value" can be overridden by the specified environment variable.
# See https://github.com/yesodweb/yesod/wiki/Configuration#overriding-configuration-values-with-environment-variables
# NB: If you need a numeric value (e.g. 123) to parse as a String, wrap it in single quotes (e.g. "_env:PGPASS:'123'")
# See https://github.com/yesodweb/yesod/wiki/Configuration#parsing-numeric-values-as-strings
#DEVELOPMENT ONLY, NOT TO BE USED IN PRODUCTION
avs-licence-synch:
times: [12]
level: 4
reason-filter: "(firm|block)"
max-changes: 999
# Enqueue at specified hour, a few minutes later
job-lms-qualifications-enqueue-hour: 16
job-lms-qualifications-dequeue-hour: 4

33
config/settings.yml
View File

@ -83,6 +83,7 @@ health-check-matching-cluster-config-timeout: "_env:HEALTHCHECK_MATCHING_CLUSTER
synchronise-ldap-users-within: "_env:SYNCHRONISE_LDAP_WITHIN:1209600" # 14 Tage in Sekunden
synchronise-ldap-users-interval: "_env:SYNCHRONISE_LDAP_INTERVAL:3600" # jede Stunde
synchronise-ldap-users-expire: "_env:SYNCHRONISE_LDAP_EXPIRE:15897600" # halbes Jahr in Sekunden
synchronise-avs-users-within: "_env:SYNCHRONISE_AVS_WITHIN:5702400" # alle 66 Tage
synchronise-avs-users-interval: "_env:SYNCHRONISE_AVS_INTERVAL:21600" # alle 6 Stunden
@ -90,10 +91,6 @@ synchronise-avs-users-interval: "_env:SYNCHRONISE_AVS_INTERVAL:21600" # alle 6
study-features-recache-relevance-within: 172800
study-features-recache-relevance-interval: 293
# Enqueue at specified hour, a few minutes later
# job-lms-qualifications-enqueue-hour: 15
# job-lms-qualifications-dequeue-hour: 3
log-settings:
detailed: "_env:DETAILED_LOGGING:false"
all: "_env:LOG_ALL:false"
@ -157,10 +154,12 @@ lms-direct:
deletion-days: "_env:LMSDELETIONDAYS:7"
avs:
host: "_env:AVSHOST:skytest.fra.fraport.de"
port: "_env:AVSPORT:443"
user: "_env:AVSUSER:fradrive"
pass: "_env:AVSPASS:"
host: "_env:AVSHOST:skytest.fra.fraport.de"
port: "_env:AVSPORT:443"
user: "_env:AVSUSER:fradrive"
pass: "_env:AVSPASS:\"0000\""
timeout: "_env:AVSTIMEOUT:42"
cache-expiry: "_env:AVSCACHEEXPIRY:420"
lpr:
host: "_env:LPRHOST:fravm017173.fra.fraport.de"
@ -207,9 +206,6 @@ memcached:
timeout: "_env:MEMCACHED_TIMEOUT:20"
expiration: "_env:MEMCACHED_EXPIRATION:300"
memcache-auth: true
memcached-local:
maximum-ghost: 512
maximum-weight: 104857600 # 100MiB
upload-cache:
host: "_env:UPLOAD_S3_HOST:localhost" # should be optional, but all file transfers will be empty without an S3 cache
@ -278,8 +274,8 @@ user-defaults:
max-favourites: 0
max-favourite-terms: 2
theme: Default
date-time-format: "%d %b %y %R"
date-format: "%d %b %Y"
date-time-format: "%d.%m.%Y %R"
date-format: "%d.%m.%y"
time-format: "%R"
download-files: false
warning-days: 1209600
@ -321,17 +317,6 @@ fallback-personalised-sheet-files-keys-expire: 2419200
download-token-expire: 604801
file-source-arc:
maximum-ghost: 512
maximum-weight: 1073741824 # 1GiB
file-source-prewarm:
maximum-weight: 1073741824 # 1GiB
start: 1800 # 30m
end: 600 # 10m
inhibit: 3600 # 60m
steps: 20
max-speedup: 3
bot-mitigations:
- only-logged-in-table-sorting
- unauthorized-form-honeypots

6
fixtest.sh Executable file
View File

@ -0,0 +1,6 @@
if [[ ! -d .stack-work-test ]]; then
mv -vT .stack-work .stack-work-test
[[ -d .stack-work-build ]] && mv -vT .stack-work-build .stack-work
else
echo "Directory .stack-work-test exists already."
fi

20
load/Load.hs
View File

@ -96,7 +96,7 @@ sampleIntegral = sampleN scaleIntegral
instance PathPiece DiffTime where
toPathPiece = (toPathPiece :: Pico -> Text) . MkFixed . diffTimeToPicoseconds
fromPathPiece t = fromPathPiece t <&> \(MkFixed ps :: Pico) -> picosecondsToDiffTime ps
data LoadSimulation
= LoadSheetDownload
@ -214,13 +214,13 @@ runSimulation sim = do
delays <- replicateM (fromIntegral p) $ do
d <- view $ _2 . _simDelay
sampleNDiffTime d
forConcurrently_ ([1..p] `zip` sort delays) $ \(n, d') -> do
begin <- liftIO getCurrentTime
dur <- view $ _2 . _simDuration
tDuration <- sampleNDiffTime dur
let MkFixed us = realToFrac d' :: Micro
threadDelay $ fromInteger us
start <- liftIO getCurrentTime
@ -268,7 +268,7 @@ runSimulation' LoadSheetSubmission = do
-- Just formData <- return . getFormData FIDsubmission $ resp ^. responseBody
-- Just addButtonData <- return . flip (runFormScraper FIDsubmission) (resp ^. responseBody) $ do
-- let btnSel = "button" Scalpel.@: [Scalpel.hasClass "btn-mass-input-add"]
-- name <- Scalpel.attr "name" btnSel
-- value <- Scalpel.attr "value" btnSel
-- guard $ value == "add__0__0"
@ -305,7 +305,7 @@ runSimulation' LoadSheetSubmission = do
procEnd <- join $ asks runtime
print ("proc", procEnd - procStart)
resp3 <- liftIO . httpRetry $ Session.post session (uriToString id formURI mempty) subData
void . evaluate $! resp3
where
@ -328,11 +328,11 @@ runSimulation' LoadSheetSubmission = do
-> m ()
logRetry shouldRetry err status = liftIO . putStrLn . pack $ Retry.defaultLogMsg shouldRetry err status
-- runSimulation' other = terror $ "Not implemented: " <> tshow other
runFormScraper :: FormIdentifier -> Scalpel.Scraper Lazy.ByteString a -> Lazy.ByteString -> Maybe a
runFormScraper fid innerS = fmap join . flip Scalpel.scrapeStringLike $
runFormScraper fid innerS = fmap join . flip Scalpel.scrapeStringLike $
fmap listToMaybe . Scalpel.chroots "form" $ do
fid' <- Scalpel.attr "value" $ "input" Scalpel.@: ["name" Scalpel.@= "form-identifier"]
guard $ fid' == encodeUtf8 (fromStrict $ toPathPiece fid)
@ -341,11 +341,11 @@ runFormScraper fid innerS = fmap join . flip Scalpel.scrapeStringLike $
getFormData :: FormIdentifier -> Lazy.ByteString -> Maybe [FormParam]
getFormData = flip runFormScraper $
Scalpel.chroots ("input") $ do
Scalpel.chroots "input" $ do
name <- Scalpel.attr "name" Scalpel.anySelector
value <- Scalpel.attr "value" Scalpel.anySelector <|> pure ""
return $ toStrict name := value
newLoadSession :: ReaderT SimulationContext IO Session
newLoadSession = do
@ -354,7 +354,7 @@ newLoadSession = do
let withToken = case loadToken of
Nothing -> id
Just (Jwt bs) -> (:) (hAuthorization, "Bearer " <> bs) . filter ((/= hAuthorization) . fst)
liftIO . Session.newSessionControl (Just mempty) $ tlsManagerSettings
{ managerModifyRequest = \req -> return $ req { requestHeaders = withToken $ requestHeaders req }

37
messages/uniworx/categories/admin/de-de-formal.msg
View File

@ -1,4 +1,4 @@
# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
# SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
#
# SPDX-License-Identifier: AGPL-3.0-or-later
@ -67,6 +67,7 @@ BearerTokenExpiresTip: Wird der Ablaufzeitpunkt überschrieben und kein Ablaufze
BearerTokenOverrideStart: Startzeitpunkt
BearerTokenOverrideStartTip: Wird kein Startzeitpunkt angegeben, wird bei Verwendung des Tokens nur der Ablaufzeitpunkt überprüft.
HeadingAdminTokens: Tokens ausstellen
UserUnknown: Unbekannter Benutzer:in
#templates adminFeautures
StudyFeaturesDegrees: Abschlüsse
@ -101,7 +102,7 @@ ProblemsHeadingDrivers: Fahrberechtigungen
ProblemsHeadingNotifications: Benachrichtigungen
ProblemsHeadingMisc: Allgemein
ProblemsAvsProblem: Synchronisation mit AVS/MoBaKo komplett fehlgeschlagen
ProblemsDriverSynch n@Int: #{tshow n} Diskrepanzen zwischen AVS und FRADrive
ProblemsDriverSynch n@Int: #{n} #{pluralDE n "Diskrepanz" "Diskrepanzen"} zwischen AVS und FRADrive
ProblemsDriverSynch0: Alle Sperrungen von Vorfeld-Fahrberechtigungen 'F' sind im AVS eingetragen
ProblemsDriverSynch1down: Alle Sperrungen von Rollfeld-Fahrberechtigungen 'R' sind im AVS eingetragen
ProblemsDriverSynch1up: Alle gültigen Vorfeld-Fahrberechtigungen 'F' sind im AVS eingetragen
@ -109,10 +110,11 @@ ProblemsDriverSynch2: Alle gültigen Rollfeld-Fahrberechtigungen 'R' sind im AVS
ProblemsRDriversHaveFs: Alle Inhaber einer Rollfeld-Fahrberechtigung besitzen auch eine gültige Vorfeld-Fahrberechtigung
ProblemsDriversHaveAvsIds: Alle Inhaber einer Fahrberechtigung konnten einer AVS Identifikationsnummer zugeordnet werden
ProblemsUsersAreReachable: Für alle Benutzer ist eine E-Mail oder postalische Adresse bekannt
ProblemsNoStalePrintJobs n@Integer: Alle Briefversandaufträge der vergangenen #{show n} Tage wurden von der Druckerei bestätigt
ProblemsNoStalePrintJobs n@Integer: Alle Briefversandaufträge #{pluralDE n "des vergangenen Tages" ("der vergangenen "<> tshow n <> " Tage")} wurden von der Druckerei bestätigt
ProblemsNoBadAPCIds: Alle kürzlich empfangenen Druckauftragsbestätigungen waren gültig
ProblemsUnreachableHeading: Unerreichbare Benutzer
ProblemsUnreachableBody: Benutzer ohne E-Mail oder Postadresse, welche z.B. bei ablaufenden Berechtigungen nicht benachrichtigt werden können:
ProblemsUnreachableButtons: Synchronisation für Unerreichbare starten
ProblemsRWithoutFHeading: Fahrer mit R ohne F
ProblemsRWithoutFBody: Diese Fahrer sind wegen einer ungültigen Vorfeld-Fahrberechtigung komplett gesperrt, obwohl eine gültige Rollfeld-Fahrberechtigung besteht:
ProblemsNoAvsIdHeading: Fahrer ohne AVS-Id
@ -120,6 +122,24 @@ ProblemsNoAvsIdBody: Fahrer mit gültiger Fahrberechtigung in FRADrive, welche t
ProblemsAvsSynchHeading: Synchronisation AVS Fahrberechtigungen
ProblemsAvsErrorHeading: Fehlermeldungen
ProblemsInterfaceSince: Berücksichtigt werden nur Erfolge und Fehler seit
ProblemAvsUsrHadR: Momentan gültiges R im AVS
AdminProblemSolved: Erledigt
AdminProblemSolver: Bearbeitet von
AdminProblemCreated: Erkannt
AdminProblemInfo: Problembeschreibung
AdminProblemsSolved n@Int: #{pluralDEeN n "Admin Problem"} als erledigt markiert
AdminProblemsReopened n@Int: #{pluralDEeN n "Admin Problem"} erneut eröffnet
AdminProblemNewCompany: Neue Firma über AVS automatisch erstellt; prüfen und ggf. Standardansprechpartner eintragen
AdminProblemSupervisorNewCompany b@Bool: Standardansprechpartner #{boolText mempty "mit Standardumleitung" b} wechselte zu neuer Firma
AdminProblemSupervisorLeftCompany b@Bool: Einziger Standardansprechpartner #{boolText mempty "mit Standardumleitung" b} dieses Fahrers wechselte zu neuer Firma
AdminProblemCompanySuperiorChange: Neuer firmenweiter Vorgesetzter.
AdminProblemCompanySuperiorNotFound t@Text: Neuer unbekannter firmenweiter Vorgesetzter mit E-Mail #{t}, keine Ansprechpartnerbeziehungen eingerichtet.
AdminProblemCompanySuperiorPrevious: Ehemaliger Vorgesetzter:
AdminProblemNewlyUnsupervised: Fahrer hat keinen Firmenansprechpartner mehr nach AVS Firmenwechsel zu Firma
AdminProblemUser: Betroffener
ProblemTableMarkSolved: Als erledigt markieren
ProblemTableMarkUnsolved: Erledigt Markierung löschen
InterfacesOk: Schnittstellen sind ok.
InterfacesFail n@Int: #{pluralDEeN n "Schnittstellenproblem"}!
@ -130,4 +150,13 @@ InterfaceSubtype: Betreffend
InterfaceWrite: Schreibend
InterfaceSuccess: Rückmeldung
InterfaceInfo: Nachricht
InterfaceFreshness: Prüfungszeitraum (h)
InterfaceFreshness: Maximale Zugriffsfrist
InterfaceFreshnessTooltip: Zeitspanne innerhalb der ein erneuter erfolgreicher Schnittstellenzugriff erfolgen muss, ohne Warnungen auszulösen
ConfigInterfacesHeading: Konfiguration Zugriffsfristen
IWTActAdd: Hinzufügen/Ändern
IWTActDelete: Entfernen
InterfaceWarningAdded: Schnittstellenwarnungszeit hinzugefügt oder geändert
InterfaceWarningDeleted n@Int: #{pluralDEeN n "Schnittstellenwarnungszeit"} gelöscht
InterfaceWarningDisabledEntirely: Alle Fehler ignorieren
InterfaceWarningDisabledInterval: Keine Zugriffsfrist

47
messages/uniworx/categories/admin/en-eu.msg
View File

@ -1,4 +1,4 @@
# SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
# SPDX-FileCopyrightText: 2022-24 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
#
# SPDX-License-Identifier: AGPL-3.0-or-later
@ -18,10 +18,10 @@ NoNameCandidatesInferred: No new name-mappings inferred
AllNameIncidencesDeleted: Successfully deleted all name observations
AllParentIncidencesDeleted: Successfully deleted all parent-relation observations
AllStandaloneIncidencesDeleted: Successfully deleted all standalone observations
IncidencesDeleted n: Successfully deleted #{show n} #{pluralEN n "observation" "observations"}
RedundantParentCandidatesRemoved n: Successfully removed #{n} rendundant #{pluralEN n "parent-candidate" "parent-candidates"}
RedundantStandaloneCandidatesRemoved n: Successfully removed #{n} rendundant #{pluralEN n "standalone-candidate" "standalone-candidates"}
ParentCandidatesInferred n: Successfully inferred #{n} field #{pluralEN n "parent-relation" "parent-reliations"}
IncidencesDeleted n: Successfully deleted #{pluralENsN n "observation"}
RedundantParentCandidatesRemoved n: Successfully removed #{n} rendundant #{pluralENs n "parent-candidate"}
RedundantStandaloneCandidatesRemoved n: Successfully removed #{n} rendundant #{pluralENs n "standalone-candidate"}
ParentCandidatesInferred n: Successfully inferred #{n} field #{pluralENs n "parent-relation"}
NoParentCandidatesInferred: No new parent-relations inferred
StudyDegreeChangeSuccess: Successfully updated degrees
StudyTermsShort: Field shorthand
@ -67,6 +67,7 @@ BearerTokenExpiresTip: If no expiration time is given, the token will not expire
BearerTokenOverrideStart: Start time
BearerTokenOverrideStartTip: If no start time is given, only the expiration time will be checked when the token is used.
HeadingAdminTokens: Issue tokens
UserUnknown: User unknown
#templates adminfeatures
StudyFeaturesDegrees: Degrees
@ -101,7 +102,7 @@ ProblemsHeadingDrivers: Driving Licences
ProblemsHeadingNotifications: User communication
ProblemsHeadingMisc: Miscellaneous
ProblemsAvsProblem: Synchronisation with AVS/MoBaKo failed entirely
ProblemsDriverSynch n: #{tshow n} mismatches between AVS and FRADrive
ProblemsDriverSynch n: #{tshow n} #{pluralEN n "mismatch" "mismatches"} between AVS and FRADrive
ProblemsDriverSynch0: All revocations of apron driving licences 'F' were successfully registered with AVS
ProblemsDriverSynch1down: All revocations of maneuvering area driving licences 'R' were successfully registered with AVS
ProblemsDriverSynch1up: All valid apron driving licences 'F' were successfully registered with AVS
@ -109,17 +110,36 @@ ProblemsDriverSynch2: All valid maneuvering area driving licences 'R' were succe
ProblemsRDriversHaveFs: All driving licence 'R' holders also have a valid 'F' licence
ProblemsDriversHaveAvsIds: All driving licence holder could be matched with their AVS id
ProblemsUsersAreReachable: Either Email or postal address is known for all users
ProblemsNoStalePrintJobs n: All requests for letter mailing within the last #{show n} days were acknowledged as printed by the airport printing center
ProblemsNoStalePrintJobs n: All requests for letter mailing within the last #{pluralENsN n "day"} were acknowledged as printed by the airport printing center
ProblemsNoBadAPCIds: All recently received print job ids from Airport Print Center were legit
ProblemsUnreachableHeading: Unreachable Users
ProblemsUnreachableBody: Users without Email nor postal address, who thus cannot be notified about expiring qualifications:
ProblemsUnreachableButtons: Start synchronisation for unreachable users only
ProblemsRWithoutFHeading: Drivers having 'R' but not 'F'
ProblemsRWithoutFBody: Drivers without apron driving licence are prohibited from driving, even if they own a valid maneuvering driving licence:
ProblemsNoAvsIdHeading: Drivers without AVS id
ProblemsNoAvsIdBody: Drivers having a valid apron driving licence within FRADrive only, but who may not drive since a missing AVS id prevents communication of the driving licence to AVS:
ProblemsAvsSynchHeading: Synchronisation AVS Driving Licences
ProblemsAvsErrorHeading: Error Log
ProblemsInterfaceSince: Only considering successes and errors since
ProblemsInterfaceSince: Only considering successes and errors since
ProblemAvsUsrHadR: Currenlt R valid in AVS
AdminProblemSolved: Done
AdminProblemSolver: Solved by
AdminProblemCreated: Recognized
AdminProblemInfo: Problem
AdminProblemsSolved n: #{pluralENsN n "admin problem"} marked as solved
AdminProblemsReopened n: #{pluralENsN n "admin problem"} reopened
AdminProblemNewCompany: New company from AVS; verify and add default supervisors
AdminProblemSupervisorNewCompany b: Default company supervisor #{boolText mempty "with reroute" b} changed to new company
AdminProblemSupervisorLeftCompany b: Only default company supervisor #{boolText mempty "with reroute" b} for this user changed to new company
AdminProblemCompanySuperiorChange: New company wide superior.
AdminProblemCompanySuperiorNotFound t: Unable to set supervision for new unknown company wide superior having Email #{t}.
AdminProblemCompanySuperiorPrevious: Previous superior:
AdminProblemNewlyUnsupervised: Driver has no longer a company default supervisor after AVS update at new company
AdminProblemUser: Affected
ProblemTableMarkSolved: Mark done
ProblemTableMarkUnsolved: Reopen as undone
InterfacesOk: Interfaces are ok.
InterfacesFail n: #{pluralENsN n "interface problem"}!
@ -130,4 +150,13 @@ InterfaceSubtype: Affecting
InterfaceWrite: Write
InterfaceSuccess: Returned
InterfaceInfo: Message
InterfaceFreshness: Check hours
InterfaceFreshness: Maximum usage period
InterfaceFreshnessTooltip: Time period within which the next successful interface access must occur to avoid a warning
ConfigInterfacesHeading: Configure interface usage warnings
IWTActAdd: Add/Edit
IWTActDelete: Delete
InterfaceWarningAdded: Interface warning time added/changed
InterfaceWarningDeleted n: #{pluralENsN n "interface warning time"} deleted
InterfaceWarningDisabledEntirely: Ignore all errors
InterfaceWarningDisabledInterval: No maximum usage period

28
messages/uniworx/categories/avs/de-de-formal.msg
View File

@ -2,17 +2,21 @@
#
# SPDX-License-Identifier: AGPL-3.0-or-later
AvsPersonInfo: AVS Personendaten
AvsPersonId: AVS Personen Id
AvsPersonId: AVS Personen Id
AvsPersonNo: AVS Personennummer
AvsPersonNoNotId: AVS Personennummer dient zur menschlichen Kommunikation mit der Ausweisstelle und darf nicht verwechselt werden mit der maschinell verwendeten AVS Personen Id
AvsPersonNoMismatch: AVS Personennummer hat sich geändert und wurde in FRADrive noch nicht aktualisiert
AvsPersonNoDiffers: Es sind derzeit zwei verschiedene AVS Personennummern zugeordnet. Bitte einen Administrator kontaktieren.
AvsCardNo: Ausweiskartennummer
AvsFirstName: Vorname
AvsLastName: Nachname
AvsPrimaryCompany: Primäre Firma
AvsInternalPersonalNo: Personalnummer (nur Fraport AG)
AvsVersionNo: Versionsnummer
AvsQueryNeeded: Benötigt Verbindung zum AVS.
AvsQueryEmpty: Bitte mindestens ein Anfragefeld ausfüllen!
AvsQueryStatusInvalid t@Text: Nur numerische IDs eingeben, durch Komma getrennt! Erhalten: #{show t}
AvsLicence: Fahrberechtigung
AvsPersonNoNotId: AVS Personennummer dient zur menschlichen Kommunikation mit der Ausweisstelle und darf nicht verwechselt werden mit der maschinell verwendeten AVS Personen Id
AvsTitleLicenceSynch: Abgleich Fahrberechtigungen zwischen AVS und FRADrive
BtnAvsRevokeUnknown: Fahrberechtigungen im AVS sofort entziehen
BtnAvsImportUnknown: AVS Daten unbekannter Personen importieren
@ -27,13 +31,33 @@ RevokeFraDriveLicences alic@AvsLicence n@Int: _{alic} in FRADrive entzogen für
RevokeUnknownLicencesOk: AVS Fahrberechtigungen unbekannter Fahrer wurden gesperrt
RevokeUnknownLicencesFail: Nicht alle AVS Fahrberechtigungen unbekannter Fahrer konnten entzogen werden, siehe Log für Details
AvsCommunicationError: AVS Schnittstelle lieferte einen unerwarteten Fehler.
AvsCommunicationTimeout: AVS Schnittstelle antwortete nicht.
LicenceTableChangeAvs: Im AVS ändern
LicenceTableGrantFDrive: In FRADrive erteilen
LicenceTableRevokeFDrive: In FRADrive entziehen
TableAvsActiveCards: Gültige Ausweise
TableAvsCardValid: Aktuell gültig
TableAvsCardIssueDate: Ausgestellt am
TableAvsCardValidTo: Gültig bis
AvsCardAreas: Ausweiszusätze
AvsCardColor: Ausweisfarbe
AvsCardColorGreen: Grün
AvsCardColorBlue: Blau
AvsCardColorRed: Rot
AvsCardColorYellow: Gelb
LastAvsSynchronisation: Letzte AVS-Synchronisation
LastAvsSyncedBefore: Letzte AVS-Synchronisation vor
LastAvsSynchError: Letzte AVS-Fehlermeldung
AvsInterfaceUnavailable: AVS Schnittstelle nicht richtig konfiguriert oder antwortet nicht
AvsUserUnassociated user@UserDisplayName: AVS Id unbekannt für Nutzer #{user}
AvsUserUnknownByAvs api@AvsPersonId: AVS kennt Id #{tshow api} nicht (mehr)
AvsUserAmbiguous api@AvsPersonId: AVS Id #{tshow api} ist nicht eindeutig
AvsStatusSearchEmpty: AVS lieferte keine Ausweisinformationen
AvsPersonSearchEmpty: AVS Suche lieferte leeres Ergebnis
AvsPersonSearchAmbiguous: AVS Suche lieferte mehrere uneindeutige Ergebnisse
AvsSetLicencesFailed reason@Text: Setzen der Fahrlizenz im AVS fehlgeschlagen. Grund: #{reason}
AvsIdMismatch api1@AvsPersonId api2@AvsPersonId: AVS Suche für Id #{tshow api1} lieferte stattdessen Id #{tshow api2}
AvsUserCreationFailed api@AvsPersonId: Für AVS Id #{tshow api} konnte kein neuer Benutzer angelegt werden, da es eine gemeinsame Id (z.B. Personalnummer) mit einem existierenden, aber verschiedenen Nutzer gibt.
AvsCardsEmpty: AVS Suche lieferte keinerlei Ausweiskarten
AvsCurrentData: Alle angezeigte Daten wurden kürzlich direkt über die AVS Schnittstelle abgerufen.

35
messages/uniworx/categories/avs/en-eu.msg
View File

@ -1,18 +1,23 @@
# SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
#
# SPDX-License-Identifier: AGPL-3.0-or-later
AvsPersonInfo: AVS Person Info
AvsPersonId: AVS Person Id
AvsPersonNo: AVS Person Number
AvsPersonInfo: AVS person info
AvsPersonId: AVS person id
AvsPersonNo: AVS person number
AvsPersonNoNotId: AVS person number is used in human communication only and must not be mistaken for the AVS personen id used in machine communications
AvsPersonNoMismatch: AVS person number has changed and was not yet updated in FRADrive
AvsPersonNoDiffers: There are currently two differing AVS person numbers associated with this user. Please contact an administrator to resolve this.
AvsCardNo: Card number
AvsFirstName: First name
AvsLastName: Last name
AvsPrimaryCompany: Primary company
AvsInternalPersonalNo: Personnel number (Fraport AG only)
AvsVersionNo: Version number
AvsQueryNeeded: AVS connection required.
AvsQueryEmpty: At least one query field must be filled!
AvsQueryStatusInvalid t: Numeric IDs only, comma seperated! #{show t}
AvsLicence: Driving Licence
AvsPersonNoNotId: AVS person number is used in human communication only and must not be mistaken for the AVS personen id used in machine communications
AvsTitleLicenceSynch: Synchronisation driving licences between AVS and FRADrive
BtnAvsRevokeUnknown: Revoke AVS driving licences for unknown persons immediately
BtnAvsImportUnknown: Import AVS data for unknown persons
@ -27,13 +32,33 @@ RevokeFraDriveLicences alic@AvsLicence n@Int: _{alic} revoked in FRADrive for #{
RevokeUnknownLicencesOk: AVS driving licences of unknown drivers revoked
RevokeUnknownLicencesFail: Not all AVS driving licences of unknown drivers could be revoked, see log for details
AvsCommunicationError: AVS interface returned an unexpected error.
AvsCommunicationTimeout: AVS interface returned no response within timeout limit.
LicenceTableChangeAvs: Change in AVS
LicenceTableGrantFDrive: Grant in FRADrive
LicenceTableRevokeFDrive: Revoke in FRADrive
TableAvsActiveCards: Valid Cards
TableAvsCardValid: Currently valid
TableAvsCardIssueDate: Issued
TableAvsCardValidTo: Valid to
AvsCardAreas: Card areas
AvsCardColor: Color
AvsCardColorGreen: Green
AvsCardColorBlue: Blue
AvsCardColorRed: Red
AvsCardColorYellow: Yellow
LastAvsSynchronisation: Last AVS synchronisation
LastAvsSynchError: Last AVS Error
LastAvsSyncedBefore: Last AVS synchronisation before
LastAvsSynchError: Last AVS Error
AvsInterfaceUnavailable: AVS interface was not configured correctly or does not respond
AvsUserUnassociated user: AVS id unknown for user #{user}
AvsUserUnknownByAvs api: AVS reports id #{tshow api} as unknown (or no longer known)
AvsUserAmbiguous api: Multiple matching users found for #{tshow api}
AvsStatusSearchEmpty: AVS returned no card information
AvsPersonSearchEmpty: AVS search returned empty result
AvsPersonSearchAmbiguous: AVS search returned more than one result
AvsSetLicencesFailed reason: Set driving licence within AVS failed. Reason: #{reason}
AvsIdMismatch api1 api2: AVS search for id #{tshow api1} returned id #{tshow api2} instead
AvsUserCreationFailed api@AvsPersonId: No new user could be created for AVS Id #{tshow api}, since an existing user shares at least one id presumed as unique
AvsCardsEmpty: AVS search returned no id cards
AvsCurrentData: All shown data has been recently received via the AVS interface.

4
messages/uniworx/categories/courses/courses/de-de-formal.msg
View File

@ -70,6 +70,10 @@ CourseInvalidInput: Eingaben bitte korrigieren.
CourseEditTitle: Kursart editieren/anlegen
CourseEditOk tid@TermId ssh@SchoolId csh@CourseShorthand: Kursart #{tid}-#{ssh}-#{csh} wurde erfolgreich geändert.
CourseEditDupShort tid@TermId ssh@SchoolId csh@CourseShorthand: Kursart #{tid}-#{ssh}-#{csh} konnte nicht geändert werden: Es gibt bereits einen andere Kursart mit dem selben Kürzel oder Titel in diesem Jahr und Bereich.
CourseEditQualificationFail: Eine Qualifikation konnte uas unbekanntem Grund nicht mit diesem Kurs assoziert werden.
CourseEditQualificationFailRights qsh@QualificationShorthand ssh@SchoolId: Qualifikation #{qsh} konnte nicht mit diesem Kurs assoziert werden, da Ihre Berechtigungen für Bereich #{ssh} dazu nicht ausreichen.
CourseEditQualificationFailExists: Diese Qualifikation ist bereits assoziert
CourseEditQualificationFailOrder: Diese Sortierpriorität existiert bereits
CourseLecturer: Kursverwalter:in
MailSubjectParticipantInvitation tid@TermId ssh@SchoolId csh@CourseShorthand: [#{tid}-#{ssh}-#{csh}] Einladung zur Kursartteilnahme
CourseParticipantInviteHeading courseName@Text: Einladung zum Kursartteilnahmer für #{courseName}

6
messages/uniworx/categories/courses/courses/en-eu.msg
View File

@ -70,8 +70,12 @@ CourseInvalidInput: Invalid input
CourseEditTitle: Edit/Create course
CourseEditOk tid ssh csh: Successfully edited course type #{tid}-#{ssh}-#{csh}
CourseEditDupShort tid ssh csh: Could not edit course type #{tid}-#{ssh}-#{csh}. Another course type with the same shorthand or title already exists for the given year and school.
CourseEditQualificationFail: A qualifikation could not be associated with this course for unknown reasons.
CourseEditQualificationFailRights qsh ssh: Qualification #{qsh} could not be associated with this course, due to your insufficient rights for department #{ssh}.
CourseEditQualificationFailExists: This qualification is already associated
CourseEditQualificationFailOrder: This sort order priority is used already
CourseLecturer: Course administrator
MailSubjectParticipantInvitation tid@TermId ssh@SchoolId csh@CourseShorthand: [#{tid}-#{ssh}-#{csh}] Invitaion to join the course
MailSubjectParticipantInvitation tid ssh csh: [#{tid}-#{ssh}-#{csh}] Invitaion to join the course
CourseParticipantInviteHeading courseName: Invitation to enrol for #{courseName}
CourseParticipantInviteExplanation: You were invited to be a participant of a course.
CourseParticipantInviteField: Email addresses to invite

10
messages/uniworx/categories/courses/tutorial/de-de-formal.msg
View File

@ -1,4 +1,4 @@
# SPDX-FileCopyrightText: 2022 Winnie Ros <winnie.ros@campus.lmu.de>
# SPDX-FileCopyrightText: 2022-24 Winnie Ros <winnie.ros@campus.lmu.de>, Steffen Jost <s.jost@fraport.de>
#
# SPDX-License-Identifier: AGPL-3.0-or-later
@ -36,6 +36,7 @@ TutorialDelete: Löschen
TutorialsHeading: Kurse
TutorialNew: Neuer Kurs
TutorialRegisteredSuccess tutn@TutorialName: Erfolgreich zum Kurs #{tutn} angemeldet
TutorialRegisteredFail tutn@TutorialName: Anmeldung zum Kurs #{tutn} fehlgeschlagen. Existiert bereits eine Anmeldung?
TutorialDeregisteredSuccess tutn@TutorialName: Erfolgreich vom Kurs #{tutn} abgemeldet
MailSubjectTutorInvitation tid@TermId ssh@SchoolId csh@CourseShorthand tutn@TutorialName: [#{tid}-#{ssh}-#{csh}] Einladung zum Ausbilder für #{tutn}
TutorInviteHeading tutn@TutorialName: Einladung zum Ausbilder/zur Ausbilderin für #{tutn}
@ -49,4 +50,9 @@ TutorialUserGrantQualification: Qualifikation vergeben
TutorialUserRenewQualification: Qualifikation regulär verlängern
TutorialUserRenewedQualification n@Int: Qualifikation für #{tshow n} Kurs-#{pluralDE n "Teilnehmer:in" "Teilnehmer:innen"} regulär verlängert
TutorialUserGrantedQualification n@Int: Qualifikation erfolgreich an #{tshow n} Kurs-#{pluralDE n "Teilnehmer:in" "Teilnehmer:innen"} vergeben
CommTutorial: Kursmitteilung
CommTutorial: Kursmitteilung
TutorialDrivingPermit: Führerschein
TutorialEyeExam: Sehtest
TutorialNote: Kursnotiz
TutorialDayAttendance day@Text: Anwesenheit am #{day}
TutorialDayNote day@Text: Anwesenheitsnotiz für #{day}

8
messages/uniworx/categories/courses/tutorial/en-eu.msg
View File

@ -1,4 +1,4 @@
# SPDX-FileCopyrightText: 2022 Winnie Ros <winnie.ros@campus.lmu.de>
# SPDX-FileCopyrightText: 2022-24 Winnie Ros <winnie.ros@campus.lmu.de>, Steffen Jost <s.jost@fraport.de>
#
# SPDX-License-Identifier: AGPL-3.0-or-later
@ -36,6 +36,7 @@ TutorialDelete: Delete
TutorialsHeading: Courses
TutorialNew: New course
TutorialRegisteredSuccess tutn: Successfully registered for the course #{tutn}
TutorialRegisteredFail tutn: Registering for the course #{tutn} failed. Probably already registered?
TutorialDeregisteredSuccess tutn: Successfully de-registered for the course #{tutn}
MailSubjectTutorInvitation tid ssh csh tutn: [#{tid}-#{ssh}-#{csh}] Invitation to be a instructor for #{tutn}
TutorInviteHeading tutn: Invitation to be instructor for #{tutn}
@ -51,3 +52,8 @@ TutorialUserRenewQualification: Renew qualification
TutorialUserRenewedQualification n@Int: Successfully renewed qualification #{tshow n} course #{pluralEN n "user" "users"}
TutorialUserGrantedQualification n: Successfully granted qualification #{tshow n} course #{pluralEN n "user" "users"}
CommTutorial: Course message
TutorialDrivingPermit: Driving permit
TutorialEyeExam: Eye exam
TutorialNote: Course note
TutorialDayAttendance day: Attendance #{day}
TutorialDayNote day: Attendance note #{day}

36
messages/uniworx/categories/firm/de-de-formal.msg
View File

@ -1,4 +1,4 @@
# SPDX-FileCopyrightText: 2023 Steffen Jost <s.jost@fraport.de>
# SPDX-FileCopyrightText: 2023-24 Steffen Jost <s.jost@fraport.de>
#
# SPDX-License-Identifier: AGPL-3.0-or-later
@ -7,7 +7,6 @@ FirmSuperForeign: Firmenfremde Ansprechpartner
FirmSuperIrregular: Irreguläre Ansprechpartner
FirmAssociates: Firmenangehörige
FirmContact: Firmenkontakt
FirmNoContact: Keine allgemeinen Kontaktinformationen bekannt.
FirmEmail: Allgemeine Email
FirmAddress: Postanschrift
FirmDefaultPreferenceInfo: Diese Voreinstellungen gelten nur für neue Firmenangehörige
@ -16,11 +15,15 @@ FirmActionInfo: Betrifft alle Firmenangehörigen unter Ihrer Aufsicht.
FirmActNotify: Mitteilung versenden
FirmActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurücksetzen
FirmActResetSuperKeep: Bisherige Ansprechpartner der Firmenangehörigen zusätzlich beibehalten?
FirmActRemoveSupers: Alle rein firmenbezogenen Ansprechpartnerbeziehungen für diese Personen entfernen?
FirmActResetMutualSupervision: Ansprechpartner beaufsichtigen sich gegenseitig
FirmActAddSupersvisors: Ansprechpartner hinzufügen
FirmActResetSupersKeepAll: Alle behalten
FirmActResetSupersRemoveAps: Nur Standardansprechpartner entfernen
FirmActResetSupersRemoveAll: Alle entfernen
FirmActAddSupervisors: Ansprechpartner hinzufügen
FirmActAddSupersEmpty: Es konnten keine Ansprechpartner hinzugefügt werden
FirmActAddSupersSet n@Int64 postal@(Maybe Bool): #{n} Standardansprechpartner geändert #{maybeBoolMessage postal "" "und auf Briefversand geschaltet" "und Benachrichtigungen per Email gesetzt"}, aber nicht nicht aktiviert.
RemoveSupervisors ndef@Int64 nact@Int64: #{ndef} Standard Ansprechpartner entfernt#{bool ", aber noch nicht deaktiviert" (", " <> tshow nact <> " aktive Ansprechpartnerbeziehungen gelöscht") (nact > 0)}
RemoveSupervisors ndef@Int64: #{ndef} Standardansprechpartner entfernt.
FirmActChangeContactUser: Kontaktinformationen von allen Firmenangehörigen ändern
FirmActChangeContactFirm: Kontaktinformationen der Firma ändern
FirmActChangeContactFirmInfo: Firmenkontaktinformationen werden nur für neue Firmenangehörige verwendet, für die sonst keine Kontaktinformationen vorliegen.
@ -28,17 +31,23 @@ FirmActChangeContactFirmResult: Firmenkontaktinformationen geändert. Betrifft n
FirmUserActNotify: Mitteilung versenden
FirmUserActResetSupervision: Ansprechpartner auf Firmenstandard zurücksetzen
FirmUserActSetSupervisor: Ansprechpartner ändern
FirmUserActChangeContact: Kontaktinformationen für ausgewählte Firmenangehörige ändern
FirmUserActChangeDetails: Firmenassoziation bearbeiten
FirmUserActRemove: Firmenassoziation entfernen
FirmUserActMkSuper: Zum Firmenansprechpartner ernennen
FirmUserActChangeDetailsResult n@Int64 t@Int64: Firmenassoziation von #{n}/#{t} #{pluralDE n "Firmenangehörigen" "Firmenangehörige"} wurden aktualisiert
FirmUserActChangeResult n@Int64 t@Int64: Benachrichtigungseinstellung für #{n}/#{t} #{pluralDE n "Firmenangehörigen" "Firmenangehörige"} wurden geändert
FirmUserActRemoveResult uc@Int64: #{uc} #{pluralDE uc "Firmenassoziation" "Firmenassoziationen"} entfernt.
FirmRemoveSupervision sup@Int64 sub@Int64: #{noneMoreDE sup "" (tshow sup <> " Ansprechpartnerbeziehungen wegen entferntem Ansprechpartner gelöscht. ")} #{noneOneMoreDE sub "Keine Ansprechpartnerbeziehung" "Eine Ansprechpartnerbeziehung" (tshow sup <> " Ansprechpartnerbeziehungen")} wegen entferntem Angesprochenem gelöscht.
FirmNewSupervisor: Neue individuelle Ansprechpartner hinzufügen
FirmSetSupervisor: Existierende Ansprechpartner hinzufügen
FirmSetSupersReport nusr@Int64 nspr@Int64 nrem@Int64: Für #{nusr} Firmenangehörige wurden #{nspr} individuelle Ansprechpartner eingetragen#{bool "." (" und " <> tshow nrem <> " individuelle Ansprechpartnerbeziehungen gelöscht.") (nrem >0)}
FirmUserActMkSuper: Zum Firmenansprechpartner ernennen
FirmUserActChangeContact: Kontaktinformationen für ausgewählte Firmenangehörige ändern
FirmResetSupervision rem@Int64 set@Int64: #{tshow set} Ansprechpartner gesetzt#{bool mempty (", " <> tshow rem <> " zuvor gelöscht") (rem > 0)}
FirmSuperActNotify: Mitteilung versenden
FirmSuperActSwitchSuper: Standard Firmenansprechpartner abändern
FirmSuperActSwitchSuperInfo: Betrifft keine firmenfremden Ansprechpartner und ändert keine aktiven individuellen Ansprechpartnerbeziehungen. Gegebenfalls im Anschluss die Funktion "Ansprechpartner auf Firmenstandard zurücksetzen" nutzen.
FirmSuperActRMSuperDef: Firmenansprechpartner entfernen
FirmSuperActRMSuperActive: Auch aktive Ansprechpartnerbeziehungen innerhalb dieser Firma beenden
FirmSuperActRMSuperActive: Aktive Ansprechpartnerbeziehungen innerhalb dieser Firma beenden?
FirmsNotification: Firmen E-Mail versenden
FirmNotification fsh@CompanyShorthand: E-Mail an #{fsh} senden
FirmsNotificationTitle: Firmen benachrichtigen
@ -47,14 +56,23 @@ FilterSupervisor: Hat aktiven Ansprechpartner
FilterSupervisorCompany fsh@CompanyShorthand: Hat aktiven Ansprechpartner, #{fsh} der angehört
FilterSupervisorForeign fsh@CompanyShorthand: Hat aktiven Ansprechpartner, der selbst nicht #{fsh} angehört
FilterForeignSupervisor: Hat firmenfremde Ansprechpartner
FilterIsForeignSupervisee: Ist Ansprechpartner für Firmenfremde
FilterFirmExtern: Externe Firma
FilterFirmExternTooltip: Hat die Firma eine Postanschrift im AVS?
FilterFirmPrimary: Ist primäre Firma in FRADrive
FilterHasQualification: Hat Firmenangehörige mit aktuell gültiger Qualifikation
FirmSupervisorOf fsh@CompanyShorthand: Ansprechpartner #{fsh} angehörig
FirmSupervisorIndependent: Ansprechpartner ohne jegliche Firmenzugehörigkeit
FirmEmployeeOf fsh@CompanyShorthand: Firmenangehörige #{fsh}
NoCompanySelected: Bitte wählen Sie mindestens eine Firma aus.
TableIsDefaultSupervisor: Standardansprechpartner
TableSuperior: Vorgesetzter
TableIsDefaultReroute: Standardumleitung
FormFieldPostal: Benachrichtigungseinstellung
FormFieldPostalTip: Gilt für alle Benachrichtigungen an diese Person, nicht nur für Umleitungen an diesen Ansprechpartner
FirmUserChanges n@Int64: Benachrichtigungseinstellung für #{n} Firmenangehörige wurden geändert
FirmSupervisionKeyData: Kennzahlen Ansprechpartner
FirmSupervisionKeyData: Kennzahlen Ansprechpartner
CompanyUserPriority: Firmenpriorität
CompanyUserPriorityTip: Firmenpriorität ist lediglich relativ zu anderen Firmenassoziation der Person
CompanyUserUseCompanyAddress: Verwendet Firmenkontaktaddresse
CompanyUserUseCompanyAddressTip: sofern im Benutzer keine Postanschrift hinterlegt ist
CompanyUserUseCompanyPostalError: Postalische Adresse muss leer bleiben, damit die Firmenanschrift genutzt wird!

40
messages/uniworx/categories/firm/en-eu.msg
View File

@ -1,4 +1,4 @@
# SPDX-FileCopyrightText: 2023 Steffen Jost <s.jost@fraport.de>
# SPDX-FileCopyrightText: 2023-24 Steffen Jost <s.jost@fraport.de>
#
# SPDX-License-Identifier: AGPL-3.0-or-later
@ -7,7 +7,6 @@ FirmSuperForeign: External supervisor
FirmSuperIrregular: Irregular supervisor
FirmAssociates: Company associated users
FirmContact: Company Contact
FirmNoContact: No general contact information known.
FirmEmail: General company email
FirmAddress: Postal address
FirmDefaultPreferenceInfo: Default setting for new company associates only
@ -16,11 +15,15 @@ FirmActionInfo: Affects alle company associates under your supervision.
FirmActNotify: Send message
FirmActResetSupervision: Reset supervisors for all company associates
FirmActResetSuperKeep: Additionally keep existing supervisors of company associates?
FirmActRemoveSupers: Terminate all company related supervisonships?
FirmActResetMutualSupervision: Supervisors supervise each other
FirmActAddSupersvisors: Add supervisors
FirmActResetSupersKeepAll: Keep all
FirmActResetSupersRemoveAps: Remove default supervisors only
FirmActResetSupersRemoveAll: Remove all
FirmActAddSupervisors: Add supervisors
FirmActAddSupersEmpty: No supervisors added
FirmActAddSupersSet n postal: #{n} default company supervisors changed #{maybeBoolMessage postal "" "and switched to postal notifications" "and switched to email notifications"}, but not yet activated.
RemoveSupervisors ndef nact: #{ndef} default supervisors removed#{bool ", but not yet deactivated" (" and " <> tshow nact <> " active supervisions terminated") (nact > 0)}
RemoveSupervisors ndef: #{ndef} default supervisors removed.
FirmActChangeContactUser: Change contact data for all company associates
FirmActChangeContactFirm: Change company contact data
FirmActChangeContactFirmInfo: The company contact data is only used for new company associates that would habe no contact information of their own otherwise.
@ -28,17 +31,23 @@ FirmActChangeContactFirmResult: Company contact data changed, affecting future c
FirmUserActNotify: Send message
FirmUserActResetSupervision: Reset supervisors to company default
FirmUserActSetSupervisor: Change supervision
FirmUserActChangeContact: Change contact data for selected company associates
FirmUserActChangeDetails: Edit company association
FirmUserActRemove: Delete company association
FirmUserActMkSuper: Mark as company supervisor
FirmUserActChangeDetailsResult n t: #{n}/#{t} #{pluralENs n "company association"} updated
FirmUserActChangeResult n t: Notification settings changed for #{n}/#{t} company #{pluralENs n "associate"}
FirmUserActRemoveResult uc: #{pluralENsN uc "Company association"} deleted.
FirmRemoveSupervision sup sub: #{noneMoreEN sup "" ((pluralENsN sup "supervision") <> " removed due to eliminated supervisors.")} #{noneMoreEN sub "No supervision" (pluralENsN sub "supervision")} removed due to eliminated supervisees.
FirmNewSupervisor: Appoint new individual supervisors
FirmSetSupervisor: Add existing supervisors
FirmSetSupersReport nusr@Int64 nspr@Int64 nrem@Int64: #{nspr} individal supervisors set for #{nusr} company associates#{bool "." (" and " <> tshow nrem <> " other individual supervisions terminated.") (nrem >0)}
FirmSetSupersReport nusr nspr nrem: #{nspr} individual supervisors set for #{nusr} company associates#{bool "." (" and " <> tshow nrem <> " other individual supervisions terminated.") (nrem >0)}
FirmResetSupervision rem set: #{tshow set} supervisors set#{bool mempty (", " <> tshow rem <> " deleted before") (rem > 0)}
FirmUserActChangeContact: Change contact data for selected company associates
FirmUserActMkSuper: Mark as company supervisor
FirmSuperActNotify: Send message
FirmSuperActSwitchSuper: Change default company supervisor
FirmSuperActSwitchSuperInfo: Does not affect company-external supervisors and does not change any active individal supervisions. Additionally use reset action, if desired.
FirmSuperActSwitchSuperInfo: Does not affect company-external supervisors and does not change any active individual supervisions. Additionally use reset action, if desired.
FirmSuperActRMSuperDef: Remove default supervisor
FirmSuperActRMSuperActive: Also remove active supervisions within this company
FirmSuperActRMSuperActive: Terminate active supervisions within this company?
FirmsNotification: Send company notification e-mail
FirmNotification fsh: Send e-mail to #{fsh}
FirmsNotificationTitle: Company notification
@ -47,14 +56,23 @@ FilterSupervisor: Has active supervisor
FilterSupervisorCompany fsh: Has active company supervisor belonging to #{fsh}
FilterSupervisorForeign fsh: Has active supervisor not belonging to #{fsh}
FilterForeignSupervisor: Has company-external supervisors
FilterIsForeignSupervisee: Supervisor for company external users
FilterFirmExtern: External company
FilterFirmExternTooltip: i.e. is a postal address registered within AVS?
FilterFirmPrimary: Is primary company in FRADrive
FilterHasQualification: Has company associates with currently valid qualification
FirmSupervisorOf fsh@CompanyShorthand: Supervisors belonging to #{fsh}
FirmSupervisorIndependent: Independent supervisors
FirmEmployeeOf fsh@CompanyShorthand: #{fsh} associated users
NoCompanySelected: Select at least one company, please.
TableIsDefaultSupervisor: Default supervisor
TableSuperior: Superior
TableIsDefaultReroute: Default reroute
FormFieldPostal: Notification type
FormFieldPostalTip: Affects all notifications to this person, not just reroutes to this supervisor
FirmUserChanges n: Notification settings changed for #{n} company associates
FirmSupervisionKeyData: Supervision key data
FirmSupervisionKeyData: Supervision key data
CompanyUserPriority: Company priority
CompanyUserPriorityTip: Company priority is relative to other company associations for a user
CompanyUserUseCompanyAddress: Use company postal address
CompanyUserUseCompanyAddressTip: if and only if the postal address of the user is empty
CompanyUserUseCompanyPostalError: Individual postal address must left empty for the company address to be used!

6
messages/uniworx/categories/print/de-de-formal.msg
View File

@ -18,6 +18,7 @@ PrintJobAcknowledgeFailed: Keine Druckaufträge bestätigt aufgrund zwischenzeit
PrintJobAcknowledgeQuestion n@Int d@Text: #{n} #{pluralDE n "Druckauftrag" "Druckaufräge"} vom #{d} als gedruckt und versendet bestätigen?
PrintJobAcknowledgements: Versanddatum von Briefen an
PrintRecipient: Empfänger
PrintAffected: Betroffener
PrintSender !ident-ok: Sender
PrintCourse: Kursarten
PrintQualification: Qualifikation
@ -25,4 +26,7 @@ PrintPDF !ident-ok: PDF
PrintManualRenewal: Vorfeldführerschein Renewal-Brief testweise versenden
PrintLmsUser: E‑Learning Id
PrintJobs: Druckaufräge
PrintLetterType: Brieftypkürzel
PrintLetterType: Brieftypkürzel
MCActDummy: Platzhalter
CCActDummy: Platzhalter

6
messages/uniworx/categories/print/en-eu.msg
View File

@ -18,6 +18,7 @@ PrintJobAcknowledgeFailed: No print-jobs acknowledged, due to intermediate chang
PrintJobAcknowledgeQuestion n d: Mark #{n} #{pluralENs n "print-job"} issued on #{d} as printed and mailed already?
PrintJobAcknowledgements: Sent-dates for Letter to
PrintRecipient: Recipient
PrintAffected: Affetcted
PrintSender: Sender
PrintCourse: Course type
PrintQualification: Qualification
@ -25,4 +26,7 @@ PrintPDF: PDF
PrintManualRenewal: Manual sending of an apron driver's licence renewal letter
PrintLmsUser: E‑learning id
PrintJobs: Print jobs
PrintLetterType: Letter type shorthand
PrintLetterType: Letter type shorthand
MCActDummy: Placeholder
CCActDummy: Placeholder

33
messages/uniworx/categories/qualification/de-de-formal.msg
View File

@ -9,23 +9,31 @@ QualificationValidIndicator: Gültigkeit
QualificationValidDuration: Gültigkeitsdauer
QualificationAuditDuration: Aufbewahrung Audit Log
QualificationAuditDurationTooltip n@Int: Optionaler Zeitraum zur Löschung von E‑Learning Daten. Hinweis: Der E‑Learning Server kann seine anonymisierten Daten schon früher löschen, aber spätestens #{n} Tage nach Abschluss.
QualificationAuditDurationReuseError: Diese Qualifikation nutzt das E‑Learning einer anderen Qualifikation, für die derzeit keinen Löschzeitraum konfiguriert wurde.
QualificationRefreshWithin: Erneurerungszeitraum
QualificationRefreshWithinTooltip: Optionaler Zeitraum vor Ablauf für automatischen Start des E‑Learnings und Versand einer Benachrichtigung per Brief oder Email.
QualificationRefreshReminder: 2. Erinnerung
QualificationRefreshReminderTooltip: Optionaler Zeitraum vor Ablauf zur Versendung einer zweiten Erinnerung per Brief oder Email mit identischen Zugangsdaten, sofern in diesem Zeitraum vor Ablauf noch keine Ablaufbenachrichtigung versendet wurde.
QualificationRefreshWithinTooltip: Optionaler Zeitraum vor Ablauf für eine Benachrichtigung per Email. Bei aktiviertem automatischem E‑Learning wird dieses gestartet und die Benachrichtigung erfolgt per Brief oder Email.
QualificationRefreshReminder: Zweite Erinnerung
QualificationRefreshReminderTooltip: Optionaler Zeitraum vor Ablauf zur Versendung einer zweiten Erinnerung per Brief oder Email mit identischen E‑Learning Zugangsdaten, sofern die Qualifikation noch gültig und das E‑Learning noch offen ist.
QualificationElearningStart: Wird das E‑Learning automatisch gestartet?
QualificationElearningRenew: Verlängert ein erfolgreiches E‑Learning die Qualifikation automatisch um die reguläre Gültigkeitsdauer?
QualificationElearningLimit: Ist die Anzahl der E‑Learning Versuche limitiert?
QualificationElearningLimitMax n@Int: Maximal #{n} Versuche
QualificationElearningNoLimit: Nicht limitiert
QualificationExpiryNotification: Ungültigkeitsbenachrichtigung?
QualificationExpiryNotificationTooltip: Nutzer werden benachrichtigt, wenn die Qualifikation ungültig wird, sofern der jeweilige Nutzer in seinen Benutzereinstellungen diese Art Benachrichtigung aktiviert hat.
TableQualificationCountActive: Aktive
TableQualificationCountActiveTooltip: Anzahl Personen mit momentan gültiger Qualifikation
TableQualificationCountTotal: Gesamt
TableQualificationLmsReuses: LMS nutzt
TableQualificationLmsReusesTooltip: Diese Qualifikation hat kein eigenes E‑Learning, sondern wird über das E‑Learning der angegebenen Qualifikation abgewickelt.
TableQualificationIsAvsLicence: AVS
TableQualificationIsAvsLicenceTooltip: Unter welchem Namen wird diese Qualifikation mit dem Ausweisverwaltungssystem (AVS) synchronisiert? Betrifft nur Benutzer mit AVS PersonenID.
TableQualificationSapExport: SAP
TableQualificationSapExportTooltip: Wird die Qualifikation an das SAP übermittelt? Betrifft nur Benutzer mit Fraport Personalnummer.
LmsQualificationValidUntil: Gültig bis
TableQualificationLastRefresh: Zuletzt erneuert
TableQualificationLastNotified: Letzte Benachrichtigung
TableQualificationLastNotified: Letzte Benachrichtigung über erfolgte Gültigkeitsänderung
TableQualificationLastNotifiedTooltip: Hier werden ausschließlich Benachrichtigungen berücksichtigt, die über einen bereits erfolgten Ablauf/Entzug/Wiedererteilung informieren. Dies ignoriert insbesondere reguläre Verlängerung, z.B. durch E-Learning.
TableQualificationFirstHeld: Erstmalig
TableQualificationBlockedDue: Entzug
TableQualificationBlockedTooltip: Wann wurde die Qualifikation vorübergehend außer Kraft gesetzt und warum wurde dies veranlasst?
@ -46,11 +54,13 @@ QualificationExpired: Ungültig seit
LmsUser: Inhaber
LmsURL: Link E‑Learning
TableLmsEmail: E‑Mail
TableLmsIdent: E-Learning Benutzer
TableLmsIdent: E‑Learning Benutzer
TableLmsElearning: E‑Learning
TableLmsElearningRenews: Automatische Verlängerung
TableLmsElearningLimit: Maximale Versuche
TableLmsPin: E‑Learning Passwort
TableLmsResetPin: E-Learning Passwort zurücksetzen?
TableLmsDatePin: E-Learning Passwort erstellt
TableLmsResetPin: E‑Learning Passwort zurücksetzen?
TableLmsDatePin: E‑Learning Passwort erstellt
TableLmsDate: Datum
TableLmsDelete: Löschen?
TableLmsStaff: Interner Mitarbeiter?
@ -88,7 +98,8 @@ LmsReportInsert: Neues LMS Ereignis
LmsReportUpdate: LMS Ereignis Aktualisierung
LmsReportCsvExceptionDuplicatedKey: CSV-Import LmsReport fand uneindeutigen Schlüssel
LmsDirectUpload: Direkter Upload für automatisierte Systeme
LmsErrorNoRefreshElearning: Fehler: E‑Learning wird nicht automatisch gestartet, da die Zeitspanne für den Erneurerungszeitraum nicht festgelegt wurde.
LmsErrorNoRefreshElearning: Fehler: E‑Learning wird nicht automatisch gestartet, da die Zeitspanne für den Erneurerungszeitraum nicht festgelegt wurde!
LmsErrorNoRenewElearning: Fehler: Erfoglreiches E‑Learning verlängert die Qualifikation nicht automatisch, da die Gültigkeitsdauer nicht festgelegt wurde!
MailSubjectQualificationRenewal qname@Text: Qualifikation #{qname} muss demnächst erneuert werden
MailSubjectQualificationExpiry qname@Text: Qualifikation #{qname} läuft demnächst ab
MailSubjectQualificationExpired qname@Text: Qualifikation #{qname} ist ab sofort ungültig
@ -106,11 +117,13 @@ QualificationActUnblock: Entzug aufheben
QualificationActRenew: Qualifikation regulär verlängern
QualificationActGrant: Qualifikation vergeben
QualificationActGrantWarning: Diese Funktion ist nur für seltene Ausnahmefälle vorgesehen! Ein Entzug wird ggf. aufgehoben.
QualificationActStartELearning: E‑Learning für gültige Inhaber (neu) starten
QualificationActStartELearningStatus l@QualificationShorthand n@Int m@Int: E‑Learning #{l} für #{n}/#{m} Teilnehmer (neu) gestartet. Hinweis: Es kann länger dauern, bis das LMS tatsächlich startet.
QualificationStatusBlock l@QualificationShorthand n@Int m@Int: #{n}/#{m} #{l} entzogen
QualificationStatusUnblock l@QualificationShorthand n@Int m@Int: #{n}/#{m} #{l} reaktiviert
LmsInactive: Aktuell kein E‑Learning aktiv
LmsRenewalInstructions: Weitere Anweisungen zur Verlängerung finden Sie im angehängten PDF. Um Missbrauch zu verhindern wurde das PDF mit dem im FRADrive hinterlegten PDF-Passwort des Prüflings verschlüsselt. Falls kein PDF-Passwort manuell hinterlegt wurde, ist das PDF-Passwort die Flughafen Ausweisnummer, inklusive Punkt und der Ziffer danach.
LmsNoRenewal: Leider kann diese Qualifikation nicht alleine durch E‑Learning verlängert werden.
LmsNoRenewal: Leider kann diese Qualifikation nicht alleine durch E‑Learning verlängert werden. Bitte setzen Sie sich mit uns in Verbindung, wenn Sie die Qualifikation verlängern möchten und noch nicht wissen, wie Sie das tun können. Ignorieren Sie diese automatisch generierte Erinnerung, falls Sie sich bereits um die Verlängerung gekümmert haben
LmsRenewalReminder: Erinnerung
LmsActNotify: Benachrichtigung E‑Learning erneut per Post oder E-Mail versenden
LmsActRenewPin: Neues zufällige E‑Learning Passwort zuweisen
@ -119,7 +132,7 @@ LmsActReset: E‑Learning Fehlversuche zurücksetzen und entsperren
LmsActResetInfo: E‑Learning Login, Passwort und Fortschritt bleiben unverändert, eine neue Benachrichtigung ist nicht notwendig. Nur möglich für bereits gesperrte Lerner. Es kann bis zu 2 Stunden dauern, bis das LMS die Anfrage umgesetzt hat.
LmsActResetFeedback n@Int m@Int: Für #{n}/#{m} E‑Learning Nutzer wurden alle Fehlversuche zurückgesetzt.
LmsActRestart: E‑Learning komplett neu starten
LmsActRestartWarning: Das vorhandene E‑Learning wird komplett gelöscht! Für Inhaber einer gültigen Fahrlizenz werden später Benutzer und Passwort neu vergeben und es sollte eine neue Benachrichtigung versendet werden. Hinweis: Es kann mehrere Stunden dauern, bis das LMS diese Anfrage umgesetzt hat.
LmsActRestartWarning: Das vorhandene E‑Learning wird komplett gelöscht! Für Inhaber einer gültigen Lizenz werden später Benutzer und Passwort neu vergeben und es sollte eine neue Benachrichtigung versendet werden. Hinweis: Es kann mehrere Stunden dauern, bis das LMS diese Anfrage umgesetzt hat.
LmsActRestartFeedback n@Int m@Int: #{n}/#{m} E‑Learning Nutzer wurden komplett neu gestartet mit neuem Login und Passwort.
LmsActRestartExtend: Gültig bis ggf. erhöhen für die nächsten # Tage
LmsActRestartUnblock: Entzug ggf. aufheben

25
messages/uniworx/categories/qualification/en-eu.msg
View File

@ -9,23 +9,31 @@ QualificationValidIndicator: Validity
QualificationValidDuration: Validity period
QualificationAuditDuration: Audit log retention period
QualificationAuditDurationTooltip n@Int: Optional period for deletion of e‑learning data. Note that the e‑learning server may delete its anonymised data earlier, at most #{n} days after closing.
QualificationAuditDurationReuseError: This qualification reuses the e‑learning from another qualification, which has no audit duration configured.
QualificationRefreshWithin: Refresh within
QualificationRefreshWithinTooltip: Optional period before expiry to start e‑learning and send a notification by post or email.
QualificationRefreshReminder: 2. Reminder
QualificationRefreshReminderTooltip: Optional period before expiry to send a second notification by post or email once more, provided that no renewal notification was sent in this period before expiry.
QualificationRefreshWithinTooltip: Optional period before expiry to send a notification by email. If e‑learning is set to start automatically, it will be started and e‑learning credentials are send with this notification by post or email.
QualificationRefreshReminder: Second reminder
QualificationRefreshReminderTooltip: Optional period before expiry to send a second notification by post or email once more, including the existing credentials, provided that the e‑learning is still undecided and the qualification has not yet expired.
QualificationElearningStart: Is e‑learning automatically started?
QualificationElearningRenew: Does successful e‑learning automatically extend a qualification by the default validity period?
QualificationElearningLimit: Is the number of e‑learning attempts limited?
QualificationElearningLimitMax n: #{n} attempts maximum
QualificationElearningNoLimit: No limit
QualificationExpiryNotification: Invalidity notification?
QualificationExpiryNotificationTooltip: Qualification holder are notfied upon invalidity, provided they have activated such notification in their user settings.
TableQualificationCountActive: Active
TableQualificationCountActiveTooltip: Number of currently valid qualification holders
TableQualificationCountTotal: Total
TableQualificationLmsReuses: Reuse LMS
TableQualificationLmsReusesTooltip: This qualification reuses the e‑learning of the given qualification, instead of having a separate e‑learning of its own.
TableQualificationIsAvsLicence: AVS driving license
TableQualificationIsAvsLicenceTooltip: Under which name is this qualification synchronized with AVS, if any? Only applies to qualification holders having an AVS PersonID.
TableQualificationSapExport: Sent to SAP
TableQualificationSapExportTooltip: Is this qualification transmitted to SAP? Only applies to qualification holder having a Fraport AG personnel number.
LmsQualificationValidUntil: Valid until
TableQualificationLastRefresh: Last renewed
TableQualificationLastNotified: Last notified
TableQualificationLastNotified: Last notified about validity change
TableQualificationLastNotifiedTooltip: The date of the last notification about any already effective change in validity due to revocation or reissue. This does not entail regular validity extensions, e.g. due to e-learning.
TableQualificationFirstHeld: First held
TableQualificationBlockedDue: Revocations
TableQualificationBlockedTooltip: Why and when was this qualification temporarily suspended?
@ -49,6 +57,8 @@ TableLmsEmail: Email
TableLmsIdent: E‑learning user
TableLmsPin: E‑learning password
TableLmsElearning: E‑learning
TableLmsElearningRenews: Automatic renewal
TableLmsElearningLimit: Max attempts
TableLmsResetPin: Reset E‑learning password?
TableLmsDatePin: E‑learning password created
TableLmsDate: Date
@ -88,7 +98,8 @@ LmsReportInsert: New LMS event
LmsReportUpdate: Update of LMS event
LmsReportCsvExceptionDuplicatedKey: CSV Import LmsReport with ambiguous key
LmsDirectUpload: Direct upload for automated systems
LmsErrorNoRefreshElearning: Error: E‑learning will not be started automatically due to refresh-within time period not being set.
LmsErrorNoRefreshElearning: Error: E‑learning will not be started automatically due to refresh-within time period not being set!
LmsErrorNoRenewElearning: Error: E‑learning will not automatically extend validity due to validity duration not being set!
MailSubjectQualificationRenewal qname: Qualification #{qname} must be renewed shortly
MailSubjectQualificationExpiry qname: Qualification #{qname} expires soon
MailSubjectQualificationExpired qname: Qualification #{qname} is no longer valid
@ -106,11 +117,13 @@ QualificationActUnblock: Clear revocation
QualificationActRenew: Renew qualification
QualificationActGrant: Grant qualification
QualificationActGrantWarning: Use with caution in rare exceptional cases only! Any revocation will be undone.
QualificationActStartELearning: Manually (re)start e‑learning for valid qualification holders
QualificationActStartELearningStatus l n m: E‑learning #{l} (re)started for #{n}/#{m} users. Note: It may take a while, until the e‑learning is activated.
QualificationStatusBlock l n m: #{n}/#{m} #{l} revoked
QualificationStatusUnblock l n m: #{n}/#{m} #{l} reactivated
LmsInactive: Currently no active e‑learning
LmsRenewalInstructions: Instruction on how to accomplish the renewal are enclosed in the attached PDF. In order to avoid misuse, the PDF is encrypted with the FRADrive PDF-password of the examinee. If no PDF-password had been chosen yet, then the password is the Fraport id card number of the examinee, including the punctuation mark and the digit thereafter.
LmsNoRenewal: Unfortunately, this particular qualification cannot be renewed through e‑learning only.
LmsNoRenewal: Unfortunately, this particular qualification cannot be renewed through e‑learning only. Please contact us, if you do not yet know how to renew this qualification. Ignore this automatically generated reminder email, if you have made arrangements for the renewal of this qualification already.
LmsRenewalReminder: Reminder
LmsActNotify: Resend e‑learning notification by post or email
LmsActRenewPin: Randomly replace e‑learning password

4
messages/uniworx/categories/school/de-de-formal.msg
View File

@ -40,4 +40,6 @@ SchoolAuthorshipStatementSheetDefinitionTip: Bitte in sowohl deutscher als auch
SchoolAuthorshipStatementSheetExamDefinition: Eigenständigkeitserklärung für prüfungszugehörige Übungsblattabgaben
SchoolAuthorshipStatementSheetExamDefinitionTip: Bitte in sowohl deutscher als auch englischer Sprache angeben.
SchoolAuthorshipStatementSheetAllowOther: Abweichende Eigenständigkeitserklärungen für nicht-prüfungszugehörige Übungsblätter erlauben?
SchoolAuthorshipStatementSheetExamAllowOther: Abweichende Eigenständigkeitserklärungen für prüfungszugehörige Übungsblätter erlauben?
SchoolAuthorshipStatementSheetExamAllowOther: Abweichende Eigenständigkeitserklärungen für prüfungszugehörige Übungsblätter erlauben?
DailyActDummy: Platzhalter ohne Funktion

4
messages/uniworx/categories/school/en-eu.msg
View File

@ -40,4 +40,6 @@ SchoolAuthorshipStatementSheetDefinitionTip: Please enter both german and englis
SchoolAuthorshipStatementSheetExamDefinition: Statement of Authorship for exam-related exercise sheets
SchoolAuthorshipStatementSheetExamDefinitionTip: Please enter both german and english statements.
SchoolAuthorshipStatementSheetAllowOther: Allow adaptations for exam-unrelated exercise sheets?
SchoolAuthorshipStatementSheetExamAllowOther: Allow adaptations for exam-related exercise sheets?
SchoolAuthorshipStatementSheetExamAllowOther: Allow adaptations for exam-related exercise sheets?
DailyActDummy: Placholder without function

10
messages/uniworx/categories/settings/personal_settings/de-de-formal.msg
View File

@ -25,10 +25,14 @@ PersonalInfoTutorialsWip: Die Anzeige von Kurse, zu denen Sie angemeldet sind wi
ProfileGroupSubmissionDates: Bei Gruppenabgaben wird kein Datum angezeigt, wenn Sie die Gruppenabgabe nie selbst hochgeladen haben.
ProfileCorrectorRemark: Die oberhalb angezeigte Tabelle zeigt nur prinzipielle Einteilungen als Korrektor zu einem Übungsblatt. Auch ohne Einteilung können Korrekturen einzeln zugewiesen werden, welche hier dann nicht aufgeführt werden.
ProfileCorrections: Auflistung aller zugewiesenen Korrekturen
Remarks: Hinweise
Remarks: Hinweis:
ProfileSupervisor: Übergeordnete Ansprechpartner
ProfileSupervisee: Ist Ansprechpartner für
ProfileNoSupervisor: Keine übergeordneten Ansprechpartner vorhanden
ProfileSupervisor n@Int m@Int: #{n} #{pluralDE n "übergeordneter" "übergeordnete"} Ansprechpartner#{noneMoreDE m "" (", davon " <> tshow m <> " mit Benachrichtigungsumleitung")}
ProfileSupervisorRemark n@Int m@Int l@Int: #{m} von #{n} #{pluralDE m "übergeordneter" "übergeordnete"} Ansprechpartner mit Benachrichtigungsumleitung#{noneMoreDE l "" (", davon " <> tshow l <> " mit postalischer Benachrichtigung")}
ProfileNoSupervisee: Ist kein Ansprechpartner für irgendjemand
ProfileSupervisee n@Int m@Int: Ist Ansprechpartner für #{n} #{pluralDE n "Person" "Personen"}#{noneMoreDE m "" (", davon " <> tshow m <> " mit Benachrichtigungsumleitung")}
ProfileSuperviseeRemark n@Int m@Int: Dieser Nutzer ist Ansprechpartner für #{n} #{pluralDE n "Person" "Personen"}#{noneMoreDE m "" (", davon " <> tshow m <> " mit Benachrichtigungsumleitung")}
UserTelephone: Telefon
UserMobile: Mobiltelefon

10
messages/uniworx/categories/settings/personal_settings/en-eu.msg
View File

@ -25,10 +25,14 @@ PersonalInfoTutorialsWip: The feature to display courses you have registered for
ProfileGroupSubmissionDates: No date is shown for group submissions if you have never uploaded the submission yourself.
ProfileCorrectorRemark: The table above only shows registration as a corrector in principle. Even without registration corrections can be assigned individually and are not listed.
ProfileCorrections: List of all assigned corrections
Remarks: Remarks
Remarks: Remark:
ProfileSupervisor: Supervised by
ProfileSupervisee: Supervises
ProfileNoSupervisor: Is not supervised by anynone
ProfileSupervisor n m: #{pluralENsN n "supervisor"} #{noneMoreEN m "" ("with " <> tshow m <> " active notification rerouting")}
ProfileSupervisorRemark n@Int m@Int l@Int: #{m} of #{n} #{pluralENs m "supervisor"} with active notification rerouting#{noneMoreEN l "" (", and " <> tshow l <> "of these prefer postal notifications")}
ProfileNoSupervisee: Does not supervise anynone
ProfileSupervisee n m: Supervises #{pluralENsN n "person"} #{noneMoreEN m "" ("with " <> tshow m <> " active notification rerouting")}
ProfileSuperviseeRemark n m: This person supervises #{pluralENsN n "person"}#{noneMoreEN m "" (" with " <> tshow m <> " having active notifications rerouting to this user")}
UserTelephone: Phone
UserMobile: Mobile

23
messages/uniworx/categories/user/de-de-formal.msg
View File

@ -22,6 +22,7 @@ AdminUserPostAddress: Postalische Anschrift
AdminUserPrefersPostal: Briefe anstatt Email bevorzugt
AdminUserPinPassword: Passwort zur Verschlüsselung von PDF Anhängen in Emails
AdminUserNoPassword: Kein Passwort gesetzt
AdminUserPinPassNotIncluded: Hinweis: Das Passwort wird hier zur Bequemlichkeit zusätzlich angezeigt und ist selbstverständlich nicht im originalem Inhalt enthalten.
AdminUserAssimilate: Diesen Benutzer assimilieren von
UserAdded: Benutzer erfolgreich angelegt
UserCollision: Benutzer konnte wegen Eindeutigkeit nicht angelegt werden
@ -37,9 +38,10 @@ AuthPWHashAlreadyConfigured: Nutzer:in meldet sich bereits mit FRADrive spezifis
AuthPWHashConfigured: Nutzer:in meldet sich nun mit FRADrive spezifischer Kennung an
UsersCourseSchool: Bereich
ActionNoUsersSelected: Keine Benutzer:innen ausgewählt
SynchroniseAvsUserQueued n@Int: AVS-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen
SynchroniseLdapUserQueued n@Int: LDAP-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen
SynchroniseLdapAllUsersQueued: LDAP-Synchronisation von allen Benutzer:innen angestoßen
SynchroniseAvsUserQueued n@Int: AVS-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} zwingend angestoßen, die Ausführung wird mehrere Minuten benötigen!
SynchroniseAvsAllUsersQueued n@Int64: AVS-Synchronisation von allen #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen, welche heute noch nicht synchronisiert wurden, die Ausführung wird eine Weile brauchen!
SynchroniseLdapUserQueued n@Int: LDAP-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen, die Ausführung wird mehrere Minuten benötigen!
SynchroniseLdapAllUsersQueued: LDAP-Synchronisation von allen Benutzer:innen angestoßen, die Ausführung kann eine Weile brauchen!
UserListTitle: Komprehensive Benutzerliste
AccessRightsSaved: Berechtigungen erfolgreich verändert
AccessRightsNotChanged: Berechtigungen wurden nicht verändert
@ -89,12 +91,19 @@ NewPasswordLink: Neues Passwort setzen
UserAccountDeleteWarning: Achtung, dies löscht den kompletten Benutzer/die komplette Benutzerin unwiderruflich und mit allen assoziierten Daten aus der Datenbank. Prüfungsdaten müssen jedoch langfristig gespeichert bleiben!
UserAvsSync: AVS-Synchronisieren
UserLdapSync: LDAP-Synchronisieren
AllUsersLdapSync: Alle LDAP-Synchronisieren
UserHijack: Sitzung übernehmen
UserAddSupervisor: Ansprechpartner hinzufügen
UserSetSupervisor: Ansprechpartner ersetzen
UserRemoveSupervisor: Alle Ansprechpartner entfernen
UserRemoveSubordinates: Alle Ansprechpartnerbeziehungen zu Untergebenen beenden
UserIsSupervisor: Ist Ansprechpartner
UserAvsSwitchCompany: Als Primärfirma verwenden
UserAvsSwitchCompanyField: Primärfirma auswählen
UserAvsCompanySwitched c@CompanyShorthand: Primärfirma gewechselt zu #{tshow c}
AllUsersLdapSync: Alle LDAP-Synchronisieren
AllUsersAvsSync: Alle AVS-Synchronisieren
ThisUserLdapSync: LDAP Synchronisation
ThisUserAvsSync: AVS Synchronisation
AuthKindLDAP: Fraport AG Kennung
AuthKindPWHash: FRADrive Kennung
AuthKindNoLogin: Kein Login möglich
@ -102,3 +111,9 @@ Name !ident-ok: Name
UsersChangeSupervisorsSuccess usr@Int spr@Int: #{tshow spr} Ansprechpartner für #{tshow usr} Benutzer gesetzt.
UsersChangeSupervisorsWarning usr@Int spr@Int bad@Int: Nur _{MsgUsersChangeSupervisorsSuccess usr spr} #{tshow bad} Ansprechpartner #{pluralDE bad "wurde" "wurden"} nicht gefunden!
UsersRemoveSupervisors usr@Int: Alle Ansprechpartner für #{tshow usr} Benutzer gelöscht.
UsersRemoveSubordinates usr@Int: Alle Ansprechpartnerbeziehungen für #{tshow usr} #{pluralDE usr "ehemaligen" "ehemalige"} Ansprechpartner gelöscht.
UserCompanyReason: Begründung der Firmenassoziation
UserCompanyReasonTooltip: Optionale Notiz für besondere Fälle. Kann ggf. autmatische Entfernung bei AVS Firmenwechsel verhindern.
UserSupervisorReason: Begründung Ansprechpartner
UserSupervisorReasonTooltip: Optionale Notiz für besondere Fälle. Kann ggf. autmatische Entfernung bei AVS Firmenwechsel verhindern.
AdminUserAllNotifications: Alle Benachrichtigungen and diesen Benutzer

25
messages/uniworx/categories/user/en-eu.msg
View File

@ -22,6 +22,7 @@ AdminUserPostAddress: Postal Address
AdminUserPrefersPostal: Prefers postal letters over email
AdminUserPinPassword: Password used for PDF attachments to emails
AdminUserNoPassword: No password set
AdminUserPinPassNotIncluded: Note: the password is shown here only for convenience, but is not contained in the original content, of course.
AdminUserAssimilate: Assimilate user by another user
UserAdded: Successfully added user
UserCollision: Could not create user due to uniqueness constraint
@ -37,9 +38,10 @@ AuthPWHashAlreadyConfigured: User already logs in using their FRADrive specific
AuthPWHashConfigured: User now logs in using their FRADrive specific account
UsersCourseSchool: Department
ActionNoUsersSelected: No users selected
SynchroniseAvsUserQueued n: Triggered AVS synchronisation of #{n} #{pluralEN n "user" "users"}.
SynchroniseLdapUserQueued n: Triggered LDAP synchronisation of #{n} #{pluralEN n "user" "users"}.
SynchroniseLdapAllUsersQueued: Triggered LDAP synchronisation of all users
SynchroniseAvsUserQueued n: Triggered forced AVS synchronisation of #{n} #{pluralEN n "user" "users"}, which may take several minutes to complete.
SynchroniseAvsAllUsersQueued n: Triggered AVS synchronisation of all #{n} #{pluralEN n "user" "users"} that were not already synchronised today, which may take quite a while to complete.
SynchroniseLdapUserQueued n: Triggered LDAP synchronisation of #{n} #{pluralEN n "user" "users"}, which may take several minutes to complete.
SynchroniseLdapAllUsersQueued: Triggered LDAP synchronisation of all users, which may take quite a while to complete.
UserListTitle: Comprehensive list of users
AccessRightsSaved: Successfully updated permissions
AccessRightsNotChanged: Permissions left unchanged
@ -89,16 +91,29 @@ NewPasswordLink: Set password
UserAccountDeleteWarning: Caution, this permanently deletes users and all of their associated data. Exam results must be stored long term!
UserAvsSync: Synchronise with AVS
UserLdapSync: Synchronise with LDAP
AllUsersLdapSync: Synchronise all with LDAP
UserHijack: Hijack session
UserAddSupervisor: Add supervisor
UserSetSupervisor: Replace supervisors
UserRemoveSupervisor: Set to unsupervised
UserRemoveSubordinates: Remove all subordinates
UserIsSupervisor: Is supervisor
UserAvsSwitchCompany: Use as primary company
UserAvsSwitchCompanyField: Select primary company
UserAvsCompanySwitched c: Primary company switched to #{tshow c}
AllUsersLdapSync: Synchronise all with LDAP
AllUsersAvsSync: Synchronise all with AVS
ThisUserLdapSync: Synchronise user with LDAP
ThisUserAvsSync: Synchronise user with AVS
AuthKindLDAP: Fraport AG account
AuthKindPWHash: FRADrive account
AuthKindNoLogin: No login
Name: Name
UsersChangeSupervisorsSuccess usr spr: #{pluralENsN spr "supervisor"} for #{pluralENsN usr "user"} set.
UsersChangeSupervisorsWarning usr spr bad: Only _{MsgUsersChangeSupervisorsSuccess usr spr} #{pluralENsN bad "supervisors"} could not be identified!
UsersRemoveSupervisors usr: Removed all supervisors for #{pluralENsN usr "user"}.
UsersRemoveSupervisors usr: Removed all supervisors for #{pluralENsN usr "user"}.
UsersRemoveSubordinates usr: Removed all subordinates for #{pluralENsN usr "previous supervisor"}.
UserCompanyReason: Reason for company association
UserCompanyReasonTooltip: Optional note for special cases. In some case this may prevent automatic removel upon AVS user company changes.
UserSupervisorReason: Reason for supervision
UserSupervisorReasonTooltip: Optional note for special cases. In some case this may prevent automatic removel upon AVS user company changes.
AdminUserAllNotifications: All notification sent to this user

13
messages/uniworx/misc/de-de-formal.msg
View File

@ -4,24 +4,31 @@
#messages or constructors that are used all over the code
Logo !ident-ok: Uni2work
EmailInvitationWarning: Diese Adresse konnte keinem Uni2work-Benutzer/keiner Uni2work-Benutzerin zugeordnet werden. Es wird eine Einladung per E-Mail versandt.
Logo !ident-ok: FRADrive
EmailInvitationWarning: Diese Adresse konnte keinem FRADrive-Benutzer/-Benutzerin zugeordnet werden. Es wird eine Einladung per E-Mail versandt.
BoolIrrelevant !ident-ok: —
FieldPrimary: Hauptfach
FieldSecondary: Nebenfach
MultiEmailFieldTip: Es sind mehrere, Komma-separierte, E-Mail-Adressen möglich
MultiSelectTip: Mehrfachauswahl und Abwählen mit Strg-Klick
WeekDay: Wochentag
Hours: Stunden
LdapIdentificationOrEmail: Fraport AG-Kennung / E-Mail-Adresse
Months num@Int64: #{num} #{pluralDE num "Monat" "Monate"}
Days num@Int64: #{num} #{pluralDE num "Tag" "Tage"}
NoAutomaticUpdateTip: Dieser Wert wurde manuell editiert und wird daher nicht mehr automatisch durch as AVS aktualisiert.
AddressIsLinkedTip: Verlinkte Postaddresse: Für diesen Benutzer ist keine individuelle Postadresse gespeichert, die Adresse wurde stattdessen aus der Firmenzugehörigkeit abgeleitet.
ClusterVolatileQuickActionsEnabled: Schnellzugriffsmenü aktiv
AvsNoLicence: Keine Fahrberechtigung
AvsLicenceVorfeld: Vorfeld Fahrberechtigung
AvsLicenceRollfeld: Rollfeld Fahrberechtigung
AvsNoLicenceGuest: Keine Fahrberechtigung (Gast, Fahrberechtigungserwerb nicht möglich)
PaginationSize: Einträge pro Seite
PaginationPage: Angzeigte Seite
PaginationError: Paginierung Parameter dürfen nicht negativ sein
PaginationError: Paginierung Parameter dürfen nicht negativ sein
NullDeletes: Zum Löschen NULL eingeben.
SortPriority: Sortierungspriorität

13
messages/uniworx/misc/en-eu.msg
View File

@ -4,24 +4,31 @@
#messages or constructors that are used all over the Code
Logo: Uni2work
EmailInvitationWarning: This address could not be matched to any Uni2work user. An invitation will be sent via email.
Logo: FRADrive
EmailInvitationWarning: This address could not be matched to any FRADrive user. An invitation will be sent via email.
BoolIrrelevant: —
FieldPrimary: Major
FieldSecondary: Minor
MultiEmailFieldTip: Multiple emails addresses may be specified (comma-separated)
MultiSelectTip: Multiple selection and desection via Ctrl-Click
WeekDay: Day of the week
Hours: Hours
LdapIdentificationOrEmail: Fraport AG-Kennung / email address
Months num: #{num} #{pluralEN num "Month" "Months"}
Days num: #{num} #{pluralEN num "Day" "Days"}
NoAutomaticUpdateTip: This particular value receives no automatic AVS updates, since it has been edited manually.
AddressIsLinkedTip: Linked postal address: No individual postal address is stored for this user, instead a postal address was inferred from the user's company association.
ClusterVolatileQuickActionsEnabled: Quick actions enabled
AvsNoLicence: No driving licence
AvsLicenceVorfeld: Apron driving licence
AvsLicenceRollfeld: Maneuvering area driving licence
AvsNoLicenceGuest: No driving licence (Guest account, cannot acquire a diriving licence)
PaginationSize: Rows per Page
PaginationPage: Page to show
PaginationError: Pagination parameter must not be negative
PaginationError: Pagination parameter must not be negative
NullDeletes: Enter NULL to delete.
SortPriority: Sort order priority

4
messages/uniworx/utils/handler_form/occurrences/de-de-formal.msg
View File

@ -20,3 +20,7 @@ ExceptionNoOccurAt: Termin
ExceptionKind: Termin ...
ExceptionKindOccur: Findet statt
ExceptionKindNoOccur: Findet nicht statt
DayNext: Folgetag
DayPrev: Vortag
WeekNext: Nächste Woche
WeekPrev: Vorherige Woche

4
messages/uniworx/utils/handler_form/occurrences/en-eu.msg
View File

@ -20,3 +20,7 @@ ExceptionNoOccurAt: Event
ExceptionKind: Event ...
ExceptionKindOccur: Does occur
ExceptionKindNoOccur: Does not occur
DayNext: Next day
DayPrev: Previous day
WeekNext: Next week
WeekPrev: Previous week

9
messages/uniworx/utils/navigation/menu/de-de-formal.msg
View File

@ -97,6 +97,7 @@ MenuExamOfficeUsers: Benutzer:innen
MenuLecturerInvite: Funktionäre hinzufügen
MenuSchoolList: Bereiche
MenuSchoolNew: Neuen Bereich anlegen
MenuSchoolDay ssh@SchoolId d@Text: #{unSchoolKey ssh} #{d} Tagesansicht
MenuExternalExamGrades: Prüfungsleistungen
MenuExternalExamUsers: Teilnehmer:innen
MenuExternalExamEdit: Bearbeiten
@ -143,12 +144,18 @@ MenuSap: SAP Schnittstelle
MenuAvs: AVS Schnittstelle
MenuAvsSynchError: AVS Problemübersicht
MenuLdap: LDAP Schnittstelle
MenuApc: Druckerei
MenuApc: Druck
MenuPrintSend: Manueller Briefversand
MenuPrintDownload: Brief herunterladen
MenuPrintLog: LPR Schnittstelle
MenuPrintAck: Druckbestätigung
MenuCommCenter: Benachrichtigungen
MenuMailCenter: E‑Mails
MenuMailHtml !ident-ok: Html
MenuMailPlain !ident-ok: Text
MenuMailAttachment: Anhang
MenuApiDocs: API-Dokumentation (Englisch)
MenuSwagger !ident-ok: OpenAPI 2.0 (Swagger)

9
messages/uniworx/utils/navigation/menu/en-eu.msg
View File

@ -97,6 +97,7 @@ MenuExamOfficeUsers: Users
MenuLecturerInvite: Add functionaries
MenuSchoolList: Departments
MenuSchoolNew: Create new department
MenuSchoolDay ssh d: #{unSchoolKey ssh} #{d} Day
MenuExternalExamGrades: Exam results
MenuExternalExamUsers: Participants
MenuExternalExamEdit: Edit
@ -143,12 +144,18 @@ MenuSap: SAP Interface
MenuAvs: AVS Interface
MenuAvsSynchError: AVS Problem Overview
MenuLdap: LDAP Interface
MenuApc: Printing
MenuApc: Print
MenuPrintSend: Send Letter
MenuPrintDownload: Download Letter
MenuPrintLog: LPR Interface
MenuPrintAck: Acknowledge Printing
MenuCommCenter: Notifications
MenuMailCenter: Email
MenuMailHtml: Html
MenuMailPlain: Text
MenuMailAttachment: Attachment
MenuApiDocs: API documentation
MenuSwagger: OpenAPI 2.0 (Swagger)

20
messages/uniworx/utils/table_column/de-de-formal.msg
View File

@ -1,4 +1,4 @@
# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
# SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>, Steffen Jost <s.jost@fraport.de>
#
# SPDX-License-Identifier: AGPL-3.0-or-later
@ -48,11 +48,11 @@ TableNotPassed: Nicht bestanden
TableTutorialTutors: Ausbilder
TableTutorialName: Bezeichnung
TableTutorialType: Art
TableTutorialRoom: Regulärer Raum
TableTutorialRoom: Raum
TableTutorialRoomHidden: Raum nur für Teilnehmer
TableTutorialRoomIsUnset !ident-ok: —
TableTutorialRoomIsHidden: Raum wird nur Teilnehmern angezeigt
TableTutorialTime: Zeit
TableTutorialOccurrence: Termin
TableTutorialDeregisterUntil: Abmeldungen bis
TableTutorialFirstDay: Starttag
TableActionsHead: Aktionen
@ -73,15 +73,20 @@ TableDiffDaysTooltip: Zeitspanne nach ISO 8601. Beispiel: "P2Y3M4D" ist eine Zei
TableExamOfficeLabel: Label-Name
TableExamOfficeLabelStatus: Label-Farbe
TableExamOfficeLabelPriority: Label-Priorität
TableQualification: Qualifikation
TableQualifications: Qualifikationen
TableCompany: Firma
TableCompanyFilter: Firma oder Nummer
TableCompanyShort: Firmenkürzel
TableCompanies: Firmen
TablePrimeCompany: Primäre Firma
TableBookingCompany: Buchende Firma
TableCompanyNo: Firmennummer
TableCompanyNos: Firmennummern
TableCompanyUser: Firmenangehöriger
TableCompanyNrUsers: Firmenangehörige
TableCompanyNrSecondaryUsers: Sekundäre Firmenangehörige
TableCompanyReason: Notiz
TableCompanyNrSupers: Ansprechpartner
TableCompanyNrEmpSupervised: Firmenangehörige mit Ansprechpartner
TableCompanyNrEmpRerouted: Firmenangehörige mit Umleitung
@ -91,8 +96,12 @@ TableCompanyNrSupersDefault: Standard Ansprechpartner
TableCompanyNrForeignSupers: Firmenfremde Ansprechpartner
TableCompanyNrRerouteDefault: Standard Umleitungen
TableCompanyNrRerouteActive: Aktive Umleitungen
TableRerouteActive: Umleitung
TableCompanyPostalPreference: Benachrichtigungspräferenz neue Firmenangehörige
TableSupervisor: Ansprechpartner
TableSupervisorActive: Aktiver Ansprechpartner
TableSupervisee: Ansprechpartner für
TableReason: Begründung
TableCreationTime: Erstellungszeit
TableJob !ident-ok: Job
TableJobContent !ident-ok: Parameter
@ -100,10 +109,13 @@ TableJobLockTime: Bearbeitung seit
TableJobLockInstance: Bearbeiter
TableJobCreationInstance: Ersteller
ActJobDelete: Job entfernen
ActJobDeleteForce n@Int: Auch vor #{pluralDEnN n "Minute"} gesperrte Jobs entfernen
TableJobActDeleteFeedback n@Int m@Int: #{n}/#{m} Jobs entfernt
TableFilterComma: Es können mehrere alternative Suchkriterien mit Komma getrennt angegeben werden, wovon mindestens eines erfüllt werden muss.
TableFilterCommaPlus: Mehrere alternative Suchkriterien mit Komma trennen. Mindestens ein Suchkriterium muss erfüllt werden, zusätzlich zu allen Suchkriterien mit vorangestelltem Plus-Symbol.
TableFilterCommaPlusShort: Unterstützt mehrere Kriterien mit Komma-Plus, siehe oben.
TableFilterCommaName: Mehrere Namen mit Komma trennen.
TableFilterCommaNameNr: Mehrere Namen oder Nummern mit Komma trennen. Nummern werden nur exakt gesucht.
TableUserEdit: Benutzer bearbeiten
TableRows: Zeilen
TableRows: Zeilen
TableUserParkingToken: Parkmarke

20
messages/uniworx/utils/table_column/en-eu.msg
View File

@ -1,4 +1,4 @@
# SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
# SPDX-FileCopyrightText: 2022-24 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>, Steffen Jost <s.jost@fraport.de>
#
# SPDX-License-Identifier: AGPL-3.0-or-later
@ -48,14 +48,14 @@ TableNotPassed: Failed
TableTutorialTutors: Instructors
TableTutorialName: Name
TableTutorialType: Type
TableTutorialRoom: Regular room
TableTutorialRoom: Room
TableTutorialRoomHidden: Room only for participants
TableTutorialRoomIsUnset: —
TableTutorialRoomIsHidden: Room is only displayed to participants
TableTutorialDeregisterUntil: Deregister until
TableTutorialFirstDay: Start date
TableActionsHead: Actions
TableTutorialTime: Time
TableTutorialOccurrence: Session
TableNoFilter: No restriction
TableUserMatriculation: AVS number
TableColumnStudyFeatures: Features of study
@ -73,15 +73,20 @@ TableDiffDaysTooltip: Duration given according to ISO 8601. Example: "P2Y3M4D" i
TableExamOfficeLabel: Label name
TableExamOfficeLabelStatus: Label colour
TableExamOfficeLabelPriority: Label priority
TableQualification: Qualification
TableQualifications: Qualifications
TableCompany: Company
TableCompanyFilter: Company/Nr
TableCompanyShort: Company shorthand
TableCompanies: Companies
TablePrimeCompany: Primary company
TableBookingCompany: Booking company
TableCompanyNo: Company number
TableCompanyNos: Company numbers
TableCompanyUser: Associate
TableCompanyNrUsers: Associates
TableCompanyNrSecondaryUsers: Secondary Associates
TableCompanyReason: Note
TableCompanyNrSupers: Supervisors
TableCompanyNrEmpSupervised: Supervised employees
TableCompanyNrEmpRerouted: Employees having reroute
@ -91,8 +96,12 @@ TableCompanyNrSupersDefault: Default supervisors
TableCompanyNrForeignSupers: External Supervisors
TableCompanyNrRerouteDefault: Default reroutes
TableCompanyNrRerouteActive: Active reroutes
TableRerouteActive: Reroute
TableCompanyPostalPreference: Default notification preference
TableSupervisor: Supervisor
TableSupervisorActive: Active supervisor
TableSupervisee: Supervisor for
TableReason: Reason
TableCreationTime: Creation
TableJob !ident-ok: Job
TableJobContent !ident-ok: Parameters
@ -100,10 +109,13 @@ TableJobLockTime: Lock time
TableJobLockInstance: Worker
TableJobCreationInstance: Creator
ActJobDelete: Delete job
ActJobDeleteForce n: Also delete jobs locked #{pluralENsN n "minute"} ago
TableJobActDeleteFeedback n@Int m@Int: #{n}/#{m} queued jobs deleted
TableFilterComma: Separate multiple alternative filter criteria by comma, at least one of which must be fulfilled.
TableFilterCommaPlus: Separate multiple alternative filter criteria by comma, at least one of which must be fulfilled in addition to all criteria preceded by a plus symbol.
TableFilterCommaPlusShort: Support multiple criteria with comma/plus, see above.
TableFilterCommaName: Separate names by comma.
TableFilterCommaNameNr: Separate names and numbers by comma. Numbers have to match exact.
TableUserEdit: Edit user
TableRows: Rows
TableRows: Rows
TableUserParkingToken: Parking token

4
messages/uniworx/utils/utils/de-de-formal.msg
View File

@ -25,6 +25,7 @@ RGTutorialParticipants tutn@TutorialName: Kursteilnehmer:innen (#{tutn})
RGExamRegistered examn@ExamName: Angemeldet zur Prüfung „#{examn}“
RGSheetSubmittor shn@SheetName: Abgebende für das Übungsblatt „#{shn}“
CommSubject: Betreff
CommContent: Inhalt
CommAttachments: Anhänge
CommAttachmentsTip: Im Allgemeinen ist es vorzuziehen Dateien, die Sie mit den Empfängern teilen möchten, als Material hochzuladen (und ggf. in der Nachricht zu verlinken). So ist die Datei für die Empfänger dauerhaft abrufbar und auch Personen, die sich z.B. erst später zur Kursart anmelden, haben Zugriff auf die Datei.
CommSuccess n@Int: Nachricht wurde an #{n} Empfänger versandt
@ -82,6 +83,7 @@ MultiUserFieldInvitationExplanationAlways: Es wird an alle Adressen, die Sie hie
AmbiguousEmail: E-Mail-Adresse nicht eindeutig
InvalidEmailAddress: E-Mail-Adresse ist ungültig
InvalidEmailAddressWith e@Text: E-Mail-Adresse #{show e} ist ungültig
MailFileAttachment: Dateianhang
UtilExamResultGrade: Note
UtilExamResultPass: Bestanden/Nicht Bestanden
UtilExamResultNoShow: Nicht erschienen
@ -89,6 +91,7 @@ UtilExamResultVoided: Entwertet
CourseOption tid@TermId ssh@SchoolId csh@CourseShorthand coursen@CourseName !ident-ok: #{tid} - #{ssh} - #{csh}: #{coursen}
RoomReferenceNone !ident-ok: —
RoomReferenceSimple !ident-ok: Text
RoomReferenceSimpleAt r@Text: in Raum #{r}
RoomReferenceLink: Link & Anweisungen
RoomReferenceSimpleText: Raum
RoomReferenceSimpleTextPlaceholder: Raum
@ -96,6 +99,7 @@ RoomReferenceLinkLink !ident-ok: Link
RoomReferenceLinkLinkPlaceholder !ident-ok: URL
RoomReferenceLinkInstructions: Anweisungen
RoomReferenceLinkInstructionsPlaceholder: Anweisungen
UtilNoneSet: Keine angegeben
UtilEmptyChoice: Auswahl war leer
UtilEmptyNoChangeTip: Eine leere Eingabe belässt den vorherigen Wert unverändert.
MultiNoSelection: Keine Auswahl

4
messages/uniworx/utils/utils/en-eu.msg
View File

@ -25,6 +25,7 @@ RGTutorialParticipants tutn: Course participants (#{tutn})
RGExamRegistered examn: Registered for exam “#{examn}”
RGSheetSubmittor shn: Submitted for exercise sheet “#{shn}”
CommSubject: Subject
CommContent: Content
CommAttachments: Attachments
CommAttachmentsTip: In general it is preferable to upload files as course type material instead of sending them as attachments. You can then link to the material from the message. The file is then permanently accessable to the recipients and to persons that, for example, register for the Course type at a later date.
CommSuccess n: Message was sent to #{n} #{pluralEN n "recipient" "recipients"}
@ -82,6 +83,7 @@ MultiUserFieldInvitationExplanationAlways: An invitation will be sent via email
AmbiguousEmail: Email address is ambiguous
InvalidEmailAddress: Email address is invalid
InvalidEmailAddressWith e: Email asdress #{show e} is invalid
MailFileAttachment: Attached file
UtilExamResultGrade: Grade
UtilExamResultPass: Passed/Failed
UtilExamResultNoShow: Not present
@ -89,6 +91,7 @@ UtilExamResultVoided: Voided
CourseOption tid ssh csh coursen: #{tid} - #{ssh} - #{csh}: #{coursen}
RoomReferenceNone: —
RoomReferenceSimple: Text
RoomReferenceSimpleAt r: at room #{r}
RoomReferenceLink: Link & Instructions
RoomReferenceSimpleText: Room
RoomReferenceSimpleTextPlaceholder: Room
@ -96,6 +99,7 @@ RoomReferenceLinkLink: Link
RoomReferenceLinkLinkPlaceholder: URL
RoomReferenceLinkInstructions: Instructions
RoomReferenceLinkInstructionsPlaceholder: Instructions
UtilNoneSet: None set
UtilEmptyChoice: Empty selection
UtilEmptyNoChangeTip: Existing values remain unchanged if this field is left empty.
MultiNoSelection: No selection

13
models/audit.model
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
@ -8,7 +8,7 @@ TransactionLog
instance InstanceId
initiator UserId Maybe -- User associated with performing this action
remote IP Maybe -- Remote party that triggered this action via HTTP
info Value -- JSON-encoded `Transaction`
info Value -- JSON-encoded `Transaction`. Value allows full backwards compatibility
deriving Eq Read Show Generic
InterfaceLog
@ -26,6 +26,13 @@ InterfaceHealth
interface Text
subtype Text Maybe
write Bool Maybe
hours Int
hours Int -- negative number: never expires, i.e. if the last entry is a success, this remains indefinitely
UniqueInterfaceHealth interface subtype write !force -- Note that nullable fields must be either empty or unique
deriving Eq Read Show Generic
ProblemLog
time UTCTime default=now()
info Value -- generic JSON Value allows maximum backwards compatibility
solved UTCTime Maybe
solver UserId Maybe -- User who marked this problem as done
deriving Eq Read Show Generic

22
models/avs.model
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-24 Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
@ -16,27 +16,19 @@
UserAvs
personId AvsPersonId -- unique identifier for user throughout avs; newtype for Int
user UserId
noPerson Int default=0 -- only needed for manual communication with personnel from Ausweisverwaltungsstelle
noPerson Int default=0 -- only needed for manual communication with personnel from Ausweisverwaltungsstelle, redundant since needed for filtering
lastSynch UTCTime default=now()
lastSynchError Text Maybe
lastPersonInfo AvsPersonInfo Maybe -- just to discern field changes
lastFirmInfo AvsFirmInfo Maybe -- just to discern field changes
lastCardNo AvsFullCardNo Maybe -- just to discern changes
UniqueUserAvsUser user
UniqueUserAvsId personId
deriving Generic Show
-- Multiple UserAvsCards per UserAvs is possible and not too uncommon.
-- Purpose of saving cards is to detect external changes in qualifications and postal addresses
-- TODO: This table will be deleted if AVS CR3 SCF-165 is implemented
UserAvsCard
personId AvsPersonId
cardNo AvsFullCardNo
card AvsDataPersonCard
lastSynch UTCTime
-- UniqueAvsCard cardNo -- Note: cardNo is not unique; invalid cardNo may be reissued to different persons
deriving Generic
AvsSync
user UserId -- Note: we need to lookup UserAvs Entity anyway, so no benefit from storing AvsPersonId here
creationTime UTCTime
pause Day Maybe
pause Day Maybe -- Don't synch if last synch after this day, otherwise synch
UniqueAvsSyncUser user
deriving Generic
deriving Generic Show

29
models/company.model
View File

@ -1,25 +1,18 @@
-- SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-24 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
-- Description of companies associated with users
Company
name CompanyName -- == (CI Text)
shorthand CompanyShorthand -- == (CI Text) and CompanyKey :: CompanyShorthand -> CompanyId FUTURE TODO: a shorthand will become available through the AVS interface in the future
avsId Int default=0 -- primary key from avs
prefersPostal Bool default=false -- new company users prefers letters by post instead of email
postAddress StoredMarkup Maybe -- default company postal address
email UserEmail Maybe -- Case-insensitive generic company eMail address
UniqueCompanyName name
UniqueCompanyShorthand shorthand
-- UniqueCompanyAvsId avsId -- should be the case, unclear if enforcing works here, since we cannot query avs by company id
Primary shorthand -- newtype Key Company = CompanyKey { unCompanyKey :: CompanyShorthand }
name CompanyName -- == (CI Text) -- NOTE: Fraport department name may carry additional information; use the Shorthand with respect to UserCompanyDepartment
shorthand CompanyShorthand -- == (CI Text) and CompanyKey :: CompanyShorthand -> CompanyId A change to AvsId as primary key is too much work and not strictly necessary due to Uniqueness
avsId Int default=0 -- primary key from avs, use negative numbers for non-AVS companies
prefersPostal Bool default=true -- new company users prefers letters by post instead of email
postAddress StoredMarkup Maybe -- default company postal address, including company name
email UserEmail Maybe -- Case-insensitive generic company eMail address
-- UniqueCompanyName name -- Should be Unique in AVS, but we do not yet need to enforce it
-- UniqueCompanyShorthand shorthand -- unnecessary, since it is the primary key already
UniqueCompanyAvsId avsId -- Should be the key, is not for historical reasons and for convenience in URLs and columns
Primary shorthand -- newtype Key Company = CompanyKey { unCompanyKey :: CompanyShorthand }
deriving Ord Eq Show Generic Binary
-- TODO: a way to populate this table (manually)
CompanySynonym
synonym CompanyName
canonical CompanyShorthand OnDeleteCascade OnUpdateCascade
UniqueCompanySynonym synonym
deriving Ord Eq Show Generic

13
models/courses.model
View File

@ -28,13 +28,12 @@ Course -- Information about a single course; contained info is always visible
TermSchoolCourseName term school name -- name must be unique within school and semester
deriving Generic
CourseEvent
type (CI Text)
course CourseId OnDeleteCascade OnUpdateCascade
room RoomReference Maybe
roomHidden Bool default=false
time Occurrences
note StoredMarkup Maybe
lastChanged UTCTime default=now()
type (CI Text)
course CourseId OnDeleteCascade OnUpdateCascade
roomHidden Bool default=false
time (JSONB Occurrences)
note StoredMarkup Maybe
lastChanged UTCTime default=now()
deriving Generic
CourseAppInstructionFile

4
models/jobs.model
View File

@ -20,11 +20,11 @@ CronLastExec
time UTCTime -- When was the job executed
instance InstanceId -- Which uni2work-instance did the work
UniqueCronLastExec job
deriving Generic
deriving Generic Show
TokenBucket
ident TokenBucketIdent
lastValue Int64
lastAccess UTCTime
Primary ident
deriving Generic
deriving Generic Show

47
models/lms.model
View File

@ -13,16 +13,18 @@ Qualification
refreshWithin CalendarDiffDays Maybe -- notify users about renewal within this number of month/days before expiry; to be used with addGregorianDurationClip
refreshReminder CalendarDiffDays Maybe -- send a second notification about renewal within this number of month/days before expiry
elearningStart Bool -- automatically schedule e-refresher
-- elearningOnly Bool -- successful E-learing automatically increases validity. NO!
elearningRenews Bool default=true -- successful e-learing automatically increases validity automatically by validDuration
elearningLimit Int Maybe -- limit of e-learning attempts, currently only for informative purposes, as it is enforced by LMS only
lmsReuses QualificationId Maybe -- if set, lms is also included within the given qualification's lms, but only for direct routes. AuditDuration is used from this Qualification instead.
expiryNotification Bool default=true -- should expiryNotification be generated for this qualification?
avsLicence AvsLicence Maybe -- if set, valid QualificationUsers are synchronized to AVS as a driving licence
sapId Text Maybe -- if set, valid QualificationUsers with userCompanyPersonalNumber are transmitted via SAP interface under this id
sapId Text Maybe -- if set, valid QualificationUsers with userCompanyPersonalNumber are transmitted via SAP interface under this id
SchoolQualificationShort school shorthand -- must be unique per school and shorthand
SchoolQualificationName school name -- must be unique per school and name
-- across all schools, only one qualification may be a driving licence:
UniqueQualificationAvsLicence avsLicence !force -- either empty or unique
-- across all schools, only one qualification may be a driving licence -- NO LONGER TRUE
-- UniqueQualificationAvsLicence avsLicence !force -- either empty or unique
-- NOTE: two NULL values are not equal for the purpose of Uniqueness constraints!
deriving Eq Generic
deriving Show Eq Generic Binary
-- TODOs:
-- - Enstehen Kosten, wenn Teilnehmer für KnowHow eingereiht werden, aber nicht am Kurs teilnehmen?
@ -40,19 +42,20 @@ Qualification
-- - PinReset==1 mit bestehendem Passwort kann problemlos erneut gesendet werden
-- - Flag "interner Mitarbeiter" wird von Know-How ignoriert / nicht ausgewertet (legacy)
QualificationPrecondition -- NOTE: this can only be enforced through a background job adding or removing qualifications
qualification QualificationId OnDeleteCascade OnUpdateCascade -- AND: not unique, ie. qualification can have multiple required preconditions
required [QualificationId] -- OR : alternatives, any one will suffice
continuous Bool -- expiring precondition blocks qualification
deriving Generic
-- QualificationPrecondition -- NOTE: this can only be enforced through a background job adding or removing qualifications
-- qualification QualificationId OnDeleteCascade OnUpdateCascade -- AND: not unique, ie. qualification can have multiple required preconditions
-- required [QualificationId] -- OR : alternatives, any one will suffice -- we don't want array, since we have recursive CTEs
-- continuous Bool -- expiring precondition blocks qualification
-- deriving Generic Show
-- Maybe an alternative for online qualification validity checking, transitivity through recursive CTEs? (already available in our version)
-- QualificationRequirement
-- qualification QualificationId OnDeleteCascade OnUpdateCascade
-- requirement QualificationId OnDeleteCascade OnUpdateCascade
-- group Text -- OR: several requirements within the same group are considered equivalent
-- UniqueQualificationRequirement qualification requirement
--
QualificationRequirement
qualification QualificationId OnDeleteCascade OnUpdateCascade
requirement QualificationId OnDeleteCascade OnUpdateCascade
group Int -- OR: several requirements within the same group are considered equivalent; no order between groups
note Text -- for humans only, no semantical effect
UniqueQualificationRequirement qualification requirement
deriving Generic Show
-- TODO: connect Qualification with Exams!
@ -60,7 +63,7 @@ QualificationEdit
user UserId
time UTCTime
qualification QualificationId OnDeleteCascade OnUpdateCascade
deriving Generic
deriving Generic Show
QualificationUser
user UserId OnDeleteCascade OnUpdateCascade
@ -69,11 +72,11 @@ QualificationUser
lastRefresh Day -- lastRefresh > validUntil possible, if Qualification^elearningOnly == False
firstHeld Day -- first time the qualification was earned, should never change
scheduleRenewal Bool default=true -- if false, no automatic renewal is scheduled and the qualification expires
lastNotified UTCTime default=now() -- last notficiation about being invalid
lastNotified UTCTime default=now() -- last notficiation about actual licence validity changes (does not entail e-learning notifications)
-- Reasons and temporary revocations are implemented through QualificationUserBlock
-- TODO: adjust SAP interface to transmit end dates
UniqueQualificationUser qualification user
deriving Generic
deriving Generic Show
QualificationUserBlock
qualificationUser QualificationUserId OnDeleteCascade OnUpdateCascade
@ -130,7 +133,7 @@ LmsUser
-- Primary ident -- newtype Key LmsUserId = LmsUserKey { unLmsUser :: Text } -- change LmsIdent -> Text. Do we want this? No.
UniqueLmsIdent ident -- idents must be unique accross all qualifications, since idents are global within LMS!
UniqueLmsQualificationUser qualification user -- each user may be enrolled at most once per course
deriving Generic
deriving Generic Show
-- LmsUserStatus
-- lmsUser LmsUserId OnDeleteCascade OnUpdateCascade
@ -148,7 +151,7 @@ LmsReport
lock Bool -- (0|1)
timestamp UTCTime default=now()
UniqueLmsReport qualification ident -- required by DBTable
deriving Generic
deriving Generic Show
-- LmsAudit removed by commit 71cde92a
-- due to frequent transmit errors, a separate lms tranmission log is necessary again
@ -160,4 +163,4 @@ LmsReportLog
lock Bool -- (0|1)
timestamp UTCTime default=now()
missing Bool default=false
deriving Generic
deriving Generic Show

7
models/print.model
View File

@ -10,22 +10,23 @@ PrintJob
created UTCTime
acknowledged UTCTime Maybe
recipient UserId Maybe OnDeleteSetNull OnUpdateCascade -- optional as some letters may contain just an address
affected UserId Maybe OnDeleteSetNull OnUpdateCascade -- subject of the letter
sender UserId Maybe OnDeleteSetNull OnUpdateCascade -- senders and associations are optional
course CourseId Maybe OnDeleteCascade OnUpdateCascade
qualification QualificationId Maybe OnDeleteCascade OnUpdateCascade
lmsUser LmsIdent Maybe OnDeleteSetNull OnUpdateCascade -- allows tracking if recipient has been notified; must be unique
-- UniquePrintJobLmsUser lmsUser -- Note that in fact multiple print jobs per LMS user are possible!
-- UniquePrintJobApcIdent apcIdent -- TODO: not yet enforced, since LmsIdent is currently used
deriving Generic
deriving Generic Show
PrintAcknowledge -- just to store acknowledging requests to be evaluated by a background job later on
apcIdent Text
timestamp UTCTime default=now()
processed Bool
deriving Generic
deriving Generic Show
PrintAckIdAlias
needle Text
replacement Text
priority Int
deriving Generic
deriving Generic Show

24
models/tutorials.model
View File

@ -6,10 +6,9 @@ Tutorial json
name TutorialName
course CourseId OnDeleteCascade OnUpdateCascade
type (CI Text) -- "Tutorium", "Zentralübung", ...
capacity Int Maybe -- limit for enrolment in this tutorial
room RoomReference Maybe
capacity Int Maybe -- limit for enrolment in this tutorial
roomHidden Bool default=false
time Occurrences
time (JSONB Occurrences)
regGroup (CI Text) Maybe -- each participant may register for one tutorial per regGroup
registerFrom UTCTime Maybe
registerTo UTCTime Maybe
@ -25,8 +24,19 @@ Tutor
UniqueTutor tutorial user
deriving Generic
TutorialParticipant
tutorial TutorialId OnDeleteCascade OnUpdateCascade
user UserId
tutorial TutorialId OnDeleteCascade OnUpdateCascade
user UserId
company CompanyId Maybe
drivingPermit UserDrivingPermit Maybe
eyeExam UserEyeExam Maybe
note Text Maybe
UniqueTutorialParticipant tutorial user
deriving Eq Ord Show
deriving Generic
deriving Eq Ord Show Generic
TutorialParticipantDay
tutorial TutorialId OnDeleteCascade OnUpdateCascade
user UserId OnDeleteCascade OnUpdateCascade
day Day
attendance Bool default=true
note Text Maybe
UniqueTutorialParticipantDay tutorial user day
deriving Show Generic

48
models/users.model
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
@ -14,14 +14,14 @@
User json -- Each Uni2work user has a corresponding row in this table; created upon first login.
surname UserSurname -- Display user names always through 'nameWidget displayName surname'
displayName UserDisplayName
displayEmail UserEmail
email UserEmail -- Case-insensitive eMail address, used for sending TODO: make this nullable
ident UserIdent -- Case-insensitive user-identifier
displayEmail UserEmail -- Case-insensitive eMail address, used for sending; leave empty for using auto-update CompanyEmail via UserCompany
email UserEmail -- Case-insensitive eMail address, used for identification and fallback for sending. Defaults to "AVSNO:dddddddd" if unknown
ident UserIdent -- Case-insensitive user-identifier. Defaults to "AVSID:dddddddd" if unknown
authentication AuthenticationMode -- 'AuthLDAP' or ('AuthPWHash'+password-hash)
lastAuthentication UTCTime Maybe -- last login date
created UTCTime default=now()
lastLdapSynchronisation UTCTime Maybe
ldapPrimaryKey UserEduPersonPrincipalName Maybe
ldapPrimaryKey UserEduPersonPrincipalName Maybe -- Fraport Personnel Number or Email-Prefix for @fraport.de work here
tokensIssuedAfter UTCTime Maybe -- do not accept bearer tokens issued before this time (accept all tokens if null)
matrikelnummer UserMatriculation Maybe -- usually a number; AVS Personalnummer; nicht Fraport Personalnummer!
firstName Text -- For export in tables, pre-split firstName from displayName
@ -44,9 +44,9 @@ User json -- Each Uni2work user has a corresponding row in this table; create
mobile Text Maybe
companyPersonalNumber Text Maybe -- Company will become a new table, but if company=fraport, some information is received via LDAP
companyDepartment Text Maybe -- thus we store such information for ease of reference directly, if available
pinPassword Text Maybe -- used to encrypt pins within emails
postAddress StoredMarkup Maybe
postLastUpdate UTCTime Maybe -- record postal address updates
pinPassword Text Maybe -- used to encrypt pins within emails, defaults to cardno.version
postAddress StoredMarkup Maybe -- including company name, if any, but excluding username; leave empty for using auto-update CompanyPostAddress via UserCompany
postLastUpdate UTCTime Maybe -- record postal address updates
prefersPostal Bool default=false -- user prefers letters by post instead of email
examOfficeGetSynced Bool default=true -- whether synced status should be displayed for exam results by default
examOfficeGetLabels Bool default=true -- whether labels should be displayed for exam results by default
@ -61,42 +61,52 @@ UserFunction -- Administratively assigned functions (lecturer, admin, evaluation
function SchoolFunction
UniqueUserFunction user school function
deriving Generic
UserSystemFunction
UserSystemFunction Show
user UserId
function SystemFunction -- Defined in Model.Types.User
manual Bool -- Inserted manually by Admin or automatic from LDAP
isOptOut Bool -- User has currently deactivate the role for themselves
UniqueUserSystemFunction user function
deriving Generic
deriving Generic Show
UserExamOffice
user UserId
field StudyTermsId
UniqueUserExamOffice user field
deriving Generic
deriving Generic Show
UserSchool -- Managed by users themselves, encodes "schools of interest"
user UserId
school SchoolId
isOptOut Bool -- true if this a marker, that the user manually deleted this entry; it should not be recreated automatically
UniqueUserSchool user school
deriving Generic
deriving Generic Show
UserGroupMember
group UserGroupName
user UserId
primary Checkmark nullable
UniquePrimaryUserGroupMember group primary !force
UniqueUserGroupMember group user
deriving Generic
deriving Generic Show
UserCompany
user UserId
company CompanyId OnDeleteCascade OnUpdateCascade
supervisor Bool default=false -- should this user be made supervisor for all _new_ users associated with this company?
supervisorReroute Bool default=false -- if supervisor is true, should this supervisor receive email for _new_ company users?
priority Int default=0 -- higher number, higher priority; default=1 for Haskell-Code
useCompanyAddress Bool default=true -- if true, CompanyPostalAddress and CompanyEmail are used if UserPostalAddress/UserDisplayEmail are Nothing, respects priority
reason Text Maybe -- miscellaneous note, e.g. Superior
UniqueUserCompany user company -- a user may belong to multiple companies, but to each one only once
deriving Generic
deriving Generic Show
UserSupervisor
supervisor UserId -- multiple supervisor per trainee possible
supervisor UserId -- multiple supervisor per trainee possible
user UserId
rerouteNotifications Bool -- User can be his own supervisor to receive notifications as well
UniqueUserSupervisor supervisor user -- each supervisor/user combination is unique (same supervisor can superviser the same user only once)
deriving Generic
rerouteNotifications Bool -- User can be his own supervisor to receive notifications as well
company CompanyId Maybe OnDeleteCascade OnUpdateCascade -- this supervisor was company default supervisor at time of entry
reason Text Maybe -- miscellaneous reason, e.g. Winterservice supervisision
UniqueUserSupervisor supervisor user -- each supervisor/user combination is unique (same supervisor can superviser the same user only once)
deriving Generic Show
UserDay
user UserId OnDeleteCascade OnUpdateCascade
day Day
parkingToken Bool default=false
UniqueUserDay user day
deriving Generic Show

4
package-lock.json generated
View File

@ -1,12 +1,12 @@
{
"name": "fradrive",
"version": "27.4.59",
"version": "27.5.1",
"lockfileVersion": 3,
"requires": true,
"packages": {
"": {
"name": "fradrive",
"version": "27.4.59",
"version": "27.5.1",
"license": "AGPL-3.0-or-later",
"dependencies": {
"@babel/runtime": "^7.25.6",

2
package.json
View File

@ -1,6 +1,6 @@
{
"name": "fradrive",
"version": "27.4.59",
"version": "27.5.1",
"description": "",
"keywords": [],
"author": "",

4
package.yaml
View File

@ -3,7 +3,7 @@
# SPDX-License-Identifier: AGPL-3.0-or-later
name: uniworx
version: 27.4.59
version: 27.5.1
dependencies:
- base
- yesod
@ -260,7 +260,7 @@ ghc-options:
- -fno-warn-unrecognised-pragmas
- -fno-warn-partial-type-signatures
- -fno-max-relevant-binds
- -j
- -j5
- -freduction-depth=0
- -fprof-auto-calls
- -g

27
routes
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>, Wolfgang Witt <Wolfgang.Witt@campus.lmu.de>
-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>, Wolfgang Witt <Wolfgang.Witt@campus.lmu.de>, Steffeb Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
@ -53,9 +53,9 @@
/ NewsR GET !free
/users UsersR GET POST -- no tags, i.e. admins only
/users/#CryptoUUIDUser AdminUserR GET POST
/users/#CryptoUUIDUser/delete AdminUserDeleteR POST
/users/#CryptoUUIDUser/hijack AdminHijackUserR GET POST !adminANDno-escalation
/users/#CryptoUUIDUser AdminUserR GET POST
/users/#CryptoUUIDUser/delete AdminUserDeleteR POST
/users/#CryptoUUIDUser/hijack AdminHijackUserR GET POST !adminANDno-escalation
/users/#CryptoUUIDUser/notifications UserNotificationR GET POST !self
/users/#CryptoUUIDUser/password UserPasswordR GET POST !selfANDis-pw-hash
!/users/functionary-invite/new AdminNewFunctionaryInviteR GET POST
@ -69,14 +69,21 @@
/admin/crontab AdminCrontabR GET
/admin/crontab/jobs AdminJobsR GET POST
/admin/avs AdminAvsR GET POST
/admin/avs/#CryptoUUIDUser AdminAvsUserR GET
/admin/avs/#CryptoUUIDUser AdminAvsUserR GET POST
/admin/ldap AdminLdapR GET POST
/admin/problems AdminProblemsR GET
/admin/problems/no-contact ProblemUnreachableR GET
/admin/problems AdminProblemsR GET POST
/admin/problems/no-contact ProblemUnreachableR GET POST
/admin/problems/no-avs-id ProblemWithoutAvsId GET
/admin/problems/r-without-f ProblemFbutNoR GET
/admin/problems/avs ProblemAvsSynchR GET POST
/admin/problems/avs/errors ProblemAvsErrorR GET
/admin/config/interfaces ConfigInterfacesR GET POST
/comm CommCenterR GET
/comm/email MailCenterR GET POST
/comm/email/html/#CryptoUUIDSentMail MailHtmlR GET
/comm/email/plain/#CryptoUUIDSentMail MailPlainR GET
/comm/email/attachment/#CryptoUUIDSentMail/#Text MailAttachmentR GET
/print PrintCenterR GET POST !system-printer
/print/acknowledge/#Day/#Int/#Int PrintAckR GET POST !system-printer
@ -147,11 +154,11 @@
!/term/#TermId/#SchoolId TermSchoolCourseListR GET !free
/school SchoolListR GET
/school SchoolListR GET !free
!/school/new SchoolNewR GET POST
/school/#SchoolId SchoolR:
/ SchoolEditR GET POST
/edit SchoolEditR GET POST
/day/#Day SchoolDayR GET POST
/participants ParticipantsListR GET !evaluation
/participants/#TermId/#SchoolId ParticipantsR GET !evaluation

3
shell.nix
View File

@ -289,13 +289,14 @@ in pkgs.mkShell {
# busybox # for print services, but interferes with build commands in develop-shell
htop
pdftk # pdftk just for testing pdf-passwords
roboto roboto-mono
# texlive.combined.scheme-full # works
# texlive.combined.scheme-medium
# texlive.combined.scheme-small
(texlive.combine {
inherit (texlive) scheme-basic
babel-german babel-english booktabs textpos
enumitem eurosym koma-script parskip xcolor dejavu
enumitem eurosym koma-script parskip xcolor roboto xkeyval
luatexbase lualatex-math unicode-math selnolig # required for LuaTeX
;
})

51
src/Application.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
@ -115,16 +115,11 @@ import GHC.RTS.Flags (getRTSFlags)
import qualified Prometheus
import qualified Data.IntervalMap.Strict as IntervalMap
import qualified Utils.Pool as Custom
import Utils.Postgresql
import Handler.Utils.Memcached (manageMemcachedLocalInvalidations)
import qualified System.Clock as Clock
import Utils.Avs
import Utils.Avs (mkAvsQuery)
-- Import all relevant handler modules here.
-- (HPack takes care to add new modules to our cabal file nowadays.)
@ -137,6 +132,7 @@ import Handler.Users.Add
import Handler.Admin
import Handler.Term
import Handler.School
import Handler.School.DayTasks
import Handler.Course
import Handler.Sheet
import Handler.Submission
@ -157,6 +153,8 @@ import Handler.Upload
import Handler.Qualification
import Handler.LMS
import Handler.SAP
import Handler.CommCenter
import Handler.MailCenter
import Handler.PrintCenter
import Handler.ApiDocs
import Handler.Swagger
@ -216,18 +214,6 @@ makeFoundation appSettings''@AppSettings{..} = do
appJobState <- liftIO newEmptyTMVarIO
appHealthReport <- liftIO $ newTVarIO Set.empty
appFileSourceARC <- for appFileSourceARCConf $ \ARCConf{..} -> do
ah <- initARCHandle arccMaximumGhost arccMaximumWeight
void . Prometheus.register $ arcMetrics ARCFileSource ah
return ah
appFileSourcePrewarm <- for appFileSourcePrewarmConf $ \PrewarmCacheConf{..} -> do
lh <- initLRUHandle precMaximumWeight
void . Prometheus.register $ lruMetrics LRUFileSourcePrewarm lh
return lh
appFileInjectInhibit <- liftIO $ newTVarIO IntervalMap.empty
for_ (guardOnM (isn't _JobsOffload appJobMode) appInjectFiles) $ \_ ->
void . Prometheus.register $ injectInhibitMetrics appFileInjectInhibit
appStartTime <- liftIO getCurrentTime
-- We need a log function to create a connection pool. We need a connection
-- pool to create our foundation. And we need our foundation to get a
@ -236,7 +222,7 @@ makeFoundation appSettings''@AppSettings{..} = do
-- from there, and then create the real foundation.
let
mkFoundation :: _ -> (forall m. MonadIO m => Custom.Pool' m DBConnLabel DBConnUseState SqlBackend) -> _
mkFoundation appSettings' appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery = UniWorX{..}
mkFoundation appSettings' appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appUploadCache appVerpSecret appAuthKey appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery = UniWorX{..}
tempFoundation = mkFoundation
(error "appSettings' forced in tempFoundation")
(error "connPool forced in tempFoundation")
@ -249,7 +235,6 @@ makeFoundation appSettings''@AppSettings{..} = do
(error "JSONWebKeySet forced in tempFoundation")
(error "ClusterID forced in tempFoundation")
(error "memcached forced in tempFoundation")
(error "memcachedLocal forced in tempFoundation")
(error "MinioConn forced in tempFoundation")
(error "VerpSecret forced in tempFoundation")
(error "AuthKey forced in tempFoundation")
@ -334,12 +319,6 @@ makeFoundation appSettings''@AppSettings{..} = do
$logWarnS "setup" "Clearing memcached"
liftIO $ Memcached.flushAll memcachedConn
return AppMemcached{..}
appMemcachedLocal <- for appMemcachedLocalConf $ \ARCConf{..} -> do
memcachedLocalARC <- initARCHandle arccMaximumGhost arccMaximumWeight
void . Prometheus.register $ arcMetrics ARCMemcachedLocal memcachedLocalARC
memcachedLocalInvalidationQueue <- newTVarIO mempty
memcachedLocalHandleInvalidations <- allocateLinkedAsync . managePostgresqlChannel appDatabaseConf ChannelMemcachedLocalInvalidation $ manageMemcachedLocalInvalidations memcachedLocalARC memcachedLocalInvalidationQueue
return AppMemcachedLocal{..}
appSessionStore <- mkSessionStore appSettings'' sqlPool `customRunSqlPool` sqlPool
@ -352,15 +331,15 @@ makeFoundation appSettings''@AppSettings{..} = do
handleIf isBucketExists (const $ return ()) $ Minio.makeBucket appUploadTmpBucket Nothing
return conn
appAvsQuery <- case appAvsConf of
appAvsQuery <- case appAvsConf of
Nothing -> do
$logErrorS "avsPrepare" "appAvsConfig is empty, i.e. invalid AVS configuration settings."
return Nothing
-- error "AvsConfig is empty, i.e. invalid AVS configuration settings."
Just avsConf -> do
-- error "AvsConfig is empty, i.e. invalid AVS configuration settings."
Just avsConf -> do
manager <- newManagerSettings $ mkManagerSettings (def { settingDisableCertificateValidation = True }) Nothing
let avsServer = BaseUrl
let avsServer = BaseUrl
{ baseUrlScheme = Https
, baseUrlHost = avsHost avsConf
, baseUrlPort = avsPort avsConf
@ -377,7 +356,7 @@ makeFoundation appSettings''@AppSettings{..} = do
$logDebugS "Runtime configuration" $ tshowCrop appSettings'
let foundation = mkFoundation appSettings' sqlPool smtpPool ldapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery
let foundation = mkFoundation appSettings' sqlPool smtpPool ldapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appUploadCache appVerpSecret appAuthKey appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery
-- Return the foundation
$logInfoS "setup" "*** DONE ***"
@ -657,7 +636,7 @@ appMain = runResourceT $ do
notifyWatchdog = forever' Nothing $ \pResults -> do
let delay = floor $ wInterval % 4
d <- liftIO $ newDelay delay
$logDebugS "Notify" $ "Waiting up to " <> tshow delay <> "µs..."
mResults <- atomically $ asum
[ pResults <$ waitDelay d
@ -746,8 +725,8 @@ shutdownApp app = do
-- | Run a handler
handler, handler' :: Handler a -> IO a
handler h = runResourceT $ getAppDevSettings >>= makeFoundation >>= liftIO . flip unsafeHandler h
handler' h = runResourceT $ getAppSettings >>= makeFoundation >>= liftIO . flip unsafeHandler h
handler h = runResourceT $ getAppDevSettings >>= makeFoundation >>= liftIO . flip unsafeHandler h
handler' h = runResourceT $ getAppSettings >>= makeFoundation >>= liftIO . flip unsafeHandler h
-- | Run DB queries
db, db' :: DB a -> IO a

36
src/Audit.hs
View File

@ -1,7 +1,9 @@
-- SPDX-FileCopyrightText: 2023 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
-- SPDX-FileCopyrightText: 2023-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
{-# LANGUAGE TypeApplications #-}
module Audit
( module Audit.Types
, AuditException(..)
@ -9,6 +11,7 @@ module Audit
, AuditRemoteException(..)
, getRemote
, logInterface, logInterface'
, reportAdminProblem
) where
@ -16,6 +19,8 @@ import Import.NoModel
import Settings
import Model
import Database.Persist.Sql
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
import qualified Database.Esqueleto.Utils as E
import Audit.Types
import qualified Data.Text as Text
@ -128,7 +133,7 @@ logInterface :: ( AuthId (HandlerSite m) ~ Key User
-> Text -- ^ Any additional information
-> ReaderT (YesodPersistBackend (HandlerSite m)) m ()
-- ^ Log a transaction using information available from `HandlerT`, also calls `audit`
logInterface interfaceLogInterface interfaceLogSubtype interfaceLogSuccess interfaceLogRows interfaceLogInfo = do
logInterface interfaceLogInterface interfaceLogSubtype interfaceLogSuccess interfaceLogRows interfaceLogInfo = do
interfaceLogWrite <- (methodGet /=) . Wai.requestMethod . reqWaiRequest <$> getRequest
logInterface' interfaceLogInterface interfaceLogSubtype interfaceLogWrite interfaceLogSuccess interfaceLogRows interfaceLogInfo
@ -152,7 +157,7 @@ logInterface' :: ( AuthId (HandlerSite m) ~ Key User
-- ^ Log a transaction using information available from `HandlerT`, also calls `audit`
logInterface' (Text.strip -> interfaceLogInterface) (Text.strip -> interfaceLogSubtype) interfaceLogWrite interfaceLogSuccess interfaceLogRows (Text.strip -> interfaceLogInfo) = do
interfaceLogTime <- liftIO getCurrentTime
-- deleteBy $ UniqueInterfaceSubtypeWrite interfaceLogInterface interfaceLogSubtype interfaceLogWrite -- always replace: deleteBy & insert seems to be safest and fastest
-- deleteBy $ UniqueInterfaceSubtypeWrite interfaceLogInterface interfaceLogSubtype interfaceLogWrite -- deleteBy & insert would be justified here, leading to a new Row-ID, since the two rows are not truly connected.
-- insert_ InterfaceLog{..}
void $ upsertBy (UniqueInterfaceSubtypeWrite interfaceLogInterface interfaceLogSubtype interfaceLogWrite)
( InterfaceLog{..} )
@ -169,3 +174,28 @@ logInterface' (Text.strip -> interfaceLogInterface) (Text.strip -> interfaceLogS
, transactionInterfaceInfo = interfaceLogInfo
, transactionInterfaceSuccess = Just interfaceLogSuccess
}
reportAdminProblem :: ( IsSqlBackend (YesodPersistBackend (HandlerSite m))
, SqlBackendCanWrite (YesodPersistBackend (HandlerSite m))
, MonadHandler m
-- , HasCallStack
)
=> AdminProblem -- ^ Problem to record
-> ReaderT (YesodPersistBackend (HandlerSite m)) m ()
-- ^ Log a problem that needs interventions by admins, provided this problem has not already been reported and is still unsolved
--
-- - `problemLogTime` is now
-- - `problemSolver` is Nothing, we do not record the person who caused it
reportAdminProblem problem = do
let problemLogSolved = Nothing
problemLogSolver = Nothing
problemLogInfo = toJSON problem
problemLogTime <- liftIO getCurrentTime
isKnown <- E.selectExists $ do
pl <- E.from $ E.table @ProblemLog
E.where_ $ E.isNothing (pl E.^. ProblemLogSolved)
E.&&. E.val problemLogInfo E.==. pl E.^. ProblemLogInfo
unless isKnown $ insert_ ProblemLog{..}
$logWarnS "Problem" $ Text.filter (/= '\n') $ tshow problem -- <> " - " <> pack (prettyCallStack callStack)

70
src/Audit/Types.hs
View File

@ -1,15 +1,18 @@
-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
module Audit.Types
( Transaction(..)
, AdminProblem(..)
, decodeAdminProblem
) where
import ClassyPrelude.Yesod hiding (derivePersistFieldJSON)
import Model.Types.TH.JSON
import Model
import Data.Aeson
import Data.Aeson.TH
import Utils.PathPiece
@ -182,7 +185,7 @@ data Transaction
}
| TransactionLmsStart
{ transactionQualification :: QualificationId
, transactionLmsIdent :: LmsIdent
, transactionLmsIdent :: LmsIdent
, transactionLmsUser :: UserId
, transactionLmsUserKey :: LmsUserId
}
@ -213,7 +216,7 @@ data Transaction
| TransactionQualificationUserEdit -- Note that a renewal always entails unblocking as well!
{ transactionUser :: UserId -- qualification holder that is updated
, transactionQualificationUser :: QualificationUserId -- not really necessary, maybe remove?
, transactionQualification :: QualificationId
, transactionQualification :: QualificationId
, transactionQualificationValidUntil :: Day
, transactionQualificationScheduleRenewal :: Maybe Bool -- Maybe, because some update may leave it unchanged (also avoids DB Migration)
, transactionNote :: Maybe Text
@ -251,4 +254,63 @@ deriveJSON defaultOptions
, sumEncoding = TaggedObject "transaction" "data"
} ''Transaction
derivePersistFieldJSON ''Transaction
derivePersistFieldJSON ''Transaction
-- Datatype for raising admin awareness to certain problems
-- Database stores generic Value in table ProblemLog, such that changes do not disturb old entries
-- Note that there is no RenderMessage instance, instead see @Handler.Admin.adminProblemCell dealing with special cases instead
-- Note: Adjust MsgAdminProblemInfoTooltip as well
data AdminProblem
= AdminProblemNewCompany -- new company was noticed, presumably without supervisors
{ adminProblemCompany :: CompanyId
}
| AdminProblemSupervisorNewCompany
{ adminProblemUser :: UserId -- a default supervisor has changed company
, adminProblemCompany :: CompanyId -- old company where the user had default supervisor rights
, adminProblemCompanyNew :: CompanyId -- new company of the user
, adminProblemSupervisorReroute :: Bool -- reroute included?
}
| AdminProblemSupervisorLeftCompany
{ adminProblemUser :: UserId -- user who had a supervisor but no longer has, due to supervisor change
, adminProblemCompany :: CompanyId -- old company
, adminProblemSupervisorReroute :: Bool -- reroute included?
}
| AdminProblemCompanySuperiorChange -- a company received a new superior user through AVS
{ adminProblemUser :: UserId -- new superior user
, adminProblemCompany :: CompanyId -- affected company
, adminProblemUserOld :: Maybe UserId -- previous superior
}
| AdminProblemCompanySuperiorNotFound -- a company received a new superior user through AVS, but user could not be created from email
{ adminProblemEmail :: Maybe Text -- new superior user's email, not found in LDAP
, adminProblemCompany :: CompanyId -- affected company
, adminProblemUserOld :: Maybe UserId -- previous superior
}
| AdminProblemNewlyUnsupervised
{ adminProblemUser :: UserId -- user who had a supervisor but no longer has, due to user company change
, adminProblemCompanyOld :: Maybe CompanyId -- old company
, adminProblemCompanyNew :: CompanyId -- new company of the user
}
| AdminProblemUnknown -- miscellanous problem, just displaying text
{ adminProblemText :: Text
}
deriving (Eq, Ord, Read, Show, Generic)
-- Columns shown in problem table: adminProblemCompany, adminProblemUser
-- For display: add clause to Handler.Admin.adminProblemCell
deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece' 2
, fieldLabelModifier = camelToPathPiece' 2
, tagSingleConstructors = True
, sumEncoding = TaggedObject "problem" "data"
, rejectUnknownFields = False
} ''AdminProblem
derivePersistFieldJSON ''AdminProblem
decodeAdminProblem :: Value -> AdminProblem
decodeAdminProblem v = case fromJSON v of
Error msg -> AdminProblemUnknown $ pack msg
Success p -> p

2
src/Auth/Dummy.hs
View File

@ -34,7 +34,7 @@ dummyForm = do
mr <- getMessageRender
wreq (ciField & addDatalist userList) (fslpI MsgDummyIdent (mr MsgDummyIdentPlaceholder) & addAttr "autocomplete" "username" & addName PostLoginDummy) Nothing
where
userList = fmap mkOptionList . runDB $ withReaderT projectBackend (map toOption <$> selectList [] [Asc UserIdent] :: ReaderT SqlBackend _ [Option UserIdent])
userList = fmap mkOptionList . runDB $ withReaderT projectBackend (map toOption <$> selectList [UserId <=. UserKey 12] [Asc UserIdent] :: ReaderT SqlBackend _ [Option UserIdent])
toOption (Entity _ User{..}) = Option userDisplayName userIdent (CI.original userIdent)
apDummy :: Text

1
src/CryptoID.hs
View File

@ -59,6 +59,7 @@ decCryptoIDs [ ''SubmissionId
, ''MaterialFileId
, ''PrintJobId
, ''QualificationId
, ''SentMailId
]
decCryptoIDKeySize

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

@ -128,4 +128,4 @@ instance Swagger.ToSchema s => Swagger.ToSchema (CI s) where
instance (CI.FoldCase s, Binary s) => Binary (CI s) where
get = CI.mk <$> Binary.get
put = Binary.put . CI.original
put = Binary.put . CI.original

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

@ -15,6 +15,7 @@ module Database.Esqueleto.Utils
, (=?.), (?=.)
, (=~.), (~=.)
, (>~.), (<~.)
, (~.), (~*.), (!~.), (!~*.)
, or, and
, any, all
, not__, parens
@ -26,12 +27,14 @@ module Database.Esqueleto.Utils
, mkContainsFilterWithSet, mkContainsFilterWithComma, mkContainsFilterWithCommaPlus
, mkDayFilter, mkDayFilterFrom, mkDayFilterTo
, mkExistsFilter, mkExistsFilterWithComma
-- , mkRegExFilterWith
, anyFilter, allFilter
, ascNullsFirst, descNullsLast
, orderByList
, orderByOrd, orderByEnum
, strip, lower, ciEq
, selectExists, selectNotExists
, filterExists
, SqlHashable
, sha256
, isTrue, isFalse
@ -41,16 +44,18 @@ module Database.Esqueleto.Utils
, greatest, least
, abs
, SqlProject(..)
, (->.), (->>.), (#>>.)
, (->.), (->>.), (->>>.), (#>>.)
, fromSqlKey
, unKey
, subSelectCountDistinct
, selectCountRows, selectCountDistinct
, selectMaybe
, num2text
, str2text, str2text'
, num2text --, text2num
, day, day', dayMaybe, interval, diffDays, diffTimes
, exprLift
, explicitUnsafeCoerceSqlExprValue
, psqlVersion_
, truncateTable
, module Database.Esqueleto.Utils.TH
) where
@ -61,12 +66,16 @@ import qualified Data.Set as Set
import qualified Data.List as List
import qualified Data.Foldable as F
import Data.List.NonEmpty (NonEmpty(..))
import qualified Database.Persist as P
import qualified Database.Persist.EntityDef.Internal as P (entityDB)
import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.Experimental as Ex
import qualified Database.Esqueleto.PostgreSQL as E
import qualified Database.Esqueleto.Internal.Internal as E
import Database.Esqueleto.Utils.TH
-- import qualified Database.Persist.Postgresql as P
import qualified Data.Text as Text
import qualified Data.Text.Lazy as Lazy (Text)
import qualified Data.ByteString.Lazy as Lazy (ByteString)
@ -156,6 +165,24 @@ infixl 4 <~.
(<~.) :: PersistField typ => E.SqlExpr (E.Value typ) -> E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool)
(<~.) a b = E.isNothing b E.||. (E.just a E.<. b)
infixr 2 ~., ~*., !~., !~*.
-- | PostgreSQL regular expression match, case sensitive. Works, but may throw SQL error for unblanced parenthesis, etc. Not suitable for dbTable filters
(~.) :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value Bool)
(~.) = E.unsafeSqlBinOp " ~ "
-- | PostgreSQL regular expression match, case insensitive. Works, but may throw SQL errors
(~*.) :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value Bool)
(~*.) = E.unsafeSqlBinOp " ~* "
-- | PostgreSQL regular expression does not match, case sensitive. Works, but may throw SQL error for unblanced parenthesis, etc. Not suitable for dbTable filters
(!~.) :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value Bool)
(!~.) = E.unsafeSqlBinOp " !~ "
-- | PostgreSQL regular expression does not match, case insensitive. Works, but may throw SQL errors
(!~*.) :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value Bool)
(!~*.) = E.unsafeSqlBinOp " !~* "
-- | Negation of `isNothing` which is missing
isJust :: PersistField typ => E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool)
@ -322,7 +349,7 @@ mkExactFilterLastWith :: (PersistField b)
-> Last a -- ^ needle
-> E.SqlExpr (E.Value Bool)
mkExactFilterLastWith cast lenslike row criterias
| Last (Just crit) <- criterias = lenslike row E.==. E.val (cast crit)
| Last (Just crit) <- criterias = lenslike row E.==. E.val (cast crit)
| otherwise = true
-- | like `mkExactFilterLast` but deals with Nothing being a filter criterion as well
@ -351,7 +378,7 @@ mkExactFilterMaybeLast' lensexists lenslike row criterias
-- | generic filter creation for dbTable
-- Given a lens-like function, make filter searching for needles in String-like elements
-- (Keep Set here to ensure that there are no duplicates)
mkContainsFilter :: E.SqlString a
mkContainsFilter :: (E.SqlString a, Ord a)
=> (t -> E.SqlExpr (E.Value a)) -- ^ getter from query to searched element
-> t -- ^ query row
-> Set.Set a -- ^ needle collection
@ -359,7 +386,7 @@ mkContainsFilter :: E.SqlString a
mkContainsFilter = mkContainsFilterWith id
-- | like `mkContainsFilter` but allows for conversion; convenient in conjunction with `anyFilter` and `allFilter`
mkContainsFilterWith :: E.SqlString b
mkContainsFilterWith :: (E.SqlString b, Ord a)
=> (a -> b)
-> (t -> E.SqlExpr (E.Value b)) -- ^ getter from query to searched element
-> t -- ^ query row
@ -367,7 +394,7 @@ mkContainsFilterWith :: E.SqlString b
-> E.SqlExpr (E.Value Bool)
mkContainsFilterWith cast lenslike row criterias
| Set.null criterias = true
| otherwise = any (hasInfix $ lenslike row) (E.val . cast <$> Set.toList criterias)
| otherwise = any (hasInfix (lenslike row) . E.val . cast) criterias
-- | like `mkContainsFilterWith` but allows conversion to produce multiple needles
mkContainsFilterWithSet :: (E.SqlString b, Ord b, Ord a)
@ -378,7 +405,7 @@ mkContainsFilterWithSet :: (E.SqlString b, Ord b, Ord a)
-> E.SqlExpr (E.Value Bool)
mkContainsFilterWithSet cast lenslike row criterias
| Set.null criterias = true
| otherwise = any (hasInfix $ lenslike row) (E.val <$> Set.toList (foldMap cast criterias))
| otherwise = any (hasInfix (lenslike row) . E.val) (foldMap cast criterias)
-- | like `mkContainsFilterWithSet` but fixed to comma separated Texts
mkContainsFilterWithComma :: (E.SqlString b, Ord b)
@ -389,7 +416,7 @@ mkContainsFilterWithComma :: (E.SqlString b, Ord b)
-> E.SqlExpr (E.Value Bool)
mkContainsFilterWithComma cast lenslike row (foldMap commaSeparatedText -> criterias)
| Set.null criterias = true
| otherwise = any (hasInfix $ lenslike row) (E.val . cast <$> Set.toList criterias)
| otherwise = any (hasInfix (lenslike row) . E.val . cast) criterias
-- | like `mkContainsFilterWithComma` but enforced the existence of all Texts prefixed with +
mkContainsFilterWithCommaPlus :: (E.SqlString b, Ord b)
@ -403,10 +430,22 @@ mkContainsFilterWithCommaPlus cast lenslike row (foldMap commaSeparatedText -> c
| Set.null compulsories = cond_optional
| Set.null alternatives = cond_compulsory
| otherwise = cond_compulsory E.&&. cond_optional
where
where
(Set.mapMonotonic (Text.stripStart . Text.drop 1) -> compulsories, alternatives) = Set.partition (Text.isPrefixOf "+") criterias
cond_compulsory = all (hasInfix $ lenslike row) (E.val . cast <$> Set.toList compulsories)
cond_optional = any (hasInfix $ lenslike row) (E.val . cast <$> Set.toList alternatives)
cond_compulsory = all (hasInfix (lenslike row) . E.val . cast) compulsories
cond_optional = any (hasInfix (lenslike row) . E.val . cast) alternatives
-- like `mkContainsFilterWith` but allows regular expression criterias
-- This works, but throws SQL errors for unbalanced parenthesis and similar invalid regex expressions
-- mkRegExFilterWith :: (E.SqlString b, Ord a)
-- => (a -> b)
-- -> (t -> E.SqlExpr (E.Value b)) -- ^ getter from query to searched element
-- -> t -- ^ query row
-- -> Set.Set a -- ^ needle collection
-- -> E.SqlExpr (E.Value Bool)
-- mkRegExFilterWith cast lenslike row criterias
-- | Set.null criterias = true
-- | otherwise = any ((~.) (lenslike row) . E.val . cast) criterias
mkDayFilter :: (t -> E.SqlExpr (E.Value UTCTime)) -- ^ getter from query to searched element
-> t -- ^ query row
@ -451,7 +490,7 @@ mkExistsFilterWithComma :: PathPiece a
-> E.SqlExpr (E.Value Bool)
mkExistsFilterWithComma cast query row (foldMap commaSeparatedText -> criterias)
| Set.null criterias = true
| otherwise = any (E.exists . query row) (cast <$> Set.toList criterias)
| otherwise = any (E.exists . query row . cast) criterias
-- | Combine several filters, using logical or
@ -510,6 +549,13 @@ selectExists query = do
_other -> error "SELECT EXISTS ... returned zero or more than one rows"
selectNotExists = fmap not . selectExists
filterExists :: (MonadIO m, PersistEntity val, MonoFoldable mono, PersistField (Element mono))
=> EntityField val (Element mono) -> mono -> E.SqlReadT m [Element mono]
filterExists prj vs = fmap (fmap Ex.unValue) <$> Ex.select $ do
ent <- Ex.from Ex.table
Ex.where_ $ ent Ex.^. prj `Ex.in_` vals vs
return $ ent Ex.^. prj
class SqlHashable a
instance SqlHashable Text
@ -603,7 +649,7 @@ max, min :: PersistField a
max a b = bool a b $ b E.>. a
min a b = bool a b $ b E.<. a
-- these alternatives for max/min ought to be more efficient; note that NULL is avoided by PostgreSQL greatest/least
-- these alternatives for max/min ought to be more efficient; note that NULL is avoided by PostgreSQL greatest/least; for Bool: t > f
greatest :: PersistField a => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a)
greatest a b = E.unsafeSqlFunction "GREATEST" $ E.toArgList (a,b)
@ -642,9 +688,16 @@ infixl 8 ->.
infixl 8 ->>.
-- Unsafe variant, see Database.Esqueleto.PostgreSQL.JSON for a safe version!
(->>.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value Text)
(->>.) expr t = E.unsafeSqlBinOp "->>" expr $ E.val t
infixl 8 ->>>.
-- Unsafe variant to obtain a DB key from a JSON field. Use with caution!
(->>>.) :: (PersistField (Key entity)) => E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value (Maybe (Key entity)))
(->>>.) expr t = E.unsafeSqlCastAs "int" $ E.unsafeSqlBinOp "->>" expr $ E.val t
infixl 8 #>>.
(#>>.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value (Maybe Text))
@ -663,7 +716,7 @@ unKey = E.veryUnsafeCoerceSqlExprValue
-- | distinct version of `Database.Esqueleto.subSelectCount`
subSelectCountDistinct :: (Num a, PersistField a) => Ex.SqlQuery (Ex.SqlExpr (Ex.Value typ)) -> Ex.SqlExpr (Ex.Value a)
subSelectCountDistinct query = Ex.subSelectUnsafe (Ex.countDistinct <$> query)
-- PersistField a => SqlQuery (SqlExpr (Value a)) -> SqlExpr (Value a)
-- countDistinct :: Num a => SqlExpr (Value typ) -> SqlExpr (Value a)
@ -685,13 +738,25 @@ selectCountDistinct q = do
_other
-> error "E.countDistinct did not return exactly one result"
selectMaybe :: (E.SqlSelect a r, MonadIO m) => E.SqlQuery a -> E.SqlReadT m (Maybe r)
selectMaybe = fmap listToMaybe . E.select . (<* E.limit 1)
-- DEPRECATED: use Database.Esqueleto.selectOne instead
-- selectMaybe :: (E.SqlSelect a r, MonadIO m) => E.SqlQuery a -> E.SqlReadT m (Maybe r)
-- selectMaybe = fmap listToMaybe . E.select . (<* E.limit 1)
-- | convert something that is like a text to text
str2text :: E.SqlString a => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value Text)
str2text = E.unsafeSqlCastAs "text"
str2text' :: E.SqlString a => E.SqlExpr (E.Value (Maybe a)) -> E.SqlExpr (E.Value (Maybe Text))
str2text' = E.unsafeSqlCastAs "text"
-- | cast numeric type to text, which is safe and allows for an inefficient but safe comparison of numbers stored as text and numbers
num2text :: Num n => E.SqlExpr (E.Value n) -> E.SqlExpr (E.Value Text)
num2text = E.unsafeSqlCastAs "text"
-- unsafe, use with care!
-- text2num :: E.SqlExpr (E.Value Text) -> E.SqlExpr (E.Value n)
-- text2num = E.unsafeSqlCastAs "int"
day :: E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Day)
day = E.unsafeSqlCastAs "date"
@ -703,9 +768,9 @@ dayMaybe :: E.SqlExpr (E.Value (Maybe UTCTime)) -> E.SqlExpr (E.Value (Maybe Day
dayMaybe = E.unsafeSqlCastAs "date"
interval :: CalendarDiffDays -> E.SqlExpr (E.Value Day) -- E.+=. requires both types to be the same, so we use Day
-- interval _ = E.unsafeSqlCastAs "interval" $ E.unsafeSqlValue "'P2Y'" -- tested working example
-- interval _ = E.unsafeSqlCastAs "interval" $ E.unsafeSqlValue "'P2Y'" -- tested working example
interval = E.unsafeSqlCastAs "interval". E.unsafeSqlValue . wrapSqlString . Text.Builder.fromString . iso8601Show
where
where
singleQuote = Text.Builder.singleton '\''
wrapSqlString b = singleQuote <> b <> singleQuote
@ -750,3 +815,16 @@ instance (PersistField a1, PersistField a2, PersistField b, Finite a1, Finite a2
]
(E.else_ $ E.else_ $ E.veryUnsafeCoerceSqlExprValue (E.nothing :: E.SqlExpr (E.Value (Maybe ()))))
psqlVersion_ :: E.SqlExpr (E.Value Text)
psqlVersion_ = E.unsafeSqlFunction "VERSION" ()
-- Suspected to cause trouble. Needs more testing!
-- truncateTable :: (MonadIO m, BackendCompatible SqlBackend backend, PersistEntity record)
-- => record -> ReaderT backend m ()
-- truncateTable tbl = E.rawExecute ("TRUNCATE TABLE " <> P.tableName tbl <> " RESTART IDENTITY") []
truncateTable :: (MonadIO m, BackendCompatible SqlBackend backend, PersistEntity record) -- TODO: test this code
=> proxy record -> ReaderT backend m ()
truncateTable tbl =
let tblName :: Text = P.unEntityNameDB $ P.entityDB $ P.entityDef tbl
in E.rawExecute ("TRUNCATE TABLE " <> tblName <> " RESTART IDENTITY") []

29
src/Database/Esqueleto/Utils/TH.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
@ -9,7 +9,7 @@ module Database.Esqueleto.Utils.TH
, sqlInTuple, sqlInTuples
, _unValue
, unValueN, unValueNIs
, sqlIJproj, sqlLOJproj, sqlFOJproj
, sqlIJproj, sqlLOJproj, sqlFOJproj, sqlMIXproj, sqlMIXproj'
) where
import ClassyPrelude
@ -26,6 +26,9 @@ import Data.List (foldr1, foldl)
import Utils.TH
import Control.Lens.Iso (Iso', iso)
{-# ANN module ("HLint: ignore Redundant bracket"::String) #-}
class E.SqlSelect a r => SqlIn a r | a -> r, r -> a where
sqlIn :: a -> [r] -> E.SqlExpr (E.Value Bool)
@ -99,7 +102,7 @@ unValueNIs arity uvIdx = do
-- | Generic projections for InnerJoin-tuples
-- gives I-th element of N-tuple of left-associative InnerJoin-pairs, i.e.
--
-- > $(projN n m) :: (t1 `E.InnerJoin` .. `E.InnerJoin` tn) -> tm@ (for m<=n)
-- > $(sqlIJproj n m) :: (t1 `E.InnerJoin` .. `E.InnerJoin` tn) -> tm@ (for m<=n)
sqlIJproj :: Int -> Int -> ExpQ
sqlIJproj = leftAssociativePairProjection 'E.InnerJoin
@ -108,3 +111,23 @@ sqlLOJproj = leftAssociativePairProjection 'E.LeftOuterJoin
sqlFOJproj :: Int -> Int -> ExpQ
sqlFOJproj = leftAssociativePairProjection 'E.FullOuterJoin
-- | Generic projections for Join-tuple
-- gives i-th element of n-tuple of left-associative join pairs, i.e.
--
-- > $(sqlMIXproj "IR" 3) :: ((t1 `E.InnerJoin` t2) `E.RightOuterJoin` t3) -> t3
sqlMIXproj :: String -> Int -> ExpQ
sqlMIXproj = leftAssociativeProjection . map decodeJoin
where
decodeJoin 'I' = 'E.InnerJoin
decodeJoin 'L' = 'E.LeftOuterJoin
decodeJoin 'R' = 'E.RightOuterJoin
decodeJoin 'F' = 'E.FullOuterJoin
decodeJoin 'O' = 'E.FullOuterJoin
decodeJoin 'X' = 'E.CrossJoin
decodeJoin 'C' = 'E.CrossJoin
decodeJoin c = error $ "Database.Esqueleto.Utils.TH.sqlMIXproj: received unknown SQL join kind \"" ++ c:"\"" -- always raised at compile time, so this is ok
-- Alternative using `reify`; works, but may require `$(return [])` between type definition and call to workaround ghc staging problems
sqlMIXproj' :: Name -> Int -> ExpQ
sqlMIXproj' t i = extractConstructorNames t >>= flip leftAssociativeProjection i

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

@ -27,7 +27,7 @@ instance Hashable LiteralType
instance Binary LiteralType
instance NFData LiteralType
deriving instance Generic PersistValue
instance Hashable PersistValue

32
src/Foundation/Authorization.hs
View File

@ -38,7 +38,7 @@ import Handler.Utils.I18n
import Handler.Utils.Routes
import Utils.Course (courseIsVisible)
import Utils.Metrics (observeAuthTagEvaluation, AuthTagEvalOutcome(..))
import qualified Data.Set as Set
import qualified Data.Aeson as JSON
import qualified Data.HashSet as HashSet
@ -95,7 +95,7 @@ instance Exception InvalidAuthTag
type AuthTagsEval m = AuthDNF -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> WriterT (Set AuthTag) m AuthResult
data AccessPredicate
= APPure (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Reader MsgRenderer AuthResult)
| APHandler (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> HandlerFor UniWorX AuthResult)
@ -174,7 +174,7 @@ cacheAPDB mExp k mkV cont = APBindDB $ \mAuthId route isWrite -> do
v <- mkV
memcachedBySet mExp k v
either (return . Left) (fmap Right . lift) $ cont mAuthId route isWrite v
-- cacheAP' :: ( Binary k
-- , Typeable v, Binary v
-- )
@ -185,7 +185,7 @@ cacheAPDB mExp k mkV cont = APBindDB $ \mAuthId route isWrite -> do
-- cacheAP' mExp mkKV cont = APBind $ \mAuthId route isWrite -> case mkKV mAuthId route isWrite of
-- Just (k, mkV) -> either (return . Left) (fmap Right) . cont mAuthId route isWrite . Just =<< memcachedBy mExp k mkV
-- Nothing -> either (return . Left) (fmap Right) $ cont mAuthId route isWrite Nothing
cacheAPDB' :: ( Binary k
, Typeable v, Binary v, NFData v
)
@ -313,7 +313,8 @@ isDryRunDB = fmap unIsDryRun . cached . fmap MkIsDryRun $ orM
dnf <- throwLeft $ routeAuthTags currentRoute
let eval :: forall m''. MonadAP m'' => AuthTagsEval m''
eval dnf' mAuthId' route' isWrite' = evalAuthTags 'isDryRun (AuthTagActive $ const True) eval (noTokenAuth dnf') mAuthId' route' isWrite'
-- eval dnf' mAuthId' route' isWrite' = evalAuthTags 'isDryRun (AuthTagActive $ const True) eval (noTokenAuth dnf') mAuthId' route' isWrite'
eval dnf' = evalAuthTags 'isDryRun (AuthTagActive $ const True) eval (noTokenAuth dnf')
in guardAuthResult <=< evalWriterT $ eval dnf mAuthId currentRoute isWrite
return False
@ -368,7 +369,8 @@ validateBearer mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo val
noTokenAuth = over _dnfTerms . Set.filter . noneOf (re _nullable . folded) $ (== AuthToken) . plVar
eval :: forall m'. MonadAP m' => AuthTagsEval m'
eval dnf' mAuthId'' route'' isWrite'' = evalAuthTags 'validateBearer (AuthTagActive $ const True) eval (noTokenAuth dnf') mAuthId'' route'' isWrite''
-- eval dnf' mAuthId'' route'' isWrite'' = evalAuthTags 'validateBearer (AuthTagActive $ const True) eval (noTokenAuth dnf') mAuthId'' route'' isWrite''
eval dnf' = evalAuthTags 'validateBearer (AuthTagActive $ const True) eval (noTokenAuth dnf')
bearerAuthority' <- hoist apRunDB $ do
bearerAuthority' <- flip foldMapM bearerAuthority $ \case
@ -538,14 +540,14 @@ tagAccessPredicate AuthAdmin = cacheAPSchoolFunction SchoolAdmin (Just $ Right d
guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin)
return Authorized
tagAccessPredicate AuthSupervisor = APDB $ \_ _ mAuthId route _ -> case route of
tagAccessPredicate AuthSupervisor = APDB $ \_ _ mAuthId route _ -> case route of
ForProfileR cID -> checkSupervisor (mAuthId, cID)
ForProfileDataR cID -> checkSupervisor (mAuthId, cID)
FirmAllR -> checkAnySupervisor mAuthId
FirmUsersR fsh -> checkCompanySupervisor (mAuthId, fsh)
FirmSupersR fsh -> checkCompanySupervisor (mAuthId, fsh)
r -> $unsupportedAuthPredicate AuthSupervisor r
where
r -> $unsupportedAuthPredicate AuthSupervisor r
where
checkSupervisor sup@(mAuthId, cID) = $cachedHereBinary sup . exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
uid <- decrypt cID
@ -553,13 +555,13 @@ tagAccessPredicate AuthSupervisor = APDB $ \_ _ mAuthId route _ -> case route of
guardMExceptT isSupervisor (unauthorizedI MsgUnauthorizedSupervisor)
return Authorized
checkCompanySupervisor sup@(mAuthId, fsh) = $cachedHereBinary sup . exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
-- isSupervisor <- lift . existsBy $ UniqueUserCompany authId $ CompanyKey fsh
isSupervisor <- lift $ exists [UserCompanyUser ==. authId, UserCompanyCompany ==. CompanyKey fsh, UserCompanySupervisor ==. True]
guardMExceptT isSupervisor (unauthorizedI $ MsgUnauthorizedCompanySupervisor fsh)
return Authorized
checkAnySupervisor mAuthId = $cachedHereBinary mAuthId . exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
isSupervisor <- lift $ exists [UserSupervisorSupervisor ==. authId]
guardMExceptT isSupervisor (unauthorizedI MsgUnauthorizedAnySupervisor)
return Authorized
@ -692,7 +694,7 @@ tagAccessPredicate AuthLecturer = cacheAPDB' (Just $ Right diffMinute) mkLecture
_ | is _Nothing mAuthId' -> return AuthenticationRequired
CourseR{} -> unauthorizedI MsgUnauthorizedLecturer
EExamR{} -> unauthorizedI MsgUnauthorizedExternalExamLecturer
_other -> unauthorizedI MsgUnauthorizedSchoolLecturer
_other -> unauthorizedI MsgUnauthorizedSchoolLecturer
| otherwise -> Left $ APDB $ \_ _ mAuthId route _ -> case route of
CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
@ -722,7 +724,7 @@ tagAccessPredicate AuthLecturer = cacheAPDB' (Just $ Right diffMinute) mkLecture
return Authorized
where
mkLecturerList _ route _ = case route of
CourseR{} -> cacheLecturerList
CourseR{} -> cacheLecturerList
EExamR{} -> Just
( AuthCacheExternalExamStaffList
, fmap (setOf $ folded . _Value) . E.select . E.from $ return . (E.^. ExternalExamStaffUser)
@ -1199,7 +1201,7 @@ tagAccessPredicate AuthExamRegistered = APDB $ \_ _ mAuthId route _ -> case rout
guardMExceptT hasRegistration $ unauthorizedI MsgUnauthorizedRegisteredExam
return Authorized
CSheetR tid ssh csh shn _ -> exceptT return return $ do
requiredExam' <- $cachedHereBinary (tid, ssh, csh, shn) . lift . E.selectMaybe . E.from $ \(course `E.InnerJoin` sheet) -> do
requiredExam' <- $cachedHereBinary (tid, ssh, csh, shn) . lift . E.selectOne . E.from $ \(course `E.InnerJoin` sheet) -> do
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
E.where_ $ course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
@ -1700,7 +1702,7 @@ evalAccessWith :: (HasCallStack, MonadThrow m, MonadAP m) => [(AuthTag, Bool)] -
evalAccessWith assumptions route isWrite = do
mAuthId <- liftHandler maybeAuthId
evalAccessWithFor assumptions mAuthId route isWrite
evalAccessWithDB :: (HasCallStack, MonadThrow m, MonadAP m, BackendCompatible SqlReadBackend backend) => [(AuthTag, Bool)] -> Route UniWorX -> Bool -> ReaderT backend m AuthResult
evalAccessWithDB = evalAccessWith

86
src/Foundation/I18n.hs
View File

@ -8,7 +8,7 @@
-- 3. add constructor to list of module exports
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-unused-top-binds #-}
module Foundation.I18n
( appLanguages, appLanguagesOpts
@ -39,7 +39,7 @@ module Foundation.I18n
, StudyDegreeTerm(..)
, ShortStudyFieldType(..)
, StudyDegreeTermType(..)
, ErrorResponseTitle(..)
, ErrorResponseTitle(..)
, UniWorXMessages(..)
, uniworxMessages
, unRenderMessage, unRenderMessage', unRenderMessageLenient
@ -87,21 +87,30 @@ pluralDE num singularForm pluralForm
| num == 1 = singularForm
| otherwise = pluralForm
-- pluralDEx :: (Eq a, Num a) => Char -> a -> Text -> Text
-- -- ^ @pluralENs n "Monat" = pluralEN n "Monat" "Monate"@
-- pluralDEx c n t = pluralDE n t $ t `snoc` c
pluralDEx :: (Eq a, Num a) => Char -> a -> Text -> Text
pluralDEx c n t = pluralDE n t $ t `snoc` c
-- -- | like `pluralDEe` but also prefixes with the number
-- pluralDExN :: (Eq a, Num a, Show a) => Char -> a -> Text -> Text
-- pluralDExN c n t = tshow n <> cons ' ' (pluralDEx c n t)
-- | like `pluralDEx` but also prefixes with the number
pluralDExN :: (Eq a, Num a, Show a) => Char -> a -> Text -> Text
pluralDExN c n t = tshow n <> cons ' ' (pluralDEx c n t)
pluralDEe :: (Eq a, Num a) => a -> Text -> Text
-- ^ @pluralENs n "Monat" = pluralEN n "Monat" "Monate"@
pluralDEe n t = pluralDE n t $ t `snoc` 'e'
-- ^ @pluralDEe n "Monat" = pluralDEe n "Monat" "Monate"@
pluralDEe = pluralDEx 'e'
-- | like `pluralDEe` but also prefixes with the number
pluralDEeN :: (Eq a, Num a, Show a) => a -> Text -> Text
pluralDEeN n t = tshow n <> cons ' ' (pluralDEe n t)
pluralDEeN = pluralDExN 'e'
-- | postfix plural with an 'n'
pluralDEn :: (Eq a, Num a) => a -> Text -> Text
-- ^ @pluralENs n "Monat" = pluralEN n "Monat" "Monate"@
pluralDEn = pluralDEx 'n'
-- | like `pluralDEn` but also prefixes with the number
pluralDEnN :: (Eq a, Num a, Show a) => a -> Text -> Text
pluralDEnN = pluralDExN 'n'
noneOneMoreDE :: (Eq a, Num a)
=> a -- ^ Count
@ -114,14 +123,14 @@ noneOneMoreDE num noneText singularForm pluralForm
| num == 1 = singularForm
| otherwise = pluralForm
-- noneMoreDE :: (Eq a, Num a)
-- => a -- ^ Count
-- -> Text -- ^ None
-- -> Text -- ^ Some
-- -> Text
-- noneMoreDE num noneText someText
-- | num == 0 = noneText
-- | otherwise = someText
noneMoreDE :: (Eq a, Num a)
=> a -- ^ Count
-> Text -- ^ None
-> Text -- ^ Some
-> Text
noneMoreDE num noneText someText
| num == 0 = noneText
| otherwise = someText
pluralEN :: (Eq a, Num a)
=> a -- ^ Count
@ -136,7 +145,7 @@ pluralENs :: (Eq a, Num a)
=> a -- ^ Count
-> Text -- ^ Singular
-> Text
-- ^ @pluralENs n "foo" = pluralEN n "foo" "foos"@
-- ^ @pluralENs n "foo" = pluralEN n "foo" "foos"@
pluralENs n t = pluralEN n t $ t `snoc` 's'
-- | like `pluralENs` but also prefixes with the number
@ -154,14 +163,14 @@ noneOneMoreEN num noneText singularForm pluralForm
| num == 1 = singularForm
| otherwise = pluralForm
-- noneMoreEN :: (Eq a, Num a)
-- => a -- ^ Count
-- -> Text -- ^ None
-- -> Text -- ^ Some
-- -> Text
-- noneMoreEN num noneText someText
-- | num == 0 = noneText
-- | otherwise = someText
noneMoreEN :: (Eq a, Num a)
=> a -- ^ Count
-> Text -- ^ None
-> Text -- ^ Some
-> Text
noneMoreEN num noneText someText
| num == 0 = noneText
| otherwise = someText
_ordinalEN :: ToMessage a
=> a
@ -181,20 +190,20 @@ notEN :: Bool -> Text
notEN = bool "not" ""
{- -- TODO: use this is message eventually
-- Commonly used plurals
-- Commonly used plurals
data Thing = Person | Examinee
deriving (Eq)
thingDE :: Int -> Thing -> Text
thingDE :: Int -> Thing -> Text
thingDE num = (tshow num <>) . Text.cons ' ' . thing
where
where
thing :: Thing -> Text
thing Person = pluralDE num "Person" "Personen"
thing Examinee = pluralDE num "Prüfling" "Prüflinge"
thingEN :: Int -> Thing -> Text
thingEN :: Int -> Thing -> Text
thingEN num t = tshow num <> Text.cons ' ' (thing t)
where
where
thing :: Thing -> Text
thing Person = pluralENs num "person"
thing Examinee = pluralENs num "examinee"
@ -210,6 +219,9 @@ maybeBoolMessage Nothing n _ _ = n
maybeBoolMessage (Just True) _ t _ = t
maybeBoolMessage (Just False) _ _ f = f
-- | Convenience function avoiding type signatures
boolText :: Text -> Text -> Bool -> Text
boolText = bool
newtype ShortTermIdentifier = ShortTermIdentifier TermIdentifier
deriving stock (Eq, Ord, Read, Show)
@ -269,7 +281,7 @@ mkMessageAddition ''UniWorX "Avs" "messages/uniworx/categories/avs" "de-de-forma
embedRenderMessage ''UniWorX ''LmsStatus (uncurry ((<>) . (<> "Status")) . Text.splitAt 3)
newtype SomeMessages master = SomeMessages [SomeMessage master]
newtype SomeMessages master = SomeMessages [SomeMessage master]
deriving newtype (Semigroup, Monoid)
instance master ~ master' => RenderMessage master (SomeMessages master') where
@ -602,12 +614,12 @@ unRenderMessage = unRenderMessage' (==)
unRenderMessageLenient :: forall a master. (Ord a, Finite a, RenderMessage master a) => master -> Text -> [a]
unRenderMessageLenient = unRenderMessage' cmp
where cmp = (==) `on` mk . under packed (filter Char.isAlphaNum . concatMap unidecode)
where cmp = (==) `on` mk . under packed (concatMap $ filter Char.isAlphaNum . unidecode)
instance Default DateTimeFormatter where
def = mkDateTimeFormatter (getTimeLocale' []) def appTZ
instance RenderMessage UniWorX Address where
instance RenderMessage UniWorX Address where
renderMessage s l a@Address{addressName = Just aname} = aname <> cons ' ' (renderMessage s l a{addressName=Nothing})
renderMessage _ _ Address{addressEmail = mail} = "<" <> mail <> ">"

142
src/Foundation/Navigation.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
@ -87,9 +87,9 @@ breadcrumb (AdminUserR cID) = useRunDB . maybeT (i18nCrumb MsgBreadcrumbUser $ J
uid <- decrypt cID
User{..} <- MaybeT $ get uid
return (userDisplayName, Just UsersR)
breadcrumb (AdminUserDeleteR cID) = i18nCrumb MsgBreadcrumbUserDelete . Just $ AdminUserR cID
breadcrumb (AdminHijackUserR cID) = i18nCrumb MsgBreadcrumbUserHijack . Just $ AdminUserR cID
breadcrumb (UserNotificationR cID) = useRunDB $ do
breadcrumb (AdminUserDeleteR cID) = i18nCrumb MsgBreadcrumbUserDelete . Just $ AdminUserR cID
breadcrumb (AdminHijackUserR cID) = i18nCrumb MsgBreadcrumbUserHijack . Just $ AdminUserR cID
breadcrumb (UserNotificationR cID) = useRunDB $ do
mayList <- hasReadAccessTo UsersR
if
| mayList
@ -122,6 +122,7 @@ breadcrumb ProblemWithoutAvsId = i18nCrumb MsgProblemsNoAvsIdHeading $ Just
breadcrumb ProblemFbutNoR = i18nCrumb MsgProblemsRWithoutFHeading $ Just AdminProblemsR
breadcrumb ProblemAvsSynchR = i18nCrumb MsgProblemsAvsSynchHeading $ Just AdminProblemsR
breadcrumb ProblemAvsErrorR = i18nCrumb MsgProblemsAvsErrorHeading $ Just AdminProblemsR
breadcrumb ConfigInterfacesR = i18nCrumb MsgConfigInterfacesHeading $ Just AdminProblemsR
breadcrumb FirmAllR = i18nCrumb MsgMenuFirms Nothing
breadcrumb FirmsCommR{} = i18nCrumb MsgMenuFirmsComm $ Just FirmAllR
@ -129,7 +130,13 @@ breadcrumb FirmUsersR{} = i18nCrumb MsgMenuFirmUsers $ Just FirmAll
breadcrumb (FirmSupersR fsh)= i18nCrumb MsgMenuFirmSupervisors $ Just $ FirmUsersR fsh
breadcrumb (FirmCommR fsh)= i18nCrumb MsgMenuFirmsComm $ Just $ FirmUsersR fsh
breadcrumb PrintCenterR = i18nCrumb MsgMenuApc Nothing
breadcrumb CommCenterR = i18nCrumb MsgMenuCommCenter Nothing
breadcrumb MailCenterR = i18nCrumb MsgMenuMailCenter $ Just CommCenterR
breadcrumb MailHtmlR{} = i18nCrumb MsgMenuMailHtml $ Just MailCenterR
breadcrumb MailPlainR{} = i18nCrumb MsgMenuMailPlain $ Just MailCenterR
breadcrumb (MailAttachmentR mid _) = i18nCrumb MsgMenuMailAttachment $ Just $ MailHtmlR mid
breadcrumb PrintCenterR = i18nCrumb MsgMenuApc $ Just CommCenterR
breadcrumb PrintSendR = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR
breadcrumb PrintDownloadR{} = i18nCrumb MsgMenuPrintDownload $ Just PrintCenterR
breadcrumb PrintAckR{} = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR -- never displayed
@ -137,11 +144,15 @@ breadcrumb PrintAckDirectR{}= i18nCrumb MsgMenuPrintAck $ Just PrintCenter
breadcrumb PrintLogR = i18nCrumb MsgMenuPrintLog $ Just PrintCenterR
breadcrumb SchoolListR = i18nCrumb MsgMenuSchoolList $ Just AdminR
breadcrumb (SchoolR ssh sRoute) = case sRoute of
SchoolEditR -> useRunDB . maybeT (i18nCrumb MsgBreadcrumbSchool $ Just SchoolListR) $ do
breadcrumb (SchoolR ssh SchoolEditR) =
useRunDB . maybeT (i18nCrumb MsgBreadcrumbSchool $ Just SchoolListR) $ do
School{..} <- MaybeT $ get ssh
isAdmin <- lift $ hasReadAccessTo SchoolListR
return (CI.original schoolName, bool Nothing (Just SchoolListR) isAdmin)
breadcrumb (SchoolR ssh (SchoolDayR d)) = do
dt <- formatTime SelFormatDate d
mr <- getMessageRender
return (mr $ MsgMenuSchoolDay ssh dt, Just SchoolListR)
breadcrumb SchoolNewR = i18nCrumb MsgMenuSchoolNew $ Just SchoolListR
breadcrumb (ExamOfficeR EOExamsR) = i18nCrumb MsgMenuExamOfficeExams Nothing
@ -930,19 +941,37 @@ pageActions :: ( MonadHandler m
, MonadUnliftIO m
)
=> Route UniWorX -> m [Nav]
pageActions NewsR = return
[ NavPageActionPrimary
{ navLink = NavLink
{ navLabel = MsgMenuOpenCourses
, navRoute = (CourseListR, [("courses-openregistration", toPathPiece True)])
, navAccess' = NavAccessTrue
, navType = NavTypeLink { navModal = False }
, navQuick' = mempty
, navForceActive = False
pageActions NewsR = do
now <- liftIO getCurrentTime
let nowaday = utctDay now
nd <- formatTime SelFormatDate now
schools <- useRunDB $ selectList [] [Asc SchoolShorthand]
return $
( NavPageActionPrimary
{ navLink = NavLink
{ navLabel = MsgMenuOpenCourses
, navRoute = (CourseListR, [("courses-openregistration", toPathPiece True)])
, navAccess' = NavAccessTrue
, navType = NavTypeLink { navModal = False }
, navQuick' = mempty
, navForceActive = False
}
, navChildren = []
}
, navChildren = []
}
]
) :
[ NavPageActionPrimary
{ navLink = NavLink
{ navLabel = MsgMenuSchoolDay ssh nd
, navRoute = SchoolR ssh $ SchoolDayR nowaday
, navAccess' = NavAccessTrue
, navType = NavTypeLink { navModal = False }
, navQuick' = mempty
, navForceActive = False
}
, navChildren = []
}
| sch <- schools, let ssh = sch ^. _entityKey
]
pageActions (CourseR tid ssh csh CShowR) = do
materialListSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh MaterialListR
tutorialListSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh CTutorialListR
@ -1172,6 +1201,13 @@ pageActions SchoolListR = return
, navChildren = []
}
]
pageActions (SchoolR ssh (SchoolDayR nd)) = return
[ NavPageActionPrimary
{ navLink = defNavLink msg $ SchoolR ssh (SchoolDayR $ addDays n nd)
, navChildren = []
}
| (msg, n) <- [(MsgWeekPrev, -7), (MsgDayPrev, -1), (MsgDayNext, 1), (MsgWeekNext, 7)]
]
pageActions UsersR = return
[ NavPageActionPrimary
{ navLink = NavLink
@ -1457,6 +1493,12 @@ pageActions (ForProfileR cID) = return
, navChildren = []
}
]
pageActions (ForProfileDataR cID) = return
[ NavPageActionPrimary
{ navLink = defNavLink MsgAdminUserHeading $ AdminUserR cID
, navChildren = []
}
]
pageActions TermShowR = do
participantsSecondary <- pageQuickActions NavQuickViewPageActionSecondary ParticipantsListR
return
@ -1946,7 +1988,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) = do
{ navLabel = MsgMenuSheetPersonalisedFiles
, navRoute = CSheetR tid ssh csh shn SPersonalFilesR
, navAccess' = NavAccessDB $
let onlyPersonalised = fmap (maybe False $ not . E.unValue) . E.selectMaybe . E.from $ \(sheet `E.InnerJoin` course) -> do
let onlyPersonalised = fmap (maybe False $ not . E.unValue) . E.selectOne . E.from $ \(sheet `E.InnerJoin` course) -> do
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
E.where_$ sheet E.^. SheetName E.==. E.val shn
E.&&. course E.^. CourseTerm E.==. E.val tid
@ -2471,6 +2513,50 @@ pageActions PrintCenterR = do
dayLinks <- mapM toDayAck $ Map.toAscList dayMap
return $ manualSend : printLog : printAck : take 9 dayLinks
pageActions CommCenterR = return
[ NavPageActionPrimary
{ navLink = defNavLink MsgMenuMailCenter MailCenterR
, navChildren = []
}
, NavPageActionPrimary
{ navLink = defNavLink MsgMenuApc PrintCenterR
, navChildren = []
}
]
pageActions (MailHtmlR smid) = do
sid <- decrypt smid
usrNotiSettings <- useRunDB $ runMaybeT $ do
sm <- MaybeT $ get sid
uid <- hoistMaybe $ sentMailRecipient sm
User{userDisplayName} <- MaybeT $ get uid
uuid <- liftHandler $ encrypt uid
return NavPageActionPrimary
{ navLink = defNavLink (MsgNotificationSettingsHeading userDisplayName) $ UserNotificationR uuid
, navChildren = []
}
let linkPlain = NavPageActionPrimary
{ navLink = defNavLink MsgMenuMailPlain $ MailPlainR smid
, navChildren = []
}
return $ msnoc [linkPlain] usrNotiSettings
pageActions (MailPlainR smid) = do
sid <- decrypt smid
usrNotiSettings <- useRunDB $ runMaybeT $ do
sm <- MaybeT $ get sid
uid <- hoistMaybe $ sentMailRecipient sm
User{userDisplayName} <- MaybeT $ get uid
uuid <- liftHandler $ encrypt uid
return NavPageActionPrimary
{ navLink = defNavLink (MsgNotificationSettingsHeading userDisplayName) $ UserNotificationR uuid
, navChildren = []
}
let linkHtml = NavPageActionPrimary
{ navLink = defNavLink MsgMenuMailHtml $ MailHtmlR smid
, navChildren = []
}
return $ msnoc [linkHtml] usrNotiSettings
pageActions AdminCrontabR = return
[ NavPageActionPrimary
{ navLink = defNavLink MsgMenuAdminJobs AdminJobsR
@ -2478,6 +2564,20 @@ pageActions AdminCrontabR = return
}
]
pageActions AdminProblemsR = return
[ NavPageActionPrimary
{ navLink = defNavLink MsgConfigInterfacesHeading ConfigInterfacesR
, navChildren = []
}
, NavPageActionPrimary
{ navLink = defNavLink MsgProblemsAvsSynchHeading ProblemAvsSynchR
, navChildren = []
}
, NavPageActionSecondary
{ navLink = defNavLink MsgProblemsAvsErrorHeading ProblemAvsErrorR
}
]
pageActions _ = return []
submissionList :: ( MonadIO m
@ -2490,7 +2590,7 @@ submissionList tid csh shn uid = withReaderT (projectBackend @SqlReadBackend) .
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val uid
E.&&. sheet E.^. SheetName E.==. E.val shn
E.&&. sheet E.^. SheetName E.==. E.val shn
E.&&. course E.^. CourseShorthand E.==. E.val csh
E.&&. course E.^. CourseTerm E.==. E.val tid

27
src/Foundation/Type.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
@ -11,11 +11,9 @@ module Foundation.Type
, _SessionStorageMemcachedSql, _SessionStorageAcid
, AppMemcached(..)
, _memcachedKey, _memcachedConn
, AppMemcachedLocal(..)
, _memcachedLocalARC
, SMTPPool
, _appSettings', _appStatic, _appConnPool, _appSmtpPool, _appLdapPool, _appWidgetMemcached, _appHttpManager, _appLogger, _appLogSettings, _appCryptoIDKey, _appClusterID, _appInstanceID, _appJobState, _appSessionStore, _appSecretBoxKey, _appJSONWebKeySet, _appHealthReport, _appMemcached, _appUploadCache, _appVerpSecret, _appAuthKey, _appPersonalisedSheetFilesSeedKey, _appVolatileClusterSettingsCache, _appAvsQuery
, DB, Form, MsgRenderer, MailM, DBFile
, DB, DBRead, Form, MsgRenderer, MailM, DBFile
) where
import Import.NoFoundation
@ -32,18 +30,13 @@ import qualified Jose.Jwk as Jose
import qualified Database.Memcached.Binary.IO as Memcached
import Network.Minio (MinioConn)
import Data.IntervalMap.Strict (IntervalMap)
import qualified Utils.Pool as Custom
import Utils.Metrics (DBConnUseState)
import qualified Data.ByteString.Lazy as Lazy
import Data.Time.Clock.POSIX (POSIXTime)
import GHC.Fingerprint (Fingerprint)
import Handler.Sheet.PersonalisedFiles.Types (PersonalisedSheetFilesSeedKey)
import Utils.Avs (AvsQuery)
import Utils.Avs (AvsQuery())
type SMTPPool = Pool SMTPConnection
@ -62,13 +55,6 @@ data AppMemcached = AppMemcached
makeLenses_ ''AppMemcached
data AppMemcachedLocal = AppMemcachedLocal
{ memcachedLocalARC :: ARCHandle (Fingerprint, Lazy.ByteString) Int (NFDynamic, Maybe POSIXTime)
, memcachedLocalHandleInvalidations :: Async ()
, memcachedLocalInvalidationQueue :: TVar (Seq (Fingerprint, Lazy.ByteString))
} deriving (Generic)
makeLenses_ ''AppMemcachedLocal
-- | The foundation datatype for your application. This can be a good place to
-- keep settings and values requiring initialization before your application
@ -93,13 +79,9 @@ data UniWorX = UniWorX
, appJSONWebKeySet :: Jose.JwkSet
, appHealthReport :: TVar (Set (UTCTime, HealthReport))
, appMemcached :: Maybe AppMemcached
, appMemcachedLocal :: Maybe AppMemcachedLocal
, appUploadCache :: Maybe MinioConn
, appVerpSecret :: VerpSecret
, appAuthKey :: Auth.Key
, appFileSourceARC :: Maybe (ARCHandle (FileContentChunkReference, (Int, Int)) Int ByteString)
, appFileSourcePrewarm :: Maybe (LRUHandle (FileContentChunkReference, (Int, Int)) UTCTime Int ByteString)
, appFileInjectInhibit :: TVar (IntervalMap UTCTime (Set FileContentReference))
, appPersonalisedSheetFilesSeedKey :: PersonalisedSheetFilesSeedKey
, appVolatileClusterSettingsCache :: TVar VolatileClusterSettingsCache
, appStartTime :: UTCTime -- for Status Page
@ -123,8 +105,9 @@ instance HasCookieSettings RegisteredCookie UniWorX where
instance (MonadHandler m, HandlerSite m ~ UniWorX) => ReadLogSettings m where
readLogSettings = liftIO . readTVarIO =<< getsYesod (view _appLogSettings)
type DB = YesodDB UniWorX
type DBRead = ReaderT SqlReadBackend (HandlerFor UniWorX)
type Form x = Html -> MForm (HandlerFor UniWorX) (FormResult x, WidgetFor UniWorX ())
type MsgRenderer = MsgRendererS UniWorX -- see Utils
type MailM a = MailT (HandlerFor UniWorX) a

33
src/Foundation/Yesod/Auth.hs
View File

@ -107,7 +107,7 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
| not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ]
_other -> return res
$logDebugS "auth" $ tshow Creds{..}
$logDebugS "auth" $ tshow Creds{..}
ldapPool' <- getsYesod $ view _appLdapPool
flip catches excHandlers $ case ldapPool' of
@ -153,9 +153,9 @@ _upsertCampusUserMode mMode cs@Creds{..}
defaultOther = apHash
ldapLookupAndUpsert :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadMask m, MonadUnliftIO m) => Text -> SqlPersistT m (Entity User)
ldapLookupAndUpsert ident =
getsYesod (view _appLdapPool) >>= \case
ldapLookupAndUpsert :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadMask m, MonadUnliftIO m) => Text -> SqlPersistT m (Entity User)
ldapLookupAndUpsert ident =
getsYesod (view _appLdapPool) >>= \case
Nothing -> throwM $ CampusUserLdapError $ LdapHostNotResolved "No LDAP configuration in Foundation."
Just ldapPool ->
campusUser'' ldapPool campusUserFailoverMode ident >>= \case
@ -182,22 +182,21 @@ upsertCampusUser upsertMode ldapData = do
userDefaultConf <- getsYesod $ view _appUserDefaults
(newUser,userUpdate) <- decodeUser now userDefaultConf upsertMode ldapData
--TODO: newUser should be associated with a company and company supervisor through Handler.Utils.Company.upsertUserCompany, but this is called by upsertAvsUser already - conflict?
oldUsers <- for (userLdapPrimaryKey newUser) $ \pKey -> selectKeysList [ UserLdapPrimaryKey ==. Just pKey ] []
user@(Entity userId userRec) <- case oldUsers of
Just [oldUserId] -> updateGetEntity oldUserId userUpdate
_other -> upsertBy (UniqueAuthentication (newUser ^. _userIdent)) newUser userUpdate
unless (validDisplayName (newUser ^. _userTitle)
unless (validDisplayName (newUser ^. _userTitle)
(newUser ^. _userFirstName)
(newUser ^. _userSurname)
(newUser ^. _userSurname)
(userRec ^. _userDisplayName)) $
update userId [ UserDisplayName =. (newUser ^. _userDisplayName) ]
when (validEmail' (userRec ^. _userEmail)) $ do
update userId [ UserDisplayName =. (newUser ^. _userDisplayName) ] -- update invalid display names only
when (validEmail' (userRec ^. _userEmail)) $ do -- RECALL: userRec already contains basic updates
let emUps = [ UserDisplayEmail =. (newUser ^. _userEmail) | not (validEmail' (userRec ^. _userDisplayEmail)) ]
++ [ UserAuthentication =. AuthLDAP | is _AuthNoLogin (userRec ^. _userAuthentication) ]
unless (null emUps) $ update userId emUps
update userId emUps -- update already checks whether list is empty
-- Attempt to update ident, too:
unless (validEmail' (userRec ^. _userIdent)) $
void $ maybeCatchAll (update userId [ UserIdent =. (newUser ^. _userEmail) ] >> return (Just ()))
@ -228,10 +227,10 @@ decodeUserTest mbIdent ldapData = do
decodeUser :: (MonadThrow m) => UTCTime -> UserDefaultConf -> UpsertCampusUserMode -> Ldap.AttrList [] -> m (User,_)
decodeUser now UserDefaultConf{..} upsertMode ldapData = do
decodeUser now UserDefaultConf{..} upsertMode ldapData = do
let
userTelephone = decodeLdap ldapUserTelephone
userMobile = decodeLdap ldapUserMobile
userTelephone = decodeLdap ldapUserTelephone <&> canonicalPhone
userMobile = decodeLdap ldapUserMobile <&> canonicalPhone
userCompanyPersonalNumber = decodeLdap ldapUserFraportPersonalnummer
userCompanyDepartment = decodeLdap ldapUserFraportAbteilung
@ -267,7 +266,7 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do
-- -> return $ CI.mk userEmail
| otherwise
-> throwM CampusUserInvalidEmail
userLdapPrimaryKey <- if
| [bs] <- ldapMap !!! ldapPrimaryKey
, Right userLdapPrimaryKey'' <- Text.decodeUtf8' bs
@ -306,13 +305,13 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do
, userPrefersPostal = userDefaultPrefersPostal
, ..
}
userUpdate =
userUpdate =
[ UserLastAuthentication =. Just now | isLogin ] ++
[ UserEmail =. userEmail | validEmail' userEmail ] ++
[
-- UserDisplayName =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 272
-- UserDisplayName =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 191
UserFirstName =. userFirstName
, UserSurname =. userSurname
, UserSurname =. userSurname
, UserLastLdapSynchronisation =. Just now
, UserLdapPrimaryKey =. userLdapPrimaryKey
, UserMobile =. userMobile

296
src/Handler/Admin.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
@ -8,23 +8,29 @@ module Handler.Admin
import Import
import Jobs
-- import Data.Either
import qualified Data.Set as Set
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.Text as Text
-- import qualified Data.Text.Lazy.Encoding as LBS
-- import qualified Control.Monad.Catch as Catch
-- import Servant.Client (ClientError(..), ResponseF(..))
-- import Text.Blaze.Html (preEscapedToHtml)
import Database.Persist.Sql (updateWhereCount)
import Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Experimental as E
import qualified Database.Esqueleto.Legacy as EL (on) -- needed for dbTable
import qualified Database.Esqueleto.Utils as E
import Jobs
import Handler.Utils
import Handler.Utils.Avs
import Handler.Utils.Users
-- import Handler.Utils.Company
import Handler.Health.Interface
import Handler.Users (AllUsersAction(..))
import Handler.Admin.Test as Handler.Admin
import Handler.Admin.ErrorMessage as Handler.Admin
@ -34,11 +40,29 @@ import Handler.Admin.Avs as Handler.Admin
import Handler.Admin.Ldap as Handler.Admin
-- Types and Template Haskell
data ProblemTableAction = ProblemTableMarkSolved
| ProblemTableMarkUnsolved
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
deriving anyclass (Universe, Finite)
nullaryPathPiece ''ProblemTableAction $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''ProblemTableAction id
data ProblemTableActionData = ProblemTableMarkSolvedData
| ProblemTableMarkUnsolvedData -- Placeholder, remove later
deriving (Eq, Ord, Read, Show, Generic)
-- Handlers
getAdminR :: Handler Html
getAdminR = redirect AdminProblemsR
getAdminProblemsR :: Handler Html
getAdminProblemsR = do
getAdminProblemsR, postAdminProblemsR :: Handler Html
getAdminProblemsR = handleAdminProblems Nothing
handleAdminProblems :: Maybe Widget -> Handler Html
handleAdminProblems mbProblemTable = do
now <- liftIO getCurrentTime
let nowaday = utctDay now
cutOffOldDays = 1
@ -50,26 +74,27 @@ getAdminProblemsR = do
msgErrorTooltip <- messageI Error MsgMessageError
let flagError = messageTooltip . bool msgErrorTooltip msgSuccessTooltip
flagWarning = messageTooltip . bool msgWarningTooltip msgSuccessTooltip
flagWarning = messageTooltip . bool msgWarningTooltip msgSuccessTooltip
flagNonZero :: Int -> Widget
flagNonZero n | n <= 0 = flagError True
| otherwise = messageTooltip =<< handlerToWidget (messageI Error (MsgProblemsDriverSynch n))
| otherwise = messageTooltip =<< handlerToWidget (messageI Error (MsgProblemsDriverSynch n))
(usersAreReachable, driversHaveAvsIds, rDriversHaveFs, noStalePrintJobs, noBadAPCids, (interfaceOks, interfaceTable)) <- runDB $ (,,,,,)
<$> areAllUsersReachable
(usersAreReachable, driversHaveAvsIds, rDriversHaveFs, noStalePrintJobs, noBadAPCids, (interfaceOks, interfaceTable)) <- runDB $ (,,,,,)
<$> areAllUsersReachable
<*> allDriversHaveAvsId now
<*> allRDriversHaveFs now
<*> (not <$> exists [PrintJobAcknowledged ==. Nothing, PrintJobCreated <. cutOffOldTime])
<*> (not <$> exists [PrintAcknowledgeProcessed ==. False])
<*> mkInterfaceLogTable flagError mempty
<*> (not <$> exists [PrintAcknowledgeProcessed ==. False])
<*> mkInterfaceLogTable mempty
let interfacesBadNr = length $ filter (not . snd) interfaceOks
-- interfacesOk = all snd interfaceOks
-- interfacesOk = all snd interfaceOks
diffLics <- try retrieveDifferingLicences >>= \case
-- (Left (UnsupportedContentType "text/html" resp)) -> Left $ text2widget "Html received"
(Left e) -> return $ Left $ text2widget $ tshow (e :: SomeException)
(Right AvsLicenceDifferences{..}) -> do
(Right (AvsLicenceDifferences{..},_)) -> do
let problemIds = avsLicenceDiffRevokeAll <> avsLicenceDiffGrantVorfeld <> avsLicenceDiffRevokeRollfeld <> avsLicenceDiffGrantRollfeld
forM_ (take 42 $ Set.toList problemIds) $ queueJob' . flip JobSynchroniseAvsId (Just nowaday)
void $ runDB $ queueAvsUpdateByAID problemIds $ Just nowaday
return $ Right
( Set.size avsLicenceDiffRevokeAll
, Set.size avsLicenceDiffGrantVorfeld
@ -78,7 +103,7 @@ getAdminProblemsR = do
)
-- Attempt to format results in a nicer way failed, since rendering Html within a modal destroyed the page layout itself
-- let procDiffLics (to0, to1, to2) = Right (Set.size to0, Set.size to1, Set.size to2)
-- diffLics <- (procDiffLics <$> retrieveDifferingLicences) `catches`
-- diffLics <- (procDiffLics . fst <$> retrieveDifferingLicences) `catches`
-- [ Catch.Handler (\case (UnsupportedContentType "text/html;charset=utf-8" Response{responseBody})
-- -> return $ Left $ toWidget $ preEscapedToHtml $ fromRight "Response UTF8-decoding error" $ LBS.decodeUtf8' responseBody
-- ex -> return $ Left $ text2widget $ tshow ex)
@ -86,20 +111,63 @@ getAdminProblemsR = do
-- ]
rerouteMail <- getsYesod $ view _appMailRerouteTo
problemLogTable <- maybeM (snd <$> runDB mkProblemLogTable) return $ return mbProblemTable -- formResult only processed in POST-Handler
siteLayoutMsg MsgProblemsHeading $ do
setTitleI MsgProblemsHeading
$(widgetFile "admin-problems")
postAdminProblemsR = do
(problemLogRes, problemLogTable) <- runDB mkProblemLogTable
formResult problemLogRes procProblems
handleAdminProblems $ Just problemLogTable
where
procProblems :: (ProblemTableActionData, Set ProblemLogId) -> Handler ()
procProblems (ProblemTableMarkSolvedData , pids) = actUpdate True pids
procProblems (ProblemTableMarkUnsolvedData, pids) = actUpdate False pids
getProblemUnreachableR :: Handler Html
getProblemUnreachableR = do
actUpdate markdone pids = do
mauid <- maybeAuthId
now <- liftIO getCurrentTime
let (pls_fltr,newv,msg) | markdone = (ProblemLogSolved ==. Nothing, Just now, MsgAdminProblemsSolved)
| otherwise = (ProblemLogSolved !=. Nothing, Nothing , MsgAdminProblemsReopened)
(fromIntegral -> oks) <- runDB $ updateWhereCount [pls_fltr, ProblemLogId <-. toList pids]
[ProblemLogSolved =. newv, ProblemLogSolver =. mauid]
let no_req = Set.size pids
mkind = if oks < no_req || no_req <= 0 then Warning else Success
addMessageI mkind $ msg oks
when (oks > 0) $ reloadKeepGetParams AdminProblemsR -- reload to update all tables
getProblemUnreachableR, postProblemUnreachableR :: Handler Html
getProblemUnreachableR = postProblemUnreachableR
postProblemUnreachableR = do
unreachables <- runDB retrieveUnreachableUsers
-- the following form is a nearly identicaly copy from Handler.Users:
((noreachUsersRes, noreachUsersWgt'), noreachUsersEnctype) <- runFormPost . identifyForm FIDUnreachableUsersAction $ buttonForm
let noreachUsersWgt = wrapForm noreachUsersWgt' def
{ formSubmit = FormNoSubmit
, formAction = Just $ SomeRoute ProblemUnreachableR
, formEncoding = noreachUsersEnctype
}
formResult noreachUsersRes $ \case
AllUsersLdapSync -> do
forM_ unreachables $ \Entity{entityKey=uid} -> void . queueJob $ JobSynchroniseLdapUser uid
addMessageI Success . MsgSynchroniseLdapUserQueued $ length unreachables
redirect ProblemUnreachableR
AllUsersAvsSync -> do
n <- runDB $ queueAvsUpdateByUID (entityKey <$> unreachables) Nothing
addMessageI Success . MsgSynchroniseAvsUserQueued $ fromIntegral n
redirect ProblemUnreachableR
siteLayoutMsg MsgProblemsUnreachableHeading $ do
setTitleI MsgProblemsUnreachableHeading
[whamlet|
<section>
#{length unreachables} _{MsgProblemsUnreachableBody}
<h3>_{MsgProblemsUnreachableButtons}
^{noreachUsersWgt}
<section>
#{length unreachables} _{MsgProblemsUnreachableBody}
<ul>
$forall usr <- unreachables
<li>
@ -107,8 +175,8 @@ getProblemUnreachableR = do
|]
getProblemFbutNoR :: Handler Html
getProblemFbutNoR = do
now <- liftIO getCurrentTime
getProblemFbutNoR = do
now <- liftIO getCurrentTime
rnofs <- runDB $ E.select $ retrieveDriversRWithoutF now
siteLayoutMsg MsgProblemsRWithoutFHeading $ do
setTitleI MsgProblemsRWithoutFHeading
@ -122,8 +190,8 @@ getProblemFbutNoR = do
|]
getProblemWithoutAvsId :: Handler Html
getProblemWithoutAvsId = do
now <- liftIO getCurrentTime
getProblemWithoutAvsId = do
now <- liftIO getCurrentTime
rnofs <- runDB $ E.select $ retrieveDriversWithoutAvsId now
siteLayoutMsg MsgProblemsNoAvsIdHeading $ do
setTitleI MsgProblemsNoAvsIdHeading
@ -138,40 +206,47 @@ getProblemWithoutAvsId = do
{-
mkUnreachableUsersTable = do
let dbtSQLQuery user -> do
let dbtSQLQuery user -> do
E.where_ $ E.isNothing (user E.^. UserPostAddress)
E.&&. E.not_ ((user E.^. UserEmail) `E.like` E.val "%@%.%")
E.&&. E.not_ ((user E.^. UserEmail) `E.like` E.val "%@%.%")
pure user
dbtRowKey = (E.^. UserId)
dbtProj = dbtProjId
dbtColonnade =
dbtColonnade =
-}
areAllUsersReachable :: DB Bool
-- areAllUsersReachable = isNothing <$> E.selectOne retrieveUnreachableUsers'
-- areAllUsersReachable = E.selectNotExists retrieveUnreachableUsers'
-- areAllUsersReachable = E.selectNotExists retrieveUnreachableUsers' -- works and would be more efficient, but we cannot check proper email validity within DB alone
areAllUsersReachable = null <$> retrieveUnreachableUsers
-- retrieveUnreachableUsers' :: E.SqlQuery (E.SqlExpr (Entity User))
-- retrieveUnreachableUsers' = do
-- retrieveUnreachableUsers' = do
-- user <- E.from $ E.table @User
-- E.where_ $ E.isNothing (user E.^. UserPostAddress)
-- E.&&. (E.isNothing (user E.^. UserCompanyDepartment) E.||. user E.^. UserCompanyPersonalNumber `E.ilike` E.justVal "E%")
-- E.&&. E.not_ ((user E.^. UserDisplayEmail) `E.like` E.val "%@%.%")
-- E.&&. E.not_ ((user E.^. UserEmail) `E.like` E.val "%@%.%")
-- return user
-- return user
retrieveUnreachableUsers :: DB [Entity User]
retrieveUnreachableUsers = do
emailOnlyUsers <- E.select $ do
retrieveUnreachableUsers = do
emailOnlyUsers <- E.select $ do
user <- E.from $ E.table @User
E.where_ $ E.isNothing (user E.^. UserPostAddress)
E.&&. (E.isNothing (user E.^. UserCompanyDepartment) E.||. user E.^. UserCompanyPersonalNumber `E.ilike` E.justVal "E%")
E.&&. (E.isNothing (user E.^. UserCompanyDepartment) E.||. user E.^. UserCompanyPersonalNumber `E.ilike` E.justVal "E%")
E.&&. E.notExists (do
(cmp :& usrCmp) <- E.from $ E.table @Company `E.innerJoin` E.table @UserCompany
`E.on` (\(cmp :& usrCmp) -> cmp E.^. CompanyId E.==. usrCmp E.^. UserCompanyCompany)
E.where_ $ user E.^. UserId E.==. usrCmp E.^. UserCompanyUser
E.&&. usrCmp E.^. UserCompanyUseCompanyAddress
E.&&. E.isJust (cmp E.^. CompanyPostAddress)
)
return user
return $ filter hasInvalidEmail emailOnlyUsers
where
hasInvalidEmail = isNothing . getEmailAddress . entityVal
filterM hasInvalidEmail emailOnlyUsers
-- filterM hasInvalifPostal -- probably not worth it, since Utils.Postal.validPostAddress is pretty weak anyway
where
hasInvalidEmail = fmap isNothing . getUserEmail
allDriversHaveAvsId :: UTCTime -> DB Bool
-- allDriversHaveAvsId = fmap isNothing . E.selectOne . retrieveDriversWithoutAvsId
@ -180,17 +255,17 @@ allDriversHaveAvsId = E.selectNotExists . retrieveDriversWithoutAvsId
{-
-- | Returns users more than once if they own multiple avs-related valid licences, but no AvsID is known
retrieveDriversWithoutAvsId' :: Day -> E.SqlQuery (E.SqlExpr (Entity User))
retrieveDriversWithoutAvsId' nowaday = do
retrieveDriversWithoutAvsId' nowaday = do
(usr :& qualUsr :& qual) <- E.from $ E.table @User
`E.innerJoin` E.table @QualificationUser
`E.on` (\(usr :& qualUsr) -> usr E.^. UserId E.==. qualUsr E.^. QualificationUserUser)
`E.innerJoin` E.table @Qualification
`E.on` (\(_usr :& qualUsr :& qual) -> qual E.^. QualificationId E.==. qualUsr E.^. QualificationUserQualification)
`E.innerJoin` E.table @Qualification
`E.on` (\(_usr :& qualUsr :& qual) -> qual E.^. QualificationId E.==. qualUsr E.^. QualificationUserQualification)
E.where_ $ -- is avs licence
E.isJust (qual E.^. QualificationAvsLicence)
E.&&. (qualUsr & validQualification nowaday)
E.&&. -- AvsId is unknown
E.notExists (do
E.notExists (do
avsUsr <- E.from $ E.table @UserAvs
E.where_ $ avsUsr E.^. UserAvsUser E.==. usr E.^. UserId
)
@ -199,20 +274,20 @@ retrieveDriversWithoutAvsId' nowaday = do
-- | Returns users at most once, even if they own multiple avs-related licences, but no AvsID is known
retrieveDriversWithoutAvsId :: UTCTime -> E.SqlQuery (E.SqlExpr (Entity User))
retrieveDriversWithoutAvsId now = do
retrieveDriversWithoutAvsId now = do
usr <- E.from $ E.table @User
E.where_ $
E.exists (do -- a valid avs licence
(qual :& qualUsr) <- E.from (E.table @Qualification
E.where_ $
E.exists (do -- a valid avs licence
(qual :& qualUsr) <- E.from (E.table @Qualification
`E.innerJoin` E.table @QualificationUser
`E.on` (\(qual :& qualUsr) -> qual E.^. QualificationId E.==. qualUsr E.^. QualificationUserQualification))
E.where_ $ -- is avs licence
E.isJust (qual E.^. QualificationAvsLicence)
E.&&. (qualUsr & validQualification now) -- currently valid
E.&&. -- matches user
E.&&. -- matches user
(qualUsr E.^. QualificationUserUser E.==. usr E.^. UserId)
)
E.&&.
E.&&.
E.notExists (do -- a known AvsId
avsUsr <- E.from $ E.table @UserAvs
E.where_ $ avsUsr E.^. UserAvsUser E.==. usr E.^. UserId
@ -221,20 +296,133 @@ retrieveDriversWithoutAvsId now = do
allRDriversHaveFs :: UTCTime -> DB Bool
-- allRDriversHaveFs = fmap isNothing . E.selectOne . retrieveDriversRWithoutF
allRDriversHaveFs = E.selectNotExists . retrieveDriversRWithoutF
-- allRDriversHaveFs = fmap isNothing . E.selectOne . retrieveDriversRWithoutF
allRDriversHaveFs = E.selectNotExists . retrieveDriversRWithoutF
-- | Returns users at most once, even if they own multiple avs-related licences, but no AvsID is known
retrieveDriversRWithoutF :: UTCTime -> E.SqlQuery (E.SqlExpr (Entity User))
retrieveDriversRWithoutF now = do
retrieveDriversRWithoutF now = do
usr <- E.from $ E.table @User
let hasValidQual lic = do
(qual :& qualUsr) <- E.from (E.table @Qualification
(qual :& qualUsr) <- E.from (E.table @Qualification
`E.innerJoin` E.table @QualificationUser
`E.on` (\(qual :& qualUsr) -> qual E.^. QualificationId E.==. qualUsr E.^. QualificationUserQualification))
E.where_ $ (qual E.^. QualificationAvsLicence E.==. E.justVal lic) -- matches licence
E.&&. (qualUsr E.^. QualificationUserUser E.==. usr E.^. UserId) -- matches user
E.&&. (qualUsr & validQualification now) -- currently valid
E.where_ $ (qual E.^. QualificationAvsLicence E.==. E.justVal lic) -- matches licence
E.&&. (qualUsr E.^. QualificationUserUser E.==. usr E.^. UserId) -- matches user
E.&&. (qualUsr & validQualification now) -- currently valid
E.where_ $ E.exists (hasValidQual AvsLicenceRollfeld)
E.&&. E.notExists (hasValidQual AvsLicenceVorfeld)
return usr
type ProblemLogTableExpr = E.SqlExpr (Entity ProblemLog) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
queryProblem :: ProblemLogTableExpr -> E.SqlExpr (Entity ProblemLog)
queryProblem = $(E.sqlLOJproj 3 1)
querySolver :: ProblemLogTableExpr -> E.SqlExpr (Maybe (Entity User))
querySolver = $(E.sqlLOJproj 3 2)
queryUser :: ProblemLogTableExpr -> E.SqlExpr (Maybe (Entity User))
queryUser = $(E.sqlLOJproj 3 3)
type ProblemLogTableData = DBRow (Entity ProblemLog, Maybe (Entity User), Maybe (Entity User))
resultProblem :: Lens' ProblemLogTableData (Entity ProblemLog)
resultProblem = _dbrOutput . _1
resultSolver :: Traversal' ProblemLogTableData (Entity User)
resultSolver = _dbrOutput . _2 . _Just
resultUser :: Traversal' ProblemLogTableData (Entity User)
resultUser = _dbrOutput . _3 . _Just
mkProblemLogTable :: DB (FormResult (ProblemTableActionData, Set ProblemLogId), Widget)
mkProblemLogTable = do
-- problem_types <- E.select $ do
-- ap <- E.from $ E.table @ProblemLog
-- let res = ap E.^. ProblemLogInfo E.->>. "problem"
-- E.groupBy res
-- return res
over _1 postprocess <$> dbTable validator DBTable{..}
where
-- TODO: query to collect all occurring problem types to use as tooltip for the problem filter, so that these don't run out of synch
dbtIdent = "problem-log" :: Text
dbtSQLQuery = \(problem `E.LeftOuterJoin` solver `E.LeftOuterJoin` usr) -> do
-- EL.on (usr E.?. UserId E.==. E.text2num (problem E.^. ProblemLogInfo E.->>. "user")) -- works
EL.on (usr E.?. UserId E.==. problem E.^. ProblemLogInfo E.->>>. "user")
EL.on (solver E.?. UserId E.==. problem E.^. ProblemLogSolver)
return (problem, solver, usr)
dbtRowKey = queryProblem >>> (E.^. ProblemLogId)
dbtProj = dbtProjFilteredPostId
dbtColonnade = formColonnade $ mconcat
[ dbSelect (applying _2) id $ return . view (resultProblem . _entityKey)
, sortable (Just "time") (i18nCell MsgAdminProblemCreated) $ \( view $ resultProblem . _entityVal . _problemLogTime -> t) -> dateTimeCell t
, sortable (Just "info") (i18nCell MsgAdminProblemInfo) $ \( view $ resultProblem . _entityVal . _problemLogAdminProblem -> p) -> adminProblemCell p
-- , sortable (Just "firm") (i18nCell MsgTableCompany) $ \(preview $ resultProblem . _entityVal . _problemLogAdminProblem . _adminProblemCompany -> c) -> cellMaybe companyIdCell c
, sortable (Just "firm") (i18nCell MsgTableCompany) $ \( view $ resultProblem . _entityVal . _problemLogAdminProblem -> p) -> cellMaybe companyIdCell $ join (p ^? _adminProblemCompanyOld) <|> (p ^? _adminProblemCompany)
, sortable (Just "user") (i18nCell MsgAdminProblemUser) $ \(preview resultUser -> u) -> maybeCell u $ cellHasUserLink AdminUserR
, sortable (Just "solved") (i18nCell MsgAdminProblemSolved) $ \( view $ resultProblem . _entityVal . _problemLogSolved -> t) -> cellMaybe dateTimeCell t
, sortable (Just "solver") (i18nCell MsgAdminProblemSolver) $ \(preview resultSolver -> u) -> maybeCell u $ cellHasUserLink AdminUserR
]
dbtSorting = Map.fromList
[ ("time" , SortColumn $ queryProblem >>> (E.^. ProblemLogTime))
, ("info" , SortColumn $ queryProblem >>> (E.^. ProblemLogInfo))
-- , ("firm" , SortColumn ((E.->>. "company" ).(queryProblem >>> (E.^. ProblemLogInfo))))
, ("firm" , SortColumn $ \r -> queryProblem r E.^. ProblemLogInfo E.->>. "company")
, ("user" , sortUserNameBareM queryUser)
, ("solved", SortColumn $ queryProblem >>> (E.^. ProblemLogSolved))
, ("solver", sortUserNameBareM querySolver)
]
dbtFilter = Map.fromList
[ ("user" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryUser) (E.?. UserDisplayName))
, ("solver" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to querySolver) (E.?. UserDisplayName))
, ("company" , FilterColumn . E.mkContainsFilter $ views (to queryProblem) ((E.->>. "company").(E.^. ProblemLogInfo)))
, ("solved" , FilterColumn . E.mkExactFilterLast $ views (to queryProblem) (E.isJust . (E.^. ProblemLogSolved)))
-- , ("problem" , FilterColumn . E.mkContainsFilter $ views (to queryProblem) ((E.->>. "problem").(E.^. ProblemLogInfo))) -- not stored in plaintext!
, ("problem" , mkFilterProjectedPost $ \(getLast -> criterion) dbr -> -- falls es nicht schnell genug ist: in dbtProj den Anzeigetext nur einmal berechnen
ifNothingM criterion True $ \(crit::Text) -> do
let problem = dbr ^. resultProblem . _entityVal . _problemLogAdminProblem
protxt <- adminProblem2Text problem
return $ crit `Text.isInfixOf` protxt
)
]
dbtFilterUI mPrev = mconcat
[ prismAForm (singletonFilter "user" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgAdminProblemUser & setTooltip MsgTableFilterCommaPlus)
, prismAForm (singletonFilter "solver" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgAdminProblemSolver & setTooltip MsgTableFilterCommaPlusShort)
, prismAForm (singletonFilter "problem" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgAdminProblemInfo)
, prismAForm (singletonFilter "company" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableCompanyShort)
, prismAForm (singletonFilter "solved" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgAdminProblemSolved)
]
acts :: Map ProblemTableAction (AForm Handler ProblemTableActionData)
acts = Map.fromList
[ (ProblemTableMarkSolved , pure ProblemTableMarkSolvedData)
, (ProblemTableMarkUnsolved , pure ProblemTableMarkUnsolvedData)
]
dbtParams = DBParamsForm
{ dbParamsFormMethod = POST
, dbParamsFormAction = Nothing
, dbParamsFormAttrs = []
, dbParamsFormSubmit = FormSubmit
, dbParamsFormAdditional
= renderAForm FormStandard
$ (, mempty) . First . Just
<$> multiActionA acts (fslI MsgTableAction) (Just ProblemTableMarkSolved)
, dbParamsFormEvaluate = liftHandler . runFormPost
, dbParamsFormResult = id
, dbParamsFormIdent = def
}
dbtCsvEncode = noCsvEncode
dbtCsvDecode = Nothing
dbtExtraReps = []
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
validator = def & defaultSorting [SortAscBy "time"]
& defaultFilter (singletonMap "solved" [toPathPiece False])
postprocess :: FormResult (First ProblemTableActionData, DBFormResult ProblemLogId Bool ProblemLogTableData)
-> FormResult ( ProblemTableActionData, Set ProblemLogId)
postprocess inp = do
(First (Just act), usrMap) <- inp
let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
return (act, usrSet)
-- adminProblemCell :: IsDBTable m a => AdminProblem -> DBCell m a -- moved to Handler.Utils
-- msgAdminProblem :: AdminProblem -> DB (SomeMessages UniWorX) -- moved to Handler.Utils

798
src/Handler/Admin/Avs.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-24 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
@ -9,7 +9,7 @@
module Handler.Admin.Avs
( getAdminAvsR, postAdminAvsR
, getAdminAvsUserR
, getAdminAvsUserR, postAdminAvsUserR
, getProblemAvsSynchR, postProblemAvsSynchR
, getProblemAvsErrorR
) where
@ -17,7 +17,7 @@ module Handler.Admin.Avs
import Import
import qualified Control.Monad.State.Class as State
-- import Data.Aeson (encode)
import qualified Data.Aeson.Encode.Pretty as Pretty
-- import qualified Data.Aeson.Encode.Pretty as Pretty
import qualified Data.Text as Text
import qualified Data.CaseInsensitive as CI
import qualified Data.Set as Set
@ -27,9 +27,8 @@ import qualified Data.Map as Map
import Handler.Utils
import Handler.Utils.Avs
-- import Handler.Utils.Qualification
import Utils.Avs
import Handler.Utils.Users (getUserPrimaryCompany)
import Handler.Utils.Company (switchAvsUserCompany)
import Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Legacy as E
@ -39,10 +38,13 @@ import qualified Database.Esqueleto.Utils as E
-- import Database.Esqueleto.Utils.TH
-- avoids repetition of local definitions
single :: (k,a) -> Map k a
single = uncurry Map.singleton
exceptionWgt :: SomeException -> Widget
exceptionWgt (SomeException e) = [whamlet|<h2>Error:</h2> #{tshow e}|]
tryShow :: MonadCatch m => m Widget -> m Widget
tryShow act = try act >>= \case
Left err -> return $ exceptionWgt err
Right res -> return res
-- Button only needed in AVS TEST; further buttons see below
data ButtonAvsTest = BtnCheckLicences -- | BtnSynchLicences
@ -53,7 +55,7 @@ instance Finite ButtonAvsTest
nullaryPathPiece ''ButtonAvsTest camelToPathPiece
instance Button UniWorX ButtonAvsTest where
btnLabel BtnCheckLicences = "Check all licences" -- could be msg
btnLabel BtnCheckLicences = "Show all licence difference to current AVS" -- could be msg
-- btnLabel BtnSynchLicences = "Synchronize all licences" -- could be msg
btnClasses BtnCheckLicences = [BCIsButton, BCPrimary]
-- btnClasses BtnSynchLicences = [BCIsButton, BCDanger]
@ -87,7 +89,7 @@ validateAvsQueryPerson = do
is _Just avsPersonQueryInternalPersonalNo ||
is _Just avsPersonQueryVersionNo
makeAvsStatusForm :: Maybe AvsQueryStatus -> Form AvsQueryStatus
makeAvsStatusForm :: Maybe AvsPersonId -> Form AvsQueryStatus
makeAvsStatusForm tmpl = identifyForm FIDAvsQueryStatus . validateForm validateAvsQueryStatus $ \html ->
flip (renderAForm FormStandard) html $
parseAvsIds <$> areq textField (fslI MsgAvsPersonId) (unparseAvsIds <$> tmpl)
@ -97,15 +99,15 @@ makeAvsStatusForm tmpl = identifyForm FIDAvsQueryStatus . validateForm validateA
where
nonemptys = filter (not . Text.null) $ Text.strip <$> Text.split (==',') txt
ids = mapMaybe readMay nonemptys
unparseAvsIds :: AvsQueryStatus -> Text
unparseAvsIds (AvsQueryStatus ids) = Text.intercalate ", " $ tshow <$> Set.toAscList ids
unparseAvsIds :: AvsPersonId -> Text
unparseAvsIds = tshow . avsPersonId
validateAvsQueryStatus :: FormValidator AvsQueryStatus Handler ()
validateAvsQueryStatus = do
AvsQueryStatus ids <- State.get
guardValidation (MsgAvsQueryStatusInvalid $ tshow ids) $ not (null ids)
makeAvsContactForm :: Maybe AvsQueryContact -> Form AvsQueryContact
makeAvsContactForm :: Maybe AvsPersonId -> Form AvsQueryContact
makeAvsContactForm tmpl = identifyForm FIDAvsQueryContact . validateForm validateAvsQueryContact $ \html ->
flip (renderAForm FormStandard) html $
parseAvsIds <$> areq textField (fslI MsgAvsPersonId) (unparseAvsIds <$> tmpl) -- consider using cfAnySeparatedSet here
@ -115,8 +117,9 @@ makeAvsContactForm tmpl = identifyForm FIDAvsQueryContact . validateForm validat
where
nonemptys = filter (not . Text.null) $ Text.strip <$> Text.split (==',') txt
ids = mapMaybe (fmap AvsObjPersonId . readMay) nonemptys
unparseAvsIds :: AvsQueryContact -> Text
unparseAvsIds (AvsQueryContact ids) = Text.intercalate ", " $ tshow <$> Set.toAscList ids
unparseAvsIds :: AvsPersonId -> Text
unparseAvsIds = tshow . avsPersonId
--unparseAvsIds (AvsQueryContact ids) = Text.intercalate ", " $ tshow <$> Set.toAscList ids
validateAvsQueryContact :: FormValidator AvsQueryContact Handler ()
validateAvsQueryContact = do
@ -140,173 +143,270 @@ postAdminAvsR = do
mbAvsConf <- getsYesod $ view _appAvsConf
let avsWgt = [whamlet|
$maybe avsConf <- mbAvsConf
AVS Konfiguration ist #{decodeUtf8 (avsUser avsConf)}@#{avsHost avsConf}:#{avsPort avsConf}
<h2>
AVS Konfiguration
<ul>
<li>
Host: #{decodeUtf8 (avsUser avsConf)}@#{avsHost avsConf}:#{avsPort avsConf}
<li>
Timeout sekundäre AVS Abfragen: #{avsTimeout avsConf}s
<li>
Cache Gültigkeit sekundäre AVS Abfragen: #{tshow (avsCacheExpiry avsConf)}
$nothing
AVS nicht konfiguriert!
|]
mAvsQuery <- getsYesod $ view _appAvsQuery
case mAvsQuery of
Nothing -> siteLayoutMsg MsgMenuAvs [whamlet|Error: AVS interface configuration is incomplete.|] -- should never occur after initilisation
Just AvsQuery{..} -> do
((presult, pwidget), penctype) <- runFormPost $ makeAvsPersonForm Nothing
let procFormPerson fr = do
addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr)
res <- avsQueryPerson fr
case res of
Left err -> let msg = tshow err in return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
Right (AvsResponsePerson pns) -> return $ Just [whamlet|
<ul>
$forall p <- pns
<li>#{decodeUtf8 (Pretty.encodePretty (toJSON p))}
|]
mbPerson <- formResultMaybe presult procFormPerson
((presult, pwidget), penctype) <- runFormPost $ makeAvsPersonForm Nothing
((sresult, swidget), senctype) <- runFormPost $ makeAvsStatusForm Nothing
let procFormStatus fr = do
addMessage Info $ text2Html $ "Status Query: " <> tshow (toJSON fr)
res <- avsQueryStatus fr
case res of
Left err -> let msg = tshow err in return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
Right (AvsResponseStatus pns) -> return $ Just [whamlet|
<ul>
$forall p <- pns
<li>#{decodeUtf8 (Pretty.encodePretty (toJSON p))}
|]
mbStatus <- formResultMaybe sresult procFormStatus
((cresult, cwidget), cenctype) <- runFormPost $ makeAvsContactForm Nothing
let procFormContact fr = do
addMessage Info $ text2Html $ "Contact Query: " <> tshow (toJSON fr)
res <- avsQueryContact fr
case res of
Left err -> let msg = tshow err in return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
Right (AvsResponseContact pns) -> return $ Just [whamlet|
<ul>
$forall AvsDataContact{..} <- pns
<li>
let procFormPerson :: AvsQueryPerson -> Handler (Maybe (Maybe Widget, Maybe AvsPersonId))
procFormPerson (fixAvsQueryPerson -> fr) = do
addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr)
try (avsQuery fr) >>= \case
Left err -> return $ Just (Just $ exceptionWgt err, Nothing)
Right (AvsResponsePerson pns) -> do
let mapid = case Set.toList pns of
[AvsDataPerson{avsPersonPersonID=apid}] -> Just apid
_ -> Nothing
wgt = [whamlet|
<ul>
<li>AvsId: #{tshow avsContactPersonID}
<li>#{decodeUtf8 (Pretty.encodePretty (toJSON avsContactPersonInfo))}
<li>#{decodeUtf8 (Pretty.encodePretty (toJSON avsContactFirmInfo))}
|]
mbContact <- formResultMaybe cresult procFormContact
$forall p <- pns
<li>^{jsonWidget p}
|] -- <li>#{decodeUtf8 (Pretty.encodePretty (toJSON p))}
return $ Just (toMaybe (notNull pns) wgt, mapid)
(mbPerson,mapid) <- fromMaybe (Nothing,Nothing) <$> formResultMaybe presult procFormPerson
((sresult', swidget), senctype) <- runFormPost $ makeAvsStatusForm mapid
let sresult = sresult' <|> maybe FormMissing (FormSuccess . AvsQueryStatus . Set.singleton) mapid -- use unique AvsId from PersonSearch for convenience, if form was empty
procFormStatus fr = do
addMessage Info $ text2Html $ "Status Query: " <> tshow (toJSON fr)
tryShow $ do
AvsResponseStatus pns <- avsQuery fr
return [whamlet|
<ul>
$forall p <- pns
<li>^{jsonWidget p}
|]
mbStatus <- formResultMaybe sresult (Just <<$>> procFormStatus)
((crUsrRes, crUsrWgt), crUsrEnctype) <- runFormPost $ identifyForm FIDAvsCreateUser $ \html ->
flip (renderAForm FormStandard) html $ areq textField (fslI MsgAvsCardNo) Nothing
let procFormCrUsr fr = do
-- addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr)
res <- try $ guessAvsUser fr
case res of
(Right (Just uid)) -> do
uuid :: CryptoUUIDUser <- encrypt uid
return $ Just [whamlet|<h2>Success:</h2> <a href=@{ForProfileR uuid}>User created or updated.|]
(Right Nothing) ->
return $ Just [whamlet|<h2>Warning:</h2> No user found.|]
(Left e) -> do
let msg = tshow (e :: SomeException)
return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
mbCrUser <- formResultMaybe crUsrRes procFormCrUsr
((getLicRes, getLicWgt), getLicEnctype) <- runFormPost $ identifyForm FIDAvsQueryLicence $ \html ->
flip (renderAForm FormStandard) html $ (,,) <$> aopt intField (fslI $ text2message "Min AvsPersonId") Nothing
<*> aopt intField (fslI $ text2message "Max AvsPersonId") Nothing
<*> aopt (selectField $ return avsLicenceOptions) (fslI MsgAvsLicence) Nothing
let procFormGetLic fr = do
res <- avsQueryGetAllLicences
case res of
(Right (AvsResponseGetLicences lics)) -> do
let flics = Set.toList $ Set.filter lfltr lics
lfltr = case fr of -- not pretty, but it'll do
(Just idmin, Just idmax, Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID `inBetween` (AvsPersonId idmin, AvsPersonId idmax))
(Just idmin, Nothing, Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID == AvsPersonId idmin)
(Nothing , Just idmax, Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID == AvsPersonId idmax)
(Nothing , Nothing, Just lic) -> \AvsPersonLicence{..} -> avsLicenceRampLicence == lic
(Just idmin, Just idmax, Nothing ) -> (`inBetween` (AvsPersonId idmin, AvsPersonId idmax)) . avsLicencePersonID
(Just idmin, Nothing, Nothing ) -> (== AvsPersonId idmin) . avsLicencePersonID
(Nothing , Just idmax, Nothing ) -> (== AvsPersonId idmax) . avsLicencePersonID
(Nothing , Nothing, Nothing ) -> const True
addMessage Info $ text2Html $ "Query returned " <> tshow (length flics) <> " licences."
return $ Just [whamlet|
<h2>Success:</h2>
((cresult', cwidget), cenctype) <- runFormPost $ makeAvsContactForm mapid
let cresult = cresult' <|> maybe FormMissing (FormSuccess . AvsQueryContact . Set.singleton . AvsObjPersonId) mapid -- use unique AvsId from PersonSearch for convenience, if form was empty
procFormContact fr = do
addMessage Info $ text2Html $ "Contact Query: " <> tshow (toJSON fr)
tryShow $ do
AvsResponseContact pns <- avsQuery fr
return [whamlet|
<ul>
$forall AvsDataContact{..} <- pns
<li>
<ul>
$forall AvsPersonLicence{..} <- flics
<li> #{tshow avsLicencePersonID}: #{licence2char avsLicenceRampLicence}
|]
(Left err) -> do
let msg = tshow err
return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
mbGetLic <- formResultMaybe getLicRes procFormGetLic
((setLicRes, setLicWgt), setLicEnctype) <- runFormPost $ identifyForm FIDAvsSetLicence $ \html ->
flip (renderAForm FormStandard) html $ (,) <$> areq intField (fslI MsgAvsPersonId) Nothing
<*> areq (selectField $ return avsLicenceOptions) (fslI MsgAvsLicence) (Just AvsLicenceVorfeld)
let procFormSetLic (aid, lic) = do
res <- try $ setLicenceAvs (AvsPersonId aid) lic
case res of
(Right True) ->
return $ Just [whamlet|<h2>Success:</h2> Licence #{tshow (licence2char lic)} set for #{tshow aid}.|]
(Right False) ->
return $ Just [whamlet|<h2>Error:</h2> Licence could not be set for #{tshow aid}.|]
(Left e) -> do
let msg = tshow (e :: SomeException)
return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
mbSetLic <- formResultMaybe setLicRes procFormSetLic
<li>AvsId: #{tshow avsContactPersonID}
<li>^{jsonWidget avsContactPersonInfo}
<li>^{jsonWidget avsContactFirmInfo}
|] -- <li>#{decodeUtf8 (Pretty.encodePretty (toJSON avsContactPersonInfo))}
mbContact <- formResultMaybe cresult (Just <<$>> procFormContact)
(qryLicForm, qryLicRes) <- runButtonForm FIDAvsQueryLicenceDiffs
mbQryLic <- case qryLicRes of
Nothing -> return Nothing
(Just BtnCheckLicences) -> do
res <- try $ do
allLicences <- throwLeftM avsQueryGetAllLicences
computeDifferingLicences allLicences
case res of
(Right diffs) -> do
let showLics l = Text.intercalate ", " $ fmap (tshow . avsLicencePersonID) $ Set.toList $ Set.filter ((l ==) . avsLicenceRampLicence) diffs
r_grant = showLics AvsLicenceRollfeld
f_set = showLics AvsLicenceVorfeld
revoke = showLics AvsNoLicence
return $ Just [whamlet|
<h2>Licence check differences:
<h3>Grant R:
<p>
#{r_grant}
<h3>Set to F:
<p>
#{f_set}
<h3>Revoke licence:
<p>
#{revoke}
((crUsrRes, crUsrWgt), crUsrEnctype) <- runFormPost $ identifyForm FIDAvsCreateUser $ \html ->
flip (renderAForm FormStandard) html $ areq textField (fslI MsgAvsCardNo) Nothing
let procFormCrUsr fr = do
-- addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr)
res <- try $ guessAvsUser fr
case res of
(Right (Just uid)) -> do
uuid :: CryptoUUIDUser <- encrypt uid
return $ Just [whamlet|<h2>Success:</h2> <a href=@{ForProfileR uuid}>User created or updated.|]
(Right Nothing) ->
return $ Just [whamlet|<h2>Warning:</h2> No user found.|]
(Left e) -> return $ Just $ exceptionWgt e
mbCrUser <- formResultMaybe crUsrRes procFormCrUsr
((getLicRes, getLicWgt), getLicEnctype) <- runFormPost $ identifyForm FIDAvsQueryLicence $ \html ->
flip (renderAForm FormStandard) html $ (,,) <$> aopt intField (fslI $ text2message "Min AvsPersonId") Nothing
<*> aopt intField (fslI $ text2message "Max AvsPersonId") Nothing
<*> aopt (selectField $ return avsLicenceOptions) (fslI MsgAvsLicence) Nothing
let procFormGetLic fr = tryShow $ do
AvsResponseGetLicences lics <- avsQuery AvsQueryGetAllLicences
let flics = Set.toList $ Set.filter lfltr lics
lfltr = case fr of -- not pretty, but it'll do
(Just idmin, Just idmax, Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID `inBetween` (AvsPersonId idmin, AvsPersonId idmax))
(Just idmin, Nothing, Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID == AvsPersonId idmin)
(Nothing , Just idmax, Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID == AvsPersonId idmax)
(Nothing , Nothing, Just lic) -> \AvsPersonLicence{..} -> avsLicenceRampLicence == lic
(Just idmin, Just idmax, Nothing ) -> (`inBetween` (AvsPersonId idmin, AvsPersonId idmax)) . avsLicencePersonID
(Just idmin, Nothing, Nothing ) -> (== AvsPersonId idmin) . avsLicencePersonID
(Nothing , Just idmax, Nothing ) -> (== AvsPersonId idmax) . avsLicencePersonID
(Nothing , Nothing, Nothing ) -> const True
addMessage Info $ text2Html $ "Query returned " <> tshow (length flics) <> " licences."
return [whamlet|
<h2>Success:</h2>
<ul>
$forall AvsPersonLicence{..} <- flics
<li> #{tshow avsLicencePersonID}: #{licence2char avsLicenceRampLicence}
|]
mbGetLic <- formResultMaybe getLicRes (Just <<$>> procFormGetLic)
((setLicRes, setLicWgt), setLicEnctype) <- runFormPost $ identifyForm FIDAvsSetLicence $ \html ->
flip (renderAForm FormStandard) html $ (,) <$> areq intField (fslI MsgAvsPersonId) Nothing
<*> areq (selectField $ return avsLicenceOptions) (fslI MsgAvsLicence) (Just AvsLicenceVorfeld)
let procFormSetLic (aid, lic) = do
res <- try $ setLicenceAvs (AvsPersonId aid) lic
case res of
(Right True) ->
return $ Just [whamlet|<h2>Success:</h2> Licence #{tshow (licence2char lic)} set for #{tshow aid}.|]
(Right False) ->
return $ Just [whamlet|<h2>Error:</h2> Licence could not be set for #{tshow aid}.|]
(Left e) -> do
let msg = tshow (e :: SomeException)
return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
mbSetLic <- formResultMaybe setLicRes procFormSetLic
(qryLicForm, qryLicRes) <- runButtonForm FIDAvsQueryLicenceDiffs
(mbQryLic :: Maybe Widget, mbAutoDiffs :: Maybe Html) <- case qryLicRes of
Nothing -> return mempty
(Just BtnCheckLicences) -> do
res <- try $ do
allLicences <- avsQueryNoCache AvsQueryGetAllLicences
computeDifferingLicences allLicences
basediffs <- case res of
(Right diffs) -> do
let showLics l =
let chgs = Set.filter ((l ==) . avsLicenceRampLicence) diffs
in if Set.null chgs
then ("[ ]", 0)
else (Text.intercalate ", " (tshow . avsLicencePersonID <$> Set.toList chgs), Set.size chgs)
(r_grant, rg_size) = showLics AvsLicenceRollfeld
(f_set , fs_size) = showLics AvsLicenceVorfeld
(revoke , rv_size) = showLics AvsNoLicence
return $ Just [whamlet|
<h2>Licence check AVS-ID differences:
<dl .deflist>
<dt .deflist__dt>Grant R (#{rg_size}):
<dd .deflist__dd>#{r_grant}
<dt .deflist__dt>Set to F (#{fs_size}):
<dd .deflist__dd>#{f_set}
<dt .deflist__dt>Revoke licence (#{rv_size}):
<dd .deflist__dd>#{revoke}
|]
(Left e) -> do
let msg = tshow (e :: SomeException)
return $ Just [whamlet|<h2>Licence check error:</h2> #{msg}|]
autoDiffs <- do
-- what follows is copy of the code from Jobs.Handler.SynchroniseAvs.dispatchJobSynchroniseAvsLicences modified to not do anything actually
AvsLicenceSynchConf
{ avsLicenceSynchLevel = synchLevel -- SynchLevel corresponds to tables of ProblemAvsSynchR: 4=top grant R, 3= reduce R->F, 2= grant F, 1= revoke F
, avsLicenceSynchReasonFilter = reasonFilter
, avsLicenceSynchMaxChanges = maxChanges
} <- getsYesod $ view _appAvsLicenceSynchConf
guardMonoidM (synchLevel > 0) $ do
let showApids apids
| null apids = "[ ]"
| otherwise = Text.intercalate ", " (tshow <$> Set.toList apids)
procLic :: (Ord a, Show a) => AvsLicence -> Bool -> Set a -> Html
procLic aLic up apids
| n <- Set.size apids, n > 0 =
let subtype = Text.cons (bool '↧' '↥' up) $ Text.singleton $ licence2char aLic
in if NTop (Just n) <= NTop maxChanges
then
[shamlet|
<dt .deflist__dt>#{subtype} (#{n}):
<dd .deflist__dd>#{showApids apids}
|]
else
[shamlet|
<dt .deflist__dt>#{subtype} (#{n}):
<dd .deflist__dd>Too many changes at once. Consider increasing avs-licence-synch-max-changes #{tshow maxChanges}
|]
| otherwise = mempty
(AvsLicenceDifferences{..}, rsChanged) <- retrieveDifferingLicences
-- prevent automatic changes to users blocked with certain reasons and with currently being associated with multiple companies
reasonFltrdIds <- ifNothingM reasonFilter mempty $ \reasons -> do
now <- liftIO getCurrentTime
firmBlocks <- runDBRead $ E.select $ do
(uavs :& _qualUser :& qblock) <- X.from $ E.table @UserAvs
`E.innerJoin` E.table @QualificationUser `X.on` (\( uavs :& qualUser) -> uavs E.^. UserAvsUser E.==. qualUser E.^. QualificationUserUser)
`E.innerJoin` E.table @QualificationUserBlock `X.on` (\(_uavs :& qualUser :& qblock) ->
qualUser E.^. QualificationUserId E.==. qblock E.^. QualificationUserBlockQualificationUser
E.&&. qblock `isLatestBlockBefore'` E.val now)
E.where_ $ (qblock E.^. QualificationUserBlockReason E.~*. E.val reasons)
E.&&. uavs E.^. UserAvsPersonId `E.in_` E.vals (Set.unions [avsLicenceDiffRevokeAll, avsLicenceDiffRevokeRollfeld, avsLicenceDiffGrantVorfeld, avsLicenceDiffGrantRollfeld])
return $ uavs E.^. UserAvsPersonId
return $ Set.fromList $ map E.unValue firmBlocks
let fltrIds
| synchLevel >= 5 = id
| synchLevel >= 3 = flip Set.difference reasonFltrdIds
| otherwise = flip Set.difference $ reasonFltrdIds `Set.union` rsChanged
l1 = guardMonoid (synchLevel >= 1) $ procLic AvsNoLicence False $ fltrIds avsLicenceDiffRevokeAll --revoke Vorfeld and maybe also Rollfeld
l2 = guardMonoid (synchLevel >= 2) $ procLic AvsLicenceVorfeld True $ fltrIds avsLicenceDiffGrantVorfeld --grant Vorfeld
l3 = guardMonoid (synchLevel >= 3) $ procLic AvsLicenceVorfeld False $ fltrIds avsLicenceDiffRevokeRollfeld --downgrade Rollfeld -> Vorfeld
l4 = guardMonoid (synchLevel >= 4) $ procLic AvsLicenceRollfeld True $ fltrIds avsLicenceDiffGrantRollfeld --grant Rollfeld
avsIdChanges = [shamlet|
<h3>
Next automatic AVS-ID licence synchronisation:
<dl .deflist>
^{l4}
^{l3}
^{l2}
^{l1}
$maybe reason <- reasonFilter
<dt .deflist__dt>Filtered "#{reason}" (#{Set.size reasonFltrdIds}):
<dd .deflist__dd>#{showApids reasonFltrdIds}
|]
(Left e) -> do
let msg = tshow (e :: SomeException)
return $ Just [whamlet|<h2>Licence check error:</h2> #{msg}|]
-- (Just BtnSynchLicences) -> do
-- res <- try synchAvsLicences
-- case res of
-- (Right True) ->
-- return $ Just [whamlet|<h2>Success:</h2> Licences sychronized.|]
-- (Right False) ->
-- return $ Just [whamlet|<h2>Error:</h2> Licences could not be synchronized, see error log.|]
-- (Left e) -> do
-- let msg = tshow (e :: SomeException)
-- return $ Just [whamlet|<h2>Licence synchronisation error:</h2> #{msg}|]
----------------------------------------------------
-- translate AVS-IDs to AVS-NOs for convenience only
avsidnos <- runDBRead $ E.select $ do
ua <- X.from $ E.table @UserAvs
E.where_ $ ua E.^. UserAvsPersonId `E.in_` E.vals (Set.unions [avsLicenceDiffRevokeAll, avsLicenceDiffRevokeRollfeld, avsLicenceDiffGrantVorfeld, avsLicenceDiffGrantRollfeld]) -- , reasonFltrdIds])
return (ua E.^. UserAvsPersonId, ua E.^. UserAvsNoPerson)
let id2no = Map.fromList $ $(E.unValueN 2) <$> avsidnos
translate = setMapMaybe (`Map.lookup` id2no)
l1' = guardMonoid (synchLevel >= 1) $ procLic AvsNoLicence False $ translate $ fltrIds avsLicenceDiffRevokeAll --revoke Vorfeld and maybe also Rollfeld
l2' = guardMonoid (synchLevel >= 2) $ procLic AvsLicenceVorfeld True $ translate $ fltrIds avsLicenceDiffGrantVorfeld --grant Vorfeld
l3' = guardMonoid (synchLevel >= 3) $ procLic AvsLicenceVorfeld False $ translate $ fltrIds avsLicenceDiffRevokeRollfeld --downgrade Rollfeld -> Vorfeld
l4' = guardMonoid (synchLevel >= 4) $ procLic AvsLicenceRollfeld True $ translate $ fltrIds avsLicenceDiffGrantRollfeld --grant Rollfeld
autoNoDiffs = [shamlet|
<h3>
Next automatic licence changes translated to human readable AVS-Numbers, if known:
<dl .deflist>
^{l4'}
^{l3'}
^{l2'}
^{l1'}
$maybe reason <- reasonFilter
<dt .deflist__dt>Filtered "#{reason}" (#{Set.size reasonFltrdIds}):
<dd .deflist__dd>#{showApids $ translate reasonFltrdIds}
|]
return $ Just $ avsIdChanges <> autoNoDiffs
return (basediffs, autoDiffs)
actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute
siteLayoutMsg MsgMenuAvs $ do
setTitleI MsgMenuAvs
let wrapFormHere fw fe = wrapForm fw def { formAction = Just $ SomeRoute actionUrl, formEncoding = fe }
personForm = wrapFormHere pwidget penctype
statusForm = wrapFormHere swidget senctype
contactForm = wrapFormHere cwidget cenctype
crUsrForm = wrapFormHere crUsrWgt crUsrEnctype
getLicForm = wrapFormHere getLicWgt getLicEnctype
setLicForm = wrapFormHere setLicWgt setLicEnctype
-- TODO: use i18nWidgetFile instead if this is to become permanent
$(widgetFile "avs")
-- (Just BtnSynchLicences) -> do
-- res <- try synchAvsLicences
-- case res of
-- (Right True) ->
-- return $ Just [whamlet|<h2>Success:</h2> Licences sychronized.|]
-- (Right False) ->
-- return $ Just [whamlet|<h2>Error:</h2> Licences could not be synchronized, see error log.|]
-- (Left e) -> do
-- let msg = tshow (e :: SomeException)
-- return $ Just [whamlet|<h2>Licence synchronisation error:</h2> #{msg}|]
actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute
siteLayoutMsg MsgMenuAvs $ do
setTitleI MsgMenuAvs
let wrapFormHere fw fe = wrapForm fw def { formAction = Just $ SomeRoute actionUrl, formEncoding = fe }
personForm = wrapFormHere pwidget penctype
statusForm = wrapFormHere swidget senctype
contactForm = wrapFormHere cwidget cenctype
crUsrForm = wrapFormHere crUsrWgt crUsrEnctype
getLicForm = wrapFormHere getLicWgt getLicEnctype
setLicForm = wrapFormHere setLicWgt setLicEnctype
-- TODO: use i18nWidgetFile instead if this is to become permanent
$(widgetFile "avs")
{-
@ -369,8 +469,8 @@ postProblemAvsSynchR = getProblemAvsSynchR
getProblemAvsSynchR = do
let catchAllAvs' r = flip catch (\err -> addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException))) >> redirect r)
catchAllAvs = catchAllAvs' ProblemAvsSynchR -- == current route; use only in conditions that are not repeated upon reload; do not call redirect within catchAllAvs actions!
(AvsLicenceDifferences{..}, apidStatus) <- catchAllAvs' AdminR retrieveDifferingLicencesStatus
((AvsLicenceDifferences{..}, rsChanged), apidStatus) <- catchAllAvs' AdminR retrieveDifferingLicencesStatus
let mkLicTbl = mkLicenceTable apidStatus rsChanged
--
unknownLicenceOwners' <- whenNonEmpty avsLicenceDiffRevokeAll $ \neZeros ->
runDB $ E.select $ do
@ -383,7 +483,7 @@ getProblemAvsSynchR = do
numUnknownLicenceOwners = length unknownLicenceOwners
(btnImportUnknownWgt, btnImportUnknownRes) <- runButtonFormHash unknownLicenceOwners FIDBtnAvsImportUnknown
ifMaybeM btnImportUnknownRes () $ \BtnAvsImportUnknown -> do
ifNothingM btnImportUnknownRes () $ \BtnAvsImportUnknown -> do
res <- catchAllAvs $ forM (take 500 unknownLicenceOwners) $ try . upsertAvsUserById -- TODO: turn this into a background job
let procRes (Right _) = (Sum 1, mempty :: Set.Set AvsPersonId, mempty :: Set.Set AvsPersonId, mempty)
--TODO: continue here!
@ -414,7 +514,7 @@ getProblemAvsSynchR = do
^{revokeUnknownExecWgt}
|]
ifMaybeM btnRevokeUnknownRes () $ \BtnAvsRevokeUnknown -> do
ifNothingM btnRevokeUnknownRes () $ \BtnAvsRevokeUnknown -> do
let revokes = Set.map (AvsPersonLicence AvsNoLicence) $ Set.fromList unknownLicenceOwners
no_revokes = Set.size revokes
oks <- catchAllAvs $ setLicencesAvs revokes
@ -425,10 +525,10 @@ getProblemAvsSynchR = do
-- licence differences
((tres0,tb0),(tres1up,tb1up),(tres1down,tb1down),(tres2,tb2)) <- runDB $ (,,,)
<$> mkLicenceTable apidStatus "avsLicDiffRevokeVorfeld" AvsLicenceVorfeld avsLicenceDiffRevokeAll
<*> mkLicenceTable apidStatus "avsLicDiffGrantVorfeld" AvsNoLicence avsLicenceDiffGrantVorfeld
<*> mkLicenceTable apidStatus "avsLicDiffRevokeRollfeld" AvsLicenceRollfeld avsLicenceDiffRevokeRollfeld
<*> mkLicenceTable apidStatus "avsLicDiffGrantRollfeld" AvsNoLicence avsLicenceDiffGrantRollfeld
<$> mkLicTbl "avsLicDiffRevokeVorfeld" AvsLicenceVorfeld avsLicenceDiffRevokeAll
<*> mkLicTbl "avsLicDiffGrantVorfeld" AvsNoLicence avsLicenceDiffGrantVorfeld
<*> mkLicTbl "avsLicDiffRevokeRollfeld" AvsLicenceRollfeld avsLicenceDiffRevokeRollfeld -- downgrade to Vorfeld
<*> mkLicTbl "avsLicDiffGrantRollfeld" AvsNoLicence avsLicenceDiffGrantRollfeld
now <- liftIO getCurrentTime
let procRes :: AvsLicence -> (LicenceTableActionData, Set AvsPersonId) -> Handler ()
@ -441,8 +541,8 @@ getProblemAvsSynchR = do
procRes alic (LicenceTableRevokeFDriveData{..}, apids) = do
oks <- runDB $ do
qId <- getKeyBy404 $ UniqueQualificationAvsLicence $ Just alic
if qId /= licenceTableChangeFDriveQId
qIds <- selectKeysList [QualificationAvsLicence ==. Just alic] [] -- sanity check
if licenceTableChangeFDriveQId `notElem` qIds
then return (-1)
else do
uids <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] []
@ -467,6 +567,7 @@ getProblemAvsSynchR = do
formResult tres1up $ procRes AvsLicenceVorfeld
formResult tres0 $ procRes AvsNoLicence
AvsLicenceSynchConf{..} <- getsYesod $ view _appAvsLicenceSynchConf
siteLayoutMsg MsgAvsTitleLicenceSynch $ do
setTitleI MsgAvsTitleLicenceSynch
$(i18nWidgetFile "avs-synchronisation")
@ -519,14 +620,17 @@ instance HasUser LicenceTableData where
-- instance HasQualificationUser LicenceTableData where -- Not possible, since not all rows have a QualificationUser
-- hasQualificationUser = resultQualUser . _entityVal
mkLicenceTable :: AvsPersonIdMapPersonCard -> Text -> AvsLicence -> Set AvsPersonId -> DB (FormResult (LicenceTableActionData, Set AvsPersonId), Widget)
mkLicenceTable apidStatus dbtIdent aLic apids = do
currentRoute <- fromMaybe (error "mkLicenceTable called from 404-handler") <$> liftHandler getCurrentRoute
avsQualifications <- selectList [QualificationAvsLicence !=. Nothing] []
mkLicenceTable :: AvsPersonIdMapPersonCard -> Set AvsPersonId -> Text -> AvsLicence -> Set AvsPersonId -> DB (FormResult (LicenceTableActionData, Set AvsPersonId), Widget)
mkLicenceTable apidStatus rsChanged dbtIdent aLic apids = do
(currentRoute, usrHasAvsRerr) <- liftHandler $ (,)
<$> (fromMaybe (error "mkLicenceTable called from 404-handler") <$> liftHandler getCurrentRoute)
<*> (messageTooltip <$> messageI Error MsgProblemAvsUsrHadR)
avsQualifications <- selectList [QualificationAvsLicence !=. Nothing] [Asc QualificationName]
now <- liftIO getCurrentTime
let nowaday = utctDay now
avsQids = entityKey <$> avsQualifications
qualOpts = pure $ qualificationsOptionList avsQualifications
-- fltrLic qual = if
-- | aLic == AvsNoLicence -> E.isNothing (qual E.?. QualificationId) E.||. E.isJust (E.joinV $ qual E.?. QualificationAvsLicence) -- could be R, F, both or none at all, but has licence in AVS
-- | otherwise -> E.isNothing (qual E.?. QualificationId) E.||. (E.val aLic E.=?. E.joinV (qual E.?. QualificationAvsLicence)) -- if we suggest granting that licence, this join should deliver a value too
@ -551,17 +655,28 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
, sortable (Just "avspersonno") (i18nCell MsgAvsPersonNo) $ \(view resultUserAvs -> a) -> avsPersonNoLinkedCellAdmin a
-- , colUserCompany
, sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \(view (resultUser . _entityKey) -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX"
companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
companies' <- liftHandler . runDBRead . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
E.orderBy [E.asc (comp E.^. CompanyName)]
return (comp E.^. CompanyShorthand, comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor)
let icnSuper = toWidget $ text2markup " " <> icon IconSupervisor
companies =
companies =
(\(E.Value cmpSh, E.Value cmpName, E.Value cmpSpr) -> simpleLink (citext2widget cmpName) (FirmUsersR cmpSh) <> bool mempty icnSuper cmpSpr) <$> companies'
pure $ intercalate (text2widget "; ") companies
, sortable (Just "qualification") (i18nCell MsgTableQualifications) $ \(preview resultQualification -> q) -> cellMaybe lmsShortCell q
, sortable (Just "qualification") (i18nCell MsgTableQualifications) $
if aLic /= AvsLicenceVorfeld
then
\(preview resultQualification -> q) -> cellMaybe lmsShortCell q
else
\row ->
let q = row ^? resultQualification
apid = row ^. resultUserAvs . _userAvsPersonId
warnCell c = if Set.member apid rsChanged
then c <> spacerCell <> wgtCell usrHasAvsRerr -- expected to be effectively dead code in practice, but we never know
else c
in warnCell $ cellMaybe lmsShortCell q
, sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \(preview $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> cellMaybe dayCell d
, sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \(preview $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> cellMaybe dayCell d
-- , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \(preview $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> cellMaybe dayCell d
@ -573,23 +688,23 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
) $ \(preview $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> cellMaybe (flip ifIconCell IconNoNotification . not) b
, sortable Nothing (i18nCell MsgTableAvsActiveCards) $ \(view $ resultUserAvs . _userAvsPersonId -> apid) -> foldMap avsPersonCardCell $ Map.lookup apid apidStatus
]
dbtSorting = mconcat
[ single $ sortUserNameLink queryUser
, single ("avspersonno" , SortColumn $ queryUserAvs >>> (E.^. UserAvsNoPerson))
, single ("qualification" , SortColumn $ queryQualification >>> (E.?. QualificationShorthand))
, single $ sortUserCompany queryUser
, single ("valid-until" , SortColumn $ queryQualUser >>> (E.?. QualificationUserValidUntil))
, single ("last-refresh" , SortColumn $ queryQualUser >>> (E.?. QualificationUserLastRefresh))
, single ("first-held" , SortColumn $ queryQualUser >>> (E.?. QualificationUserFirstHeld))
, single ("blocked" , SortColumnNeverNull $ queryQualBlock >>> (E.?. QualificationUserBlockFrom))
, single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.?. QualificationUserScheduleRenewal))
-- , single ("validity" , SortColumn $ queryQualUser >>> (E.?. QualificationUserValidUntil))
dbtSorting = Map.fromList
[ sortUserNameLink queryUser
, ("avspersonno" , SortColumn $ queryUserAvs >>> (E.^. UserAvsNoPerson))
, ("qualification" , SortColumn $ queryQualification >>> (E.?. QualificationShorthand))
, sortUserCompany queryUser
, ("valid-until" , SortColumn $ queryQualUser >>> (E.?. QualificationUserValidUntil))
, ("last-refresh" , SortColumn $ queryQualUser >>> (E.?. QualificationUserLastRefresh))
, ("first-held" , SortColumn $ queryQualUser >>> (E.?. QualificationUserFirstHeld))
, ("blocked" , SortColumnNeverNull $ queryQualBlock >>> (E.?. QualificationUserBlockFrom))
, ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.?. QualificationUserScheduleRenewal))
-- , ("validity" , SortColumn $ queryQualUser >>> (E.?. QualificationUserValidUntil))
]
dbtFilter = mconcat
[ single $ fltrUserNameEmail queryUser
, single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification' now))
, single ( "user-company", FilterColumn . E.mkExistsFilter $ \row criterion ->
dbtFilter = Map.fromList
[ fltrUserNameEmail queryUser
, ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification' now))
, ( "user-company", FilterColumn . E.mkExistsFilter $ \row criterion ->
E.from $ \(usrComp `E.InnerJoin` comp) -> do
let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf`
(E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text)))
@ -605,14 +720,6 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
, prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany)
]
qualOpt :: Entity Qualification -> Handler (Option QualificationId)
qualOpt (Entity qualId qual) = do
cQualId :: CryptoUUIDQualification <- encrypt qualId
return $ Option
{ optionDisplay = CI.original $ qualificationName qual
, optionInternalValue = qualId
, optionExternalValue = tshow cQualId
}
aLicQid = fmap entityKey . headMay $ filter ((== Just aLic) . qualificationAvsLicence . entityVal) avsQualifications
-- Block identical to Handler/Qualifications TODO: refactor
@ -630,20 +737,20 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
mkOption :: E.Value Text -> Option Text
mkOption (E.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t }
suggestionsBlock :: HandlerFor UniWorX (OptionList Text)
suggestionsBlock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons E.not_)
suggestionsUnblock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons id)
suggestionsBlock = mkOptionList . fmap mkOption <$> runDBRead (getBlockReasons E.not__)
suggestionsUnblock = mkOptionList . fmap mkOption <$> runDBRead (getBlockReasons id)
acts :: Map LicenceTableAction (AForm Handler LicenceTableActionData)
acts = mconcat
[ singletonMap LicenceTableChangeAvs $ pure LicenceTableChangeAvsData
, if aLic == AvsNoLicence
then singletonMap LicenceTableRevokeFDrive $ LicenceTableRevokeFDriveData
<$> apreq (selectField . fmap mkOptionList $ mapM qualOpt avsQualifications) (fslI MsgQualificationName) aLicQid
<$> apreq (selectField qualOpts) (fslI MsgQualificationName) aLicQid
<*> apreq (textField & cfStrip & addDatalist suggestionsBlock) (fslI MsgQualificationBlockReason) Nothing
<*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False)
else singletonMap LicenceTableGrantFDrive $ LicenceTableGrantFDriveData
<$> apreq (selectField . fmap mkOptionList $ mapM qualOpt avsQualifications) (fslI MsgQualificationName) aLicQid
<$> apreq (selectField qualOpts) (fslI MsgQualificationName) aLicQid
<*> apreq (textField & cfStrip & addDatalist suggestionsUnblock) (fslI MsgQualificationGrantReason) Nothing
<*> apreq dayField (fslI MsgLmsQualificationValidUntil) Nothing -- apreq?!
<*> aopt (convertField not not (boolField . Just $ SomeMessage MsgBoolIrrelevant)) (fslI MsgQualificationUserNoRenewal) Nothing
@ -677,52 +784,204 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
getAdminAvsUserR :: CryptoUUIDUser -> Handler Html
getAdminAvsUserR uuid = do
uid <- decrypt uuid
Entity{entityVal=UserAvs{..}} <- runDB $ getBy404 $ UniqueUserAvsUser uid
mAvsQuery <- getsYesod $ view _appAvsQuery
resWgt <- case mAvsQuery of
Nothing -> return [whamlet|Error: AVS interface configuration is incomplete.|] -- should never occur after initilisation
Just AvsQuery{..} -> do
mbContact <- avsQueryContact $ AvsQueryContact $ Set.singleton $ AvsObjPersonId userAvsPersonId
mbDataPerson <- lookupAvsUser userAvsPersonId
return [whamlet|
data UserAvsAction = UserAvsSwitchCompany
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
deriving anyclass (Universe, Finite)
nullaryPathPiece ''UserAvsAction $ camelToPathPiece' 1
embedRenderMessage ''UniWorX ''UserAvsAction id
instance Button UniWorX UserAvsAction where
btnClasses UserAvsSwitchCompany = [BCIsButton, BCDefault]
getAdminAvsUserR, postAdminAvsUserR :: CryptoUUIDUser -> Handler Html
getAdminAvsUserR = postAdminAvsUserR
postAdminAvsUserR uuid = do
isModal <- hasCustomHeader HeaderIsModal
uid <- decrypt uuid
Entity{entityVal=UserAvs{..}} <- runDB $ getBy404 $ UniqueUserAvsUser uid
-- let fltrById prj = over _Wrapped (Set.filter ((== userAvsPersonId) . prj)) -- not sufficiently polymorphic
let fltrIdContact = over _Wrapped (Set.filter ((== userAvsPersonId) . avsContactPersonID))
-- fltrIdStatus = over _Wrapped (Set.filter ((== userAvsPersonId) . avsStatusPersonID))
mbContact <- try $ fmap fltrIdContact $ avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId userAvsPersonId
-- mbStatus <- try $ fmap fltrIdStatus $ avsQuery $ AvsQueryStatus $ Set.singleton userAvsPersonId
mbStatus <- try $ queryAvsFullStatus userAvsPersonId -- TODO: delete Handler.Utils.Avs.lookupAvsUser if no longer needed -- NOTE: currently needed to provide card firms that are missing in AVS status query responses
let compsUsed :: [CompanyName] = stripCI <$> mbStatus ^.. _Right . _Wrapped . folded . _avsStatusPersonCardStatus . folded . _avsDataFirm . _Just
compDict <- if 1 >= length compsUsed
then return mempty -- switch company only sensible if there is more than one company to choose
else do
let switchCompFormHandler :: [(CompanyName,CompanyId)] -> Maybe CompanyId -> Handler Widget
switchCompFormHandler availComps _ | 1 >= length availComps = return mempty -- don't offer a form if there is only one company
switchCompFormHandler availComps mbPrime = do
let switchCompForm :: AForm (HandlerFor UniWorX) (CryptoUUIDUser,CompanyId)
switchCompForm = (,)
<$> apopt hiddenField "" (Just uuid)
<*> areq (selectFieldList [(ciOriginal cn, cid) | (cn, cid) <- availComps]) (fslI MsgUserAvsSwitchCompanyField) mbPrime
<* aopt (buttonField UserAvsSwitchCompany) "" Nothing
switchCompValidate :: FormValidator (CryptoUUIDUser,CompanyId) Handler ()
switchCompValidate = do
(uuid_rcvd,_) <- State.get
guardValidation MsgWrongButtonValue $ uuid_rcvd == uuid
((spRes, spWgt), spEnc) <- runFormPost . validateForm switchCompValidate . identifyForm ("switch-primary-company"::Text) $ renderAForm FormStandard switchCompForm
formResultModal spRes (AdminAvsUserR uuid) (\(_,cid) -> do
lift $ $logInfoS "AVS" ("Switch company option result " <> tshow spRes)
problems <- liftHandler . runDB $ do
(usrUp, problems) <- switchAvsUserCompany True False uid cid
update uid usrUp
forM problems $ \p -> reportAdminProblem p >> msgAdminProblem p
forM_ problems (\p -> do
-- lift $ $logErrorS "AVS" $ "Switch company problem: " <> tshow p -- no instance Show for SomeMessages
tell . pure =<< messageI Warning p
)
let ok = if null problems then Success else Error
tell . pure =<< messageI ok (MsgUserAvsCompanySwitched $ unCompanyKey cid)
)
return $ wrapForm spWgt
def { formAction = Just $ SomeRoute (AdminAvsUserR uuid), formEncoding = spEnc, formSubmit = FormNoSubmit, formAttrs = [ asyncSubmitAttr | isModal ]}
(availComps, primName, primId) <- runDB $ do
mbPrimeUsrComp :: Maybe UserCompany <- getUserPrimaryCompany uid
mbPrimeComp :: Maybe Company <- traverseJoin (get . userCompanyCompany) mbPrimeUsrComp
-- let fltrCmps = (CompanyName <-. compsUsed) : maybeEmpty mbPrimeComp (\Company{companyShorthand=pShort} -> [CompanyShorthand !=. pShort])
comps :: [Entity Company] <- selectList [CompanyName <-. compsUsed] [Asc CompanyName, Asc CompanyAvsId] -- company name is already unique, but AVS sometimes contains uses whitespace
return ([(companyName v, k) | (Entity k v) <- comps], companyName <$> mbPrimeComp, CompanyKey . companyShorthand <$> mbPrimeComp)
-- formDict <- Map.traverseWithKey runSwitchFrom compDict
swForm <- switchCompFormHandler availComps primId
return (primName, swForm)
msgWarningTooltip <- messageI Warning MsgMessageWarning
let warnBolt = messageTooltip msgWarningTooltip
heading = [whamlet|_{MsgAvsPersonNo} #{userAvsNoPerson}|]
siteLayout heading $ do
setTitle $ toHtml $ show userAvsNoPerson
let contactWgt = case mbContact of
Left err -> exceptionWgt err
Right (AvsResponseContact adcs) ->
if null adcs
then [whamlet|_{MsgAvsPersonSearchEmpty}|]
else
let cs = mkContactWgt warnBolt userAvsNoPerson <$> toList adcs
in mconcat cs
cardsWgt = case mbStatus of
Left err -> exceptionWgt err
Right (AvsResponseStatus asts) ->
if null asts
then [whamlet|_{MsgAvsStatusSearchEmpty}|]
else
let cs = mkCardsWgt compDict . avsStatusPersonCardStatus <$> toList asts
in mconcat cs
[whamlet|
<p>
Vorläufige Admin Ansicht AVS Daten.
Ansicht zeigt aktuelle Daten.
Es erfolgte damit aber noch kein Update der FRADrive Daten.
^{contactWgt}
<p>
<dl .deflist>
<dt .deflist__dt>InfoPersonContact <br>
<i>(bevorzugt)
^{cardsWgt}
<p>
_{MsgAvsCurrentData}
|]
where
mkContactWgt :: Widget -> Int -> AvsDataContact -> Widget
mkContactWgt warnBolt reqAvsNo AvsDataContact
{ -- avsContactPersonID = _api
avsContactPersonInfo = AvsPersonInfo{..}
, avsContactFirmInfo = AvsFirmInfo{ avsFirmFirm = firmName }
} =
let avsNoOk = readMay avsInfoPersonNo /= Just reqAvsNo in
[whamlet|
<section .profile>
<dl .deflist.profile-dl>
$if avsNoOk
<dt .deflist__dt>
_{MsgAvsPersonNo}
<dd .deflist__dd>
#{avsInfoPersonNo}
^{warnBolt}
_{MsgAvsPersonNoMismatch}
<dt .deflist__dt>
_{MsgAvsLastName}
<dd .deflist__dd>
$case mbContact
$of Left err
Fehler: #{tshow err}
$of Right contactInfo
#{decodeUtf8 (Pretty.encodePretty (toJSON contactInfo))}
<dt .deflist__dt>PersonStatus und mehrere PersonSearch <br>
<i>(benötigt mehrere AVS Abfragen)
#{avsInfoLastName}
<dt .deflist__dt>
_{MsgAvsFirstName}
<dd .deflist__dd>
$maybe dataPerson <- mbDataPerson
#{decodeUtf8 (Pretty.encodePretty (toJSON dataPerson))}
#{avsInfoFirstName}
<dt .deflist__dt>
_{MsgAvsPrimaryCompany}
<dd .deflist__dd>
#{firmName}
$maybe bday <- avsInfoDateOfBirth
<dt .deflist__dt>
_{MsgAdminUserBirthday}
<dd .deflist__dd>
^{formatTimeW SelFormatDate bday}
<dt .deflist__dt>
_{MsgAvsLicence}
<dd .deflist__dd>
$maybe licence <- parseAvsLicence avsInfoRampLicence
_{licence}
$nothing
Keine Daten erhalten.
<h3>
Provisorische formatierte Ansicht
<p>
Generisch formatierte Ansicht, die zeigt, in welche Richtung die Endansicht gehen könnte.
In der Endansicht wären nur ausgewählte Felder mit besserer Bennenung in einer manuell gewählten Reihenfolge sichtbar.
<p>
^{foldMap jsonWidget mbContact}
<p>
^{foldMap jsonWidget mbDataPerson}
_{MsgAvsNoLicenceGuest}
|]
-- mkCardsWgt :: (Maybe CompanyName, Map CompanyName Widget, Widget) -> Set AvsDataPersonCard -> Widget
mkCardsWgt :: (Maybe CompanyName, Widget) -> Set AvsDataPersonCard -> Widget
mkCardsWgt (mbPrimName, swForm) crds
| null crds = [whamlet|_{MsgAvsCardsEmpty}|]
| otherwise = do
let hasCompany = isJust $ Set.foldr ((<|>) . avsDataFirm) Nothing crds -- some if, since a true AVS status query never delivers values for these fields, but queryAvsFullStatus-workaround does
hasIssueDate = isJust $ Set.foldr ((<|>) . avsDataIssueDate) Nothing crds
hasValidToDate = isJust $ Set.foldr ((<|>) . avsDataValidTo) Nothing crds
[whamlet|
<div .scrolltable .scrolltable-bordered>
<table .table .table--striped>
<thead>
<tr .table__row .table__row--head>
<th .table__th>_{MsgAvsCardNo}
<th .table__th>_{MsgTableAvsCardValid}
<th .table__th>_{MsgAvsCardColor}
<th .table__th>_{MsgAvsCardAreas}
$if hasIssueDate
<th .table__th>_{MsgTableAvsCardIssueDate}
$if hasValidToDate
<th .table__th>_{MsgTableAvsCardValidTo}
$if hasCompany
<th .table__th>_{MsgTableCompany}
<th .table__th>_{MsgAvsPrimaryCompany}
<tbody>
$forall c <- Set.toDescList crds
$with AvsDataPersonCard{avsDataValid,avsDataCardColor,avsDataCardAreas,avsDataFirm,avsDataIssueDate,avsDataValidTo} <- c
<tr .table__row>
<td .table__td>
#{tshowAvsFullCardNo (getFullCardNo c)}
<td .table__td>
#{boolSymbol avsDataValid}
<td .table__td>
_{avsDataCardColor}
<td .table__td>
$forall a <- avsDataCardAreas
#{a} #
$if hasIssueDate
<td .table__td>
$maybe d <- avsDataIssueDate
^{formatTimeW SelFormatDate d}
$if hasValidToDate
<td .table__td>
$maybe d <- avsDataValidTo
^{formatTimeW SelFormatDate d}
$if hasCompany
<td .table__td>
$maybe f <- avsDataFirm
#{f}
<td .table__td>
$maybe f <- avsDataFirm
$with fci <- stripCI f
$maybe primName <- mbPrimName
$if (primName == fci)
_{MsgAvsPrimaryCompany}
<p>
^{swForm}
|]
let heading = [whamlet|_{MsgAvsPersonNo} #{userAvsNoPerson}|]
siteLayout heading $ do
setTitle $ toHtml $ show userAvsNoPerson
resWgt
instance HasEntity (DBRow (Entity UserAvs, Entity User)) User where
hasEntity = _dbrOutput . _2
@ -740,16 +999,16 @@ getProblemAvsErrorR = do
dbtSQLQuery (usravs `E.InnerJoin` user) = do
E.on $ usravs E.^. UserAvsUser E.==. user E.^. UserId
E.where_ $ E.isJust $ usravs E.^. UserAvsLastSynchError
return (usravs, user)
qerryUsrAvs :: (E.SqlExpr (Entity UserAvs) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity UserAvs)
qerryUsrAvs = $(E.sqlIJproj 2 1)
qerryUser :: (E.SqlExpr (Entity UserAvs) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity User)
qerryUser = $(E.sqlIJproj 2 2)
return (usravs, user) -- , E.substring (usravs E.^. UserAvsLastSynchError) (E.val ("'#\"%#\" %'") (E.val "#")) -- needs a different type on substring
querryUsrAvs :: (E.SqlExpr (Entity UserAvs) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity UserAvs)
querryUsrAvs = $(E.sqlIJproj 2 1)
querryUser :: (E.SqlExpr (Entity UserAvs) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity User)
querryUser = $(E.sqlIJproj 2 2)
reserrUsrAvs :: Lens' (DBRow (Entity UserAvs, Entity User)) (Entity UserAvs)
reserrUsrAvs = _dbrOutput . _1
-- reserrUser :: Lens' (DBRow (Entity UserAvs, Entity User)) (Entity User)
-- reserrUser = _dbrOutput . _2
dbtRowKey = qerryUsrAvs >>> (E.^. UserAvsId)
dbtRowKey = querryUsrAvs >>> (E.^. UserAvsId)
dbtProj = dbtProjId
dbtColonnade = dbColonnade $ mconcat
[ colUserNameModalHdrAdmin MsgLmsUser AdminUserR
@ -762,15 +1021,15 @@ getProblemAvsErrorR = do
, sortable (Just "avs-last-error") (i18nCell MsgLastAvsSynchError)
$ cellMaybe textCell . view (reserrUsrAvs . _entityVal . _userAvsLastSynchError)
]
dbtSorting = mconcat
[ single (sortUserNameLink qerryUser)
, single ("avs-nr" , SortColumn $ qerryUsrAvs >>> (E.^. UserAvsNoPerson))
, single ("avs-last-synch", SortColumnNullsInv $ qerryUsrAvs >>> (E.^. UserAvsLastSynch))
, single ("avs-last-error", SortColumn $ qerryUsrAvs >>> (E.^. UserAvsLastSynchError))
dbtSorting = Map.fromList
[ sortUserNameLink querryUser
, ("avs-nr" , SortColumn $ querryUsrAvs >>> (E.^. UserAvsNoPerson))
, ("avs-last-synch", SortColumnNullsInv $ querryUsrAvs >>> (E.^. UserAvsLastSynch))
, ("avs-last-error", SortColumn $ querryUsrAvs >>> (E.^. UserAvsLastSynchError))
]
dbtFilter = mconcat
[ single $ fltrUserNameEmail qerryUser
, single ("avs-last-error", FilterColumn $ E.mkContainsFilterWithCommaPlus Just $ views (to qerryUsrAvs) (E.^. UserAvsLastSynchError))
dbtFilter = Map.fromList
[ fltrUserNameEmail querryUser
, ("avs-last-error", FilterColumn $ E.mkContainsFilterWithCommaPlus Just $ views (to querryUsrAvs) (E.^. UserAvsLastSynchError))
]
dbtFilterUI mPrev = mconcat
[ fltrUserNameEmailHdrUI MsgLmsUser mPrev
@ -788,4 +1047,3 @@ getProblemAvsErrorR = do
siteLayoutMsg MsgMenuAvsSynchError $ do
setTitleI MsgMenuAvsSynchError
[whamlet|^{avsSyncErrTbl}|]

31
src/Handler/Admin/Crontab.hs
View File

@ -35,6 +35,9 @@ import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.Utils as E
-- import Database.Esqueleto.Utils.TH
-- Number of minutes a job must have been locked already to allow forced deletion
jobDeleteLockMinutes :: Int
jobDeleteLockMinutes = 3
deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece' 1
@ -118,7 +121,9 @@ instance Finite JobTableAction
nullaryPathPiece ''JobTableAction $ camelToPathPiece' 1
embedRenderMessage ''UniWorX ''JobTableAction id
data JobTableActionData = ActJobDeleteData
newtype JobTableActionData = ActJobDeleteData
{ jobDeleteLocked :: Bool
}
deriving (Eq, Ord, Read, Show, Generic)
@ -164,7 +169,8 @@ postAdminJobsR = do
]
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
acts :: Map JobTableAction (AForm Handler JobTableActionData)
acts = Map.singleton ActJobDelete $ pure ActJobDeleteData
acts = Map.singleton ActJobDelete $ ActJobDeleteData
<$> areq checkBoxField (fslI $ MsgActJobDeleteForce jobDeleteLockMinutes) Nothing
dbtParams = DBParamsForm
{ dbParamsFormAdditional =
renderAForm FormStandard
@ -193,13 +199,22 @@ postAdminJobsR = do
(jobActRes, jobsTable) <- runDB (over _1 postprocess <$> dbTable jobsDBTableValidator jobsDBTable)
formResult jobActRes $ \case
(ActJobDeleteData, jobIds) -> do
let jobReq = length jobIds
(ActJobDeleteData{jobDeleteLocked}, jobIds) -> do
now <- liftIO getCurrentTime
let cutoff :: UTCTime
cutoff = addUTCTime (nominalMinute * fromIntegral (negate jobDeleteLockMinutes)) now
jobReq = length jobIds
lockCriteria
| jobDeleteLocked =
[ QueuedJobLockTime ==. Nothing ] ||.
[ QueuedJobLockTime <=. Just cutoff ]
| otherwise =
[ QueuedJobLockTime ==. Nothing
, QueuedJobLockInstance ==. Nothing
]
rmvd <- runDB $ fromIntegral <$> deleteWhereCount
[ QueuedJobLockTime ==. Nothing
, QueuedJobLockInstance ==. Nothing
, QueuedJobId <-. Set.toList jobIds
]
((QueuedJobId <-. Set.toList jobIds) : lockCriteria)
addMessageI (bool Success Warning $ rmvd < jobReq) (MsgTableJobActDeleteFeedback rmvd jobReq)
reloadKeepGetParams AdminJobsR

34
src/Handler/Admin/Test.hs
View File

@ -28,7 +28,9 @@ import Text.Hamlet
-- import Handler.Utils.I18n
import Handler.Admin.Test.Download (testDownload)
import qualified Database.Esqueleto.Experimental as E (selectOne, unValue)
import qualified Database.Esqueleto.PostgreSQL as E (now_)
import qualified Database.Esqueleto.Utils as E (psqlVersion_)
-- BEGIN - Buttons needed only here
data ButtonCreate = CreateMath | CreateInf | CrashApp -- Dummy for Example
@ -112,7 +114,7 @@ postAdminTestR = do
let emailWidget' = wrapForm emailWidget def
{ formAction = Just . SomeRoute $ AdminTestR
, formEncoding = emailEnctype
, formAttrs = [("uw-async-form", "")]
, formAttrs = [asyncSubmitAttr] -- equivalent to [("uw-async-form", "")]
}
now <- liftIO getCurrentTime
@ -226,10 +228,13 @@ postAdminTestR = do
UniWorX{ appSettings' = AppSettings{..} } <- getYesod
psqlVersion <- runDBRead $ E.selectOne $ return E.psqlVersion_
dbTime <- runDBRead $ E.selectOne $ return E.now_
let locallyDefinedPageHeading = [whamlet|Admin TestPage for Uni2work|]
siteLayout locallyDefinedPageHeading $ do
-- defaultLayout $ do
setTitle "Uni2work Admin Testpage"
setTitle "Uni2work Admin Testpage"
$(i18nWidgetFile "admin-test")
@ -327,19 +332,30 @@ postAdminTestR = do
<dd .deflist__dd>#{tshow appSynchroniseAvsUsersWithin}
|]
[whamlet|
<section>
<h2> PostgreSQL Information
<dl .deflist>
$maybe pver <- psqlVersion
<dt .deflist__dt>DB Version
<dd .deflist__dd>#{E.unValue pver}
$maybe ptme <- dbTime
<dt .deflist__dt>DB Time
<dd .deflist__dd>#{tshow (E.unValue ptme)}
|]
getAdminTestPdfR :: Handler TypedContent
getAdminTestPdfR = do
usr <- requireAuth -- to determine language and recipient for test
usr <- requireAuth -- to determine language and recipient for test
qual <- fromMaybeM
(addMessage Error "Keine Qualifikation in der Datenbank zur Erzeugung eines Test-PDFs gefunden." >> redirect AdminTestR)
(runDB $ selectFirst [] [Asc QualificationAvsLicence, Asc QualificationShorthand])
encRecipient :: CryptoUUIDUser <- encrypt $ usr ^. _entityKey
now <- liftIO getCurrentTime
let nowaday = utctDay now
letter = LetterRenewQualificationF
letter = LetterRenewQualification
{ lmsLogin = LmsIdent "abcdefgh"
, lmsPin = "12345678"
, qualHolderID = usr ^. _entityKey
@ -351,15 +367,17 @@ getAdminTestPdfR = do
, qualShort = qual ^. _qualificationShorthand . _CI
, qualSchool = qual ^. _qualificationSchool
, qualDuration = qual ^. _qualificationValidDuration
, qualRenewAuto = qual ^. _qualificationElearningRenews
, qualELimit = qual ^. _qualificationElearningLimit
, isReminder = False
}
}
apcIdent <- letterApcIdent letter encRecipient now
renderLetterPDF usr letter apcIdent >>= \case
renderLetterPDF usr letter apcIdent Nothing >>= \case
Left err -> sendResponseStatus internalServerError500 $ "PDF generation failed: \n" <> err
Right pdf -> do
liftIO $ LBS.writeFile "/tmp/generated.pdf" pdf
encryptPDF "tomatenmarmelade" pdf >>= \case
Left err -> sendResponseStatus internalServerError500 $ "PDFtk error: \n" <> err
Right encPdf -> do
Right encPdf -> do
liftIO $ LBS.writeFile "/tmp/crypted.pdf" encPdf
sendByteStringAsFile "demoPDF.pdf" (LBS.toStrict pdf) now

147
src/Handler/CommCenter.hs Normal file
View File

@ -0,0 +1,147 @@
-- SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Handler.CommCenter
( getCommCenterR
) where
import Import
import Handler.Utils
-- import qualified Data.Set as Set
import qualified Data.Map as Map
-- import qualified Data.Text as Text
import Data.Text.Lens (packed)
-- import Database.Persist.Sql (updateWhereCount)
-- import Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Legacy as EL (on) -- only `on` and `from` are different, needed for dbTable using Esqueleto.Legacy
import qualified Database.Esqueleto.Experimental as E
import qualified Database.Esqueleto.Utils as E
import qualified Database.Esqueleto.PostgreSQL as E
import Database.Esqueleto.Utils.TH
data CCTableAction = CCActDummy -- just a dummy, since we don't now yet which actions we will be needing
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
instance Universe CCTableAction
instance Finite CCTableAction
nullaryPathPiece ''CCTableAction $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''CCTableAction id
data CCTableActionData = CCActDummyData
deriving (Eq, Ord, Read, Show, Generic)
-- SJ: I don't know how to use E.unionAll_ with dbTable, so we simulate it by a FullOuterJoin with constant False ON-clause instead
type CCTableExpr =
( (E.SqlExpr (Maybe (Entity User)) `E.InnerJoin` E.SqlExpr (Maybe (Entity SentMail)))
`E.FullOuterJoin` (E.SqlExpr (Maybe (Entity User)) `E.InnerJoin` E.SqlExpr (Maybe (Entity PrintJob)))
)
queryRecipientMail :: CCTableExpr -> E.SqlExpr (Maybe (Entity User))
queryRecipientMail = $(sqlIJproj 2 1) . $(sqlFOJproj 2 1)
queryMail :: CCTableExpr -> E.SqlExpr (Maybe (Entity SentMail))
queryMail = $(sqlIJproj 2 2) . $(sqlFOJproj 2 1)
queryRecipientPrint :: CCTableExpr -> E.SqlExpr (Maybe (Entity User))
queryRecipientPrint = $(sqlIJproj 2 1) . $(sqlFOJproj 2 2)
queryPrint :: CCTableExpr -> E.SqlExpr (Maybe (Entity PrintJob))
queryPrint = $(sqlIJproj 2 2) . $(sqlFOJproj 2 2)
type CCTableData = DBRow (Maybe (Entity User), Maybe (Entity SentMail), Maybe (Entity User), Maybe (Entity PrintJob))
resultRecipientMail :: Traversal' CCTableData (Entity User)
resultRecipientMail = _dbrOutput . _1 . _Just
resultMail :: Traversal' CCTableData (Entity SentMail)
resultMail = _dbrOutput . _2 . _Just
resultRecipientPrint :: Traversal' CCTableData (Entity User)
resultRecipientPrint = _dbrOutput . _3 . _Just
resultPrint :: Traversal' CCTableData (Entity PrintJob)
resultPrint = _dbrOutput . _4 . _Just
mkCCTable :: DB (Any, Widget)
mkCCTable = do
let
dbtSQLQuery :: CCTableExpr -> E.SqlQuery (E.SqlExpr (Maybe (Entity User)), E.SqlExpr (Maybe (Entity SentMail)), E.SqlExpr (Maybe (Entity User)), E.SqlExpr (Maybe (Entity PrintJob)))
dbtSQLQuery ((recipientMail `E.InnerJoin` mail) `E.FullOuterJoin` (recipientPrint `E.InnerJoin` printJob)) = do
EL.on $ recipientMail E.?. UserId E.==. E.joinV (mail E.?. SentMailRecipient)
EL.on $ recipientPrint E.?. UserId E.==. E.joinV (printJob E.?. PrintJobRecipient)
-- EL.on $ recipientMail E.?. UserId E.==. recipientPrint E.?. UserId E.&&. E.false -- simulating E.unionAll_ by a constant false full outer join, since it is unclear how dbTable could handle E.unionAll_
EL.on E.false -- simulating E.unionAll_ by a constant false full outer join, since it is unclear how dbTable could handle E.unionAll_
-- E.where_ $ E.isJust (recipientMail E.?. UserId) E.||. E.isJust (recipientPrint E.?. UserId) -- not needed for full outer join
-- return (E.coalesce[recipientMail, recipientPrint], mail, print) -- coalesce only works on values, not entities
return (recipientMail, mail, recipientPrint, printJob)
-- dbtRowKey = (,) <$> views (to queryMail) (E.?. SentMailId) <*> views (to queryPrint) (E.?. PrintJobId)
dbtRowKey ((_recipientMail `E.InnerJoin` mail) `E.FullOuterJoin` (_recipientPrint `E.InnerJoin` printJob)) = (mail E.?. SentMailId, printJob E.?. PrintJobId)
dbtProj = dbtProjId
dbtColonnade = dbColonnade $ mconcat -- prefer print over email in the impossible case that both are Just
[ sortable (Just "date") (i18nCell MsgPrintJobCreated) $ \row ->
let tprint = row ^? resultPrint . _entityVal . _printJobCreated
tmail = row ^? resultMail . _entityVal . _sentMailSentAt
in maybeCell (tprint <|> tmail) dateTimeCell
, sortable (Just "recipient") (i18nCell MsgPrintRecipient) $ \row ->
let uprint = row ^? resultRecipientPrint
umail = row ^? resultRecipientMail
in maybeCell (uprint <|> umail) $ cellHasUserLink AdminUserR
, sortable Nothing (i18nCell MsgCommBody) $ \row -> if
| (Just k) <- row ^? resultPrint . _entityKey
-> anchorCellM (PrintDownloadR <$> encrypt k) $ toWgt (iconLetterOrEmail True ) <> text2widget "-link"
| (Just k) <- row ^? resultMail . _entityKey
-> anchorCellM (MailHtmlR <$> encrypt k) $ toWgt (iconLetterOrEmail False) <> text2widget "-link"
| otherwise
-> mempty
, sortable Nothing (i18nCell MsgCommSubject) $ \row ->
let tsubject = row ^? resultPrint . _entityVal . _printJobFilename . packed
msubject = row ^? resultMail . _entityVal . _sentMailHeaders . _mailHeaders' . _mailHeader' "Subject"
in maybeCell (tsubject <|> msubject) textCell
]
dbtSorting = mconcat
[ singletonMap "date" $ SortColumn $ \row -> E.coalesce [queryPrint row E.?. PrintJobCreated, queryMail row E.?. SentMailSentAt]
, singletonMap "recipient" $ SortColumns $ \row ->
[ SomeExprValue $ E.coalesce [queryRecipientPrint row E.?. UserSurname , queryRecipientMail row E.?. UserSurname ]
, SomeExprValue $ E.coalesce [queryRecipientPrint row E.?. UserDisplayName, queryRecipientMail row E.?. UserDisplayName]
]
]
dbtFilter = Map.fromList
[ ("sent" , FilterColumn . E.mkDayFilterTo
$ \row -> E.coalesceDefault [queryPrint row E.?. PrintJobCreated, queryMail row E.?. SentMailSentAt] E.now_) -- either one is guaranteed to be non-null, default never used
, ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just
$ \row -> E.coalesce [queryRecipientPrint row E.?. UserDisplayName, queryRecipientMail row E.?. UserDisplayName])
, ("subject" , FilterColumn . E.mkContainsFilterWithCommaPlus Just
$ \row -> E.coalesce [E.str2text' $ queryPrint row E.?. PrintJobFilename
,E.str2text' $ queryMail row E.?. SentMailHeaders ])
]
dbtFilterUI mPrev = mconcat
[ prismAForm (singletonFilter "date" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgPrintJobCreated)
, prismAForm (singletonFilter "recipient" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintRecipient & setTooltip MsgTableFilterCommaPlus)
, prismAForm (singletonFilter "subject" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgCommSubject & setTooltip MsgTableFilterCommaPlusShort)
]
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout}
dbtIdent :: Text
dbtIdent = "comms"
dbtCsvEncode = noCsvEncode
dbtCsvDecode = Nothing
dbtExtraReps = []
dbtParams = def
psValidator = def & defaultSorting [SortDescBy "date"]
dbTable psValidator DBTable{..}
getCommCenterR :: Handler Html
getCommCenterR = do
(_, ccTable) <- runDB mkCCTable
siteLayoutMsg MsgMenuCommCenter $ do
setTitleI MsgMenuCommCenter
$(widgetFile "comm-center")

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

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>,Winnie Ros <winnie.ros@campus.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
@ -46,12 +46,13 @@ data CourseForm = CourseForm
, cfRegTo :: Maybe UTCTime
, cfDeRegUntil :: Maybe UTCTime
, cfLecturers :: [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)]
, cfQualis :: [(QualificationId, Int)]
}
makeLenses_ ''CourseForm
courseToForm :: Entity Course -> [Lecturer] -> Map UserEmail (InvitationDBData Lecturer) -> CourseForm
courseToForm (Entity cid Course{..}) lecs lecInvites = CourseForm
courseToForm :: Entity Course -> [Lecturer] -> Map UserEmail (InvitationDBData Lecturer) -> [CourseQualification] -> CourseForm
courseToForm (Entity cid Course{..}) lecs lecInvites qualis = CourseForm
{ cfCourseId = Just cid
, cfName = courseName
, cfDesc = courseDescription
@ -69,6 +70,9 @@ courseToForm (Entity cid Course{..}) lecs lecInvites = CourseForm
, cfDeRegUntil = courseDeregisterUntil
, cfLecturers = [Right (lecturerUser, lecturerType) | Lecturer{..} <- lecs]
++ [Left (email, mType) | (email, InvDBDataLecturer mType) <- Map.toList lecInvites ]
-- TODO: Filterung nach aktueller Schule, da ansonsten ein Sicherheitleck droht! Siehe #150
, cfQualis = [ (courseQualificationQualification, courseQualificationSortOrder)
| CourseQualification{..} <- qualis, courseQualificationCourse == cid ]
}
@ -81,17 +85,19 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
MsgRenderer mr <- getMsgRenderer
uid <- liftHandler requireAuthId
(lecturerSchools, adminSchools, oldSchool) <- liftHandler . runDB $ do
lecturerSchools <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolLecturer]] []
protoAdminSchools <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolAdmin]] []
adminSchools <- filterM (hasWriteAccessTo . flip SchoolR SchoolEditR) protoAdminSchools
(userSchools, elegibleQualifications) :: ([SchoolId], OptionList QualificationId) <- liftHandler . runDB $ do
lecturerSchools <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolLecturer]] []
protoAdminSchools <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolAdmin]] [] -- default rights
adminSchools <- filterM (hasWriteAccessTo . flip SchoolR SchoolEditR) protoAdminSchools -- and user as admin rights active right now
oldSchool <- forM (cfCourseId =<< template) $ fmap courseSchool . getJust
return (lecturerSchools, adminSchools, oldSchool)
let userSchools = nubOrd . maybe id (:) oldSchool $ lecturerSchools ++ adminSchools
let elegibleSchools = Set.fromList $ lecturerSchools ++ adminSchools
userSchools = Set.toList $ maybe id Set.insert oldSchool elegibleSchools
elegibleQualifications <- selectList [QualificationSchool <-. Set.toList elegibleSchools] [Asc QualificationName, Asc QualificationSchool]
return (userSchools, qualificationsOptionList elegibleQualifications)
(termsField, userTerms) <- liftHandler $ case template of
-- Change of term is only allowed if user may delete the course (i.e. no participants) or admin
(Just cform) | (Just cid) <- cfCourseId cform -> do -- edit existing course
(Just cform) | (Just cid) <- cfCourseId cform -> do -- edit existing course& \c
_courseOld@Course{..} <- runDB $ get404 cid
mayEditTerm <- isAuthorized TermEditR True
mayDelete <- isAuthorized (CourseR courseTerm courseSchool courseShorthand CDeleteR) True
@ -102,51 +108,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
-> return (termsSetField [cfTerm cform], [cfTerm cform])
_allOtherCases -> (termsAllowedField, ) . Set.toList <$> runDB getActiveTerms
let miAdd :: ListPosition -> Natural -> ListLength -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))))
miAdd _ _ _ nudge btn = Just $ \csrf -> do
(addRes, addView) <- mpreq (multiUserInvitationField $ MUILookupAnyUser Nothing) (fslI MsgCourseLecturerEmail & addName (nudge "email") & addPlaceholder (mr MsgLdapIdentificationOrEmail)) Nothing
let addRes'' = addRes <&> \newDat oldDat -> if
| existing <- newDat `Set.intersection` Set.fromList (Map.elems oldDat)
, not $ Set.null existing
-> FormFailure [mr MsgCourseLecturerAlreadyAdded]
| otherwise
-> FormSuccess . Map.fromList . zip [maybe 0 (succ . fst) $ Map.lookupMax oldDat ..] $ Set.toList newDat
addView' = $(widgetFile "course/lecturerMassInput/add")
return (addRes'', addView')
miCell :: ListPosition -> Either UserEmail UserId -> Maybe (Maybe LecturerType) -> (Text -> Text) -> Form (Maybe LecturerType)
miCell _ (Right lid) defType nudge = \csrf -> do
(lrwRes,lrwView) <- mreq (selectField optionsFinite) (fslI MsgCourseLecturerType & addName (nudge "lecturer-type")) (join defType)
usr <- liftHandler . runDB $ get404 lid
let lrwView' = $(widgetFile "course/lecturerMassInput/cellKnown")
return (Just <$> lrwRes,lrwView')
miCell _ (Left lEmail) defType nudge = \csrf -> do
(lrwRes,lrwView) <- mopt (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) defType
invWarnMsg <- messageIconI Info IconEmail MsgEmailInvitationWarning
let lrwView' = $(widgetFile "course/lecturerMassInput/cellInvitation")
return (lrwRes,lrwView')
miDelete :: Map ListPosition (Either UserEmail UserId) -- ^ Current shape
-> ListPosition -- ^ Coordinate to delete
-> MaybeT (MForm (HandlerFor UniWorX)) (Map ListPosition ListPosition)
miDelete = miDeleteList
miAddEmpty :: ListPosition -> Natural -> ListLength -> Set ListPosition
miAddEmpty _ _ _ = Set.empty
miLayout :: ListLength
-> Map ListPosition (Either UserEmail UserId, FormResult (Maybe LecturerType)) -- ^ massInput state
-> Map ListPosition Widget -- ^ Cell widgets
-> Map ListPosition (FieldView UniWorX) -- ^ Deletion buttons
-> Map (Natural, ListPosition) Widget -- ^ Addition widgets
-> Widget
miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "course/lecturerMassInput/layout")
miIdent :: Text
miIdent = "lecturers"
lecturerForm :: AForm Handler [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)]
let lecturerForm :: AForm Handler [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)]
lecturerForm = formToAForm . over (mapped._2) pure . over (mapped._1.mapped) (map liftEither . Map.elems) $ massInput
MassInput{..}
(fslI MsgCourseLecturers & setTooltip MsgCourseLecturerRightsIdentical)
@ -163,6 +125,79 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
unliftEither (Right (lid , lType )) = (Right lid , Just lType)
unliftEither (Left (lEmail, mLType)) = (Left lEmail, mLType )
miAdd :: ListPosition -> Natural -> ListLength -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))))
miAdd _ _ _ nudge btn = Just $ \csrf -> do
(addRes, addView) <- mpreq (multiUserInvitationField $ MUILookupAnyUser Nothing) (fslI MsgCourseLecturerEmail & addName (nudge "email") & addPlaceholder (mr MsgLdapIdentificationOrEmail)) Nothing
let addRes'' = addRes <&> \newDat oldDat -> if
| existing <- newDat `Set.intersection` Set.fromList (Map.elems oldDat)
, not $ Set.null existing
-> FormFailure [mr MsgCourseLecturerAlreadyAdded]
| otherwise
-> FormSuccess . Map.fromList . zip [maybe 0 (succ . fst) $ Map.lookupMax oldDat ..] $ Set.toList newDat
addView' = $(widgetFile "course/lecturerMassInput/add")
return (addRes'', addView')
miCell :: ListPosition -> Either UserEmail UserId -> Maybe (Maybe LecturerType) -> (Text -> Text) -> Form (Maybe LecturerType)
miCell _ (Right lid) defType nudge = \csrf -> do
(lrwRes,lrwView) <- mreq (selectField optionsFinite) (fslI MsgCourseLecturerType & addName (nudge "lecturer-type")) (join defType)
usr <- liftHandler . runDB $ get404 lid
let lrwView' = $(widgetFile "course/lecturerMassInput/cellKnown")
return (Just <$> lrwRes,lrwView')
miCell _ (Left lEmail) defType nudge = \csrf -> do
(lrwRes,lrwView) <- mopt (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) defType
invWarnMsg <- messageIconI Info IconEmail MsgEmailInvitationWarning
let lrwView' = $(widgetFile "course/lecturerMassInput/cellInvitation")
return (lrwRes,lrwView')
miDelete :: Map ListPosition (Either UserEmail UserId) -- ^ Current shape
-> ListPosition -- ^ Coordinate to delete
-> MaybeT (MForm (HandlerFor UniWorX)) (Map ListPosition ListPosition)
miDelete = miDeleteList
miAddEmpty :: ListPosition -> Natural -> ListLength -> Set ListPosition
miAddEmpty _ _ _ = Set.empty
miLayout :: ListLength
-> Map ListPosition (Either UserEmail UserId, FormResult (Maybe LecturerType)) -- ^ massInput state
-> Map ListPosition Widget -- ^ Cell widgets
-> Map ListPosition (FieldView UniWorX) -- ^ Deletion buttons
-> Map (Natural, ListPosition) Widget -- ^ Addition widgets
-> Widget
miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "course/lecturerMassInput/layout")
miIdent :: Text
miIdent = "lecturers"
qualificationsForm :: Maybe [(QualificationId, Int)] -> AForm Handler [(QualificationId, Int)] -- filter by admin school done later through upsertCourseQualifications
qualificationsForm = massInputAccumEditA miAdd miEdit miButtonAction miLayout miIdent (fslI $ MsgCourseQualifications 9) False
where
miIdent :: Text
miIdent = "qualifications"
miAdd :: (Text -> Text) -> FieldView UniWorX -> Form ([(QualificationId,Int)] -> FormResult [(QualificationId,Int)])
miAdd nudge submitView csrf = do
(formRes, formView) <- aCourseQualiForm nudge Nothing csrf
let addRes = formRes <&> \newDat@(newQid,oldOrd) (unzip -> (oldQids,oldOrds)) ->
let qidBad = guardMonoid (newQid `elem` oldQids) [mr MsgCourseEditQualificationFailExists]
ordBad = guardMonoid (oldOrd `elem` oldOrds) [mr MsgCourseEditQualificationFailOrder ]
problems = qidBad ++ ordBad
in if null problems
then FormSuccess $ pure newDat
else FormFailure problems
return (addRes, $(widgetFile "widgets/massinput/courseQualifications/add"))
miEdit :: (Text -> Text) -> (QualificationId, Int) -> Form (QualificationId, Int)
miEdit nudge = aCourseQualiForm nudge . Just
miLayout :: MassInputLayout ListLength (QualificationId,Int) (QualificationId, Int)
miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/courseQualifications/layout")
aCourseQualiForm :: (Text -> Text) -> Maybe (QualificationId, Int) -> Form (QualificationId, Int)
aCourseQualiForm nudge mTemplate csrf = do
(cquRes, cquView) <- mpreq (selectField $ pure elegibleQualifications) ("" & addName (nudge "cquali")) (view _1 <$> mTemplate)
(ordRes, ordView) <- mpreq intField ("" & addName (nudge "cqordr")) (view _2 <$> mTemplate)
return ((,) <$> cquRes <*> ordRes, $(widgetFile "widgets/massinput/courseQualifications/form"))
(newVisFrom,newRegFrom,newRegTo,newDeRegUntil) <- case template of
(Just cform) | (Just _cid) <- cfCourseId cform -> return (Nothing,Nothing,Nothing,Nothing)
_allIOtherCases -> do
@ -208,6 +243,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
& setTooltip MsgCourseDeregisterUntilTip) (deepAlt (cfDeRegUntil <$> template) newDeRegUntil)
<* aformSection MsgCourseFormSectionAdministration
<*> lecturerForm
<*> qualificationsForm (cfQualis <$> template)
return (result, widget)
@ -227,6 +263,10 @@ validateCourse = do
unless userAdmin $ do
guardValidation MsgCourseUserMustBeLecturer
$ anyOf (traverse . _Right . _1) (== uid) cfLecturers
guardValidation MsgCourseEditQualificationFailExists
$ not $ hasDuplicates $ fst <$> cfQualis
guardValidation MsgCourseEditQualificationFailOrder
$ not $ hasDuplicates $ snd <$> cfQualis
warnValidation MsgCourseShorthandTooLong
$ length (CI.original cfShort) <= 10
@ -280,8 +320,11 @@ getCourseNewR = do
E.limit 1
return course
template <- case oldCourses of
(oldTemplate:_) ->
let newTemplate = courseToForm oldTemplate mempty mempty in
(oldTemplate:_) -> runDB $ do
mbLecs <- oldTemplate & \course -> map entityVal <$> selectList [LecturerCourse ==. entityKey course] [Asc LecturerType]
mbLecInvites <- oldTemplate & sourceInvitationsF . entityKey
mbQualis <- oldTemplate & \course -> map entityVal <$> selectList [CourseQualificationCourse ==. entityKey course] [Asc CourseQualificationSortOrder]
let newTemplate = courseToForm oldTemplate mbLecs mbLecInvites mbQualis
return $ Just $ newTemplate
{ cfCourseId = Nothing
, cfTerm = TermKey $ termFromRational 0 -- invalid, will be ignored; undefined won't work due to strictness
@ -291,9 +334,9 @@ getCourseNewR = do
}
[] -> do
(tidOk,sshOk,cshOk) <- runDB $ (,,)
<$> ifMaybeM mbTid True existsKey
<*> ifMaybeM mbSsh True existsKey
<*> ifMaybeM mbCsh True (\csh -> not . null <$> selectKeysList [CourseShorthand ==. csh] [LimitTo 1])
<$> ifNothingM mbTid True existsKey
<*> ifNothingM mbSsh True existsKey
<*> ifNothingM mbCsh True (\csh -> not . null <$> selectKeysList [CourseShorthand ==. csh] [LimitTo 1])
unless tidOk $ addMessageI Warning $ MsgNoSuchTerm $ fromJust mbTid -- safe, since tidOk==True otherwise
unless sshOk $ addMessageI Warning $ MsgNoSuchSchool $ fromJust mbSsh -- safe, since sshOk==True otherwise
unless cshOk $ addMessageI Warning $ MsgNoSuchCourseShorthand $ fromJust mbCsh
@ -314,10 +357,11 @@ pgCEditR tid ssh csh = do
mbCourse <- getBy (TermSchoolCourseShort tid ssh csh)
mbLecs <- for mbCourse $ \course -> map entityVal <$> selectList [LecturerCourse ==. entityKey course] [Asc LecturerType]
mbLecInvites <- for mbCourse $ sourceInvitationsF . entityKey
return $ (,,) <$> mbCourse <*> mbLecs <*> mbLecInvites
mbQualis <- for mbCourse $ \course -> map entityVal <$> selectList [CourseQualificationCourse ==. entityKey course] [Asc CourseQualificationSortOrder]
return $ (,,,) <$> mbCourse <*> mbLecs <*> mbLecInvites <*> mbQualis
-- IMPORTANT: both GET and POST Handler must use the same template,
-- since an Edit is identified via CourseID, which is not embedded in the received form data for security reasons.
courseEditHandler (\p -> Just . SomeRoute $ CourseR tid ssh csh CEditR :#: p) $ $(uncurryN 3) courseToForm <$> courseData
courseEditHandler (\p -> Just . SomeRoute $ CourseR tid ssh csh CEditR :#: p) $ $(uncurryN 4) courseToForm <$> courseData
-- | Course Creation and Editing
@ -357,6 +401,7 @@ courseEditHandler miButtonAction mbCourseForm = do
let (invites, adds) = partitionEithers $ cfLecturers res
insertMany_ $ map (\(lid, lty) -> Lecturer lid cid lty) adds
sinkInvitationsF lecturerInvitationConfig $ map (\(lEmail, mLty) -> (lEmail, cid, (InvDBDataLecturer mLty, InvTokenDataLecturer))) invites
void $ upsertCourseQualifications aid cid $ cfQualis res
insert_ $ CourseEdit aid now cid
memcachedByInvalidate AuthCacheLecturerList $ Proxy @(Set UserId)
return insertOkay
@ -405,11 +450,10 @@ courseEditHandler miButtonAction mbCourseForm = do
let (invites, adds) = partitionEithers $ cfLecturers res
insertMany_ $ map (\(lid, lty) -> Lecturer lid cid lty) adds
sinkInvitationsF lecturerInvitationConfig $ map (\(lEmail, mLty) -> (lEmail, cid, (InvDBDataLecturer mLty, InvTokenDataLecturer))) invites
void $ upsertCourseQualifications aid cid $ cfQualis res
insert_ $ CourseEdit aid now cid
memcachedFlushClass MemcachedKeyClassTutorialOccurrences
memcachedByInvalidate AuthCacheLecturerList $ Proxy @(Set UserId)
addMessageI Success $ MsgCourseEditOk tid ssh csh
return True
when success $ redirect $ CourseR tid ssh csh CShowR
@ -420,3 +464,35 @@ courseEditHandler miButtonAction mbCourseForm = do
{ formAction = Just $ SomeRoute actionUrl
, formEncoding = formEnctype
}
-- upsertCourseQualifications :: forall m backend . (MonadIO m, PersistStoreWrite backend, PersistQueryRead backend) => UserId -> CourseId -> [(QualificationId, Int)] -> ReaderT backend m Bool
upsertCourseQualifications :: UserId -> CourseId -> [(QualificationId, Int)] -> YesodJobDB UniWorX Bool -- could be generalized
upsertCourseQualifications uid cid qualis = do
let newQualis = Map.fromList qualis
oldQualis <- Map.fromList . fmap (\Entity{entityKey=k, entityVal=CourseQualification{..}} -> (courseQualificationQualification, (k, courseQualificationSortOrder)))
<$> selectList [CourseQualificationCourse ==. cid] [Asc CourseQualificationQualification]
-- NOTE: CourseQualification allow the immediate assignment of these qualifications to any enrolled user. Hence SchoolAdmins must not be allowed to assign school-foreign qualifications, see #150
okSchools <- Set.fromList . fmap (userFunctionSchool . entityVal)
<$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolAdmin, SchoolLecturer]] [Asc UserFunctionSchool]
{- Some debugging due to an error caused by using fromDistinctAscList with violated precondition:
$logErrorS "CourseQuali" $ "OLD Course Qualifications:" <> tshow oldQualis
$logErrorS "CourseQuali" $ "NEW Course Qualifications:" <> tshow newQualis
$logErrorS "CourseQuali" $ "DIFF Course Qualifications:" <> tshow (newQualis Map.\\ oldQualis)
-}
foldWithKeyMapM oldQualis $ \qu (k, so_old) -> case Map.lookup qu newQualis of
Just so_new | so_new /= so_old
-> update k [CourseQualificationSortOrder =. so_new] -- existing CourseQualifications may be re-ordered, regardless of school association
Nothing -> delete k -- existing CourseQualifications may be removed, regardless of school association
_ -> return ()
res <- foldWithKeyMapM (newQualis Map.\\ oldQualis) $ \qu so -> get qu >>= \case
Just Qualification{qualificationSchool=ssh, qualificationShorthand=qsh}
| Set.member ssh okSchools ->
insert_ CourseQualification{courseQualificationQualification = qu, courseQualificationCourse = cid, courseQualificationSortOrder = so}
$> All True
| otherwise -> do
addMessageI Warning $ MsgCourseEditQualificationFailRights qsh ssh
pure $ All False
_ -> do
addMessageI Warning MsgCourseEditQualificationFail
pure $ All False
pure $ getAll res

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

@ -31,10 +31,8 @@ postCEvDeleteR tid ssh csh cID = do
[whamlet|
$newline never
#{courseEventType}
$maybe room <- courseEventRoom
, #{roomReferenceText room}
:
^{occurrencesWidget courseEventTime}
^{occurrencesWidget False courseEventTime}
|]
drRecordConfirmString :: Entity CourseEvent -> DB Text

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

@ -26,9 +26,8 @@ postCEvEditR tid ssh csh cID = do
replace eId CourseEvent
{ courseEventCourse
, courseEventType = cefType
, courseEventRoom = cefRoom
, courseEventRoomHidden = cefRoomHidden
, courseEventTime = cefTime
, courseEventTime = cefTime & JSONB
, courseEventNote = cefNote
, courseEventLastChanged = now
}

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

@ -17,7 +17,6 @@ import qualified Database.Esqueleto.Legacy as E
data CourseEventForm = CourseEventForm
{ cefType :: CI Text
, cefRoom :: Maybe RoomReference
, cefRoomHidden :: Bool
, cefTime :: Occurrences
, cefNote :: Maybe StoredMarkup
@ -37,14 +36,12 @@ courseEventForm template = identifyForm FIDCourseEvent . renderWForm FormStandar
let courseEventTypes = optionsPairs [ (courseEventType, courseEventType) | Entity _ CourseEvent{..} <- existingEvents ]
cefType' <- wreq (textField & cfStrip & cfCI & addDatalist courseEventTypes) (fslI MsgCourseEventType & addPlaceholder (mr MsgCourseEventTypePlaceholder)) (cefType <$> template)
cefRoom' <- aFormToWForm $ roomReferenceFormOpt (fslI MsgCourseEventRoom) (cefRoom <$> template)
cefRoomHidden' <- wpopt checkBoxField (fslI MsgCourseEventRoomHidden & setTooltip MsgCourseEventRoomHiddenTip) (cefRoomHidden <$> template)
cefTime' <- aFormToWForm $ occurrencesAForm ("time" :: Text) (cefTime <$> template)
cefNote' <- wopt htmlField (fslI MsgCourseEventNote) (cefNote <$> template)
return $ CourseEventForm
<$> cefType'
<*> cefRoom'
<*> cefRoomHidden'
<*> cefTime'
<*> cefNote'
@ -52,8 +49,7 @@ courseEventForm template = identifyForm FIDCourseEvent . renderWForm FormStandar
courseEventToForm :: CourseEvent -> CourseEventForm
courseEventToForm CourseEvent{..} = CourseEventForm
{ cefType = courseEventType
, cefRoom = courseEventRoom
, cefRoomHidden = courseEventRoomHidden
, cefTime = courseEventTime
, cefTime = courseEventTime & unJSONB
, cefNote = courseEventNote
}

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

@ -24,9 +24,8 @@ postCEventsNewR tid ssh csh = do
eId <- insert CourseEvent
{ courseEventCourse = cid
, courseEventType = cefType
, courseEventRoom = cefRoom
, courseEventRoomHidden = cefRoomHidden
, courseEventTime = cefTime
, courseEventTime = cefTime & JSONB
, courseEventNote = cefNote
, courseEventLastChanged = now
}

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

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022-23 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Steffen Jost <s.jost@fraport.de>
-- SPDX-FileCopyrightText: 2022-24 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Steffen Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
@ -13,6 +13,7 @@ import Import
import Handler.Utils
import Handler.Utils.Avs
import Handler.Utils.Company
import Jobs.Queue
@ -49,15 +50,15 @@ tutorialTemplateNames Nothing = ["Vorlage", "Template"]
tutorialTemplateNames (Just name) = [prefixes <> suffixes | prefixes <- tutorialTemplateNames Nothing, suffixes <- [mempty, tutorialTypeSeparator <> name]]
tutorialDefaultName :: Maybe TutorialType -> Day -> TutorialName
tutorialDefaultName Nothing = formatDayForTutName
tutorialDefaultName (Just ttyp) =
tutorialDefaultName Nothing = formatDayForTutName
tutorialDefaultName (Just ttyp) =
let prefix = CI.mk $ snd $ Text.breakOnEnd (CI.original tutorialTypeSeparator) $ CI.original ttyp
in (<> (tutorialTypeSeparator <> prefix)) . tutorialDefaultName Nothing
formatDayForTutName :: Day -> CI Text -- "%yy_%mm_%dd" -- Do not use user date display setting, since tutorial default names must be universal regardless of user
-- formatDayForTutName = CI.mk . formatTime' "%y_%m_%d" -- we don't want to go monadic for this
formatDayForTutName = CI.mk . Text.map d2u . Text.drop 2 . tshow
where
formatDayForTutName = CI.mk . Text.map d2u . Text.drop 2 . tshow
where
d2u '-' = '_'
d2u c = c
@ -151,7 +152,7 @@ instance Monoid AddParticipantsResult where
getCAddUserR, postCAddUserR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCAddUserR = postCAddUserR
postCAddUserR tid ssh csh = do
postCAddUserR tid ssh csh = do
today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
handleAddUserR tid ssh csh (Right today) Nothing
-- postTAddUserR tid ssh csh (CI.mk $ tshow today) -- Don't use user date display setting, so that tutorial default names conform to all users
@ -163,8 +164,8 @@ postTAddUserR tid ssh csh tutn = handleAddUserR tid ssh csh (Left tutn) Nothing
handleAddUserR :: TermId -> SchoolId -> CourseShorthand -> Either TutorialName Day -> Maybe TutorialType -> Handler Html
handleAddUserR tid ssh csh tdesc ttyp = do
(cid, tutTypes, tutNameSuggestions) <- runDB $ do
handleAddUserR tid ssh csh tdesc ttyp = do
(cid, tutTypes, tutNameSuggestions) <- runDB $ do
let plainTemplates = tutorialTemplateNames Nothing
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
tutTypes <- E.select $ E.distinct $ do
@ -176,9 +177,9 @@ handleAddUserR tid ssh csh tdesc ttyp = do
let typeSet = Set.fromList [ maybe t CI.mk $ Text.stripPrefix temp_sep $ CI.original t
| temp <- plainTemplates
, let temp_sep = CI.original (temp <> tutorialTypeSeparator)
, E.Value t <- tutTypes
, E.Value t <- tutTypes
]
tutNames <- E.select $ do
tutNames <- E.select $ do
tutorial <- E.from $ E.table @Tutorial
let tuName = tutorial E.^. TutorialName
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
@ -192,23 +193,23 @@ handleAddUserR tid ssh csh tdesc ttyp = do
currentRoute <- fromMaybe (error "postCAddUserR called from 404-handler") <$> getCurrentRoute
(_ , registerConfirmResult) <- runButtonForm FIDCourseRegisterConfirm
(_ , registerConfirmResult) <- runButtonForm FIDCourseRegisterConfirm
-- $logDebugS "***AbortProblem***" $ tshow registerConfirmResult
prefillUsers <- case registerConfirmResult of
prefillUsers <- case registerConfirmResult of
Nothing -> return mempty
(Just BtnCourseRegisterAbort) -> do
(Just BtnCourseRegisterAbort) -> do
addMessageI Warning MsgAborted
-- prefill confirmed users for convenience. Note that Browser-Back may also return to the filled form, but history.back() does not in Chrome
confirmedActs :: [CourseRegisterActionData] <- exceptT (const $ return mempty) return . mapMM encodedSecretBoxOpen . lookupPostParams $ toPathPiece PostCourseUserAddConfirmAction -- ignore any exception, since it is only used to prefill a form field for convenience
return $ Just $ Set.fromList $ fmap crActIdent confirmedActs
(Just BtnCourseRegisterConfirm) -> do
confirmedActs :: Set CourseRegisterActionData <- fmap Set.fromList . throwExceptT . mapMM encodedSecretBoxOpen . lookupPostParams $ toPathPiece PostCourseUserAddConfirmAction
confirmedActs :: Set CourseRegisterActionData <- fmap Set.fromList . throwExceptT . mapMM encodedSecretBoxOpen . lookupPostParams $ toPathPiece PostCourseUserAddConfirmAction
-- $logDebugS "CAddUserR confirmedActs" . tshow $ Set.map Aeson.encode confirmedActs
unless (Set.null confirmedActs) $ do -- TODO: check that all acts are member of availableActs
let
users = Map.fromList . fmap (\act -> (crActIdent act, Just . view _1 $ crActUser act)) $ Set.toList confirmedActs
tutActs = Set.filter (is _CourseRegisterActionAddTutorialMemberData) confirmedActs
actTutorial = crActTutorial <$> Set.lookupMin tutActs -- tutorial ident must be the same for every added member!
actTutorial = crActTutorial <$> Set.lookupMin tutActs -- tutorial ident must be the same for every added member!
registeredUsers <- registerUsers cid users
whenIsJust actTutorial $ \(tutName,tutType,tutDay) -> do
whenIsJust (tutName <|> fmap (tutorialDefaultName tutType) tutDay) $ \tName -> do
@ -218,13 +219,13 @@ handleAddUserR tid ssh csh tdesc ttyp = do
redirect $ CTutorialR tid ssh csh tName TUsersR
redirect $ CourseR tid ssh csh CUsersR
return mempty
((usersToAdd :: FormResult AddUserRequest, formWgt), formEncoding) <- runFormPost . identifyForm FIDCourseRegister . renderWForm FormStandard $ do
let tutTypesMsg = [(SomeMessage tt,tt) | tt <- tutTypes]
tutDefType = ttyp >>= (\ty -> if ty `elem` tutTypes then Just ty else Nothing)
tutDefType = ttyp >>= (\ty -> if ty `elem` tutTypes then Just ty else Nothing)
auReqUsers <- wreq (textField & cfAnySeparatedSet) (fslI MsgCourseParticipantsRegisterUsersField & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) prefillUsers
auReqTutorial <- optionalActionW
( (,,)
( (,,)
<$> aopt (textField & cfStrip & cfCI & addDatalist tutNameSuggestions)
(fslI MsgCourseParticipantsRegisterTutorialField & setTooltip MsgCourseParticipantsRegisterTutorialFieldTip)
(Just $ maybeLeft tdesc)
@ -349,12 +350,12 @@ upsertNewTutorial cid newTutorialName newTutorialType newFirstDay = runDB $ do
existingTut <- getBy $ UniqueTutorial cid newTutorialName
templateEnt <- selectFirst [TutorialType <-. tutorialTemplateNames newTutorialType] [Desc TutorialType, Asc TutorialName]
case (existingTut, newFirstDay, templateEnt) of
(Just Entity{entityKey=tid},_,_) -> return tid -- no need to update, we ignore the anchor day
(Just Entity{entityKey=tid},_,_) -> return tid -- no need to update, we ignore the anchor day
(Nothing, Just moveDay, Just Entity{entityVal=Tutorial{..}}) -> do
Course{..} <- get404 cid
term <- get404 courseTerm
let oldFirstDay = fromMaybe moveDay $ tutorialFirstDay <|> fst (occurrencesBounds term tutorialTime)
newTime = normalizeOccurrences $ occurrencesAddBusinessDays term (oldFirstDay, moveDay) tutorialTime
let oldFirstDay = fromMaybe moveDay $ tutorialFirstDay <|> fst (occurrencesBounds term $ unJSONB tutorialTime)
newTime = normalizeOccurrences $ occurrencesAddBusinessDays term (oldFirstDay, moveDay) $ unJSONB tutorialTime
dayDiff = maybe 0 (diffDays moveDay) tutorialFirstDay
mvTime = fmap $ addLocalDays dayDiff
newType0 = CI.map (snd . Text.breakOnEnd (CI.original tutorialTypeSeparator)) tutorialType
@ -367,13 +368,13 @@ upsertNewTutorial cid newTutorialName newTutorialType newFirstDay = runDB $ do
, tutorialCourse = cid
, tutorialType = newType
, tutorialFirstDay = newFirstDay
, tutorialTime = newTime
, tutorialTime = newTime & JSONB
, tutorialRegisterFrom = mvTime tutorialRegisterFrom
, tutorialRegisterTo = mvTime tutorialRegisterTo
, tutorialDeregisterUntil = mvTime tutorialDeregisterUntil
, tutorialLastChanged = now
, ..
} [] -- update cannot happen due to previous case
} [] -- update cannot happen due to previous case
audit $ TransactionTutorialEdit tutId
return tutId
_ -> do
@ -383,9 +384,8 @@ upsertNewTutorial cid newTutorialName newTutorialType newFirstDay = runDB $ do
, tutorialCourse = cid
, tutorialType = fromMaybe defaultTutorialType newTutorialType
, tutorialCapacity = Nothing
, tutorialRoom = Nothing
, tutorialRoomHidden = False
, tutorialTime = Occurrences mempty mempty
, tutorialTime = mempty
, tutorialRegGroup = Nothing
, tutorialRegisterFrom = Nothing
, tutorialRegisterTo = Nothing
@ -393,7 +393,7 @@ upsertNewTutorial cid newTutorialName newTutorialType newFirstDay = runDB $ do
, tutorialLastChanged = now
, tutorialTutorControlled = False
, tutorialFirstDay = Nothing
} [] -- update cannot happen due to previous cases
} [] -- update cannot happen due to previous cases
audit $ TransactionTutorialEdit tutId
return tutId
@ -401,6 +401,10 @@ registerTutorialMembers :: TutorialId -> Set UserId -> Handler ()
registerTutorialMembers tutId (Set.toList -> users) = runDB $ do
prevParticipants <- Set.fromList . fmap entityKey <$> selectList [TutorialParticipantUser <-. users, TutorialParticipantTutorial ==. tutId] []
participants <- fmap Set.fromList . for users $ \tutorialParticipantUser -> do
tutorialParticipantCompany <- selectCompanyUserPrime' tutorialParticipantUser
let tutorialParticipantDrivingPermit = Nothing
tutorialParticipantEyeExam = Nothing
tutorialParticipantNote = Nothing
Entity tutPartId _ <- upsert TutorialParticipant { tutorialParticipantTutorial = tutId, .. } []
audit $ TransactionTutorialParticipantEdit tutId tutPartId tutorialParticipantUser
return tutPartId

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

@ -68,7 +68,7 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do
| otherwise
-> return $ FormSuccess ()
mayViewCourseAfterDeregistration <- liftHandler . runDB $ E.selectExists . E.from $ \course -> do
mayViewCourseAfterDeregistration <- liftHandler . runDBRead $ E.selectExists . E.from $ \course -> do
E.where_ $ course E.^. CourseId E.==. E.val cid
E.&&. ( isSchoolAdminLike muid ata (course E.^. CourseSchool)
E.||. mayEditCourse muid ata course
@ -92,7 +92,7 @@ courseMayReRegister :: Entity Course -> DB Bool
courseMayReRegister (Entity cid Course{..}) = do
registrations <- count [ CourseParticipantState ==. CourseParticipantActive, CourseParticipantCourse ==. cid ]
let capacity = maybe True (>= registrations) courseCapacity
wouldHaveWriteAccessTo [(AuthCapacity, capacity), (AuthCourseRegistered, False)] $ CourseR courseTerm courseSchool courseShorthand CRegisterR

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

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
@ -29,7 +29,7 @@ import Handler.Exam.List (mkExamTable)
getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCShowR tid ssh csh = do
mbAid <- maybeAuthId
mbAid <- maybeAuthId
now <- liftIO getCurrentTime
(cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,administrators,correctors,tutors,news,events,submissionGroup,_mayReRegister,(mayViewSheets, mayViewAnySheet), (mayViewMaterials, mayViewAnyMaterial),courseQualifications) <- runDB . maybeT notFound $ do
[(E.Entity cid course, E.Value courseVisible, E.Value schoolName, E.Value participants, fmap entityVal -> registration)]
@ -146,7 +146,7 @@ getCShowR tid ssh csh = do
| otherwise
-> return . modal $(widgetFile "course/login-to-register") . Left . SomeRoute $ AuthR LoginR
registrationOpen <- hasWriteAccessTo $ CourseR tid ssh csh CRegisterR
mayMassRegister <- hasWriteAccessTo $ CourseR tid ssh csh CAddUserR
mayMassRegister <- hasWriteAccessTo $ CourseR tid ssh csh CAddUserR
MsgRenderer mr <- getMsgRenderer
@ -154,14 +154,14 @@ getCShowR tid ssh csh = do
tutorialDBTable = DBTable{..}
where
resultTutorial :: Lens' (DBRow (Entity Tutorial, Bool)) (Entity Tutorial)
resultTutorial = _dbrOutput . _1
resultShowRoom = _dbrOutput . _2
resultTutorial = _dbrOutput . _1
resultHideRoom = _dbrOutput . _2
dbtSQLQuery tutorial = do
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
let showRoom = maybe E.false (flip showTutorialRoom tutorial . E.val) mbAid
E.||. E.not_ (tutorial E.^. TutorialRoomHidden)
return (tutorial, showRoom)
let hideRoom = maybe E.true (E.not__ . flip showTutorialRoom tutorial . E.val) mbAid
E.&&. (tutorial E.^. TutorialRoomHidden)
return (tutorial, hideRoom)
dbtRowKey = (E.^. TutorialId)
dbtProj = over (_dbrOutput . _2) E.unValue <$> dbtProjId
dbtColonnade = dbColonnade $ mconcat
@ -180,10 +180,10 @@ getCShowR tid ssh csh = do
<li>
^{nameEmailWidget' tutor}
|]
, sortable (Just "room") (i18nCell MsgTableTutorialRoom) $ \res -> if
| res ^. resultShowRoom -> maybe (i18nCell MsgTableTutorialRoomIsUnset) roomReferenceCell $ views (resultTutorial . _entityVal) tutorialRoom res
| otherwise -> i18nCell MsgTableTutorialRoomIsHidden & addCellClass ("explanation" :: Text)
, sortable Nothing (i18nCell MsgTableTutorialTime) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> occurrencesCell tutorialTime
, sortable Nothing (i18nCell MsgTableTutorialOccurrence) $ \res ->
let roomHidden = res ^. resultHideRoom
ttime = res ^. resultTutorial . _entityVal . _tutorialTime
in occurrencesCell roomHidden ttime
, sortable (Just "register-from") (i18nCell MsgTutorialRegisterFrom) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybeDateTimeCell tutorialRegisterFrom
, sortable (Just "register-to") (i18nCell MsgTutorialRegisterTo) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybeDateTimeCell tutorialRegisterTo
, sortable (Just "deregister-until") (i18nCell MsgTableTutorialDeregisterUntil) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybeDateTimeCell tutorialDeregisterUntil
@ -220,7 +220,6 @@ getCShowR tid ssh csh = do
[ ("type", SortColumn $ \tutorial -> tutorial E.^. TutorialType )
, ("name", SortColumn $ \tutorial -> tutorial E.^. TutorialName )
, ("first-day", SortColumnNullsInv $ \tutorial -> tutorial E.^. TutorialFirstDay )
, ("room", SortColumn $ \tutorial -> tutorial E.^. TutorialRoom )
, ("register-from", SortColumn $ \tutorial -> tutorial E.^. TutorialRegisterFrom )
, ("register-to", SortColumn $ \tutorial -> tutorial E.^. TutorialRegisterTo )
, ("deregister-until", SortColumn $ \tutorial -> tutorial E.^. TutorialDeregisterUntil )

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

@ -9,12 +9,11 @@ module Handler.Course.User
import Import
import Utils.Form
import Utils.Mail (pickValidUserEmail)
import Handler.Utils
import Handler.Utils.SheetType
import Handler.Utils.Profile (pickValidEmail)
import Handler.Utils.StudyFeatures
import Handler.Submission.List
import Handler.Course.Register
import Jobs.Queue
@ -445,13 +444,11 @@ courseUserTutorialsSection (Entity cid Course{..}) (Entity uid _) = do
<li>
^{userEmailWidget usr}
|]
, sortable (Just "room") (i18nCell MsgTableTutorialRoom) $ maybe (i18nCell MsgTableTutorialRoomIsUnset) roomReferenceCell . view (_dbrOutput . _1 . _entityVal . _tutorialRoom)
, sortable Nothing (i18nCell MsgTableTutorialTime) $ occurrencesCell . view (_dbrOutput . _1 . _entityVal . _tutorialTime)
, sortable Nothing (i18nCell MsgTableTutorialOccurrence) $ occurrencesCell False . 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

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

@ -18,6 +18,7 @@ import Import
import Utils.Form
import Handler.Utils
import Handler.Utils.Course
import Handler.Utils.Company
import qualified Database.Esqueleto.Utils as E
import qualified Database.Esqueleto.PostgreSQL as E
import Database.Esqueleto.Utils.TH
@ -129,11 +130,11 @@ _userSheets = _dbrOutput . _7
-- _userQualifications :: Traversal' UserTableData [Entity Qualification]
-- _userQualifications = _dbrOutput . _8 . (traverse _1)
-- last part: ([Entity Qualification] -> f [Entity Qualification]) -> UserTableQualfications -> f UserTableQualifications
-- last part: ([Entity Qualification] -> f [Entity Qualification]) -> UserTableQualifications -> f UserTableQualifications
_userQualifications :: Getter UserTableData [Entity Qualification]
_userQualifications = _dbrOutput . _8 . to (fmap fst3)
-- _userQualifications = _dbrOutput . _8 . each . _1 -- TODO: how to make this work
-- _userQualifications = _dbrOutput . _8 . each . _1 -- TODO: how to make this work
_userCourseQualifications :: Lens' UserTableData UserTableQualifications
@ -194,7 +195,7 @@ colUserQualifications cutoff = sortable (Just "qualifications") (i18nCell MsgTab
colUserQualificationBlocked :: forall m c. IsDBTable m c => Bool -> Day -> Colonnade Sortable UserTableData (DBCell m c)
colUserQualificationBlocked isAdmin cutoff = sortable (Just "qualification-block") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $
let qualNamedReasonCell (q,qu,qb) = textCell ((q ^. hasQualification . _qualificationShorthand . _CI) <> ": ") <> qualificationValidReasonCell' Nothing isAdmin cutoff qb qu
in \(view _userCourseQualifications -> qualis) ->
in \(view _userCourseQualifications -> qualis) ->
(cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) . listCell qualis $ qualNamedReasonCell
data UserTableCsv = UserTableCsv
@ -420,12 +421,12 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
)
)
qualis <- E.select . E.from $ \(qualification `E.InnerJoin` qualificationUser `E.LeftOuterJoin` qualificationBlock) -> do
E.on $ qualificationUser E.^. QualificationUserId E.=?. qualificationBlock E.?. QualificationUserBlockQualificationUser
E.on $ qualificationUser E.^. QualificationUserId E.=?. qualificationBlock E.?. QualificationUserBlockQualificationUser
E.&&. qualificationBlock `isLatestBlockBefore` E.now_
E.on $ qualificationUser E.^. QualificationUserQualification E.==. qualification E.^. QualificationId
E.on $ qualificationUser E.^. QualificationUserQualification E.==. qualification E.^. QualificationId
E.where_ $ qualificationUser E.^. QualificationUserUser E.==. E.val (entityKey user)
E.&&. qualification E.^. QualificationId `E.in_` E.valList cqids
E.orderBy [E.asc $ qualification E.^. QualificationShorthand] -- we should sort by CourseQualificationSortOrder instead, but since we have not seen a course with multiple qualifications yet, we take a shortcut here
E.&&. qualification E.^. QualificationId `E.in_` E.valList cqids
E.orderBy [E.asc $ qualification E.^. QualificationShorthand] -- we should sort by CourseQualificationSortOrder instead, but since we have not seen a course with multiple qualifications yet, we take a shortcut here
return (qualification, qualificationUser, qualificationBlock)
let
regGroups = setOf (folded . _entityVal . _tutorialRegGroup . _Just) tutorials
@ -733,13 +734,16 @@ postCUsersR tid ssh csh = do
addMessageI Success $ MsgCourseUsersDeregistered nrDel
redirect $ CourseR tid ssh csh CUsersR
(CourseUserRegisterTutorialData{..}, selectedUsers) -> do
runDB . forM_ selectedUsers $
void . insertUnique . TutorialParticipant registerTutorial
addMessageI Success . MsgCourseUsersTutorialRegistered . fromIntegral $ Set.size selectedUsers
Sum nrOk <- runDB $ flip foldMapM selectedUsers $ \uid -> do
fsh <- selectCompanyUserPrime' uid
mbKey <- insertUnique $ TutorialParticipant registerTutorial uid fsh Nothing Nothing Nothing
return $ Sum $ length mbKey
let mStatus = bool Success Warning $ nrOk < Set.size selectedUsers
addMessageI mStatus $ MsgCourseUsersTutorialRegistered $ fromIntegral nrOk
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 ]
guardM . lift $ exists [ CourseParticipantUser ==. uid, CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ]
let (exam, mOccurrence) = registerExam
mExamReg <- lift $ insertUnique ExamRegistration
{ examRegistrationExam = exam
@ -763,7 +767,7 @@ postCUsersR tid ssh csh = do
Just _ -> addMessageI Success $ MsgCourseUsersSubmissionGroupSetNew nrSet
redirect $ CourseR tid ssh csh CUsersR
(CourseUserReRegisterData, selectedUsers) -> do
(CourseUserReRegisterData, selectedUsers) -> do
Sum nrSet <- runDB . flip foldMapM selectedUsers $ \uid -> maybeT (return mempty) $ do
didUpdate <- lift $ updateWhereCount
[ CourseParticipantUser ==. uid

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

@ -23,7 +23,7 @@ import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.Utils as E
-- import qualified Database.Esqueleto.Utils as E
import qualified Control.Monad.State.Class as State
import Text.Blaze.Html.Renderer.Text (renderHtml)
@ -419,7 +419,7 @@ examTemplate cid = runMaybeT $ do
E.limit 1
E.orderBy [ E.desc $ course E.^. CourseTerm, E.asc $ exam E.^. ExamVisibleFrom ]
return (course, exam, authorshipStatementDefinition)
extraSchools <- lift $ selectList [ ExamOfficeSchoolExam ==. oldExamId ] []
oldTerm <- MaybeT . get $ courseTerm oldCourse
@ -517,7 +517,7 @@ validateExam cId oldExam = do
.| C.mapM_ (\(Entity _ Sheet{..}) -> guardValidationM (MsgExamPartCannotBeDeletedDueToSheetReference epNumber sheetName) . anyM (otoList efExamParts) $ \ExamPartForm{..} -> (== Just epId) <$> traverse decrypt epfId)
mSchool <- liftHandler . runDB . E.selectMaybe . E.from $ \(course `E.InnerJoin` school) -> do
mSchool <- liftHandler . runDB . E.selectOne . E.from $ \(course `E.InnerJoin` school) -> do
E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId
E.where_ $ course E.^. CourseId E.==. E.val cId
return school

648
src/Handler/Firm.hs
View File

File diff suppressed because it is too large Load Diff

48
src/Handler/Health.hs
View File

@ -6,6 +6,7 @@ module Handler.Health where
import Import
import Data.Time.Format.ISO8601 (iso8601Show)
import Handler.Utils.DateTime (formatTimeW)
import qualified Data.Aeson.Encode.Pretty as Aeson
@ -19,6 +20,9 @@ import Control.Concurrent.STM.Delay
import System.Environment (lookupEnv) -- while git version number is not working
import qualified Database.Esqueleto.Experimental as E
import qualified Database.Esqueleto.PostgreSQL as E (now_)
-- import Data.FileEmbed (embedStringFile)
getHealthR :: Handler TypedContent
@ -77,12 +81,12 @@ getHealthR = do
#{boolSymbol (healthOk hcstatus)} #
$case report
$of HealthLDAPAdmins (Just found)
#{textPercent found 1}
#{textPercent found 1}
$of HealthActiveJobExecutors (Just active)
#{textPercent active 1}
$of _
<div>
^{formatTimeW SelFormatDateTime lUp}
^{formatTimeW SelFormatDateTime lUp}
|]
provideJson healthReports
provideRep . return . Builder.toLazyText $ Aeson.encodePrettyToTextBuilder healthReports
@ -113,34 +117,44 @@ getInstanceR = do
getStatusR :: Handler Html
getStatusR = do
starttime <- getsYesod appStartTime
(currtime, env_version) <- liftIO $ (,) <$> getCurrentTime <*> lookupEnv "VERSION_NR"
dbTime <- runDBRead $ E.selectOne $ return E.now_
(currtime,env_version) <- liftIO $ (,) <$> getCurrentTime <*> lookupEnv "VERSION_NR"
-- ft <- formatTime' "%Y-%m-%d %H:%M:%S" currtime
withUrlRenderer
let diffTime :: UTCTime -> Text
diffTime t =
let tdiff = diffUTCTime currtime t
in if 64 > abs tdiff
then tshow tdiff
else pack . iso8601Show . calendarTimeTime . fromIntegral $ truncate tdiff
withUrlRenderer
[hamlet|
$doctype 5
<html lang=en>
<head>
<head>
<title>Status
<body>
$maybe env_ver <- env_version
<p>
Environment version #{env_ver}
<p>
Current Time <br>
#{show currtime} <br>
<p>
Instance Start <br>
Current Application Time <br>
#{show currtime} <br>
$maybe dbtval <- dbTime
$with dbt <- E.unValue dbtval
Current Database Time <br>
#{show dbt} #
Difference: #{diffTime dbt} <br>
<p>
Instance Start <br>
#{show starttime} #
Uptime: #{show $ ddays starttime currtime} days.
Uptime: #{diffTime starttime}
<p>
Compile Time <br>
#{show cTime} #
Build age: #{show $ ddays cTime currtime} days.
Build age: #{diffTime cTime}
|]
where
-- vnr_full :: Text = $(embedStringFile "nix/docker/version.json") -- nix/ files not accessible during container construction
where
-- vnr_full :: Text = $(embedStringFile "nix/docker/version.json") -- nix/ files not accessible during container construction
cTime :: UTCTime
cTime = $compileTime
ddays :: UTCTime -> UTCTime -> Double
ddays tstart tstop = (/100) $ fromIntegral $ round $ diffUTCTime tstop tstart / (36 * 24)
cTime = $compileTime

187
src/Handler/Health/Interface.hs
View File

@ -8,12 +8,14 @@ module Handler.Health.Interface
getHealthInterfaceR
, mkInterfaceLogTable
, runInterfaceChecks
, getConfigInterfacesR, postConfigInterfacesR
)
where
import Import
-- import qualified Data.Set as Set
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.Text as Text
import Handler.Utils
import Handler.Utils.Concurrent
@ -24,6 +26,8 @@ import qualified Database.Esqueleto.Utils as E
import qualified Database.Esqueleto.Legacy as EL (on)
import qualified Database.Persist.Sql as E (deleteWhereCount)
defaultInterfaceWarnHours :: Int
defaultInterfaceWarnHours = 3 * 24 -- if no warn time can be found, use 3 days instead
-- | identify a wildcard argument
wc2null :: Text -> Maybe Text
@ -33,6 +37,12 @@ wc2null "_" = Nothing
wc2null "*" = Nothing
wc2null o = Just o
warnIntervalCell :: (IsDBTable m b, Integral a) => a -> DBCell m b
warnIntervalCell x
| x >= 0 = textCell $ formatDiffHours x
| x <= (-100) = i18nCell MsgInterfaceWarningDisabledEntirely
| otherwise = i18nCell MsgInterfaceWarningDisabledInterval
-- | sloppily parse a boolean, also see Model.Types.Avs.SloppyBool
pbool :: Text -> Maybe Bool
pbool (Text.toLower . Text.strip -> w)
@ -88,12 +98,7 @@ getHealthInterfaceR (dropWhile (=="force") -> ris) = do -- for bac
runInterfaceLogTable :: ReqBanInterfaceHealth -> Handler (Bool, Bool, [(Text,Bool)], Widget)
runInterfaceLogTable interfs@(reqIfs,_) = do
-- we abuse messageTooltip for colored icons here
msgSuccessTooltip <- messageI Success MsgMessageSuccess
-- msgWarningTooltip <- messageI Warning MsgMessageWarning
msgErrorTooltip <- messageI Error MsgMessageError
let flagError = messageTooltip . bool msgErrorTooltip msgSuccessTooltip
(res, twgt) <- runDB $ mkInterfaceLogTable flagError interfs
(res, twgt) <- runDB $ mkInterfaceLogTable interfs
let missing = notNull [ifce | (UniqueInterfaceHealth ifce _subt _writ) <- reqIfs, ifce `notElem` (fst <$> res) ]
allok = all snd res
return (missing, allok, res, twgt)
@ -101,12 +106,14 @@ runInterfaceLogTable interfs@(reqIfs,_) = do
-- ihDebugShow :: Unique InterfaceHealth -> Text
-- ihDebugShow (UniqueInterfaceHealth i s w) = "(" <> tshow i <> "," <> tshow s <> "," <> tshow w <> ")"
mkInterfaceLogTable :: (Bool -> Widget) -> ReqBanInterfaceHealth -> DB ([(Text,Bool)], Widget)
mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do
mkInterfaceLogTable :: ReqBanInterfaceHealth -> DB ([(Text,Bool)], Widget)
mkInterfaceLogTable interfs@(reqIfs, banIfs) = do
-- $logWarnS "DEBUG" $ tshow ([ihDebugShow x | x<- reqIfs], [ihDebugShow x | x<- banIfs])
void $ liftHandler $ timeoutHandler 42000001 $ runDB $ runInterfaceChecks interfs
flagError <- liftHandler $ do
void $ timeoutHandler 42000001 $ runDB $ runInterfaceChecks interfs -- ensure interface checkc are up to date
mkErrorFlag
now <- liftIO getCurrentTime
dbTableDB ilvalidator DBTable{dbtColonnade=colonnade now, ..}
dbTableDB ilvalidator DBTable{dbtColonnade=colonnade now flagError, ..}
where
sanitize = text2AlphaNumPlus ['+','-','_','Ä','Ö','Ü','ß','ä','ö','ü']
dbtIdent = "interface-log" :: Text
@ -115,7 +122,16 @@ mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do
EL.on ( ilog E.^. InterfaceLogInterface E.=?. ihealth E.?. InterfaceHealthInterface
E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.joinV (ihealth E.?. InterfaceHealthSubtype)
E.&&. ilog E.^. InterfaceLogWrite E.=~. E.joinV (ihealth E.?. InterfaceHealthWrite )
)
E.&&. E.notExists (do -- a more specific match does not exist
otherh <- E.from $ E.table @InterfaceHealth
E.where_ $ ilog E.^. InterfaceLogInterface E.==. otherh E.^. InterfaceHealthInterface
E.&&. ilog E.^. InterfaceLogSubtype E.=~. otherh E.^. InterfaceHealthSubtype
E.&&. ilog E.^. InterfaceLogWrite E.=~. otherh E.^. InterfaceHealthWrite
E.&&. ihealth E.?. InterfaceHealthHours E.!=. E.just (otherh E.^. InterfaceHealthHours)
E.&&. (E.isNothing (E.joinV $ ihealth E.?. InterfaceHealthSubtype)
E.||. E.isNothing (E.joinV $ ihealth E.?. InterfaceHealthWrite ))
)
)
let matchUIH crits = E.or
[ E.and $ catMaybes
[ ilog E.^. InterfaceLogInterface E.==. E.val (sanitize ifce) & Just
@ -139,32 +155,34 @@ mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do
-- E.where_ $ E.not_ (ilog E.^. InterfaceLogInterface E.==. E.val "LMS" E.&&. ilog E.^. InterfaceLogSubtype E.==. E.val (sanitize "F")) -- BAD All missing, except for "Printer" "F"
-- E.where_ $ E.not_ $ E.parens (ilog E.^. InterfaceLogInterface E.==. E.val "LMS" E.&&. ilog E.^. InterfaceLogSubtype E.==. E.val (sanitize "F")) -- WORKS OKAY
-- E.where_ $ ilog E.^. InterfaceLogInterface E.!=. E.val "LMS" E.||. ilog E.^. InterfaceLogSubtype E.!=. E.val (sanitize "F") -- WORKS OKAY
let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val $ 3 * 24) -- if no default time is set, use 3 days instead
let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val defaultInterfaceWarnHours) -- if no default time is set, use a default instead
return (ilog, ihour)
queryILog :: (E.SqlExpr (Entity InterfaceLog) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity InterfaceHealth))) -> E.SqlExpr (Entity InterfaceLog)
queryILog = $(E.sqlLOJproj 2 1)
queryHealth :: (E.SqlExpr (Entity InterfaceLog) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity InterfaceHealth))) -> E.SqlExpr (Maybe (Entity InterfaceHealth))
queryHealth = $(E.sqlLOJproj 2 2)
resultILog :: Lens' (DBRow (Entity InterfaceLog, E.Value Int)) InterfaceLog
resultILog = _dbrOutput . _1 . _entityVal
resultHours :: Lens' (DBRow (Entity InterfaceLog, E.Value Int)) Int
resultHours = _dbrOutput . _2 . E._unValue
dbtRowKey = queryILog >>> (E.^.InterfaceLogId)
colonnade now = mconcat
colonnade now flagError = mconcat
[ sortable Nothing (i18nCell MsgInterfaceStatus) $ \row -> -- do
let hours = row ^. resultHours
-- defmsg = row ^? resultErrMsg
logtime = row ^. resultILog . _interfaceLogTime
success = row ^. resultILog . _interfaceLogSuccess
iface = row ^. resultILog . _interfaceLogInterface
status = success && now <= addHours hours logtime
in tellCell [(iface,status)] $
wgtCell $ flagError status
status = (success || hours <= -100) && (hours < 0 || now <= addHours hours logtime)
in tellCell [(iface,status)] $ wgtCell $ flagError $ toMaybe (success || not status) status
, sortable (Just "interface") (i18nCell MsgInterfaceName ) $ \(view (resultILog . _interfaceLogInterface) -> n) -> textCell n
, sortable (Just "subtype") (i18nCell MsgInterfaceSubtype ) $ textCell . view (resultILog . _interfaceLogSubtype)
, sortable (Just "write") (i18nCell MsgInterfaceWrite ) $ (`ifIconCell` IconEdit) . view (resultILog . _interfaceLogWrite)
, sortable (Just "time") (i18nCell MsgInterfaceLastSynch ) $ dateTimeCell . view (resultILog . _interfaceLogTime)
, sortable Nothing (i18nCell MsgInterfaceFreshness ) $ numCell . view resultHours
, sortable (Just "hours") (i18nCell MsgInterfaceFreshness & cellTooltips [SomeMessage MsgInterfaceFreshnessTooltip, SomeMessage MsgTableDiffDaysTooltip]
) $ warnIntervalCell . view resultHours
, sortable (Just "rows") (i18nCell MsgTableRows ) $ cellMaybe numCell . view (resultILog . _interfaceLogRows)
, sortable (Just "success") (i18nCell MsgInterfaceSuccess ) $ \(view (resultILog . _interfaceLogSuccess) -> s) -> iconBoolCell s
, sortable Nothing (i18nCell MsgInterfaceInfo ) $ \(view resultILog -> ilt) -> case ilt of
@ -180,6 +198,7 @@ mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do
, singletonMap "time" $ SortColumn $ queryILog >>> (E.^. InterfaceLogTime)
, singletonMap "rows" $ SortColumn $ queryILog >>> (E.^. InterfaceLogRows)
, singletonMap "success" $ SortColumn $ queryILog >>> (E.^. InterfaceLogSuccess)
, singletonMap "hours" $ SortColumn $ \r -> E.coalesceDefault [queryHealth r E.?. InterfaceHealthHours] (E.val defaultInterfaceWarnHours)
]
ilvalidator = def & defaultSorting [SortAscBy "interface", SortAscBy "subtype", SortAscBy "write"]
dbtFilter = mempty
@ -249,3 +268,135 @@ avsInterfaceCheck interfs = maybeRunCheck interfs (UniqueInterfaceHealth "AVS" (
-- lastOk <- userAvsLastSynch . entityVal <<$>> selectFirst [UserAvsLastSynchError ==. Nothing] [Desc UserAvsLastSynch]
writeAvsSynchStats Nothing =<< mkBadInfo badRows badTime
_ -> return ()
data IWTableAction
= IWTActAdd
| IWTActDelete
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
instance Universe IWTableAction
instance Finite IWTableAction
nullaryPathPiece ''IWTableAction $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''IWTableAction id
data IWTableActionData
= IWTActAddData
{ iwtActInterface :: Text
, iwtActSubtype :: Maybe Text
, iwtActWrite :: Maybe Bool
, iwtActHours :: Int
}
| IWTActDeleteData
deriving (Eq, Ord, Read, Show, Generic)
type IWTableExpr = E.SqlExpr (Entity InterfaceHealth)
queryInterfaceHealth :: IWTableExpr -> E.SqlExpr (Entity InterfaceHealth)
queryInterfaceHealth = id
type IWTableData = DBRow (Entity InterfaceHealth)
resultInterfaceHealth :: Lens' IWTableData (Entity InterfaceHealth)
resultInterfaceHealth = _dbrOutput
wildcardCell :: IsDBTable m b => (a -> DBCell m b) -> Maybe a -> DBCell m b
wildcardCell _ Nothing = iconFixedCell $ icon IconWildcard
wildcardCell c (Just x) = c x
mkInterfaceWarnTable :: DB (FormResult (IWTableActionData, Set InterfaceHealthId), Widget)
mkInterfaceWarnTable = do
let
mkOption :: E.Value Text -> Option Text
mkOption (E.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t }
getSuggestion pj = E.select $ E.distinct $ do
il <- E.from $ E.table @InterfaceLog
let res = il E.^. pj
E.orderBy [E.asc res]
pure res
suggestionInterface :: HandlerFor UniWorX (OptionList Text)
suggestionInterface = mkOptionList . fmap mkOption <$> runDB (getSuggestion InterfaceLogInterface)
suggestionSubtype :: HandlerFor UniWorX (OptionList Text)
suggestionSubtype = mkOptionList . fmap mkOption <$> runDB (getSuggestion InterfaceLogSubtype)
dbtIdent = "interface-warnings" :: Text
dbtSQLQuery :: IWTableExpr -> E.SqlQuery IWTableExpr
dbtSQLQuery = return
dbtRowKey = queryInterfaceHealth >>> (E.^. InterfaceHealthId)
dbtProj = dbtProjId
dbtColonnade = formColonnade $ mconcat
[ dbSelect (applying _2) id (return . view (resultInterfaceHealth . _entityKey))
, sortable (Just "interface") (i18nCell MsgInterfaceName ) $ \(view (resultInterfaceHealth . _entityVal . _interfaceHealthInterface) -> n) -> textCell n
, sortable (Just "subtype") (i18nCell MsgInterfaceSubtype ) $ wildcardCell textCell . view (resultInterfaceHealth . _entityVal . _interfaceHealthSubtype )
, sortable (Just "write") (i18nCell MsgInterfaceWrite ) $ wildcardCell (iconFixedCell . iconWriteReadOnly) . view (resultInterfaceHealth . _entityVal . _interfaceHealthWrite )
-- , sortable (Just "hours") (i18nCell MsgInterfaceFreshness ) $ numCell . view (resultInterfaceHealth . _entityVal . _interfaceHealthHours )
, sortable (Just "hours") (i18nCell MsgInterfaceFreshness
& cellTooltip MsgTableDiffDaysTooltip ) $ warnIntervalCell . view (resultInterfaceHealth . _entityVal . _interfaceHealthHours )
]
dbtSorting = mconcat
[ singletonMap "interface" $ SortColumn $ queryInterfaceHealth >>> (E.^. InterfaceHealthInterface)
, singletonMap "subtype" $ SortColumn $ queryInterfaceHealth >>> (E.^. InterfaceHealthSubtype)
, singletonMap "write" $ SortColumn $ queryInterfaceHealth >>> (E.^. InterfaceHealthWrite)
, singletonMap "hours" $ SortColumn $ queryInterfaceHealth >>> (E.^. InterfaceHealthHours)
]
dbtFilter = mempty
dbtFilterUI = mempty
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
dbtParams = DBParamsForm
{ dbParamsFormMethod = POST
, dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute
, dbParamsFormAttrs = []
, dbParamsFormSubmit = FormSubmit
, dbParamsFormAdditional
= let acts :: Map IWTableAction (AForm Handler IWTableActionData)
acts = mconcat
[ singletonMap IWTActAdd $ IWTActAddData
<$> apreq (textField & cfStrip & addDatalist suggestionInterface) (fslI MsgInterfaceName) Nothing
<*> aopt (textField & cfStrip & addDatalist suggestionSubtype) (fslI MsgInterfaceSubtype) Nothing
<*> aopt boolField' (fslI MsgInterfaceWrite) Nothing
<*> apreq intField (fslI MsgInterfaceFreshness & setTooltip MsgHours) Nothing
, singletonMap IWTActDelete $ pure IWTActDeleteData
]
in renderAForm FormStandard
$ (, mempty) . First . Just
<$> multiActionA acts (fslI MsgTableAction) Nothing
, dbParamsFormEvaluate = liftHandler . runFormPost
, dbParamsFormResult = id
, dbParamsFormIdent = def
}
dbtCsvEncode = noCsvEncode
dbtCsvDecode = Nothing
dbtExtraReps = []
postprocess :: FormResult (First IWTableActionData, DBFormResult InterfaceHealthId Bool IWTableData)
-> FormResult ( IWTableActionData, Set InterfaceHealthId)
postprocess inp = do
(First (Just act), jobMap) <- inp
let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap
return (act, jobSet)
psValidator = def & defaultSorting [SortAscBy "interface", SortAscBy "subtype", SortAscBy "write"]
over _1 postprocess <$> dbTable psValidator DBTable{..}
getConfigInterfacesR, postConfigInterfacesR :: Handler Html
getConfigInterfacesR = postConfigInterfacesR
postConfigInterfacesR = do
((interfaceOks, interfaceTable), (warnRes, configTable)) <- runDB $ (,)
<$> mkInterfaceLogTable mempty
<*> mkInterfaceWarnTable
let interfacesBadNr = length $ filter (not . snd) interfaceOks
formResult warnRes $ \case
(IWTActAddData{..}, _) -> do
void $ runDB $ upsertBy
(UniqueInterfaceHealth iwtActInterface iwtActSubtype iwtActWrite)
( InterfaceHealth iwtActInterface iwtActSubtype iwtActWrite iwtActHours)
[InterfaceHealthHours =. iwtActHours]
addMessageI Success MsgInterfaceWarningAdded
reloadKeepGetParams ConfigInterfacesR
(IWTActDeleteData, ihids) -> do
runDB $ mapM_ delete ihids
addMessageI Success $ MsgInterfaceWarningDeleted $ Set.size ihids
reloadKeepGetParams ConfigInterfacesR
siteLayoutMsg MsgConfigInterfacesHeading $ do
setTitleI MsgConfigInterfacesHeading
let defWarnTime = formatDiffHours defaultInterfaceWarnHours
$(i18nWidgetFile "config-interfaces")

330
src/Handler/LMS.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022-23 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-24 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
@ -19,7 +19,7 @@ module Handler.LMS
, getLmsFakeR , postLmsFakeR
, getLmsUserR
, getLmsUserSchoolR
, getLmsUserAllR
, getLmsUserAllR
)
where
@ -29,6 +29,7 @@ import Jobs
import Handler.Utils
import Handler.Utils.Users
import Handler.Utils.LMS
import Handler.Utils.Company
import qualified Data.Set as Set
@ -50,10 +51,6 @@ import Handler.LMS.Report as Handler.LMS
import Handler.LMS.Fake as Handler.LMS -- TODO: remove in production!
-- avoids repetition of local definitions
single :: (k,a) -> Map k a
single = uncurry Map.singleton
-- Button only needed here
data ButtonManualLms = BtnLmsEnqueue | BtnLmsDequeue
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic)
@ -81,11 +78,11 @@ postLmsAllR = do
mbBtnForm <- if not isAdmin then return Nothing else do
((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("buttons" :: Text) (buttonForm :: Form ButtonManualLms)
case btnResult of
(FormSuccess BtnLmsEnqueue) ->
queueJob' JobLmsQualificationsEnqueue
(FormSuccess BtnLmsEnqueue) ->
queueJob' JobLmsQualificationsEnqueue
>> addMessage Info "Einreihung ablaufender Qualifikationen zum LMS wird nun im Hintergund durchgeführt."
(FormSuccess BtnLmsDequeue) ->
queueJob' JobLmsQualificationsDequeue
(FormSuccess BtnLmsDequeue) ->
queueJob' JobLmsQualificationsDequeue
>> addMessage Info "Benachrichtigung abgelaufener Qualifikationen und Aufräumen beendeter LMS Nutzer wird im Hintergund ausgeführt."
FormMissing -> return ()
_other -> addMessage Warning "Kein korrekter LMS Knopf erkannt"
@ -112,20 +109,20 @@ resultAllQualificationActive = _dbrOutput . _2 . _unValue
resultAllQualificationTotal :: Lens' AllQualificationTableData Word64
resultAllQualificationTotal = _dbrOutput . _3 . _unValue
mkLmsAllTable :: Bool -> Int -> DB (Any, Widget)
mkLmsAllTable isAdmin lmsDeletionDays = do
svs <- getSupervisees
svs <- getSupervisees
let
resultDBTable = DBTable{..}
where
dbtSQLQuery quali = do
let filterSvs luser = luser Ex.^. LmsUserQualification Ex.==. quali Ex.^. QualificationId
let filterSvs luser = luser Ex.^. LmsUserQualification Ex.==. quali Ex.^. QualificationId
Ex.&&. (E.val isAdmin E.||. luser Ex.^. LmsUserUser `Ex.in_` E.vals svs)
cusers = Ex.subSelectCount $ do
cusers = Ex.subSelectCount $ do
luser <- Ex.from $ Ex.table @LmsUser
Ex.where_ $ filterSvs luser
cactive = Ex.subSelectCount $ do
Ex.where_ $ filterSvs luser
cactive = Ex.subSelectCount $ do
luser <- Ex.from $ Ex.table @LmsUser
Ex.where_ $ filterSvs luser Ex.&&. E.isNothing (luser E.^. LmsUserStatus)
-- Failed attempt using Join/GroupBy instead of subselect: see branch csv-osis-demo-groupby-problem
@ -149,21 +146,29 @@ mkLmsAllTable isAdmin lmsDeletionDays = do
, sortable Nothing (i18nCell MsgQualificationRefreshWithin & cellTooltips [SomeMessage MsgQualificationRefreshWithinTooltip , SomeMessage MsgTableDiffDaysTooltip]) $
foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshWithin)
-- , sortable Nothing (i18nCell MsgQualificationRefreshWithin) $ foldMap textCell . view (resultAllQualification . _qualificationRefreshWithin . to formatCalendarDiffDays) -- does not work, since there is a maybe in between
, sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart) $ \row ->
let elearnstart = row ^. resultAllQualification . _qualificationElearningStart
reminder = row ^. resultAllQualification . _qualificationRefreshReminder
in tickmarkCell $ elearnstart && isJust reminder
, sortable Nothing (i18nCell MsgQualificationRefreshReminder & cellTooltips [SomeMessage MsgQualificationRefreshReminderTooltip, SomeMessage MsgTableDiffDaysTooltip]) $
foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshReminder)
, sortable Nothing (i18nCell MsgQualificationAuditDuration & cellTooltips [SomeMessage (MsgQualificationAuditDurationTooltip lmsDeletionDays), SomeMessage MsgTableDiffDaysTooltip]) $
foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationAuditDuration)
, sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart)
$ tickmarkCell . view (resultAllQualification . _qualificationElearningStart)
, sortable Nothing (i18nCell MsgTableQualificationIsAvsLicence & cellTooltip MsgTableQualificationIsAvsLicenceTooltip)
, sortable (Just "qel-renew") (i18nCell MsgTableLmsElearningRenews & cellTooltip MsgQualificationElearningRenew)
$ tickmarkCell . view (resultAllQualification . _qualificationElearningRenews)
, sortable (Just "qel-limit") (i18nCell MsgTableLmsElearningLimit & cellTooltip MsgQualificationElearningLimit)
$ cellMaybe numCell . view (resultAllQualification . _qualificationElearningLimit)
, sortable (Just "qel-reuse") (i18nCell MsgTableQualificationLmsReuses & cellTooltip MsgTableQualificationLmsReusesTooltip)
$ \(view (resultAllQualification . _qualificationLmsReuses) -> reuseQid) -> maybeCell reuseQid qualificationIdShortCell
, sortable Nothing (i18nCell MsgTableQualificationIsAvsLicence & cellTooltip MsgTableQualificationIsAvsLicenceTooltip)
$ \(view (resultAllQualification . _qualificationAvsLicence) -> licence) -> maybeCell licence $ textCell . T.singleton . licence2char
, sortable Nothing (i18nCell MsgTableQualificationSapExport & cellTooltip MsgTableQualificationSapExportTooltip)
, sortable Nothing (i18nCell MsgTableQualificationSapExport & cellTooltip MsgTableQualificationSapExportTooltip)
$ \(view (resultAllQualification . _qualificationSapId) -> mbSapId) ->
let icn = IconOK -- change icon here, if desired
in case mbSapId of
in case mbSapId of
Nothing -> mempty
Just sapId | isAdmin -> cellTooltipIcon (Just icn) (text2message sapId) mempty
Just _ -> iconCell icn
Just _ -> iconCell icn
, adminable Nothing (i18nCell MsgTableQualificationCountActive & cellTooltip MsgTableQualificationCountActiveTooltip)
$ \(view resultAllQualificationActive -> n) -> wgtCell $ word2widget n
, adminable Nothing (i18nCell MsgTableQualificationCountTotal) $ wgtCell . word2widget . view resultAllQualificationTotal
@ -175,6 +180,9 @@ mkLmsAllTable isAdmin lmsDeletionDays = do
, singletonMap "qshort" $ SortColumn (E.^. QualificationShorthand)
, singletonMap "qname" $ SortColumn (E.^. QualificationName)
, singletonMap "qelearning" $ SortColumn (E.^. QualificationElearningStart)
, singletonMap "qel-renew" $ SortColumn (E.^. QualificationElearningRenews)
, singletonMap "qel-limit" $ SortColumn (E.^. QualificationElearningLimit)
, singletonMap "qel-reuse" $ SortColumn (E.^. QualificationLmsReuses)
]
dbtFilter = mconcat
[
@ -209,7 +217,6 @@ data LmsTableCsv = LmsTableCsv -- L..T..C.. -> ltc..
{ ltcDisplayName :: UserDisplayName
, ltcEmail :: UserEmail
, ltcCompany :: Maybe Text
, ltcCompanyNumbers :: CsvSemicolonList Int
, ltcValidUntil :: Day
, ltcLastRefresh :: Day
, ltcFirstHeld :: Day
@ -231,8 +238,7 @@ ltcExample :: LmsTableCsv
ltcExample = LmsTableCsv
{ ltcDisplayName = "Max Mustermann"
, ltcEmail = "m.mustermann@example.com"
, ltcCompany = Just "Example Brothers LLC, SecondaryJobs Inc"
, ltcCompanyNumbers = CsvSemicolonList [27,69]
, ltcCompany = Just "Example Brothers LLC"
, ltcValidUntil = succ compDay
, ltcLastRefresh = compDay
, ltcFirstHeld = pred $ pred compDay
@ -274,8 +280,7 @@ instance CsvColumnsExplained LmsTableCsv where
csvColumnsExplanations = genericCsvColumnsExplanations ltcOptions $ Map.fromList
[ ('ltcDisplayName , SomeMessage MsgLmsUser)
, ('ltcEmail , SomeMessage MsgTableLmsEmail)
, ('ltcCompany , SomeMessage MsgTableCompanies)
, ('ltcCompanyNumbers , SomeMessage MsgTableCompanyNos)
, ('ltcCompany , SomeMessage MsgTablePrimeCompany)
, ('ltcValidUntil , SomeMessage MsgLmsQualificationValidUntil)
, ('ltcLastRefresh , SomeMessage MsgTableQualificationLastRefresh)
, ('ltcFirstHeld , SomeMessage MsgTableQualificationFirstHeld)
@ -294,22 +299,25 @@ instance CsvColumnsExplained LmsTableCsv where
type LmsTableExpr = ( E.SqlExpr (Entity QualificationUser)
`E.InnerJoin` E.SqlExpr (Entity User)
`E.InnerJoin` E.SqlExpr (Entity LmsUser)
) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity QualificationUserBlock))
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity QualificationUserBlock))
)
-- due to GHC staging restrictions, we use the preprocessor instead
#define LMS_TABLE_JOIN "IIL"
queryQualUser :: LmsTableExpr -> E.SqlExpr (Entity QualificationUser)
queryQualUser = $(sqlIJproj 3 1) . $(sqlLOJproj 2 1)
queryQualUser = $(sqlMIXproj LMS_TABLE_JOIN 1)
queryUser :: LmsTableExpr -> E.SqlExpr (Entity User)
queryUser = $(sqlIJproj 3 2) . $(sqlLOJproj 2 1)
queryUser = $(sqlMIXproj LMS_TABLE_JOIN 2)
queryLmsUser :: LmsTableExpr -> E.SqlExpr (Entity LmsUser)
queryLmsUser = $(sqlIJproj 3 3) . $(sqlLOJproj 2 1)
queryLmsUser = $(sqlMIXproj LMS_TABLE_JOIN 3)
queryQualBlock :: LmsTableExpr -> E.SqlExpr (Maybe (Entity QualificationUserBlock))
queryQualBlock = $(sqlLOJproj 2 2)
queryQualBlock = $(sqlMIXproj LMS_TABLE_JOIN 4)
type LmsTableData = DBRow (Entity QualificationUser, Entity User, Entity LmsUser, Maybe (Entity QualificationUserBlock), E.Value (Maybe [Maybe UTCTime]), [Entity UserCompany], E.Value Bool)
type LmsTableData = DBRow (Entity QualificationUser, Entity User, Entity LmsUser, Maybe (Entity QualificationUserBlock), E.Value (Maybe [Maybe UTCTime]), E.Value (Maybe CompanyId), E.Value Bool)
resultQualUser :: Lens' LmsTableData (Entity QualificationUser)
resultQualUser = _dbrOutput . _1
@ -326,8 +334,8 @@ resultQualBlock = _dbrOutput . _4 . _Just
resultPrintAck :: Traversal' LmsTableData [Maybe UTCTime]
resultPrintAck = _dbrOutput . _5 . _unValue . _Just
resultCompanyUser :: Lens' LmsTableData [Entity UserCompany]
resultCompanyUser = _dbrOutput . _6
resultCompanyId :: Traversal' LmsTableData CompanyId
resultCompanyId = _dbrOutput . _6 . _unValue . _Just
resultValidQualification :: Lens' LmsTableData Bool
resultValidQualification = _dbrOutput . _7 . _unValue
@ -342,7 +350,7 @@ instance HasEntity LmsTableData QualificationUser where
hasEntity = resultQualUser
instance HasQualificationUser LmsTableData where
hasQualificationUser = resultQualUser . _entityVal
hasQualificationUser = resultQualUser . _entityVal
data LmsTableAction = LmsActNotify
| LmsActRenewNotify
@ -351,7 +359,7 @@ data LmsTableAction = LmsActNotify
| LmsActRestart
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
deriving anyclass (Universe, Finite)
nullaryPathPiece ''LmsTableAction $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''LmsTableAction id
@ -360,12 +368,12 @@ data LmsTableActionData = LmsActNotifyData
| LmsActRenewPinData -- no longer used
| LmsActResetData
{ lmsActRestartExtend :: Maybe Integer
, lmsActRestartUnblock :: Maybe Bool
, lmsActRestartUnblock :: Maybe Bool
, lmsActRestartNotify :: Maybe Bool
}
| LmsActRestartData
| LmsActRestartData
{ lmsActRestartExtend :: Maybe Integer
, lmsActRestartUnblock :: Maybe Bool
, lmsActRestartUnblock :: Maybe Bool
, lmsActRestartNotify :: Maybe Bool
}
deriving (Eq, Ord, Read, Show, Generic)
@ -395,6 +403,7 @@ lmsTableQuery :: UTCTime -> QualificationId -> LmsTableExpr
, E.SqlExpr (Entity LmsUser)
, E.SqlExpr (Maybe (Entity QualificationUserBlock))
, E.SqlExpr (E.Value (Maybe [Maybe UTCTime])) -- outer maybe indicates, whether a printJob exists, inner maybe indicates all acknowledged printJobs
, E.SqlExpr (E.Value (Maybe CompanyId))
, E.SqlExpr (E.Value Bool)
)
lmsTableQuery now qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser `E.LeftOuterJoin` qualBlock) = do
@ -407,15 +416,15 @@ lmsTableQuery now qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser `E.Left
E.on $ user E.^. UserId E.==. lmsUser E.^. LmsUserUser
E.&&. E.val qid E.==. lmsUser E.^. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work
E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
E.where_ $ E.val qid E.==. qualUser E.^. QualificationUserQualification
E.where_ $ E.val qid E.==. qualUser E.^. QualificationUserQualification
-- Letztes Datum anzeigen, wenn mehrere, dann diese in klickbaren Tooltip verstecken!
let printAcknowledged = E.subSelectMaybe . E.from $ \pj -> do
E.where_ $ E.isJust (pj E.^. PrintJobLmsUser)
E.&&. ((lmsUser E.^. LmsUserIdent) E.=?. (pj E.^. PrintJobLmsUser))
let pjOrder = [E.desc $ pj E.^. PrintJobCreated, E.desc $ pj E.^. PrintJobAcknowledged] -- latest created comes first! This is assumed to be the case later on!
pure $ --(E.arrayAggWith E.AggModeAll (pj E.^. PrintJobCreated ) pjOrder, -- return two aggregates only works with select, the restricted type of subSelect does not seem to support this!
E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder
return (qualUser, user, lmsUser, qualBlock, printAcknowledged, validQualification now qualUser)
E.where_ $ E.isJust (pj E.^. PrintJobLmsUser)
E.&&. ((lmsUser E.^. LmsUserIdent) E.=?. (pj E.^. PrintJobLmsUser))
let pjOrder = [E.desc $ pj E.^. PrintJobCreated, E.desc $ pj E.^. PrintJobAcknowledged] -- latest created comes first! This is assumed to be the case later on!
pure $ --(E.arrayAggWith E.AggModeAll (pj E.^. PrintJobCreated ) pjOrder, -- return two aggregates only works with select, the restricted type of subSelect does not seem to support this!
E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder
return (qualUser, user, lmsUser, qualBlock, printAcknowledged, selectCompanyUserPrime user, validQualification now qualUser)
mkLmsTable :: ( Functor h, ToSortable h
@ -423,106 +432,101 @@ mkLmsTable :: ( Functor h, ToSortable h
)
=> Bool
-> Entity Qualification
-> Map LmsTableAction (AForm Handler LmsTableActionData)
-> (Map CompanyId Company -> cols)
-> Map LmsTableAction (AForm Handler LmsTableActionData)
-> ((CompanyId -> CompanyName) -> cols)
-> PSValidator (MForm Handler) (FormResult (First LmsTableActionData, DBFormResult UserId Bool LmsTableData))
-> DB (FormResult (LmsTableActionData, Set UserId), Widget)
mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
now <- liftIO getCurrentTime
-- lookup all companies
cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do
-- lookup all companies
cmpMap <- memcachedBy (Just . Right $ 30 * diffMinute) ("CompanyDictionary"::Text) $ do
cmps <- selectList [] [] -- [Asc CompanyShorthand]
return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps
let
let
getCompanyName :: CompanyId -> CompanyName
getCompanyName cid = maybe (unCompanyKey cid) companyName $ Map.lookup cid cmpMap -- use shorthand in case of impossible failure
csvName = T.replace " " "-" $ ciOriginal (quali ^. _qualificationName)
dbtIdent :: Text
dbtIdent = "lms"
dbtSQLQuery = lmsTableQuery now qid
dbtRowKey = queryUser >>> (E.^. UserId)
dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, qUsrBlock, printAcks, validQ) -> do
cmpUsr <- selectList [UserCompanyUser ==. entityKey usr] [Asc UserCompanyCompany]
return (qualUsr, usr, lmsUsr, qUsrBlock, printAcks, cmpUsr, validQ)
dbtColonnade = cols cmpMap
dbtSorting = mconcat
[ single $ sortUserNameLink queryUser
, single $ sortUserEmail queryUser
, single $ sortUserMatriclenr queryUser
, single ("valid-until" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserValidUntil))
-- , single ("validity" , SortColumn $ queryQualUser >>> validQualification nowaday)
, single ("last-refresh" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserLastRefresh))
, single ("first-held" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserFirstHeld))
, single ("blocked" , SortColumnNeverNull$ queryQualBlock >>> (E.?. QualificationUserBlockFrom))
, single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal))
, single ("ident" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserIdent))
, single ("pin" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserPin))
-- , single ("status" , SortColumnNullsInv $ views (to queryLmsUser) (E.^. LmsUserStatusDay))
, single ("status" , SortColumnNeverNull $ \row -> E.coalesceDefault [ queryLmsUser row E.^. LmsUserStatusDay
dbtProj = dbtProjId
dbtColonnade = cols getCompanyName
dbtSorting = Map.fromList
[ sortUserNameLink queryUser
, sortUserEmail queryUser
, sortUserMatriclenr queryUser
, ("valid-until" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserValidUntil))
-- , ("validity" , SortColumn $ queryQualUser >>> validQualification nowaday)
, ("last-refresh" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserLastRefresh))
, ("first-held" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserFirstHeld))
, ("blocked" , SortColumnNeverNull$ queryQualBlock >>> (E.?. QualificationUserBlockFrom))
, ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal))
, ("ident" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserIdent))
, ("pin" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserPin))
-- , ("status" , SortColumnNullsInv $ views (to queryLmsUser) (E.^. LmsUserStatusDay))
, ("status" , SortColumnNeverNull $ \row -> E.coalesceDefault [ queryLmsUser row E.^. LmsUserStatusDay
, queryLmsUser row E.^. LmsUserNotified
](queryLmsUser row E.^. LmsUserStarted))
, single ("started" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserStarted))
, single ("datepin" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserDatePin))
, single ("received" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserReceived))
, single ("notified" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserNotified)) -- cannot include printJob acknowledge date
, single ("ended" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserEnded))
, single ("user-company", SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
, ("started" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserStarted))
, ("datepin" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserDatePin))
, ("received" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserReceived))
, ("notified" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserNotified)) -- cannot include printJob acknowledge date
, ("ended" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserEnded))
, ("user-company", SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId
E.orderBy [E.asc (comp E.^. CompanyName)]
return (comp E.^. CompanyName)
)
)
]
dbtFilter = mconcat
[ single $ fltrUserNameEmail queryUser
, single ("ident" , FilterColumn . E.mkContainsFilterWithCommaPlus LmsIdent $ views (to queryLmsUser) (E.^. LmsUserIdent))
, single ("status" , FilterColumn . E.mkExactFilterMaybeLast $ views (to queryLmsUser) (E.^. LmsUserStatus))
-- , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) ((E.>=. E.val nowaday) . (E.^. QualificationUserValidUntil)))
, single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification now))
-- , single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion ->
dbtFilter = Map.fromList
[ fltrUserNameEmail queryUser
, ("ident" , FilterColumn . E.mkContainsFilterWithCommaPlus LmsIdent $ views (to queryLmsUser) (E.^. LmsUserIdent))
, ("status" , FilterColumn . E.mkExactFilterMaybeLast $ views (to queryLmsUser) (E.^. LmsUserStatus))
-- , ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) ((E.>=. E.val nowaday) . (E.^. QualificationUserValidUntil)))
, ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification now))
-- , ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion ->
-- if | Just renewal <- mbRenewal
-- , Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal
-- E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday
-- | otherwise -> E.true
-- )
, single ("notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.^. LmsUserNotified)))
, single ("avs-number" , FilterColumn . E.mkExistsFilter $ \row criterion ->
E.from $ \usrAvs -> -- do
, ("notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.^. LmsUserNotified)))
, ("avs-number" , FilterColumn . E.mkExistsFilter $ \row criterion ->
E.from $ \usrAvs -> -- do
E.where_ $ usrAvs E.^. UserAvsUser E.==. queryUser row E.^. UserId
E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==.
(E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) ))
, single ("user-company", FilterColumn . E.mkExistsFilter $ \row criterion ->
E.from $ \(usrComp `E.InnerJoin` comp) -> do
, ("user-company", FilterColumn . E.mkExistsFilter $ \row criterion ->
E.from $ \(usrComp `E.InnerJoin` comp) -> do
let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf`
(E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text)))
testnumber nr = E.val nr E.==. comp E.^. CompanyAvsId
testcrit = maybe testname testnumber $ readMay $ ciOriginal criterion
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.&&. testcrit
)
, single ("avs-card" , FilterColumn $ \(queryUser -> user) (criterion :: Set.Set Text) -> case readAvsFullCardNo =<< Set.lookupMin criterion of
Nothing -> E.false
Just cardNo -> E.exists $ E.from $ \(avsCard `E.InnerJoin` usrAvs) -> do
E.on $ usrAvs E.^. UserAvsPersonId E.==. avsCard E.^. UserAvsCardPersonId
E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId
E.&&. (avsCard E.^. UserAvsCardCardNo E.==. E.val cardNo)
)
, single ("personal-number", FilterColumn $ \(queryUser -> user) (criteria :: Set.Set Text) -> if
)
, fltrAVSCardNos queryUser
, ("personal-number", FilterColumn $ \(queryUser -> user) (criteria :: Set.Set Text) -> if
| Set.null criteria -> E.true
| otherwise -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria
)
]
dbtFilterUI mPrev = mconcat
[ fltrUserNameEmailHdrUI MsgLmsUser mPrev
[ fltrUserNameEmailHdrUI MsgLmsUser mPrev
, prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany)
, prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber)
, prismAForm (singletonFilter "avs-card" ) mPrev $ aopt textField (fslI MsgAvsCardNo)
, fltrAVSCardNosUI mPrev
, prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo)
, prismAForm (singletonFilter "ident" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent)
, prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid)
, prismAForm (singletonFilter "notified" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsNotified)
, prismAForm (singletonFilter "status" . maybePrism _PathPiece) mPrev $ aopt (hoistField liftHandler (selectField optionsFinite) :: (Field _ (Maybe LmsStatus))) (fslI MsgTableLmsStatus)
-- , if isNothing mbRenewal then mempty
-- else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal)
-- else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal)
]
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
dbtCsvEncode = Just DBTCsvEncode
@ -539,29 +543,24 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
doEncode' = LmsTableCsv
<$> view (resultUser . _entityVal . _userDisplayName)
<*> view (resultUser . _entityVal . _userDisplayEmail)
<*> (view resultCompanyUser >>= getCompanies)
<*> (view resultCompanyUser >>= getCompanyNos)
<*> view (resultQualUser . _entityVal . _qualificationUserValidUntil)
<*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh)
<*> view (resultQualUser . _entityVal . _qualificationUserFirstHeld)
<*> preview (resultCompanyId . to getCompanyName . _CI)
<*> view (resultQualUser . _entityVal . _qualificationUserValidUntil)
<*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh)
<*> view (resultQualUser . _entityVal . _qualificationUserFirstHeld)
<*> preview (resultQualBlock . _entityVal . _qualificationUserBlockUnblock . _not)
<*> preview (resultQualBlock . _entityVal . _qualificationUserBlockFrom)
<*> view (resultLmsUser . _entityVal . _lmsUserIdent)
<*> view (resultLmsUser . _entityVal . _lmsUserStatus)
<*> view (resultLmsUser . _entityVal . _lmsUserStatusDay)
<*> view (resultLmsUser . _entityVal . _lmsUserStarted)
<*> view (resultLmsUser . _entityVal . _lmsUserDatePin)
<*> view (resultLmsUser . _entityVal . _lmsUserReceived)
<*> view (resultLmsUser . _entityVal . _lmsUserNotified) -- TODO: only exports last email date / print job sending date, not print acknowledge
<*> view (resultLmsUser . _entityVal . _lmsUserEnded)
getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of
[] -> pure Nothing
somecmps -> pure $ Just $ intercalate ", " $ fmap (view (_companyName . _CI)) somecmps
getCompanyNos = pure . CsvSemicolonList . mapMaybe (preview (_Just . _companyAvsId) . flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany))
<*> view (resultLmsUser . _entityVal . _lmsUserIdent)
<*> view (resultLmsUser . _entityVal . _lmsUserStatus)
<*> view (resultLmsUser . _entityVal . _lmsUserStatusDay)
<*> view (resultLmsUser . _entityVal . _lmsUserStarted)
<*> view (resultLmsUser . _entityVal . _lmsUserDatePin)
<*> view (resultLmsUser . _entityVal . _lmsUserReceived)
<*> view (resultLmsUser . _entityVal . _lmsUserNotified) -- TODO: only exports last email date / print job sending date, not print acknowledge
<*> view (resultLmsUser . _entityVal . _lmsUserEnded)
dbtCsvDecode = Nothing
dbtExtraReps = []
dbtParams = if not isAdmin then def {dbParamsFormAction = Nothing, dbParamsFormSubmit = FormNoSubmit} else
dbtParams = if not isAdmin then def {dbParamsFormAction = Nothing, dbParamsFormSubmit = FormNoSubmit} else
DBParamsForm
{ dbParamsFormMethod = POST
, dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute
@ -602,37 +601,34 @@ postLmsR sid qsh = do
msgResetInfo <- messageIconI Info IconNotificationNonactive MsgLmsActResetInfo
msgRestartWarning <- messageIconI Warning IconWarning MsgLmsActRestartWarning
((lmsRes, lmsTable), Entity qid quali) <- runDB $ do
qent <- getBy404 $ SchoolQualificationShort sid qsh
((lmsRes, lmsTable), Entity qid quali, lmsQualiReused) <- runDB $ do
qent@Entity{entityVal=Qualification{qualificationLmsReuses = reuseQuali}} <- getBy404 $ SchoolQualificationShort sid qsh
lmsQualiReused <- traverseJoin get reuseQuali
let acts :: Map LmsTableAction (AForm Handler LmsTableActionData)
acts = mconcat
[ singletonMap LmsActNotify $ pure LmsActNotifyData
, singletonMap LmsActRenewNotify $ pure LmsActRenewNotifyData
-- , singletonMap LmsActRenewPin $ pure LmsActRenewPinData
, singletonMap LmsActReset $ LmsActResetData
<$> aopt intField (fslI MsgLmsActRestartExtend) Nothing
, singletonMap LmsActReset $ LmsActResetData
<$> aopt intField (fslI MsgLmsActRestartExtend) Nothing
<*> aopt checkBoxField (fslI MsgLmsActRestartUnblock) Nothing
<*> aopt checkBoxField (fslI MsgLmsActNotify) Nothing
<*> aopt checkBoxField (fslI MsgLmsActNotify) Nothing
<* aformMessage msgResetInfo
, singletonMap LmsActRestart $ LmsActRestartData
<$> aopt intField (fslI MsgLmsActRestartExtend) Nothing
, singletonMap LmsActRestart $ LmsActRestartData
<$> aopt intField (fslI MsgLmsActRestartExtend) Nothing
<*> aopt checkBoxField (fslI MsgLmsActRestartUnblock) Nothing
<*> aopt checkBoxField (fslI MsgLmsActNotify) Nothing
-- <*> aopt (commentField MsgQualificationActBlockSupervisor) (fslI MsgMessageWarning) Nothing
<* aformMessage msgRestartWarning
]
colChoices cmpMap = mconcat
<* aformMessage msgRestartWarning
]
colChoices getCompanyName = mconcat
[ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUser . _entityKey))
, colUserNameModalHdrAdmin MsgLmsUser AdminUserR
, colUserEmail
, sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) ->
let cs = [ companyCell (unCompanyKey cmpId) cmpName cmpSpr
| Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps
, let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap
]
in intercalate spacerCell cs
, sortable (Just "user-company") (i18nCell MsgTablePrimeCompany) $ \(preview resultCompanyId -> mcid) ->
maybeEmpty mcid $ \cid -> companyCell (unCompanyKey cid) (getCompanyName cid) False
, colUserMatriclenr isAdmin
-- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser)
-- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser)
, sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d
, sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d
, sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d
@ -659,8 +655,8 @@ postLmsR sid qsh = do
-- - Letter printed : LmsUserNotified == Just _ && PrintJobId == Just _
-- - Letter sent : LmsUserNotified == Just _ && PrintJobId == Just _ && PrintJobAcknowledged == Just _
let notifyDate = row ^. resultLmsUser . _entityVal . _lmsUserNotified
lmsident = row ^. resultLmsUser . _entityVal . _lmsUserIdent
recipient = row ^. hasUser
lmsident = row ^. resultLmsUser . _entityVal . _lmsUserIdent
recipient = row ^. hasUser
letterDates = row ^? resultPrintAck
lastLetterDate = headDef Nothing =<< letterDates
letterSent = isJust letterDates && (isNothing lastLetterDate || lastLetterDate >= notifyDate) -- was a letter attempted to send last (not 100% safe, if an email is sent after an unacknowledged letter)
@ -681,7 +677,7 @@ postLmsR sid qsh = do
$maybe ackdate <- mbackdate
^{formatTimeW SelFormatDateTime ackdate}
$nothing
_{MsgPrintJobUnacknowledged}
_{MsgPrintJobUnacknowledged}
<p>
<a href=@{lprLink}>
_{MsgPrintJobs}
@ -700,31 +696,31 @@ postLmsR sid qsh = do
i18nLms msg = cell [whamlet|LMS #|] <> i18nCell msg
psValidator = def & defaultSorting [SortDescBy "started", SortDescBy "status"]
tbl <- mkLmsTable isAdmin qent acts colChoices psValidator
return (tbl, qent)
return (tbl, qent, lmsQualiReused)
formResult lmsRes $ \case
_ | not isAdmin -> addMessageI Error MsgUnauthorized -- only admins can use the form on this page
(action, selectedUsers) | isResetRestartAct action -> do
let usersList = Set.toList selectedUsers
let usersList = Set.toList selectedUsers
numUsers = Set.size selectedUsers
isReset = isResetAct action
actRestartExtend = action & lmsActRestartExtend
actRestartUnblock = action & lmsActRestartUnblock
actRestartNotify = action & lmsActRestartNotify
actRestartExtend = action & lmsActRestartExtend
actRestartUnblock = action & lmsActRestartUnblock
actRestartNotify = action & lmsActRestartNotify
chgUsers <- runDB $ do
chgUsers <- runDB $ do
when (actRestartUnblock == Just True) $ do
oks <- qualificationUserBlocking qid usersList True Nothing (Left $ bool "Manueller LMS Neustart" "Manuelle LMS Zurücksetzung" isReset) (fromMaybe True actRestartNotify)
addMessageI Success $ MsgQualificationStatusUnblock qsh oks numUsers
whenIsJust actRestartExtend $ \extDays -> do
let cutoff = addDays extDays nowaday
shortUsers <- view (_entityVal . _qualificationUserUser) <<$>> selectList
shortUsers <- view (_entityVal . _qualificationUserUser) <<$>> selectList
[ QualificationUserQualification ==. qid
, QualificationUserUser <-. usersList
, QualificationUserUser <-. usersList
, QualificationUserValidUntil <. cutoff
] []
] []
forM_ shortUsers $ upsertQualificationUser qid now cutoff Nothing "E-Learning Reset"
fromIntegral <$> (if isReset
@ -733,25 +729,25 @@ postLmsR sid qsh = do
else deleteWhereCount [LmsUserQualification ==. qid, LmsUserUser <-. usersList]
)
unless isReset $
unless isReset $
forM_ selectedUsers $ \uid ->
queueJob' $ JobLmsEnqueueUser { jQualification = qid, jUser = uid }
runDB $ forM_ selectedUsers $ \uid ->
audit $ TransactionLmsReset
{ transactionQualification = qid
runDB $ forM_ selectedUsers $ \uid ->
audit $ TransactionLmsReset
{ transactionQualification = qid
, transactionLmsUser = uid
, transactionLmsReset = isReset
, transactionLmsResetExtend = actRestartExtend
, transactionLmsResetExtend = actRestartExtend
, transactionLmsResetUnblock = actRestartUnblock
, transactionLmsResetNotify = actRestartNotify
, transactionLmsResetNotify = actRestartNotify
}
let mStatus = bool Success Warning $ chgUsers < numUsers
addMessageI mStatus $ bool MsgLmsActRestartFeedback MsgLmsActResetFeedback isReset chgUsers numUsers
reloadKeepGetParams $ LmsR sid qsh
(action, selectedUsers) | isRenewPinAct action || isNotifyAct action -> do
(action, selectedUsers) | isRenewPinAct action || isNotifyAct action -> do
numExaminees <- runDB $ do
okUsers <- selectList [ LmsUserQualification ==. qid -- matching qualification
, LmsUserEnded ==. Nothing -- not yet deleted
@ -767,7 +763,7 @@ postLmsR sid qsh = do
return $ length okUsers
let numSelected = length selectedUsers
diffSelected = numSelected - numExaminees
mstat = bool Success Warning $ diffSelected /= 0
mstat = bool Success Warning $ diffSelected /= 0
when (isRenewPinAct action) $ addMessageI mstat $ MsgLmsPinRenewal numExaminees
when (isNotifyAct action) $ addMessageI mstat $ MsgLmsNotificationSend numExaminees
when (diffSelected /= 0) $ addMessageI Warning $ MsgLmsActionFailed diffSelected
@ -797,22 +793,22 @@ getLmsUserR sid qsh = viewLmsUserR (Just sid) (Just qsh)
viewLmsUserR :: Maybe SchoolId -> Maybe QualificationShorthand -> CryptoUUIDUser -> Handler Html
viewLmsUserR msid mqsh uuid = do
uid <- decrypt uuid
now <- liftIO getCurrentTime
(user@User{userDisplayName}, quals, qblocks) <- runDB $ do
now <- liftIO getCurrentTime
(user@User{userDisplayName}, quals, qblocks) <- runDBRead $ do
usr <- get404 uid
qs <- Ex.select $ do
(qual :& qualUsr :& lmsUsr) <-
qs <- Ex.select $ do
(qual :& qualUsr :& lmsUsr) <-
Ex.from $ Ex.table @Qualification
`Ex.leftJoin` Ex.table @QualificationUser
`Ex.on` (\(qual :& qualUsr) -> qualUsr E.?. QualificationUserUser E.?=. Ex.val uid
E.&&. qualUsr E.?. QualificationUserQualification E.?=. qual Ex.^. QualificationId
)
)
`Ex.leftJoin` Ex.table @LmsUser
`Ex.on` (\(qual :& _ :& lmsUsr) -> lmsUsr E.?. LmsUserUser E.?=. Ex.val uid
E.&&. lmsUsr E.?. LmsUserQualification E.?=. qual Ex.^. QualificationId
E.&&. lmsUsr E.?. LmsUserQualification E.?=. qual Ex.^. QualificationId
)
Ex.where_ $ E.and $
(E.isJust (qualUsr E.?. QualificationUserUser) E.||. E.isJust ( lmsUsr E.?. LmsUserUser)) : catMaybes
(E.isJust (qualUsr E.?. QualificationUserUser) E.||. E.isJust ( lmsUsr E.?. LmsUserUser)) : catMaybes
[ (qual E.^. QualificationSchool E.==.) . E.val <$> msid
, (qual E.^. QualificationShorthand E.==.) . E.val <$> mqsh
]
@ -822,7 +818,7 @@ viewLmsUserR msid mqsh uuid = do
<- foldMapM (\(_, mbqu, _, _) -> case mbqu of
Nothing -> pure mempty
Just (Entity quid _) -> do
blocks <- Ex.select $ do
blocks <- Ex.select $ do
(qBlock :& qbUsr) <- Ex.from $ Ex.table @QualificationUserBlock
`Ex.leftJoin` Ex.table @User
`Ex.on` (\(qBlock :& qbUsr) -> qBlock Ex.^. QualificationUserBlockBlocker Ex.==. qbUsr Ex.?. UserId)
@ -832,7 +828,7 @@ viewLmsUserR msid mqsh uuid = do
return $ Map.singleton quid blocks
) qs
return (usr, qs, Map.filter notNull bs)
let heading = [whamlet|_{MsgMenuLmsUser} ^{userWidget user}|]
let heading = [whamlet|_{MsgMenuLmsUser} ^{userWidget user}|]
siteLayout heading $ do
setTitle $ toHtml userDisplayName
$(widgetFile "lms-user")
$(widgetFile "lms-user")

8
src/Handler/LMS/Fake.hs
View File

@ -71,11 +71,11 @@ fakeQualificationUsers (Entity qid Qualification{qualificationRefreshWithin}) (u
theSupervisor <- selectKeysList [UserSurname ==. "Jost", UserFirstName ==. "Steffen"] [Asc UserCreated, LimitTo 1]
let addSupervisor = case theSupervisor of
[s] -> \suid k -> case k of
1 -> void $ insertBy $ UserSupervisor s suid True
1 -> void $ insertBy $ UserSupervisor s suid True Nothing Nothing
2 -> do
void $ insertBy $ UserSupervisor s suid True
void $ insertBy $ UserSupervisor suid suid True
3 -> void $ insertBy $ UserSupervisor s suid True
void $ insertBy $ UserSupervisor s suid True Nothing (Just "Test")
void $ insertBy $ UserSupervisor suid suid True Nothing Nothing
3 -> void $ insertBy $ UserSupervisor s suid True Nothing Nothing
_ -> return ()
_ -> \_ _ -> return ()
expiryOffsets = concatMap (replicate usersPerDay) [0..(diffDays dto dfrom)]

46
src/Handler/LMS/Learners.hs
View File

@ -19,6 +19,7 @@ import Handler.Utils.LMS
import qualified Data.Map as Map
import qualified Data.Csv as Csv
import qualified Data.Text as Text
import qualified Data.Conduit.List as C
-- import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma
import qualified Database.Esqueleto.Legacy as E
@ -38,7 +39,7 @@ lmsUser2csv :: UTCTime -> LmsUser -> LmsUserTableCsv
lmsUser2csv cutoff lu@LmsUser{..} = LmsUserTableCsv
{ csvLUTident = lmsUserIdent
, csvLUTpin = lmsUserPin
, csvLUTresetPin = LmsBool lmsUserResetPin
, csvLUTresetPin = LmsBool lmsUserResetPin
, csvLUTdelete = LmsBool (lmsUserToDelete cutoff lu)
, csvLUTstaff = LmsBool (lmsUserStaff lu)
, csvLUTresetTries= LmsBool (lmsUserToResetTries lu) -- TODO: verify this works as intended!
@ -75,24 +76,20 @@ instance FromNamedRecord LmsUserTableCsv where
<*> csv Csv..: csvLmsLock
instance CsvColumnsExplained LmsUserTableCsv where
csvColumnsExplanations _ = mconcat
[ single csvLmsIdent MsgCsvColumnLmsIdent
, single csvLmsPin MsgCsvColumnLmsPin
, single csvLmsResetPin MsgCsvColumnLmsResetPin
, single csvLmsDelete MsgCsvColumnLmsDelete
, single csvLmsStaff MsgCsvColumnLmsStaff
, single csvLmsResetTries MsgCsvColumnLmsResetTries
, single csvLmsLock MsgCsvColumnLmsLock
csvColumnsExplanations _ = Map.fromList
[ (csvLmsIdent , msg2widget MsgCsvColumnLmsIdent)
, (csvLmsPin , msg2widget MsgCsvColumnLmsPin)
, (csvLmsResetPin , msg2widget MsgCsvColumnLmsResetPin)
, (csvLmsDelete , msg2widget MsgCsvColumnLmsDelete)
, (csvLmsStaff , msg2widget MsgCsvColumnLmsStaff)
, (csvLmsResetTries , msg2widget MsgCsvColumnLmsResetTries)
, (csvLmsLock , msg2widget MsgCsvColumnLmsLock)
]
where
single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
single k v = singletonMap k [whamlet|_{v}|]
mkUserTable :: SchoolId -> QualificationShorthand -> QualificationId -> UTCTime -> DB (Any, Widget)
mkUserTable _sid qsh qid cutoff = do
dbtCsvName <- csvFilenameLmsUser qsh
dbtCsvName <- csvFilenameLmsUser qsh
let dbtCsvSheetName = dbtCsvName
let
userDBTable = DBTable{..}
@ -166,7 +163,7 @@ getQidCutoff sid qsh = do
getLmsLearnersR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsLearnersR sid qsh = do
lmsTable <- runDB $ do
(qid, cutoff) <- getQidCutoff sid qsh
(qid, cutoff) <- getQidCutoff sid qsh
view _2 <$> mkUserTable sid qsh qid cutoff
siteLayoutMsg MsgMenuLmsLearners $ do
setTitleI MsgMenuLmsLearners
@ -174,14 +171,17 @@ getLmsLearnersR sid qsh = do
getLmsLearnersDirectR :: SchoolId -> QualificationShorthand -> Handler TypedContent
getLmsLearnersDirectR sid qsh = do
$logInfoS "LMS" $ "Direct Download Users for " <> tshow qsh <> " at " <> tshow sid
(lms_users,cutoff) <- runDB $ do
(qid, cutoff) <- getQidCutoff sid qsh
lms_users <- selectList [ LmsUserQualification ==. qid
$logInfoS "LMS" $ "Direct Download Users for " <> tshow qsh <> " at " <> tshow sid
(lms_users,cutoff,qshs) <- runDB $ do
(qid, cutoff) <- getQidCutoff sid qsh
qidsReuse <- selectList [QualificationLmsReuses ==. Just qid] []
let qids = qid : (entityKey <$> qidsReuse)
qshs = qsh : (qualificationShorthand . entityVal <$> qidsReuse)
lms_users <- selectList [ LmsUserQualification <-. qids
, LmsUserEnded ==. Nothing
-- , LmsUserReceived ==. Nothing ||. LmsUserResetPin ==. True ||. LmsUserStatus !=. Nothing -- send delta only NOTE: know-how no longer expects delta
] [Asc LmsUserStarted, Asc LmsUserIdent]
return (lms_users, cutoff)
] [Asc LmsUserStarted, Asc LmsUserIdent]
return (lms_users, cutoff, qshs)
{- To avoid exporting unneeded columns, we would need an SqlSelect instance for LmsUserTableCsv; probably not worth it
Ex.select $ do
@ -196,7 +196,7 @@ getLmsLearnersDirectR sid qsh = do
, csvLUTstaff = LmsBool False
}
-}
LmsConf{..} <- getsYesod $ view _appLmsConf
LmsConf{..} <- getsYesod $ view _appLmsConf
let --csvRenderedData = toNamedRecord . lmsUser2csv . entityVal <$> lms_users
--csvRenderedHeader = lmsUserTableCsvHeader
--cvsRendered = CsvRendered {..}
@ -209,7 +209,7 @@ getLmsLearnersDirectR sid qsh = do
csvOpts = def { csvFormat = fmtOpts }
csvSheetName <- csvFilenameLmsUser qsh
let nr = length lms_users
msg = "Success. LMS user learners download file " <> csvSheetName <> " containing " <> tshow nr <> " rows"
msg = "Success. LMS user learners download file " <> csvSheetName <> " containing " <> tshow nr <> " rows for Qualifications " <> Text.intercalate ", " (ciOriginal <$> qshs)
$logInfoS "LMS" msg
addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\""
csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered

77
src/Handler/LMS/Report.hs
View File

@ -3,6 +3,7 @@
-- SPDX-License-Identifier: AGPL-3.0-or-later
{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances
{-# LANGUAGE TypeApplications #-}
module Handler.LMS.Report
( getLmsReportR, postLmsReportR
@ -17,10 +18,13 @@ import Handler.Utils
import Handler.Utils.Csv
import Handler.Utils.LMS
import qualified Data.Text as Text
import qualified Data.Map as Map
import qualified Data.Csv as Csv
import qualified Data.Conduit.List as C
import qualified Database.Esqueleto.Legacy as E
-- import Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
import qualified Database.Esqueleto.PostgreSQL as E
import qualified Database.Esqueleto.Utils as E
import Jobs.Queue
@ -60,15 +64,12 @@ instance FromNamedRecord LmsReportTableCsv where
<*> csv Csv..: csvLmsLock
instance CsvColumnsExplained LmsReportTableCsv where
csvColumnsExplanations _ = mconcat
[ single csvLmsIdent MsgCsvColumnLmsIdent
, single csvLmsDate MsgCsvColumnLmsDate
, single csvLmsResult MsgCsvColumnLmsResult
, single csvLmsLock MsgCsvColumnLmsLock
csvColumnsExplanations _ = Map.fromList
[ (csvLmsIdent , msg2widget MsgCsvColumnLmsIdent)
, (csvLmsDate , msg2widget MsgCsvColumnLmsDate)
, (csvLmsResult , msg2widget MsgCsvColumnLmsResult)
, (csvLmsLock , msg2widget MsgCsvColumnLmsLock)
]
where
single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
single k v = singletonMap k [whamlet|_{v}|]
data LmsReportCsvActionClass = LmsReportInsert | LmsReportUpdate
deriving (Eq, Ord, Read, Show, Generic, Enum, Bounded)
@ -121,7 +122,7 @@ mkReportTable sid qsh qid = do
]
dbtFilter = Map.fromList
[ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWithCommaPlus LmsIdent (E.^. LmsReportIdent))
, (csvLmsDate , FilterColumn $ E.mkExactFilter (E.^. LmsReportDate))
, (csvLmsDate , FilterColumn $ E.mkExactFilter (E.^. LmsReportDate))
]
dbtFilterUI = \mPrev -> mconcat
[ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent & setTooltip MsgTableFilterCommaPlus)
@ -199,7 +200,7 @@ mkReportTable sid qsh qid = do
, LmsReportResult =. lmsReportCsvResult actionData
, LmsReportLock =. lmsReportCsvLock actionData
, LmsReportTimestamp =. eanow
]
]
lift . queueDBJob $ JobLmsReports qid
return $ LmsReportR sid qsh
, dbtCsvRenderKey = const $ \case
@ -246,8 +247,8 @@ postLmsReportR sid qsh = do
-- Direct File Upload/Download
saveReportCsv :: UTCTime -> QualificationId -> Int -> LmsReportTableCsv -> JobDB Int
saveReportCsv now qid i LmsReportTableCsv{..} = do
saveReportCsv :: UTCTime -> NonEmpty QualificationId -> Int -> LmsReportTableCsv -> JobDB Int
saveReportCsv now (qid :| []) i LmsReportTableCsv{..} = do
void $ upsert
LmsReport
{ lmsReportQualification = qid
@ -263,6 +264,30 @@ saveReportCsv now qid i LmsReportTableCsv{..} = do
, LmsReportTimestamp =. now
]
return $ succ i
saveReportCsv now qids@(qid :| _) i lrtc@LmsReportTableCsv{..} = do
ok <- E.insertSelectWithConflictCount UniqueLmsReport
(do
lusr <- E.from $ E.table @LmsUser
E.where_ $ lusr E.^. LmsUserIdent E.==. E.val csvLRident
E.&&. lusr E.^. LmsUserQualification `E.in_` E.vals qids
return $ LmsReport
E.<# (lusr E.^. LmsUserQualification)
E.<&> E.val csvLRident
E.<&> E.val (csvLRdate <&> lms2timestamp)
E.<&> E.val csvLRresult
E.<&> E.val (csvLRlock & lms2bool)
E.<&> E.val now
)
(\_old _new ->
[ LmsReportDate E.=. E.val (csvLRdate <&> lms2timestamp)
, LmsReportResult E.=. E.val csvLRresult
, LmsReportLock E.=. E.val (csvLRlock & lms2bool)
, LmsReportTimestamp E.=. E.val now
]
)
if ok > 0
then return $ succ i
else saveReportCsv now (qid :| []) i lrtc -- save unknown LmsIdent to primary qid regardless, so that the error can be tracked
makeReportUploadForm :: Form FileInfo
makeReportUploadForm = renderAForm FormStandard $ fileAFormReq "Report CSV"
@ -276,15 +301,18 @@ postLmsReportUploadR sid qsh = do
FormSuccess file -> do
-- content <- fileSourceByteString file
-- return $ Just (fileName file, content)
(nr, qid) <- runDBJobs $ do
(nr, qids, qshs) <- runDBJobs $ do
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
qidsReuse <- selectList [QualificationLmsReuses ==. Just qid] []
let qids = qid :| (entityKey <$> qidsReuse)
qshs = qsh : (qualificationShorthand . entityVal <$> qidsReuse)
nr <- runConduit $ fileSource file
.| decodeCsv
.| foldMC (saveReportCsv now qid) 0
return (nr, qid)
addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen")
.| foldMC (saveReportCsv now qids) 0
return (nr, qids, qshs)
addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen") <> " für Qualifikationen: " <> Text.intercalate ", " (ciOriginal <$> qshs)
-- redirect $ LmsReportR sid qsh
getLmsReportR sid qsh <* queueJob' (JobLmsReports qid) -- show uploaded data before processing
getLmsReportR sid qsh <* forM_ qids (queueJob' . JobLmsReports) -- show uploaded data before processing
FormFailure errs -> do
forM_ errs $ addMessage Error . toHtml
@ -294,7 +322,7 @@ postLmsReportUploadR sid qsh = do
setTitleI MsgMenuLmsUpload
[whamlet|$newline never
<form method=post enctype=#{enctype}>
^{widget}
^{widget}
<input type=submit>
|]
@ -308,18 +336,21 @@ postLmsReportDirectR sid qsh = do
lmsDecoder <- getLmsCsvDecoder
runDBJobs $ do
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
qidsReuse <- selectList [QualificationLmsReuses ==. Just qid] []
let qids = qid :| (entityKey <$> qidsReuse)
qshs = qsh : (qualificationShorthand . entityVal <$> qidsReuse)
enr <- try $ runConduit $ fileSource file
.| lmsDecoder
.| foldMC (saveReportCsv now qid) 0
.| foldMC (saveReportCsv now qids) 0
case enr of
Left (e :: SomeException) -> do -- catch all to avoid ok220 in case of any error
$logWarnS "LMS" $ "Report upload failed parsing: " <> tshow e
$logWarnS "LMS" $ "Report upload failed parsing: " <> tshow e <> " for Qualification: " <> Text.intercalate ", " (ciOriginal <$> qshs)
logInterface "LMS" (ciOriginal qsh) False Nothing ""
return (badRequest400, "Exception: " <> tshow e)
Right nr -> do
let msg = "Success. LMS Report upload file " <> fileName file <> " containing " <> tshow nr <> " rows for " <> fhead <> ". "
let msg = "Success. LMS Report upload file " <> fileName file <> " containing " <> tshow nr <> " rows for " <> fhead <> " and Qualifications: " <> Text.intercalate ", " (ciOriginal <$> qshs)
$logInfoS "LMS" msg
when (nr > 0) $ queueDBJob $ JobLmsReports qid
when (nr > 0) $ forM_ qids (queueDBJob . JobLmsReports)
logInterface "LMS" (ciOriginal qsh) True (Just nr) ""
return (ok200, msg)
[] -> do

26
src/Handler/LMS/Users.hs
View File

@ -68,23 +68,19 @@ instance FromNamedRecord LmsUserTableCsv where
<*> csv Csv..: csvLmsStaff
instance CsvColumnsExplained LmsUserTableCsv where
csvColumnsExplanations _ = mconcat
[ single csvLmsIdent MsgCsvColumnLmsIdent
, single csvLmsPin MsgCsvColumnLmsPin
, single csvLmsResetPin MsgCsvColumnLmsResetPin
, single csvLmsDelete MsgCsvColumnLmsDelete
, single csvLmsStaff MsgCsvColumnLmsStaff
csvColumnsExplanations _ = Map.fromList
[ (csvLmsIdent , msg2widget MsgCsvColumnLmsIdent)
, (csvLmsPin , msg2widget MsgCsvColumnLmsPin)
, (csvLmsResetPin , msg2widget MsgCsvColumnLmsResetPin)
, (csvLmsDelete , msg2widget MsgCsvColumnLmsDelete)
, (csvLmsStaff , msg2widget MsgCsvColumnLmsStaff)
]
where
single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
single k v = singletonMap k [whamlet|_{v}|]
mkUserTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget)
mkUserTable _sid qsh qid = do
cutoff <- liftHandler $ lmsDeletionDate Nothing
dbtCsvName <- csvFilenameLmsUser qsh
dbtCsvName <- csvFilenameLmsUser qsh
let dbtCsvSheetName = dbtCsvName
let
userDBTable = DBTable{..}
@ -160,7 +156,7 @@ getLmsUsersDirectR sid qsh = do
selectList [ LmsUserQualification ==. qid
, LmsUserEnded ==. Nothing
-- , LmsUserReceived ==. Nothing ||. LmsUserResetPin ==. True ||. LmsUserStatus !=. Nothing -- send delta only NOTE: know-how no longer expects delta
] [Asc LmsUserStarted, Asc LmsUserIdent]
] [Asc LmsUserStarted, Asc LmsUserIdent]
{- To avoid exporting unneeded columns, we would need an SqlSelect instance for LmsUserTableCsv; probably not worth it
Ex.select $ do
@ -175,7 +171,7 @@ getLmsUsersDirectR sid qsh = do
, csvLUTstaff = LmsBool False
}
-}
LmsConf{..} <- getsYesod $ view _appLmsConf
LmsConf{..} <- getsYesod $ view _appLmsConf
let --csvRenderedData = toNamedRecord . lmsUser2csv . entityVal <$> lms_users
--csvRenderedHeader = lmsUserTableCsvHeader
--cvsRendered = CsvRendered {..}
@ -188,10 +184,10 @@ getLmsUsersDirectR sid qsh = do
csvOpts = def { csvFormat = fmtOpts }
csvSheetName <- csvFilenameLmsUser qsh
let nr = length lms_users
msg = "Success. LMS Users download file " <> csvSheetName <> " containing " <> tshow nr <> " rows"
msg = "Success. LMS Users download file " <> csvSheetName <> " containing " <> tshow nr <> " rows"
$logInfoS "LMS" msg
addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\""
csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered
csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered
-- direct Download see:
-- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod

369
src/Handler/MailCenter.hs Normal file
View File

@ -0,0 +1,369 @@
-- SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Handler.MailCenter
( getMailCenterR, postMailCenterR
, getMailHtmlR
, getMailPlainR
, getMailAttachmentR
) where
import Import
import qualified Data.Set as Set
import qualified Data.Map as Map
-- import qualified Data.Aeson as Aeson
-- import qualified Data.Text as Text
-- import Database.Persist.Sql (updateWhereCount)
-- import Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Legacy as EL (on) -- only `on` and `from` are different, needed for dbTable using Esqueleto.Legacy
import qualified Database.Esqueleto.Experimental as E
import qualified Database.Esqueleto.Utils as E
import Database.Esqueleto.Utils.TH
import qualified Data.Aeson as Aeson
import Text.Blaze.Html (preEscapedToHtml)
-- import Text.Blaze.Html5 as H (html, body, pre, p, h1)
-- import Text.Blaze.Html.Renderer.String (renderHtml)
import Numeric (readHex)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as LB
import Handler.Utils
data MCTableAction = MCActDummy -- just a dummy, since we don't now yet which actions we will be needing
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
instance Universe MCTableAction
instance Finite MCTableAction
nullaryPathPiece ''MCTableAction $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''MCTableAction id
data MCTableActionData = MCActDummyData
deriving (Eq, Ord, Read, Show, Generic)
type MCTableExpr =
( E.SqlExpr (Entity SentMail)
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
)
queryMail :: MCTableExpr -> E.SqlExpr (Entity SentMail)
queryMail = $(sqlLOJproj 2 1)
queryRecipient :: MCTableExpr -> E.SqlExpr (Maybe (Entity User))
queryRecipient = $(sqlLOJproj 2 2)
type MCTableData = DBRow (Entity SentMail, Maybe (Entity User))
resultMail :: Lens' MCTableData (Entity SentMail)
resultMail = _dbrOutput . _1
resultRecipient :: Traversal' MCTableData (Entity User)
resultRecipient = _dbrOutput . _2 . _Just
mkMCTable :: DB (FormResult (MCTableActionData, Set SentMailId), Widget)
mkMCTable = do
let
dbtSQLQuery :: MCTableExpr -> E.SqlQuery (E.SqlExpr (Entity SentMail), E.SqlExpr (Maybe (Entity User)))
dbtSQLQuery (mail `E.LeftOuterJoin` recipient) = do
EL.on $ mail E.^. SentMailRecipient E.==. recipient E.?. UserId
return (mail, recipient)
dbtRowKey = queryMail >>> (E.^. SentMailId)
dbtProj = dbtProjId
dbtColonnade = mconcat
[ -- dbSelect (applying _2) id (return . view (resultMail . _entityKey))
sortable (Just "sent") (i18nCell MsgPrintJobCreated) $ \( view $ resultMail . _entityVal . _sentMailSentAt -> t) -> dateTimeCell t
, sortable (Just "recipient") (i18nCell MsgPrintRecipient) $ \(preview resultRecipient -> u) -> maybeCell u $ cellHasUserLink AdminUserR
, sortable Nothing (i18nCell MsgCommSubject) $ \(view resultMail -> Entity k v) ->
let subject = v ^? _sentMailHeaders . _mailHeaders' . _mailHeader' "Subject"
linkWgt = maybe (msg2widget MsgUtilEMail) text2widget subject
in anchorCellM (MailHtmlR <$> encrypt k) linkWgt
-- , sortable Nothing (i18nCell MsgCommContent) $ \(view $ resultMail . _entityKey -> k) -> anchorCellM (MailHtmlR <$> encrypt k) (text2widget "html")
-- , sortable Nothing (i18nCell MsgCommSubject) $ \(preview $ resultMail . _entityVal . _sentMailHeaders . _mailHeaders' . _mailHeader' "Subject" -> h) -> cellMaybe textCell h
]
dbtSorting = Map.fromList
[ ("sent" , SortColumn $ queryMail >>> (E.^. SentMailSentAt))
, ("recipient" , sortUserNameBareM queryRecipient)
]
dbtFilter = Map.fromList
[ ("sent" , FilterColumn . E.mkDayFilterTo $ views (to queryMail) (E.^. SentMailSentAt))
, ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryRecipient) (E.?. UserDisplayName))
, ("subject" , FilterColumn . E.mkContainsFilterWithCommaPlus id $ views (to queryMail) (E.str2text . (E.^. SentMailHeaders)))
-- , ("regex" , FilterColumn . E.mkRegExFilterWith id $ views (to queryMail) (E.str2text . (E.^. SentMailHeaders)))
]
dbtFilterUI mPrev = mconcat
[ prismAForm (singletonFilter "sent" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgPrintJobCreated)
, prismAForm (singletonFilter "recipient" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintRecipient & setTooltip MsgTableFilterCommaPlus)
, prismAForm (singletonFilter "subject" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgCommSubject & setTooltip MsgTableFilterCommaPlusShort)
-- , prismAForm (singletonFilter "regex" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgCommSubject )
]
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout}
dbtIdent :: Text
dbtIdent = "sent-mail"
dbtCsvEncode = noCsvEncode
dbtCsvDecode = Nothing
dbtExtraReps = []
dbtParams = DBParamsForm
{ dbParamsFormMethod = POST
, dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute
, dbParamsFormAttrs = []
, dbParamsFormSubmit = FormNoSubmit
, dbParamsFormAdditional = \_csrf -> return (FormMissing, mempty)
-- , dbParamsFormSubmit = FormSubmit
-- , dbParamsFormAdditional
-- = let acts :: Map MCTableAction (AForm Handler MCTableActionData)
-- acts = mconcat
-- [ singletonMap MCActDummy $ pure MCActDummyData
-- ]
-- in renderAForm FormStandard
-- $ (, mempty) . First . Just
-- <$> multiActionA acts (fslI MsgTableAction) Nothing
, dbParamsFormEvaluate = liftHandler . runFormPost
, dbParamsFormResult = id
, dbParamsFormIdent = def
}
postprocess :: FormResult (First MCTableActionData, DBFormResult SentMailId Bool MCTableData)
-> FormResult ( MCTableActionData, Set SentMailId)
postprocess inp = do
(First (Just act), jobMap) <- inp
let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap
return (act, jobSet)
psValidator = def & defaultSorting [SortDescBy "sent"]
over _1 postprocess <$> dbTable psValidator DBTable{..}
getMailCenterR, postMailCenterR :: Handler Html
getMailCenterR = postMailCenterR
postMailCenterR = do
(mcRes, mcTable) <- runDB mkMCTable
formResult mcRes $ \case
(MCActDummyData, Set.toList -> _smIds) -> do
addMessageI Success MsgBoolIrrelevant
reloadKeepGetParams MailCenterR
siteLayoutMsg MsgMenuMailCenter $ do
setTitleI MsgMenuMailCenter
$(widgetFile "mail-center")
typePDF :: ContentType
typePDF = "application/pdf"
getMailAttachmentR :: CryptoUUIDSentMail -> Text -> Handler TypedContent
getMailAttachmentR cusm attdisp = do
smid <- decrypt cusm
(sm,cn) <- runDBRead $ do
sm <- get404 smid
cn <- get404 $ sm ^. _sentMailContentRef
return (sm,cn)
let mcontent = getMailContent (sentMailContentContent cn)
getAttm alts = case selectAlternative [typePDF] alts of
(Just Part{partContent=PartContent (LB.toStrict -> pc), partDisposition=AttachmentDisposition t}) -- partType=pt,
| t == attdisp
-> Just pc
_ -> Nothing
attm = firstJust getAttm mcontent
case attm of
(Just pc) -> sendByteStringAsFile (T.unpack attdisp) pc $ sm ^. _sentMailSentAt
_ -> notFound
getMailHtmlR :: CryptoUUIDSentMail -> Handler Html
getMailHtmlR = handleMailShow (SomeMessages [SomeMessage MsgUtilEMail, SomeMessage MsgMenuMailHtml]) [typeHtml,typePlain]
getMailPlainR :: CryptoUUIDSentMail -> Handler Html
getMailPlainR = handleMailShow (SomeMessages [SomeMessage MsgUtilEMail, SomeMessage MsgMenuMailPlain]) [typePlain,typeHtml]
handleMailShow :: _ -> [ContentType] -> CryptoUUIDSentMail -> Handler Html
handleMailShow hdr prefTypes cusm = do
smid <- decrypt cusm
(sm,cn) <- runDBRead $ do
sm <- get404 smid
cn <- get404 $ sm ^. _sentMailContentRef
return (sm,cn)
siteLayout' Nothing $ do
setTitleI hdr
let mcontent = getMailContent (sentMailContentContent cn)
getHeader h = preview (_mailHeader' h) (sm ^. _sentMailHeaders . _mailHeaders')
mparts = reorderParts $ mapMaybe (selectAlternative prefTypes) mcontent
[whamlet|
<section>
<dl .deflist>
<dt .deflist__dt>
_{MsgPrintJobCreated}
<dd .deflist__dd>
^{formatTimeW SelFormatDateTime (sm ^. _sentMailSentAt)}
$maybe usr <- sm ^. _sentMailRecipient
<dt .deflist__dt>
_{MsgPrintRecipient}
<dd .deflist__dd>
^{userIdWidget usr}
$maybe r <- getHeader "To"
<dt .deflist__dt>
To
<dd .deflist__dd>
#{decodeEncodedWord r}
$maybe r <- getHeader "Cc"
<dt .deflist__dt>
Cc
<dd .deflist__dd>
#{decodeEncodedWord r}
$maybe r <- getHeader "From"
<dt .deflist__dt>
From
<dd .deflist__dd>
#{decodeEncodedWord r}
$maybe r <- getHeader "Subject"
<dt .deflist__dt>
_{MsgCommSubject}
<dd .deflist__dd>
#{decodeEncodedWord r}
<section>
$forall pt <- mparts
^{part2widget cusm pt}
|]
-- Include for Debugging:
-- <section>
-- <h2>Debugging
-- <p>
-- ^{jsonWidget (sm ^. _sentMailHeaders)}
-- <p>
-- ^{jsonWidget (sentMailContentContent cn)} -- content fields needs decoding of base64 to make sense here
selectAlternative :: [ContentType] -> Alternatives -> Maybe Part
selectAlternative (fmap decodeUtf8 -> prefTypes) allAlts = aux prefTypes allAlts
where
aux ts@(ct:_) (pt:ps)
| ct == partType pt = Just pt
| otherwise = aux ts ps
aux (_:ts) [] = aux ts allAlts
aux [] (pt:_) = Just pt
aux _ [] = Nothing
reorderParts :: [Part] -> [Part]
reorderParts = sortBy pOrder
where
pOrder Part{partDisposition=d1} Part{partDisposition=d2} = dispoOrder d1 d2
dispoOrder DefaultDisposition DefaultDisposition = EQ
dispoOrder DefaultDisposition _ = LT
dispoOrder _ DefaultDisposition = GT
dispoOrder (InlineDisposition t1) (InlineDisposition t2) = compare t1 t2
dispoOrder (InlineDisposition _) _ = LT
dispoOrder _ (InlineDisposition _) = GT
dispoOrder (AttachmentDisposition t1) (AttachmentDisposition t2) = compare t1 t2
disposition2widget :: Disposition -> Widget
disposition2widget (AttachmentDisposition _) = [whamlet|<h3>_{MsgMailFileAttachment}|]
disposition2widget (InlineDisposition n) = [whamlet|<h3>_{MsgMenuMailAttachment} #{n}|]
disposition2widget DefaultDisposition = mempty
part2widget :: CryptoUUIDSentMail -> Part -> Widget
part2widget cusm Part{partContent=NestedParts ps} =
[whamlet|
$forall p <- ps
^{part2widget cusm p}
|]
part2widget cusm Part{partContent=PartContent (LB.toStrict -> pc), partType=pt, partDisposition=dispo} =
[whamlet|
<section>
^{disposition2widget dispo}
^{showBody}
^{showPass}
|]
where
showBody
| pt == decodeUtf8 typePlain = toWidget $ preEscapedToHtml $ plainTextToHtml $ decodeUtf8 pc
| pt == decodeUtf8 typeHtml = toWidget $ preEscapedToHtml $ plainHtmlToHtml $ decodeUtf8 pc -- preEscapedToHtml :: ToMarkup a => a -> Html
| pt == decodeUtf8 typeJson =
let jw :: Aeson.Value -> Widget = jsonWidget
in either str2widget jw $ Aeson.eitherDecodeStrict' pc
| pt == decodeUtf8 typePDF
, AttachmentDisposition t <- dispo
= [whamlet|<a href=@{MailAttachmentR cusm t}>#{t}|]
| otherwise = [whamlet|FRADrive cannot decode email parts of type #{pt} yet.|]
showPass
| pt == decodeUtf8 typePlain
, let cw = T.words $ decodeUtf8 pc
, Just name <- listBracket ("Inhaber","Gültig") cw -- heursitic for dirving licence renewal letters only; improve
<|> listBracket ("Licensee","Valid") cw
= let sdn = T.filter (/= '*') (T.unwords $ dropWhile (":"==) name) in
liftHandler (runDBRead $ getByFilter [UserDisplayName ==. sdn]) >>= \case
Nothing -> mempty -- DEBUG: [whamlet|<h2>Not found: #{sdn}|]
Just Entity{entityVal = u@User{userPinPassword=mbpw}} ->
[whamlet|
<section>
$maybe pw <- mbpw
<details>
<summary>
_{MsgAdminUserPinPassword}
<p>
<dl .deflist>
<dt .deflist__dt>
^{userWidget u}
<dd .deflist__dd>
<b>
#{pw}
<p>
_{MsgAdminUserPinPassNotIncluded}
$nothing
_{MsgAdminUserNoPassword}
|]
| otherwise = mempty
------------------------------
-- Decode MIME Encoded Word
-- | decode the MIME encoded-word format, which is used in email headers to encode non-ASCII text. This format is specified in RFC 2047.
decodeEncodedWord :: Text -> Text
decodeEncodedWord tinp
| (pl, T.drop 2 -> cf) <- T.breakOn "=?" tinp
, (cw, T.drop 2 -> rm) <- T.breakOn "?=" cf
, notNull cw
= pl <> decodeEncodedWordHeader cw <> decodeEncodedWord rm
| otherwise
= tinp
decodeEncodedWordHeader :: Text -> Text
decodeEncodedWordHeader tinp
| [enc, bin, cw] <- T.splitOn "?" tinp
, "utf-8" == T.toLower enc
, "Q" == T.toUpper bin -- Quoted Printable Text
= decEncWrdUtf8Q cw
-- TODO: add more decoders for other possible encodings here, but "=?utf-8?Q?..?=" is the only one used by Network.Mail.Mime at the moment
| otherwise
= tinp
decEncWrdUtf8Q :: Text -> Text
decEncWrdUtf8Q tinp
| Right ok <- TE.decodeUtf8' $ decWds tinp
= ok
| otherwise
= tinp
where
decWds :: Text -> S.ByteString
decWds t
| (h:tl) <- T.splitOn "=" t
= mconcat $ TE.encodeUtf8 h : map deco tl
| otherwise
= TE.encodeUtf8 t
deco :: Text -> S.ByteString
deco w
| (c,r) <- T.splitAt 2 w
, [(v,"")] <- readHex $ T.unpack c
= S.cons v $ TE.encodeUtf8 r
| otherwise
= TE.encodeUtf8 w

22
src/Handler/News.hs
View File

@ -13,7 +13,7 @@ import Handler.SystemMessage
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Database.Esqueleto.Utils.TH
import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.Utils as E
@ -315,16 +315,16 @@ newsUpcomingExams uid = do
| otherwise -> mempty
]
dbtSorting = Map.fromList
[ ("demo-both", SortColumn $ queryCourse &&& queryExam >>> (\(_course,exam)-> exam E.^. ExamName))
, ("term", SortColumn $ queryCourse >>> (E.^. CourseTerm ))
, ("school", SortColumn $ queryCourse >>> (E.^. CourseSchool ))
, ("course", SortColumn $ queryCourse >>> (E.^. CourseShorthand ))
, ("name", SortColumn $ queryExam >>> (E.^. ExamName ))
, ("time", SortColumn $ queryExam >>> (E.^. ExamStart ))
, ("register-from", SortColumn $ queryExam >>> (E.^. ExamRegisterFrom ))
, ("register-to", SortColumn $ queryExam >>> (E.^. ExamRegisterTo ))
, ("visible", SortColumn $ queryExam >>> (E.^. ExamVisibleFrom ))
, ("registered", SortColumn $ queryExam >>> (\exam ->
[ ("demo-both", SortColumns $ queryCourse &&& queryExam >>> (\(course,exam)-> [SomeExprValue $ course E.^. CourseShorthand, SomeExprValue $ exam E.^. ExamName]))
, ("term", SortColumn $ queryCourse >>> (E.^. CourseTerm ))
, ("school", SortColumn $ queryCourse >>> (E.^. CourseSchool ))
, ("course", SortColumn $ queryCourse >>> (E.^. CourseShorthand ))
, ("name", SortColumn $ queryExam >>> (E.^. ExamName ))
, ("time", SortColumn $ queryExam >>> (E.^. ExamStart ))
, ("register-from", SortColumn $ queryExam >>> (E.^. ExamRegisterFrom ))
, ("register-to", SortColumn $ queryExam >>> (E.^. ExamRegisterTo ))
, ("visible", SortColumn $ queryExam >>> (E.^. ExamVisibleFrom ))
, ("registered", SortColumn $ queryExam >>> (\exam ->
E.exists $ E.from $ \registration -> do
E.where_ $ registration E.^. ExamRegistrationUser E.==. E.val uid
E.where_ $ registration E.^. ExamRegistrationExam E.==. exam E.^. ExamId

133
src/Handler/PrintCenter.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-24 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
@ -20,9 +20,9 @@ import qualified Data.Set as Set
import qualified Data.Map as Map
import Database.Persist.Sql (updateWhereCount)
import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma
import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.Utils as E
import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma
import qualified Database.Esqueleto.Legacy as E -- needed for dbTable using Esqueleto.Legacy
import qualified Database.Esqueleto.Utils as E
import Database.Esqueleto.Utils.TH
import Utils.Print
@ -39,11 +39,6 @@ import qualified Data.CaseInsensitive as CI
import Jobs.Queue
-- avoids repetition of local definitions
single :: (k,a) -> Map k a
single = uncurry Map.singleton
data LRQF = LRQF
{ lrqfLetter :: Text
, lrqfUser :: Either UserEmail UserId
@ -56,7 +51,7 @@ data LRQF = LRQF
} deriving (Eq, Generic)
makeRenewalForm :: Maybe LRQF -> Form LRQF
makeRenewalForm tmpl = identifyForm FIDLmsLetter . validateForm validateLetterRenewQualificationF $ \html -> do
makeRenewalForm tmpl = identifyForm FIDLmsLetter . validateForm validateLetterRenewQualification $ \html -> do
-- now_day <- utctDay <$> liftIO getCurrentTime
flip (renderAForm FormStandard) html $ LRQF
<$> areq textField (fslI MsgPrintLetterType) (lrqfLetter <$> tmpl)
@ -71,8 +66,8 @@ makeRenewalForm tmpl = identifyForm FIDLmsLetter . validateForm validateLetterRe
where
lmsField = convertField LmsIdent getLmsIdent textField
validateLetterRenewQualificationF :: FormValidator LRQF Handler ()
validateLetterRenewQualificationF = -- do
validateLetterRenewQualification :: FormValidator LRQF Handler ()
validateLetterRenewQualification = -- do
-- LRQF{..} <- State.get
return ()
@ -82,7 +77,7 @@ lrqf2letter LRQF{..}
usr <- getUser lrqfUser
rcvr <- mapM getUser lrqfSuper
now <- liftIO getCurrentTime
let letter = LetterRenewQualificationF
let letter = LetterRenewQualification
{ lmsLogin = lrqfIdent
, lmsPin = lrqfPin
, qualHolderID = usr ^. _entityKey
@ -94,6 +89,8 @@ lrqf2letter LRQF{..}
, qualShort = lrqfQuali ^. _qualificationShorthand . _CI
, qualSchool = lrqfQuali ^. _qualificationSchool
, qualDuration = lrqfQuali ^. _qualificationValidDuration
, qualRenewAuto = lrqfQuali ^. _qualificationElearningRenews
, qualELimit = lrqfQuali ^. _qualificationElearningLimit
, isReminder = lrqfReminder
}
return (fromMaybe usr rcvr, SomeLetter letter)
@ -131,11 +128,12 @@ instance Finite PJTableAction
nullaryPathPiece ''PJTableAction $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''PJTableAction id
-- Not yet needed, since there is no additional data for now:
data PJTableActionData = PJActAcknowledgeData | PJActReprintData { ignoreReroute :: Maybe Bool }
deriving (Eq, Ord, Read, Show, Generic)
type PJTableExpr = ( E.SqlExpr (Entity PrintJob)
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity Course))
@ -143,21 +141,24 @@ type PJTableExpr = ( E.SqlExpr (Entity PrintJob)
)
queryPrintJob :: PJTableExpr -> E.SqlExpr (Entity PrintJob)
queryPrintJob = $(sqlLOJproj 5 1)
queryPrintJob = $(sqlLOJproj 6 1)
queryRecipient :: PJTableExpr -> E.SqlExpr (Maybe (Entity User))
queryRecipient = $(sqlLOJproj 5 2)
queryRecipient = $(sqlLOJproj 6 2)
queryAffected :: PJTableExpr -> E.SqlExpr (Maybe (Entity User))
queryAffected = $(sqlLOJproj 6 3)
querySender :: PJTableExpr -> E.SqlExpr (Maybe (Entity User))
querySender = $(sqlLOJproj 5 3)
querySender = $(sqlLOJproj 6 4)
queryCourse :: PJTableExpr -> E.SqlExpr (Maybe (Entity Course))
queryCourse = $(sqlLOJproj 5 4)
queryCourse = $(sqlLOJproj 6 5)
queryQualification :: PJTableExpr -> E.SqlExpr (Maybe (Entity Qualification))
queryQualification = $(sqlLOJproj 5 5)
queryQualification = $(sqlLOJproj 6 6)
type PJTableData = DBRow (Entity PrintJob, Maybe (Entity User), Maybe (Entity User), Maybe (Entity Course), Maybe (Entity Qualification))
type PJTableData = DBRow (Entity PrintJob, Maybe (Entity User), Maybe (Entity User), Maybe (Entity User), Maybe (Entity Course), Maybe (Entity Qualification))
resultPrintJob :: Lens' PJTableData (Entity PrintJob)
resultPrintJob = _dbrOutput . _1
@ -165,30 +166,36 @@ resultPrintJob = _dbrOutput . _1
resultRecipient :: Traversal' PJTableData (Entity User)
resultRecipient = _dbrOutput . _2 . _Just
resultAffected :: Traversal' PJTableData (Entity User)
resultAffected = _dbrOutput . _3 . _Just
resultSender :: Traversal' PJTableData (Entity User)
resultSender = _dbrOutput . _3 . _Just
resultSender = _dbrOutput . _4 . _Just
resultCourse :: Traversal' PJTableData (Entity Course)
resultCourse = _dbrOutput . _4 . _Just
resultCourse = _dbrOutput . _5 . _Just
resultQualification :: Traversal' PJTableData (Entity Qualification)
resultQualification = _dbrOutput . _5 . _Just
resultQualification = _dbrOutput . _6 . _Just
pjTableQuery :: PJTableExpr -> E.SqlQuery
( E.SqlExpr (Entity PrintJob)
, E.SqlExpr (Maybe (Entity User))
, E.SqlExpr (Maybe (Entity User))
, E.SqlExpr (Maybe (Entity User))
, E.SqlExpr (Maybe (Entity Course))
, E.SqlExpr (Maybe (Entity Qualification)))
pjTableQuery (printJob `E.LeftOuterJoin` recipient
`E.LeftOuterJoin` affected
`E.LeftOuterJoin` sender
`E.LeftOuterJoin` course
`E.LeftOuterJoin` quali ) = do
E.on $ printJob E.^. PrintJobRecipient E.==. recipient E.?. UserId
E.on $ printJob E.^. PrintJobAffected E.==. affected E.?. UserId
E.on $ printJob E.^. PrintJobSender E.==. sender E.?. UserId
E.on $ printJob E.^. PrintJobCourse E.==. course E.?. CourseId
E.on $ printJob E.^. PrintJobQualification E.==. quali E.?. QualificationId
return (printJob, recipient, sender, course, quali)
return (printJob, recipient, affected, sender, course, quali)
mkPJTable :: DB (FormResult (PJTableActionData, Set PrintJobId), Widget)
mkPJTable = do
@ -206,36 +213,39 @@ mkPJTable = do
, sortable (Just "apcid") (i18nCell MsgPrintJobApcAcknowledge)$ \( view $ resultPrintJob . _entityVal . _printJobApcIdent -> t) -> textCell t
, sortable (Just "name") (i18nCell MsgPrintJobName) $ \( view $ resultPrintJob . _entityVal . _printJobName -> n) -> textCell n
, sortable (Just "recipient") (i18nCell MsgPrintRecipient) $ \(preview resultRecipient -> u) -> maybeCell u $ cellHasUserLink AdminUserR
, sortable (Just "affected") (i18nCell MsgPrintAffected) $ \(preview resultAffected -> u) -> maybeCell u $ cellHasUserLink AdminUserR
, sortable (Just "sender") (i18nCell MsgPrintSender) $ \(preview resultSender -> u) -> maybeCell u $ cellHasUserLink AdminUserR
, sortable (Just "course") (i18nCell MsgPrintCourse) $ \(preview $ resultCourse . _entityVal -> c) -> maybeCell c courseCell
, sortable (Just "qualification")(i18nCell MsgPrintQualification) $ \(preview $ resultQualification . _entityVal -> q) -> maybeCell q qualificationCell
, sortable (Just "lmsid") (i18nCell MsgPrintLmsUser) $ \( view $ resultPrintJob . _entityVal . _printJobLmsUser -> l) -> foldMap (textCell . getLmsIdent) l
]
dbtSorting = mconcat
[ single ("name" , SortColumn $ queryPrintJob >>> (E.^. PrintJobName))
, single ("filename" , SortColumn $ queryPrintJob >>> (E.^. PrintJobFilename))
, single ("created" , SortColumn $ queryPrintJob >>> (E.^. PrintJobCreated))
, single ("acknowledged" , SortColumn $ queryPrintJob >>> (E.^. PrintJobAcknowledged))
, single ("apcid" , SortColumn $ queryPrintJob >>> (E.^. PrintJobApcIdent))
, single ("recipient" , sortUserNameBareM queryRecipient)
, single ("sender" , sortUserNameBareM querySender )
, single ("course" , SortColumn $ queryCourse >>> (E.?. CourseName))
, single ("qualification", SortColumn $ queryQualification >>> (E.?. QualificationName))
, single ("lmsid" , SortColumn $ queryPrintJob >>> (E.^. PrintJobLmsUser))
dbtSorting = Map.fromList
[ ("name" , SortColumn $ queryPrintJob >>> (E.^. PrintJobName))
, ("filename" , SortColumn $ queryPrintJob >>> (E.^. PrintJobFilename))
, ("created" , SortColumn $ queryPrintJob >>> (E.^. PrintJobCreated))
, ("acknowledged" , SortColumn $ queryPrintJob >>> (E.^. PrintJobAcknowledged))
, ("apcid" , SortColumn $ queryPrintJob >>> (E.^. PrintJobApcIdent))
, ("recipient" , sortUserNameBareM queryRecipient)
, ("affected" , sortUserNameBareM queryAffected )
, ("sender" , sortUserNameBareM querySender )
, ("course" , SortColumn $ queryCourse >>> (E.?. CourseName))
, ("qualification", SortColumn $ queryQualification >>> (E.?. QualificationName))
, ("lmsid" , SortColumn $ queryPrintJob >>> (E.^. PrintJobLmsUser))
]
dbtFilter = mconcat
[ single ("name" , FilterColumn . E.mkContainsFilterWithCommaPlus id $ views (to queryPrintJob) (E.^. PrintJobName))
, single ("apcid" , FilterColumn . E.mkContainsFilterWithComma id $ views (to queryPrintJob) (E.^. PrintJobApcIdent))
, single ("filename" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobFilename))
, single ("created" , FilterColumn . E.mkDayFilter $ views (to queryPrintJob) (E.^. PrintJobCreated))
--, single ("created" , FilterColumn . E.mkDayBetweenFilter $ views (to queryPrintJob) (E.^. PrintJobCreated))
, single ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryRecipient) (E.?. UserDisplayName))
, single ("sender" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to querySender) (E.?. UserDisplayName))
, single ("course" , FilterColumn . E.mkContainsFilterWith (Just . CI.mk) $ views (to queryCourse) (E.?. CourseName))
, single ("qualification", FilterColumn . E.mkContainsFilterWith (Just . CI.mk) $ views (to queryQualification) (E.?. QualificationName))
, single ("lmsid" , FilterColumn . E.mkContainsFilterWithCommaPlus (Just . LmsIdent) $ views (to queryPrintJob) (E.^. PrintJobLmsUser))
dbtFilter = Map.fromList
[ ("name" , FilterColumn . E.mkContainsFilterWithCommaPlus id $ views (to queryPrintJob) (E.^. PrintJobName))
, ("apcid" , FilterColumn . E.mkContainsFilterWithComma id $ views (to queryPrintJob) (E.^. PrintJobApcIdent))
, ("filename" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobFilename))
, ("created" , FilterColumn . E.mkDayFilter $ views (to queryPrintJob) (E.^. PrintJobCreated))
--, ("created" , FilterColumn . E.mkDayBetweenFilter $ views (to queryPrintJob) (E.^. PrintJobCreated))
, ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryRecipient) (E.?. UserDisplayName))
, ("affected" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryAffected) (E.?. UserDisplayName))
, ("sender" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to querySender) (E.?. UserDisplayName))
, ("course" , FilterColumn . E.mkContainsFilterWith (Just . CI.mk) $ views (to queryCourse) (E.?. CourseName))
, ("qualification", FilterColumn . E.mkContainsFilterWith (Just . CI.mk) $ views (to queryQualification) (E.?. QualificationName))
, ("lmsid" , FilterColumn . E.mkContainsFilterWithCommaPlus (Just . LmsIdent) $ views (to queryPrintJob) (E.^. PrintJobLmsUser))
, single ("acknowledged" , FilterColumn . E.mkExactFilterLast $ views (to queryPrintJob) (E.isJust . (E.^. PrintJobAcknowledged)))
, ("acknowledged" , FilterColumn . E.mkExactFilterLast $ views (to queryPrintJob) (E.isJust . (E.^. PrintJobAcknowledged)))
]
dbtFilterUI mPrev = mconcat
[ prismAForm (singletonFilter "name" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobName & setTooltip MsgTableFilterCommaPlus)
@ -244,11 +254,12 @@ mkPJTable = do
--, prismAForm (singletonFilter "created" . maybePrism _PathPiece) mPrev ((,) <$> aopt (hoistField lift dayField) (fslI MsgPrintJobCreated)
-- <*> aopt (hoistField lift dayField) (fslI MsgPrintJobCreated)
-- )
, prismAForm (singletonFilter "recipient" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintRecipient & setTooltip MsgTableFilterCommaPlus)
, prismAForm (singletonFilter "sender" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintSender & setTooltip MsgTableFilterCommaPlus)
, prismAForm (singletonFilter "recipient" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintRecipient & setTooltip MsgTableFilterCommaPlusShort)
, prismAForm (singletonFilter "affected" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintAffected & setTooltip MsgTableFilterCommaPlusShort)
, prismAForm (singletonFilter "sender" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintSender & setTooltip MsgTableFilterCommaPlusShort)
, prismAForm (singletonFilter "course" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintCourse)
, prismAForm (singletonFilter "qualification". maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintQualification)
, prismAForm (singletonFilter "lmsid" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintLmsUser & setTooltip MsgTableFilterCommaPlus)
, prismAForm (singletonFilter "lmsid" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintLmsUser & setTooltip MsgTableFilterCommaPlusShort)
, prismAForm (singletonFilter "apcid" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobApcAcknowledge & setTooltip MsgTableFilterComma)
, prismAForm (singletonFilter "acknowledged" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgPrintJobAcknowledged)
]
@ -508,23 +519,25 @@ getPrintLogR = do
dbtIdent = "lpr-log" :: Text
dbtSQLQuery l = do
E.where_ $ E.val "LPR" E.==. l E.^. TransactionLogInfo E.->>. "interface-name"
-- E.&&. E.val "interface" E.==. l E.^. TransactionLogInfo E.->>. "transaction" -- not necessary
E.where_ $ (l E.^. TransactionLogInfo E.->>. "interface-name") `E.in_` E.valList ["LPR", "LETTER","APC", "Printer"]
-- E.&&. E.val "interface" E.==. l E.^. TransactionLogInfo E.->>. "transaction" -- not necessary
return l
dbtRowKey = (E.^. TransactionLogId)
dbtProj = dbtProjSimple $ \(Entity _ l) -> do
return (l, Aeson.fromJSON $ transactionLogInfo l)
dbtColonnade = dbColonnade $ mconcat
[ sortable (Just "time") (i18nCell MsgSystemMessageTimestamp) $ \(view $ resultLog . to transactionLogTime -> t) -> dateTimeCell t
, sortable (Just "status") (textCell "Status") $ tCell (cellMaybe iconBoolCell . transactionInterfaceSuccess)
, sortable (Just "subtype") (i18nCell MsgInterfaceSubtype) $ tCell ( textCell . transactionInterfaceSubtype)
, sortable (Just "info") (i18nCell MsgSystemMessageContent) $ tCellErr ( textCell . transactionInterfaceInfo)
[ sortable (Just "time") (i18nCell MsgSystemMessageTimestamp) $ \(view $ resultLog . to transactionLogTime -> t) -> dateTimeCell t
, sortable (Just "status") (textCell "Status" ) $ tCell (cellMaybe iconBoolCell . transactionInterfaceSuccess)
, sortable (Just "interface") (i18nCell MsgInterfaceName ) $ tCell ( textCell . transactionInterfaceName)
, sortable (Just "subtype") (i18nCell MsgInterfaceSubtype ) $ tCell ( textCell . transactionInterfaceSubtype)
, sortable (Just "info") (i18nCell MsgSystemMessageContent ) $ tCellErr ( textCell . transactionInterfaceInfo)
]
dbtSorting = mconcat
[ singletonMap "time" $ SortColumn (E.^. TransactionLogTime)
, singletonMap "status" $ SortColumn (\r -> r E.^. TransactionLogTime E.->>. "interface-success")
, singletonMap "subtype" $ SortColumn (\r -> r E.^. TransactionLogTime E.->>. "interface-subtype")
, singletonMap "info" $ SortColumn (\r -> r E.^. TransactionLogTime E.->>. "interface-info" )
[ singletonMap "time" $ SortColumn (E.^. TransactionLogTime)
, singletonMap "status" $ SortColumn (\r -> r E.^. TransactionLogInfo E.->>. "interface-success")
, singletonMap "interface" $ SortColumn (\r -> r E.^. TransactionLogInfo E.->>. "interface-name" )
, singletonMap "subtype" $ SortColumn (\r -> r E.^. TransactionLogInfo E.->>. "interface-subtype")
, singletonMap "info" $ SortColumn (\r -> r E.^. TransactionLogInfo E.->>. "interface-info" )
]
dbtFilter = mempty
dbtFilterUI = mempty

429
src/Handler/Profile.hs
View File

@ -2,10 +2,12 @@
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity and HasUser instances
module Handler.Profile
( getProfileR, postProfileR
, getForProfileR, postForProfileR
, getProfileDataR, makeProfileData
, getProfileDataR, makeProfileData
, getForProfileDataR
, getAuthPredsR, postAuthPredsR
, getUserNotificationR, postUserNotificationR
@ -17,7 +19,10 @@ module Handler.Profile
import Import
import Handler.Utils
import Handler.Utils.AvsUpdate
import Handler.Utils.Profile
import Handler.Utils.Users
import Handler.Utils.Company
import Utils.Print (validCmdArgument)
@ -26,9 +31,12 @@ import Utils.Print (validCmdArgument)
import Data.Map ((!))
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Database.Esqueleto.Legacy as E
import Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Experimental as E
import qualified Database.Esqueleto.Legacy as EL (on,from)
import qualified Database.Esqueleto.Utils as E
-- import Database.Esqueleto ((^.))
import qualified Database.Esqueleto.PostgreSQL as E
import qualified Data.Text as Text
import Data.List (inits)
@ -39,6 +47,9 @@ import Jobs
import Foundation.Yesod.Auth (updateUserLanguage)
{-# ANN module ("HLint: ignore Functor law" :: String) #-}
data ExamOfficeSettings
= ExamOfficeSettings
{ eosettingsGetSynced :: Bool
@ -65,11 +76,11 @@ data SettingsForm = SettingsForm
, stgDownloadFiles :: Bool
, stgWarningDays :: NominalDiffTime
, stgShowSex :: Bool
, stgPinPassword :: Maybe Text
, stgPrefersPostal :: Bool
, stgPostAddress :: Maybe StoredMarkup
, stgTelephone :: Maybe Text
, stgMobile :: Maybe Text
@ -108,10 +119,11 @@ instance RenderMessage UniWorX NotificationTriggerKind where
makeSettingForm :: Maybe SettingsForm -> Form SettingsForm
makeSettingForm template html = do
MsgRenderer mr <- getMsgRenderer
-- isAdmin <- checkAdmin
(result, widget) <- flip (renderAForm FormStandard) html $ SettingsForm
<$ aformSection MsgFormPersonalAppearance
<*> areq (textField & cfStrip) (fslI MsgUserDisplayName & setTooltip MsgUserDisplayNameRulesBelow) (stgDisplayName <$> template)
<*> areq (emailField & cfStrip & cfCI) (fslI MsgUserDisplayEmail & setTooltip MsgUserDisplayEmailTip) (stgDisplayEmail <$> template)
<*> areq (textField & cfStrip) (fslI MsgUserDisplayName & setTooltip MsgUserDisplayNameRulesBelow) (stgDisplayName <$> template)
<*> areq (textField & cfStrip & cfCI) (fslI MsgUserDisplayEmail & setTooltip MsgUserDisplayEmailTip) (stgDisplayEmail <$> template)
<* aformSection MsgFormCosmetics
<*> areq (natFieldI MsgFavouritesNotNatural)
(fslpI MsgFavourites (mr MsgFavouritesPlaceholder) & setTooltip MsgFavouritesTip) (stgMaxFavourites <$> template)
@ -137,9 +149,9 @@ makeSettingForm template html = do
<*> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) (stgPostAddress <$> template)
<*> aopt (textField & cfStrip) (fslI MsgUserTelephone) (stgTelephone <$> template)
<*> aopt (textField & cfStrip) (fslI MsgUserMobile ) (stgMobile <$> template)
<*> aopt (textField & cfStrip) (fslI MsgUserMobile ) (stgMobile <$> template)
<*> examOfficeForm (stgExamOfficeSettings <$> template)
<*> examOfficeForm (stgExamOfficeSettings <$> template)
<*> schoolsForm (stgSchools <$> template)
<*> notificationForm (stgNotificationSettings <$> template)
return (result, widget) -- no validation here, done later by validateSettings
@ -151,7 +163,7 @@ schoolsForm template = formToAForm $ schoolsFormView =<< renderWForm FormStandar
where
schoolsForm' :: WForm Handler (FormResult (Set SchoolId))
schoolsForm' = do
allSchools <- liftHandler . runDB $ selectList [] [Asc SchoolName]
allSchools <- liftHandler . runDBRead $ selectList [] [Asc SchoolName]
let
schoolForm (Entity ssh School{schoolName})
@ -186,28 +198,28 @@ notificationForm template = wFormToAForm $ do
-> return False
NTKCourseParticipant
| Just uid <- mbUid
-> fmap not . E.selectExists . E.from $ \courseParticipant ->
-> fmap not . E.selectExists . EL.from $ \courseParticipant ->
E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val uid
E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
NTKSubmissionUser
| Just uid <- mbUid
-> fmap not . E.selectExists . E.from $ \submissionUser ->
-> fmap not . E.selectExists . EL.from $ \submissionUser ->
E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val uid
NTKExamParticipant
| Just uid <- mbUid
-> fmap not . E.selectExists . E.from $ \examRegistration ->
-> fmap not . E.selectExists . EL.from $ \examRegistration ->
E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val uid
NTKCorrector
| Just uid <- mbUid
-> fmap not . E.selectExists . E.from $ \sheetCorrector ->
-> fmap not . E.selectExists . EL.from $ \sheetCorrector ->
E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid
NTKCourseLecturer
| Just uid <- mbUid
-> fmap not . E.selectExists . E.from $ \lecturer ->
-> fmap not . E.selectExists . EL.from $ \lecturer ->
E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid
NTKFunctionary f
| Just uid <- mbUid
-> fmap not . E.selectExists . E.from $ \userFunction ->
-> fmap not . E.selectExists . EL.from $ \userFunction ->
E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val uid
E.&&. userFunction E.^. UserFunctionFunction E.==. E.val f
_ | Nothing <- mbUid -> return False -- Show everything for not-logged-in users (e.g. if they presented a token)
@ -221,7 +233,7 @@ notificationForm template = wFormToAForm $ do
let
ntfs nt = fslI nt & case nt of
_other -> id
nsForm nt
| maybe False ntHidden $ ntSection nt
= pure $ notificationAllowed def nt
@ -292,7 +304,7 @@ examOfficeForm template = wFormToAForm $ do
| otherwise
-> FormSuccess $ Map.singleton kStart (Left nLabel)
return (addRes', $(widgetFile "profile/exam-office-labels/add"))
miCell :: ListPosition
-> Either ExamOfficeLabelName ExamOfficeLabelId
-> Maybe EOLabelData
@ -361,11 +373,13 @@ validateSettings User{..} = do
userDisplayName' <- use _stgDisplayName
guardValidation MsgUserDisplayNameInvalid $
userDisplayName == userDisplayName' || -- unchanged or valid (invalid displayNames delivered by LDAP are preserved)
validDisplayName userTitle userFirstName userSurname userDisplayName'
validDisplayName userTitle userFirstName userSurname userDisplayName'
userDisplayEmail' <- use _stgDisplayEmail
guardValidation (MsgInvalidEmailAddressWith $ CI.original userDisplayEmail') $
validEmail' userDisplayEmail'
validEmail' userDisplayEmail' || -- valid
userDisplayEmail' == userDisplayEmail || -- unchanged
userDisplayEmail' == userEmail -- euqal to default, which is then ignored
userPostAddress' <- use _stgPostAddress
let postalNotSet = isNothing userPostAddress' -- TODO $ canonical userPostAddress'
@ -407,7 +421,7 @@ nullaryPathPiece ''ProfileAnchor $ camelToPathPiece' 1
getForProfileR , postForProfileR :: CryptoUUIDUser -> Handler Html
getForProfileR = postForProfileR
postForProfileR cID = do
postForProfileR cID = do
uid <- decrypt cID
user <- runDB $ get404 uid
serveProfileR (uid, user)
@ -420,8 +434,8 @@ serveProfileR :: (UserId, User) -> Handler Html
serveProfileR (uid, user@User{..}) = do
currentRoute <- fromMaybe ProfileR <$> getCurrentRoute
(userSchools, userExamOfficeLabels) <- runDB $ do
userSchools <- fmap (setOf $ folded . _Value) . E.select . E.from $ \school -> do
E.where_ . E.exists . E.from $ \userSchool ->
userSchools <- fmap (setOf $ folded . _Value) . E.select . EL.from $ \school -> do
E.where_ . E.exists . EL.from $ \userSchool ->
E.where_ $ E.not_ (userSchool E.^. UserSchoolIsOptOut)
E.&&. userSchool E.^. UserSchoolUser E.==. E.val uid
E.&&. userSchool E.^. UserSchoolSchool E.==. school E.^. SchoolId
@ -430,7 +444,7 @@ serveProfileR (uid, user@User{..}) = do
return (userSchools, userExamOfficeLabels)
let settingsTemplate = Just SettingsForm
{ stgDisplayName = userDisplayName
, stgDisplayEmail = userDisplayEmail
, stgDisplayEmail = if userDisplayEmail == "" then userEmail else userDisplayEmail
, stgMaxFavourites = userMaxFavourites
, stgMaxFavouriteTerms = userMaxFavouriteTerms
, stgTheme = userTheme
@ -444,7 +458,7 @@ serveProfileR (uid, user@User{..}) = do
, stgShowSex = userShowSex
, stgPinPassword = userPinPassword
, stgPostAddress = userPostAddress
, stgPrefersPostal = userPrefersPostal
, stgPrefersPostal = userPrefersPostal
, stgTelephone = userTelephone
, stgMobile = userMobile
, stgExamOfficeSettings = ExamOfficeSettings
@ -459,11 +473,12 @@ serveProfileR (uid, user@User{..}) = do
now <- liftIO getCurrentTime
isAdmin <- checkAdmin
thisUser <- fromMaybe uid <$> maybeAuthId
let changeEmailByUser = userDisplayEmail /= stgDisplayEmail && (not isAdmin || thisUser == uid)
let changeEmailByUser = not isAdmin || thisUser == uid
changeEmailProper = userDisplayEmail /= stgDisplayEmail && userEmail /= stgDisplayEmail
runDBJobs $ do
update uid $
[ UserDisplayEmail =. stgDisplayEmail | not changeEmailByUser ] ++ -- DisplayEmail changes by Users must be confirmed, see 480 below
[ UserPostLastUpdate =. Just now | userPostAddress /= stgPostAddress ] ++
[ UserDisplayEmail =. stgDisplayEmail | not changeEmailByUser, changeEmailProper ] ++ -- DisplayEmail changes by Users must be confirmed, see 480 below
[ UserPostLastUpdate =. Just now | userPostAddress /= stgPostAddress ] ++
[ UserDisplayName =. stgDisplayName
, UserMaxFavourites =. stgMaxFavourites
, UserMaxFavouriteTerms =. stgMaxFavouriteTerms
@ -484,7 +499,7 @@ serveProfileR (uid, user@User{..}) = do
, UserExamOfficeGetLabels =. (stgExamOfficeSettings & eosettingsGetLabels)
]
updateFavourites Nothing
when changeEmailByUser $ do
when (changeEmailByUser && changeEmailProper) $ do
queueDBJob $ JobChangeUserDisplayEmail uid stgDisplayEmail
addMessageI Info $ MsgUserDisplayEmailChangeSent stgDisplayEmail
let
@ -510,8 +525,8 @@ serveProfileR (uid, user@User{..}) = do
oldExamLabels = userExamOfficeLabels
newExamLabels = stgExamOfficeSettings & eosettingsLabels
forM_ oldExamLabels $ \(Entity eolid ExamOfficeLabel{..}) -> unless (Right eolid `Map.member` newExamLabels || Left examOfficeLabelName `Map.member` newExamLabels) $ do
E.delete . E.from $ \examOfficeExternalExamLabel -> E.where_ $ examOfficeExternalExamLabel E.^. ExamOfficeExternalExamLabelLabel E.==. E.val eolid
E.delete . E.from $ \examOfficeExamLabel -> E.where_ $ examOfficeExamLabel E.^. ExamOfficeExamLabelLabel E.==. E.val eolid
E.delete . EL.from $ \examOfficeExternalExamLabel -> E.where_ $ examOfficeExternalExamLabel E.^. ExamOfficeExternalExamLabelLabel E.==. E.val eolid
E.delete . EL.from $ \examOfficeExamLabel -> E.where_ $ examOfficeExamLabel E.^. ExamOfficeExamLabelLabel E.==. E.val eolid
when (csvExportLabel userCsvOptions == Just examOfficeLabelName) $
update uid [ UserCsvOptions =. userCsvOptions { csvExportLabel = Nothing } ]
delete eolid
@ -575,70 +590,122 @@ getProfileDataR = do
getForProfileDataR :: CryptoUUIDUser -> Handler Html
getForProfileDataR cID = do
uid <- decrypt cID
(user,dataWidget) <- runDB $ bind2 (get404 uid) $ makeProfileData . Entity uid
(user,dataWidget) <- runDB $ bind2 (get404 uid) $ makeProfileData . Entity uid
defaultLayout $ do
setTitleI $ MsgHeadingForProfileData $ userDisplayName user
dataWidget
-- data TableHasData = TableHasData{tableHasRows :: Bool, tableWidget :: Widget}
-- a poor man's record subsitute
{-
type TableHasData = (Bool, Widget)
tableHasRows :: TableHasData -> Bool
tableHasRows = fst
tableWidget :: TableHasData -> Widget
tableWidget = snd
-}
-- | Given a header message, a bool and widget; display widget and header only if the boolean is true
maybeTable :: (RenderMessage UniWorX a)
=> a -> (Bool, Widget) -> Widget
maybeTable m = maybeTable' m Nothing Nothing
maybeTable' :: (RenderMessage UniWorX a)
=> a -> Maybe a -> Maybe Widget -> (Bool, Widget) -> Widget
maybeTable' _ Nothing _ (False, _ ) = mempty
maybeTable' _ (Just nodata) _ (False, _ ) =
[whamlet|
<div .container>
_{nodata}
|]
maybeTable' hdr _ mbRemark (True ,tbl) =
[whamlet|
<div .container>
<h2> _{hdr}
<div .container>
^{tbl}
$maybe remark <- mbRemark
<em>_{MsgProfileRemark}
\ ^{remark}
|]
makeProfileData :: Entity User -> DB Widget
makeProfileData (Entity uid User{..}) = do
makeProfileData usrEnt@(Entity uid usrVal@User{..}) = do
now <- liftIO getCurrentTime
avsId <- entityVal <<$>> getBy (UniqueUserAvsUser uid)
-- avsCards <- maybe (pure mempty) (\a -> selectList [UserAvsCardPersonId ==. userAvsPersonId a] []) avsId
let usrAutomatic :: CU_UserAvs_User -> Widget
usrAutomatic = updateAutomatic . mayUpdate usrVal avsId . mkCheckUpdate
addressLinkdIcon <- messageTooltip <$> messageIconI Info IconLink MsgAddressIsLinkedTip
(actualPrefersPostal, (actualPostAddress, postalAutomatic), (actualDisplayEmail, emailAutomatic)) <- getPostalPreferenceAndAddress' usrEnt
functions <- Map.fromListWith Set.union . map (\(Entity _ UserFunction{..}) -> (userFunctionFunction, Set.singleton userFunctionSchool)) <$> selectList [UserFunctionUser ==. uid] []
lecture_corrector <- E.select $ E.distinct $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
lecture_corrector <- E.select $ E.distinct $ EL.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do
EL.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
EL.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid
return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand)
studies <- E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do
E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId
E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId
studies <- E.select $ EL.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do
EL.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId
EL.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId
E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
return (studyfeat, studydegree, studyterms)
companies' <- E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
E.orderBy [E.asc (comp E.^. CompanyName)] -- E.desc (usrComp E.^. UserCompanySupervisor),
return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor)
let companies = intersperse (text2markup ", ") $
(\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies'
icnSuper = text2markup " " <> icon IconSupervisor
supervisors' <- E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
E.on $ spvr E.^. UserSupervisorSupervisor E.==. usrSpvr E.^. UserId
E.where_ $ spvr E.^. UserSupervisorUser E.==. E.val uid
E.orderBy [E.asc (usrSpvr E.^. UserDisplayName)]
return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications)
let numSupervisors = length supervisors'
supervisors = intersperse (text2widget ", ") $
(\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisors'
icnReroute = text2widget " " <> toWgt (icon IconLetter)
supervisees' <- E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
E.on $ spvr E.^. UserSupervisorUser E.==. usrSpvr E.^. UserId
E.where_ $ spvr E.^. UserSupervisorSupervisor E.==. E.val uid
return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications)
let numSupervisees = length supervisees'
supervisees = intersperse (text2widget ", ") $
(\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisees'
-- icnReroute = text2widget " " <> toWgt (icon IconLetter)
companies <- wgtCompanies uid
-- supervisors' <- E.select $ EL.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
-- EL.on $ spvr E.^. UserSupervisorSupervisor E.==. usrSpvr E.^. UserId
-- E.where_ $ spvr E.^. UserSupervisorUser E.==. E.val uid
-- E.orderBy [E.asc (usrSpvr E.^. UserDisplayName)]
-- return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications)
-- let numSupervisors = length supervisors'
-- supervisors = intersperse (text2widget ", ") $
-- (\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisors'
-- icnReroute = text2widget " " <> toWgt (icon IconReroute)
-- supervisees' <- E.select $ EL.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
-- EL.on $ spvr E.^. UserSupervisorUser E.==. usrSpvr E.^. UserId
-- E.where_ $ spvr E.^. UserSupervisorSupervisor E.==. E.val uid
-- return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications)
-- let numSupervisees = length supervisees'
-- supervisees = intersperse (text2widget ", ") $
-- (\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisees'
-- -- icnReroute = text2widget " " <> toWgt (icon IconReroute)
--Tables
(hasRows, ownedCoursesTable) <- mkOwnedCoursesTable uid -- Tabelle mit eigenen Kursen
ownedCoursesTable <- mkOwnedCoursesTable uid -- Tabelle mit eigenen Kursen
enrolledCoursesTable <- mkEnrolledCoursesTable uid -- Tabelle mit allen Teilnehmer: Kurs (link), Datum
submissionTable <- mkSubmissionTable uid -- Tabelle mit allen Abgaben und Abgabe-Gruppen
submissionGroupTable <- mkSubmissionGroupTable uid -- Tabelle mit allen Abgabegruppen
correctionsTable <- mkCorrectionsTable uid -- Tabelle mit allen Korrektor-Aufgaben
qualificationsTable <- mkQualificationsTable now uid -- Tabelle mit allen Qualifikationen
let examTable, ownTutorialTable, tutorialTable :: Widget
examTable = i18n MsgPersonalInfoExamAchievementsWip
ownTutorialTable = i18n MsgPersonalInfoOwnTutorialsWip
tutorialTable = i18n MsgPersonalInfoTutorialsWip
supervisorsTable <- mkSupervisorsTable uid -- Tabelle mit allen Supervisors
superviseesTable <- mkSuperviseesTable actualPrefersPostal uid -- Tabelle mit allen Supervisees
countUnderlings <- E.select $ do
spr <- E.from $ E.table @UserSupervisor
E.where_ $ spr E.^. UserSupervisorSupervisor E.==. E.val uid
return (E.countRows, E.count (spr E.^. UserSupervisorId) `E.filterWhere` (spr E.^. UserSupervisorRerouteNotifications))
countSupervisors <- E.select $ do
spr <- E.from $ E.table @UserSupervisor
E.where_ $ spr E.^. UserSupervisorUser E.==. E.val uid
return (E.countRows, E.count (spr E.^. UserSupervisorId) `E.filterWhere` (spr E.^. UserSupervisorRerouteNotifications))
let errorCount ((E.Value x, E.Value y):_) = (x,y)
errorCount _ = (-1,-1)
supervisorsWgt :: Widget =
let (nrSupers, nrSupersReroute) = errorCount countSupervisors
in maybeTable' (MsgProfileSupervisor nrSupers nrSupersReroute) (Just MsgProfileNoSupervisor)
(toMaybe (nrSupersReroute > 0) $ msg2widget $ MsgProfileSupervisorRemark nrSupers nrSupersReroute 0) (nrSupers > 0, supervisorsTable)
superviseesWgt :: Widget =
let (nrUnderlings, nrUndersReroute) = errorCount countUnderlings
in maybeTable' (MsgProfileSupervisee nrUnderlings nrUndersReroute) (Just MsgProfileNoSupervisee)
(toMaybe (nrUndersReroute > 0) $ msg2widget $ MsgProfileSuperviseeRemark nrUnderlings nrUndersReroute) (nrUnderlings > 0, superviseesTable)
-- let examTable, ownTutorialTable, tutorialTable :: Widget
-- examTable = i18n MsgPersonalInfoExamAchievementsWip
-- ownTutorialTable = i18n MsgPersonalInfoOwnTutorialsWip
-- tutorialTable = i18n MsgPersonalInfoTutorialsWip -- note that tutorials are linked in enrolledCoursesTable
cID <- encrypt uid
mCRoute <- getCurrentRoute
showAdminInfo <- pure (mCRoute == Just (AdminUserR cID)) `or2M` hasReadAccessTo (AdminUserR cID)
tooltipAvsPersNo <- messageI Info MsgAvsPersonNoNotId
tooltipInvalidEmail <- messageI Error MsgInvalidEmailAddress
showAdminInfo <- pure (mCRoute == Just (AdminUserR cID)) `or2M` hasReadAccessTo (AdminUserR cID)
tooltipAvsPersNo <- messageI Info MsgAvsPersonNoNotId
tooltipAvsPersNoDiffers <- messageI Error MsgAvsPersonNoDiffers
tooltipInvalidEmail <- messageI Error MsgInvalidEmailAddress
let profileRemarks = $(i18nWidgetFile "profile-remarks")
return $(widgetFile "profileData")
@ -655,7 +722,7 @@ mkOwnedCoursesTable =
withType = id
dbtSQLQuery' uid (course `E.InnerJoin` lecturer) = do
E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
EL.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid
return ( course E.^. CourseTerm
, course E.^. CourseSchool
@ -696,26 +763,36 @@ mkOwnedCoursesTable =
-- | Table listing all courses that the given user is enrolled in
mkEnrolledCoursesTable :: UserId -> DB Widget
mkEnrolledCoursesTable =
let withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a)
mkEnrolledCoursesTable :: UserId -> DB (Bool, Widget)
mkEnrolledCoursesTable uid = do
usrTuts <- E.select $ do
(tpar :& tut) <- E.from $ E.table @TutorialParticipant `E.innerJoin` E.table @Tutorial
`E.on` (\(tpar :& tut) -> tut E.^. TutorialId E.==. tpar E.^. TutorialParticipantTutorial)
E.where_ $ tpar E.^. TutorialParticipantUser E.==. E.val uid
E.orderBy [E.asc $ tut E.^. TutorialCourse, E.desc $ tut E.^. TutorialName] -- Data.Map.fromAscListWith reverses tutorials, hence E.desc
return (tut E.^. TutorialCourse, tut E.^. TutorialName)
let usrTutMap :: Map CourseId [TutorialName]
usrTutMap = Map.fromAscListWith (++) [(tcid, [tnm]) | (E.Value tcid, E.Value tnm) <- usrTuts]
withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a)
-> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a)
withType = id
validator = def & defaultSorting [SortDescBy "time"]
in \uid -> dbTableWidget' validator
(_1 %~ getAny) <$> dbTableWidget validator
DBTable
{ dbtIdent = "courseMembership" :: Text
, dbtSQLQuery = \(course `E.InnerJoin` participant) -> do
E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse
EL.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse
E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid
E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
return (course, participant E.^. CourseParticipantRegistration)
, dbtRowKey = \(course `E.InnerJoin` _) -> course E.^. CourseId
, dbtProj = dbtProjId <&> _dbrOutput . _2 %~ E.unValue
, dbtColonnade = mconcat
[ sortable (Just "term") (i18nCell MsgTableTerm) $
[ sortable (Just "term") (i18nCell MsgTableTerm) $ fmap addIndicatorCell
termCell <$> view (_dbrOutput . _1 . _entityVal . _courseTerm)
, sortable (Just "school") (i18nCell MsgTableCourseSchool) . magnify (_dbrOutput . _1 . _entityVal) $
schoolCell <$> view _courseTerm
@ -725,7 +802,14 @@ mkEnrolledCoursesTable =
, sortable (Just "time") (i18nCell MsgProfileRegistered) $ do
regTime <- view $ _dbrOutput . _2
return $ dateTimeCell regTime
]
, sortable Nothing (i18nCell MsgCourseTutorials) $ \(view $ _dbrOutput . _1 -> Entity{entityKey=cid, entityVal=Course{..}}) ->
cell [whamlet|
<ul .list--iconless>
$forall tutName <- maybeMonoid (Map.lookup cid usrTutMap)
<li>
^{simpleLink (citext2widget tutName) (CTutorialR courseTerm courseSchool courseShorthand tutName TUsersR)}
|]
]
, dbtSorting = Map.fromList
[ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseName )
, ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseTerm )
@ -748,7 +832,7 @@ mkEnrolledCoursesTable =
-- | Table listing all submissions for the given user
mkSubmissionTable :: UserId -> DB Widget
mkSubmissionTable :: UserId -> DB (Bool, Widget)
mkSubmissionTable =
let dbtIdent = "submissions" :: Text
dbtStyle = def
@ -758,9 +842,9 @@ mkSubmissionTable =
withType = id
dbtSQLQuery' uid (course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` subUser) = do
E.on $ submission E.^. SubmissionId E.==. subUser E.^. SubmissionUserSubmission
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
EL.on $ submission E.^. SubmissionId E.==. subUser E.^. SubmissionUserSubmission
EL.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
EL.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
E.where_ $ subUser E.^. SubmissionUserUser E.==. E.val uid
let crse = ( course E.^. CourseTerm
, course E.^. CourseSchool
@ -771,7 +855,7 @@ mkSubmissionTable =
dbtRowKey (_ `E.InnerJoin` _ `E.InnerJoin` submission `E.InnerJoin` _) = submission E.^. SubmissionId
lastSubEdit uid submission = -- latest Edit-Time of this user for submission
E.subSelectMaybe . E.from $ \subEdit -> do
E.subSelectMaybe . EL.from $ \subEdit -> do
E.where_ $ subEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId
E.&&. subEdit E.^. SubmissionEditUser E.==. E.val (Just uid)
return . E.max_ $ subEdit E.^. SubmissionEditTime
@ -782,7 +866,7 @@ mkSubmissionTable =
<&> _dbrOutput . _4 %~ E.unValue
dbtColonnade = mconcat
[ sortable (Just "term") (i18nCell MsgTableTerm) $
[ sortable (Just "term") (i18nCell MsgTableTerm) $ fmap addIndicatorCell
termCell <$> view (_dbrOutput . _1 . _1)
, sortable (Just "school") (i18nCell MsgTableCourseSchool) . magnify (_dbrOutput . _1 ) $
schoolCell <$> view _1
@ -826,14 +910,10 @@ mkSubmissionTable =
dbtExtraReps = []
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid
dbtSorting = dbtSorting' uid
in dbTableWidget' validator DBTable{..}
-- in do dbtSQLQuery <- dbtSQLQuery'
-- dbtSorting <- dbtSorting'
-- return $ dbTableWidget' validator $ DBTable {..}
in (_1 %~ getAny) <$> dbTableWidget validator DBTable{..}
-- | Table listing all submissions for the given user
mkSubmissionGroupTable :: UserId -> DB Widget
mkSubmissionGroupTable :: UserId -> DB (Bool, Widget)
mkSubmissionGroupTable =
let dbtIdent = "subGroups" :: Text
dbtStyle = def
@ -842,8 +922,8 @@ mkSubmissionGroupTable =
withType = id
dbtSQLQuery' uid (course `E.InnerJoin` sgroup `E.InnerJoin` sguser) = do
E.on $ sguser E.^. SubmissionGroupUserSubmissionGroup E.==. sgroup E.^. SubmissionGroupId
E.on $ sgroup E.^. SubmissionGroupCourse E.==. course E.^. CourseId
EL.on $ sguser E.^. SubmissionGroupUserSubmissionGroup E.==. sgroup E.^. SubmissionGroupId
EL.on $ sgroup E.^. SubmissionGroupCourse E.==. course E.^. CourseId
E.where_ $ sguser E.^. SubmissionGroupUserUser E.==. E.val uid
let crse = ( course E.^. CourseTerm
, course E.^. CourseSchool
@ -856,7 +936,7 @@ mkSubmissionGroupTable =
<&> _dbrOutput . _1 %~ $(E.unValueN 3)
dbtColonnade = mconcat
[ sortable (Just "term") (i18nCell MsgTableTerm) $
[ sortable (Just "term") (i18nCell MsgTableTerm) $ fmap addIndicatorCell
termCell <$> view (_dbrOutput . _1 . _1)
, sortable (Just "school") (i18nCell MsgTableCourseSchool) . magnify (_dbrOutput . _1 ) $
schoolCell <$> view _1
@ -885,10 +965,10 @@ mkSubmissionGroupTable =
dbtCsvDecode = Nothing
dbtExtraReps = []
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid
in dbTableWidget' validator DBTable{..}
in (_1 %~ getAny) <$> dbTableWidget validator DBTable{..}
mkCorrectionsTable :: UserId -> DB Widget
mkCorrectionsTable :: UserId -> DB (Bool, Widget)
mkCorrectionsTable =
let dbtIdent = "corrections" :: Text
dbtStyle = def
@ -896,18 +976,18 @@ mkCorrectionsTable =
-> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity SheetCorrector))->a)
withType = id
corrsAssigned uid sheet = E.subSelectCount . E.from $ \submission ->
corrsAssigned uid sheet = E.subSelectCount . EL.from $ \submission ->
E.where_ $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
E.&&. submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
corrsCorrected uid sheet = E.subSelectCount . E.from $ \submission ->
corrsCorrected uid sheet = E.subSelectCount . EL.from $ \submission ->
E.where_ $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
E.&&. submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
E.&&. E.not_ (E.isNothing $ submission E.^. SubmissionRatingTime)
dbtSQLQuery' uid (course `E.InnerJoin` sheet `E.InnerJoin` corrector) = do
E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
EL.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
EL.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid
let crse = ( course E.^. CourseTerm
, course E.^. CourseSchool
@ -921,7 +1001,7 @@ mkCorrectionsTable =
<&> _dbrOutput . _2 %~ E.unValue
dbtColonnade = mconcat
[ sortable (Just "term") (i18nCell MsgTableTerm) $
[ sortable (Just "term") (i18nCell MsgTableTerm) $ fmap addIndicatorCell
termCellCL <$> view (_dbrOutput . _1)
, sortable (Just "school") (i18nCell MsgTableCourseSchool) $
schoolCellCL <$> view (_dbrOutput . _1)
@ -958,7 +1038,7 @@ mkCorrectionsTable =
dbtCsvDecode = Nothing
dbtExtraReps = []
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid
in dbTableWidget' validator DBTable{..}
in (_1 %~ getAny) <$> dbTableWidget validator DBTable{..}
-- | Table listing all qualifications that the given user is enrolled in
@ -972,29 +1052,29 @@ mkQualificationsTable =
DBTable
{ dbtIdent = "userQualifications" :: Text
, dbtSQLQuery = \(quali `E.InnerJoin` quser `E.LeftOuterJoin` qblock) -> do
E.on $ quser E.^. QualificationUserId E.=?. qblock E.?. QualificationUserBlockQualificationUser
EL.on $ quser E.^. QualificationUserId E.=?. qblock E.?. QualificationUserBlockQualificationUser
E.&&. qblock `isLatestBlockBefore` E.val now
E.on $ quser E.^. QualificationUserQualification E.==. quali E.^. QualificationId
E.where_ $ quser E.^. QualificationUserUser E.==. E.val uid
EL.on $ quser E.^. QualificationUserQualification E.==. quali E.^. QualificationId
E.where_ $ quser E.^. QualificationUserUser E.==. E.val uid
return (quali, quser, qblock)
, dbtRowKey = \(_quali `E.InnerJoin` quser `E.LeftOuterJoin` _qblock) -> quser E.^. QualificationUserId
, dbtProj = dbtProjId
, dbtProj = dbtProjId
, dbtColonnade = mconcat
[ colSchool (_dbrOutput . _1 . _entityVal . _qualificationSchool)
, sortable (Just "quali") (i18nCell MsgQualificationName) $ qualificationDescrCell <$> view (_dbrOutput . _1 . _entityVal)
, sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ dayCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserFirstHeld )
, sortable (Just "quali") (i18nCell MsgQualificationName) $ qualificationDescrCell <$> view (_dbrOutput . _1 . _entityVal)
, sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ dayCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserFirstHeld )
, sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh) $ dayCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserLastRefresh)
, sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ dayCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserValidUntil )
, sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ \row ->
qualificationValidReasonCell False (utctDay now) (row ^? _dbrOutput . _3 . _Just . _entityVal) (row ^. _dbrOutput . _2 . _entityVal)
qualificationValidReasonCell False (utctDay now) (row ^? _dbrOutput . _3 . _Just . _entityVal) (row ^. _dbrOutput . _2 . _entityVal)
]
, dbtSorting = mconcat
[ sortSchool $ to (\(quali `E.InnerJoin` _ `E.LeftOuterJoin` _) -> quali E.^. QualificationSchool)
, singletonMap "quali" $ SortColumn $ withType $ \(quali `E.InnerJoin` _ `E.LeftOuterJoin` _) -> quali E.^. QualificationName
, singletonMap "quali" $ SortColumn $ withType $ \(quali `E.InnerJoin` _ `E.LeftOuterJoin` _) -> quali E.^. QualificationName
, singletonMap "blocked" $ SortColumn $ withType $ \(_ `E.InnerJoin` _ `E.LeftOuterJoin` qblock) -> qblock E.?. QualificationUserBlockFrom
, singletonMap "valid-until" $ SortColumn $ withType $ \(_ `E.InnerJoin` quser `E.LeftOuterJoin` _) -> quser E.^. QualificationUserValidUntil
, singletonMap "last-refresh" $ SortColumn $ withType $ \(_ `E.InnerJoin` quser `E.LeftOuterJoin` _) -> quser E.^. QualificationUserLastRefresh
, singletonMap "first-held" $ SortColumn $ withType $ \(_ `E.InnerJoin` quser `E.LeftOuterJoin` _) -> quser E.^. QualificationUserFirstHeld
, singletonMap "first-held" $ SortColumn $ withType $ \(_ `E.InnerJoin` quser `E.LeftOuterJoin` _) -> quser E.^. QualificationUserFirstHeld
]
, dbtFilter = mempty
, dbtFilterUI = mempty
@ -1006,6 +1086,125 @@ mkQualificationsTable =
}
-- Types & Definitions used for both mkSupervisorsTable and mkSuperviseeTable
type TblSupervisorExpr = E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity UserSupervisor) -- `E.LeftOuterJoin` E.SqlExpr (Entity Company)
type TblSupervisorData = DBRow (Entity User, Entity UserSupervisor)
queryUser :: TblSupervisorExpr -> E.SqlExpr (Entity User)
queryUser = $(E.sqlIJproj 2 1)
queryUserSupervisor :: TblSupervisorExpr -> E.SqlExpr (Entity UserSupervisor)
queryUserSupervisor = $(E.sqlIJproj 2 2)
resultUser :: Lens' TblSupervisorData (Entity User)
resultUser = _dbrOutput . _1
resultUserSupervisor :: Lens' TblSupervisorData (Entity UserSupervisor)
resultUserSupervisor = _dbrOutput . _2
instance HasEntity TblSupervisorData User where
hasEntity = _dbrOutput . _1
instance HasUser TblSupervisorData where
hasUser = _dbrOutput . _1 . _entityVal
-- | Table listing all supervisor of the given user
mkSupervisorsTable :: UserId -> DB Widget
mkSupervisorsTable uid = dbTableWidget' validator DBTable{..}
where
dbtIdent = "supervisors" :: Text
dbtStyle = def
dbtSQLQuery (usr `E.InnerJoin` spr) = do
EL.on $ spr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId
E.where_ $ spr E.^. UserSupervisorUser E.==. E.val uid
return (usr, spr)
dbtRowKey (_ `E.InnerJoin` spr) = spr E.^. UserSupervisorId
dbtProj = dbtProjId
dbtColonnade = mconcat
[ colUserNameModalHdr MsgTableSupervisor ForProfileDataR
, colUserEmail
-- , sortable (Just "rerouted") (i18nCell MsgTableRerouteActive) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorRerouteNotifications -> b) -> indicatorCell <> ifIconCell b IconReroute
-- , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b
, sortable (Just "reroute") (i18nCell MsgTableRerouteActive) $ \row ->
let isReroute = row ^. resultUserSupervisor . _entityVal ._userSupervisorRerouteNotifications
isLetter = row ^. resultUser . _userPrefersPostal
in if isReroute
then iconCell IconReroute <> spacerCell <> iconFixedCell (iconLetterOrEmail isLetter)
else mempty
, sortable (Just "cshort") (i18nCell MsgTableCompany) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorCompany -> mc) -> maybeCell mc (\(unCompanyKey -> c) -> anchorCell (FirmUsersR c) $ citext2widget c)
, sortable (Just "reason") (i18nCell MsgTableReason) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorReason -> mr) -> maybeCell mr textCell
]
validator = def & defaultSorting [ SortAscBy "cshort", SortAscBy "user-name" ]
dbtSorting = mconcat
[ singletonMap & uncurry $ sortUserNameLink queryUser
, singletonMap & uncurry $ sortUserEmail queryUser
, singletonMap "postal-pref" $ SortColumn $ queryUser >>> (E.^. UserPrefersPostal)
, singletonMap "rerouted" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorRerouteNotifications)
-- , singletonMap "reroute" $ SortColumn $ queryUserSupervisor &&& queryUser >>> (\(spr,usr) -> mTuple (spr E.^. UserSupervisorRerouteNotifications) (usr E.^. UserPrefersPostal))
, singletonMap "reroute" $ SortColumns $ \row ->
[ SomeExprValue $ queryUserSupervisor row E.^. UserSupervisorRerouteNotifications
, SomeExprValue $ queryUser row E.^. UserPrefersPostal
]
, singletonMap "cshort" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorCompany)
, singletonMap "reason" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorReason)
]
dbtFilter = mconcat
[ singletonMap & uncurry $ fltrUserNameEmail queryUser
]
dbtFilterUI = mempty
dbtParams = def
dbtCsvEncode = noCsvEncode
dbtCsvDecode = Nothing
dbtExtraReps = []
-- | Table listing all persons supervised by the given user
mkSuperviseesTable ::Bool -> UserId -> DB Widget
mkSuperviseesTable userPrefersPostal uid = dbTableWidget' validator DBTable{..}
where
dbtIdent = "supervisees" :: Text
dbtStyle = def
dbtSQLQuery (usr `E.InnerJoin` spr) = do
EL.on $ spr E.^. UserSupervisorUser E.==. usr E.^. UserId
E.where_ $ spr E.^. UserSupervisorSupervisor E.==. E.val uid
return (usr, spr)
dbtRowKey (_ `E.InnerJoin` spr) = spr E.^. UserSupervisorId
dbtProj = dbtProjId
iconCellLetterOrEmail = spacerCell <> iconFixedCell (iconLetterOrEmail userPrefersPostal) -- only notification type of supervisor matters here
dbtColonnade = mconcat
[ colUserNameModalHdr MsgTableSupervisee ForProfileDataR
, colUserEmail
-- , sortable (Just "rerouted") (i18nCell MsgTableRerouteActive) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorRerouteNotifications -> b) -> ifIconCell b IconReroute
-- , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b
, sortable (Just "reroute") (i18nCell MsgTableRerouteActive) $ \row ->
let isReroute = row ^. resultUserSupervisor . _entityVal ._userSupervisorRerouteNotifications
in boolCell isReroute $ iconCell IconReroute <> iconCellLetterOrEmail
, sortable (Just "cshort") (i18nCell MsgTableCompany) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorCompany -> mc) -> maybeCell mc (\(unCompanyKey -> c) -> anchorCell (FirmUsersR c) $ citext2widget c)
, sortable (Just "reason") (i18nCell MsgTableReason) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorReason -> mr) -> maybeCell mr textCell
]
validator = def & defaultSorting [ SortAscBy "cshort", SortAscBy "user-name" ]
dbtSorting = mconcat
[ singletonMap & uncurry $ sortUserNameLink queryUser
, singletonMap & uncurry $ sortUserEmail queryUser
-- , singletonMap "postal-pref" $ SortColumn $ queryUser >>> (E.^. UserPrefersPostal)
-- , singletonMap "rerouted" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorRerouteNotifications)
, singletonMap "reroute" $ SortColumns $ \row ->
[ SomeExprValue $ queryUserSupervisor row E.^. UserSupervisorRerouteNotifications
, SomeExprValue $ queryUser row E.^. UserPrefersPostal
]
, singletonMap "cshort" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorCompany)
, singletonMap "reason" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorReason)
]
dbtFilter = mconcat
[ singletonMap & uncurry $ fltrUserNameEmail queryUser
]
dbtFilterUI = mempty
dbtParams = def
dbtCsvEncode = noCsvEncode
dbtCsvDecode = Nothing
dbtExtraReps = []
getAuthPredsR, postAuthPredsR :: Handler Html
getAuthPredsR = postAuthPredsR
postAuthPredsR = do
@ -1124,7 +1323,7 @@ postCsvOptionsR = do
Entity uid User{userCsvOptions} <- requireAuth
userIsExamOffice <- hasReadAccessTo $ ExamOfficeR EOExamsR
examOfficeLabels <- if not userIsExamOffice then return mempty else runDB . E.select . E.from $ \examOfficeLabel -> do
examOfficeLabels <- if not userIsExamOffice then return mempty else runDB . E.select . EL.from $ \examOfficeLabel -> do
E.where_ $ examOfficeLabel E.^. ExamOfficeLabelUser E.==. E.val uid
E.orderBy [ E.asc (examOfficeLabel E.^. ExamOfficeLabelName) ]
return $ examOfficeLabel E.^. ExamOfficeLabelName

315
src/Handler/Qualification.hs
View File

@ -14,11 +14,11 @@ module Handler.Qualification
import Import
-- import Jobs
import Jobs
import Handler.Utils
import Handler.Utils.Users
import Handler.Utils.LMS
import Handler.Utils.Company
import qualified Data.Set as Set
import qualified Data.Map as Map
@ -37,10 +37,6 @@ import Database.Esqueleto.Utils.TH
-- import Handler.Utils.Qualification (validQualification)
-- avoids repetition of local definitions
single :: (k,a) -> Map k a
single = uncurry Map.singleton
getQualificationSchoolR :: SchoolId -> Handler Html
getQualificationSchoolR ssh = redirect (QualificationAllR, [("qualification-overview-school", toPathPiece ssh)])
@ -56,7 +52,7 @@ getQualificationAllR = do
type AllQualificationTableData = DBRow (Entity Qualification, Ex.Value Word64, Ex.Value Word64)
resultAllQualification :: Lens' AllQualificationTableData Qualification
resultAllQualification = _dbrOutput . _1 . _entityVal
resultAllQualification = _dbrOutput . _1 . _entityVal
resultAllQualificationActive :: Lens' AllQualificationTableData Word64
resultAllQualificationActive = _dbrOutput . _2 . _unValue
@ -66,53 +62,59 @@ resultAllQualificationTotal = _dbrOutput . _3 . _unValue
mkQualificationAllTable :: Bool -> DB (Any, Widget)
mkQualificationAllTable isAdmin = do
svs <- getSupervisees
mkQualificationAllTable isAdmin = do
svs <- getSupervisees
now <- liftIO getCurrentTime
let
let
resultDBTable = DBTable{..}
where
dbtSQLQuery quali = do
let filterSvs quser = quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId
dbtSQLQuery quali = do
let filterSvs quser = quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId
Ex.&&. (E.val isAdmin E.||. quser Ex.^. QualificationUserUser `Ex.in_` E.vals svs)
cusers = Ex.subSelectCount $ do
cusers = Ex.subSelectCount $ do
quser <- Ex.from $ Ex.table @QualificationUser
Ex.where_ $ filterSvs quser
cactive = Ex.subSelectCount $ do
Ex.where_ $ filterSvs quser
cactive = Ex.subSelectCount $ do
quser <- Ex.from $ Ex.table @QualificationUser
Ex.where_ $ filterSvs quser Ex.&&. validQualification now quser
return (quali, cactive, cusers)
return (quali, cactive, cusers)
dbtRowKey = (Ex.^. QualificationId)
dbtProj = dbtProjId
dbtColonnade = dbColonnade $ mconcat
[ colSchool $ resultAllQualification . _qualificationSchool
, sortable (Just "qshort") (i18nCell MsgQualificationShort) $ \(view resultAllQualification -> quali) ->
let qsh = qualificationShorthand quali in
, sortable (Just "qshort") (i18nCell MsgQualificationShort) $ \(view resultAllQualification -> quali) ->
let qsh = qualificationShorthand quali in
anchorCell (QualificationR (qualificationSchool quali) qsh) $ toWgt qsh
, sortable (Just "qname") (i18nCell MsgQualificationName) $ \(view resultAllQualification -> quali) ->
, sortable (Just "qname") (i18nCell MsgQualificationName) $ \(view resultAllQualification -> quali) ->
let qsh = qualificationShorthand quali
qnm = qualificationName quali
qnm = qualificationName quali
in anchorCell (QualificationR (qualificationSchool quali) qsh) $ toWgt qnm
, sortable Nothing (i18nCell MsgQualificationDescription) $ \(view resultAllQualification -> quali) ->
maybeCell (qualificationDescription quali) markupCellLargeModal
, sortable Nothing (i18nCell MsgQualificationValidDuration & cellTooltip MsgTableDiffDaysTooltip) $
, sortable Nothing (i18nCell MsgQualificationValidDuration & cellTooltip MsgTableDiffDaysTooltip) $
foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationValidDuration)
, sortable Nothing (i18nCell MsgQualificationRefreshWithin & cellTooltips [SomeMessage MsgQualificationRefreshWithinTooltip , SomeMessage MsgTableDiffDaysTooltip]) $
foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshWithin)
, sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart) $ \row ->
let elearnstart = row ^. resultAllQualification . _qualificationElearningStart
reminder = row ^. resultAllQualification . _qualificationRefreshReminder
in tickmarkCell $ elearnstart && isJust reminder
, sortable Nothing (i18nCell MsgQualificationRefreshReminder & cellTooltips [SomeMessage MsgQualificationRefreshReminderTooltip, SomeMessage MsgTableDiffDaysTooltip]) $
foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshReminder)
, sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart)
$ tickmarkCell . view (resultAllQualification . _qualificationElearningStart)
, sortable (Just "noteexpiry") (i18nCell MsgQualificationExpiryNotification & cellTooltip MsgQualificationExpiryNotificationTooltip)
foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshReminder)
, sortable (Just "noteexpiry") (i18nCell MsgQualificationExpiryNotification & cellTooltip MsgQualificationExpiryNotificationTooltip)
$ tickmarkCell . view (resultAllQualification . _qualificationExpiryNotification)
, sortable Nothing (i18nCell MsgTableQualificationIsAvsLicence & cellTooltip MsgTableQualificationIsAvsLicenceTooltip)
-- , sortable (Just "qelearrenew") (i18nCell MsgTableLmsElearningRenews & cellTooltip MsgQualificationElearningRenew)
-- $ tickmarkCell . view (resultAllQualification . _qualificationElearningRenews)
-- , sortable Nothing (i18nCell MsgTableQualificationLmsReuses & cellTooltip MsgTableQualificationLmsReusesTooltip)
-- $ \(view (resultAllQualification . _qualificationLmsReuses) -> reuseQid) -> maybeCell reuseQid qualificationIdShortCell
, sortable Nothing (i18nCell MsgTableQualificationIsAvsLicence & cellTooltip MsgTableQualificationIsAvsLicenceTooltip)
$ \(view (resultAllQualification . _qualificationAvsLicence) -> licence) -> maybeCell licence $ textCell . T.singleton . licence2char
, sortable Nothing (i18nCell MsgTableQualificationSapExport & cellTooltip MsgTableQualificationSapExportTooltip)
, sortable Nothing (i18nCell MsgTableQualificationSapExport & cellTooltip MsgTableQualificationSapExportTooltip)
$ \(view (resultAllQualification . _qualificationSapId) -> mbSapId) -> tickmarkCell $ isJust mbSapId
, sortable Nothing (i18nCell MsgTableQualificationCountActive & cellTooltip MsgTableQualificationCountActiveTooltip)
$ \(view resultAllQualificationActive -> n) -> wgtCell $ word2widget n
, sortable Nothing (i18nCell MsgTableQualificationCountTotal) $ wgtCell . word2widget . view resultAllQualificationTotal
]
$ \(view resultAllQualificationActive -> n) -> wgtCell $ word2widget n
, sortable Nothing (i18nCell MsgTableQualificationCountTotal) $ wgtCell . word2widget . view resultAllQualificationTotal
]
dbtSorting = mconcat
[
sortSchool $ to (E.^. QualificationSchool)
@ -134,7 +136,7 @@ mkQualificationAllTable isAdmin = do
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
dbtParams = def
dbtIdent :: Text
dbtIdent = "qualification-overview"
dbtIdent = "qualification-overview"
dbtCsvEncode = noCsvEncode
dbtCsvDecode = Nothing
dbtExtraReps = []
@ -146,18 +148,17 @@ mkQualificationAllTable isAdmin = do
-- getQualificationEditR, postQualificationEditR :: SchoolId -> QualificationShorthand -> Handler Html
-- getQualificationEditR = postQualificationEditR
-- getQualificationEditR = postQualificationEditR
-- postQualificationEditR = error "TODO"
data QualificationTableCsv = QualificationTableCsv -- Q..T..C.. -> qtc..
{ qtcDisplayName :: UserDisplayName
, qtcEmail :: UserEmail
, qtcCompany :: Maybe Text
, qtcCompanyNumbers :: CsvSemicolonList Int
, qtcValidUntil :: Day
, qtcLastRefresh :: Day
, qtcBlockStatus :: Maybe Bool
, qtcBlockFrom :: Maybe UTCTime
, qtcBlockFrom :: Maybe UTCTime
, qtcScheduleRenewal:: Bool
, qtcLmsStatusTxt :: Maybe Text
, qtcLmsStatusDay :: Maybe UTCTime
@ -169,12 +170,11 @@ qtcExample :: QualificationTableCsv
qtcExample = QualificationTableCsv
{ qtcDisplayName = "Max Mustermann"
, qtcEmail = "m.mustermann@example.com"
, qtcCompany = Just "Example Brothers LLC, SecondaryJobs Inc"
, qtcCompanyNumbers = CsvSemicolonList [27,69]
, qtcCompany = Just "Example Brothers LLC"
, qtcValidUntil = compDay
, qtcLastRefresh = compDay
, qtcBlockStatus = Nothing
, qtcBlockFrom = Nothing
, qtcBlockFrom = Nothing
, qtcScheduleRenewal= True
, qtcLmsStatusTxt = Just "Success"
, qtcLmsStatusDay = Just compTime
@ -204,15 +204,14 @@ instance CsvColumnsExplained QualificationTableCsv where
csvColumnsExplanations = genericCsvColumnsExplanations qtcOptions $ Map.fromList
[ ('qtcDisplayName , SomeMessage MsgLmsUser)
, ('qtcEmail , SomeMessage MsgTableLmsEmail)
, ('qtcCompany , SomeMessage MsgTableCompanies)
, ('qtcCompanyNumbers , SomeMessage MsgTableCompanyNos)
, ('qtcCompany , SomeMessage MsgTablePrimeCompany)
, ('qtcValidUntil , SomeMessage MsgLmsQualificationValidUntil)
, ('qtcLastRefresh , SomeMessage MsgTableQualificationLastRefresh)
, ('qtcBlockStatus , SomeMessage MsgInfoQualificationBlockStatus)
, ('qtcBlockFrom , SomeMessage MsgInfoQualificationBlockFrom)
, ('qtcScheduleRenewal, SomeMessage MsgQualificationScheduleRenewalTooltip)
, ('qtcLmsStatusTxt , SomeMessage MsgTableLmsStatus)
, ('qtcLmsStatusDay , SomeMessage MsgTableLmsStatusDay)
, ('qtcLmsStatusDay , SomeMessage MsgTableLmsStatusDay)
]
@ -233,7 +232,7 @@ queryLmsUser = $(sqlLOJproj 3 2)
queryQualBlock :: QualificationTableExpr -> E.SqlExpr (Maybe (Entity QualificationUserBlock))
queryQualBlock = $(sqlLOJproj 3 3)
type QualificationTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), Maybe (Entity QualificationUserBlock), [Entity UserCompany])
type QualificationTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), Maybe (Entity QualificationUserBlock), E.Value (Maybe CompanyId))
resultQualUser :: Lens' QualificationTableData (Entity QualificationUser)
resultQualUser = _dbrOutput . _1
@ -247,8 +246,8 @@ resultLmsUser = _dbrOutput . _3 . _Just
resultQualBlock :: Traversal' QualificationTableData (Entity QualificationUserBlock)
resultQualBlock = _dbrOutput . _4 . _Just
resultCompanyUser :: Lens' QualificationTableData [Entity UserCompany]
resultCompanyUser = _dbrOutput . _5
resultCompanyId :: Traversal' QualificationTableData CompanyId
resultCompanyId = _dbrOutput . _5 . _unValue . _Just
instance HasEntity QualificationTableData User where
@ -267,15 +266,16 @@ instance HasQualificationUser QualificationTableData where
-- hasQualificationUserBlock = resultQualBlock
data QualificationTableAction
= QualificationActExpire
data QualificationTableAction
= QualificationActExpire
| QualificationActUnexpire
| QualificationActBlockSupervisor
| QualificationActBlock
| QualificationActUnblock
| QualificationActRenew
| QualificationActGrant
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
| QualificationActStartELearning
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
instance Universe QualificationTableAction
instance Finite QualificationTableAction
@ -290,15 +290,16 @@ isAdminAct QualificationActBlockSupervisor = False
isAdminAct _ = True
-}
data QualificationTableActionData
= QualificationActExpireData
| QualificationActUnexpireData
data QualificationTableActionData
= QualificationActExpireData
| QualificationActUnexpireData
| QualificationActBlockSupervisorData
| QualificationActBlockData { qualTableActBlockReason :: Text, qualTableActNotify :: Bool, qualTableActRemoveSupervisors :: Bool }
| QualificationActUnblockData { qualTableActBlockReason :: Text, qualTableActNotify :: Bool}
| QualificationActRenewData { qualTableActChangeReason :: Text}
| QualificationActGrantData { qualTableActGrantUntil :: Day }
deriving (Eq, Ord, Show, Generic)
| QualificationActBlockData { qualTableActBlockReason :: Text, qualTableActNotify :: Bool, qualTableActRemoveSupervisors :: Bool }
| QualificationActUnblockData { qualTableActBlockReason :: Text, qualTableActNotify :: Bool }
| QualificationActRenewData { qualTableActChangeReason :: Text }
| QualificationActGrantData { qualTableActGrantUntil :: Day }
| QualificationActStartELearningData -- { qualTableActELearnUntil :: Maybe Day }
deriving (Eq, Ord, Show, Generic)
isExpiryAct :: QualificationTableActionData -> Bool
isExpiryAct QualificationActExpireData = True
@ -333,18 +334,19 @@ qualificationTableQuery :: UTCTime -> QualificationId -> (_ -> E.SqlExpr (E.Valu
, E.SqlExpr (Entity User)
, E.SqlExpr (Maybe (Entity LmsUser))
, E.SqlExpr (Maybe (Entity QualificationUserBlock))
, E.SqlExpr (E.Value (Maybe CompanyId))
)
qualificationTableQuery now qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser `E.LeftOuterJoin` qualBlock) = do
-- E.distinctOnOrderBy will not work: sorting with dbTable should work, except that columns contained in distinctOnOrderBy cannot be sorted inversely by user; but PostgreSQL leftJoin with distinct filters too many results, see SQL Example lead/lag under jost/misc DevOps
--
--
E.on $ qualBlock E.?. QualificationUserBlockQualificationUser E.?=. qualUser E.^. QualificationUserId
E.&&. qualBlock `isLatestBlockBefore` E.val now
E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser
E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work
E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
E.where_ $ fltr qualUser
E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification)
return (qualUser, user, lmsUser, qualBlock)
E.where_ $ fltr qualUser
E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification)
return (qualUser, user, lmsUser, qualBlock, selectCompanyUserPrime user)
mkQualificationTable ::
@ -353,18 +355,20 @@ mkQualificationTable ::
)
=> Bool
-> Entity Qualification
-> Map QualificationTableAction (AForm Handler QualificationTableActionData)
-> (Map CompanyId Company -> cols)
-> Map QualificationTableAction (AForm Handler QualificationTableActionData)
-> ((CompanyId -> CompanyName) -> cols)
-> PSValidator (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData))
-> DB (FormResult (QualificationTableActionData, Set UserId), Widget)
mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
svs <- getSupervisees
now <- liftIO getCurrentTime
-- lookup all companies
cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do
now <- liftIO getCurrentTime
-- lookup all companies
cmpMap <- memcachedBy (Just . Right $ 30 * diffMinute) ("CompanyDictionary"::Text) $ do
cmps <- selectList [] [] -- [Asc CompanyShorthand]
return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps
let
getCompanyName :: CompanyId -> CompanyName
getCompanyName cid = maybe (unCompanyKey cid) companyName $ Map.lookup cid cmpMap -- use shorthand in case of impossible failure
nowaday = utctDay now
mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday
csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName)
@ -373,82 +377,69 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
fltrSvs = if isAdmin then const E.true else \quser -> quser E.^. QualificationUserUser `Ex.in_` E.vals svs
dbtSQLQuery = qualificationTableQuery now qid fltrSvs
dbtRowKey = queryUser >>> (E.^. UserId)
dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, qUsrBlock) -> do
-- cmps <- E.select . E.from $ \(usrComp `E.InnerJoin` comp) -> do
-- E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
-- E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val (entityKey usr)
-- E.orderBy [E.asc (comp E.^. CompanyName)]
-- return (comp E.^. CompanyName, comp E.^. CompanyAvsId, usrComp E.^. UserCompanySupervisor)
cmpUsr <- selectList [UserCompanyUser ==. entityKey usr] [Asc UserCompanyCompany]
return (qualUsr, usr, lmsUsr, qUsrBlock, cmpUsr)
dbtColonnade = cols cmpMap
dbtSorting = mconcat
[ single $ sortUserNameLink queryUser
, single $ sortUserEmail queryUser
, single $ sortUserMatriclenr queryUser
, single ("first-held" , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld))
, single ("last-refresh" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh))
, single ("last-notified" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastNotified))
, single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil))
, single ("blocked" , SortColumnNeverNull $ queryQualBlock >>> (E.?. QualificationUserBlockFrom))
, single ("lms-status-plus",SortColumnNeverNull $ \row -> E.coalesce [ E.joinV (queryLmsUser row E.?. LmsUserStatusDay)
dbtProj = dbtProjId
dbtColonnade = cols getCompanyName
dbtSorting = Map.fromList
[ sortUserNameLink queryUser
, sortUserEmail queryUser
, sortUserMatriclenr queryUser
, ("first-held" , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld))
, ("last-refresh" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh))
, ("last-notified" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastNotified))
, ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil))
, ("blocked" , SortColumnNeverNull $ queryQualBlock >>> (E.?. QualificationUserBlockFrom))
, ("lms-status-plus",SortColumnNullsInv $ \row -> E.coalesce [ E.joinV (queryLmsUser row E.?. LmsUserStatusDay)
, E.joinV (queryLmsUser row E.?. LmsUserNotified)
, queryLmsUser row E.?. LmsUserStarted])
, single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal))
, single ("user-company" , SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
, ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal))
, ("user-company" , SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId
E.orderBy [E.asc (comp E.^. CompanyName)]
return (comp E.^. CompanyName)
)
-- , single ("validity", SortColumn $ queryQualUser >>> validQualification now)
)
-- , ("validity", SortColumn $ queryQualUser >>> validQualification now)
]
dbtFilter = mconcat
[ single $ fltrUserNameEmail queryUser
, single ("avs-number" , FilterColumn . E.mkExistsFilter $ \row criterion ->
E.from $ \usrAvs -> -- do
dbtFilter = Map.fromList
[ fltrUserNameEmail queryUser
, ("avs-number" , FilterColumn . E.mkExistsFilter $ \row criterion ->
E.from $ \usrAvs -> -- do
E.where_ $ usrAvs E.^. UserAvsUser E.==. queryUser row E.^. UserId
E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==.
(E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) ))
, single ("avs-card" , FilterColumn $ \(queryUser -> user) (criterion :: Set.Set Text) -> case readAvsFullCardNo =<< Set.lookupMin criterion of
Nothing -> E.false
Just cardNo -> E.exists $ E.from $ \(avsCard `E.InnerJoin` usrAvs) -> do
E.on $ usrAvs E.^. UserAvsPersonId E.==. avsCard E.^. UserAvsCardPersonId
E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId
E.&&. (avsCard E.^. UserAvsCardCardNo E.==. E.val cardNo)
)
, single ("personal-number", FilterColumn $ \(queryUser -> user) (criteria :: Set.Set Text) -> if
, fltrAVSCardNos queryUser
, ("personal-number", FilterColumn $ \(queryUser -> user) (criteria :: Set.Set Text) -> if
| Set.null criteria -> E.true
| otherwise -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria
)
, single ("user-company", FilterColumn . E.mkExistsFilter $ \row criterion ->
E.from $ \(usrComp `E.InnerJoin` comp) -> do
, ("user-company", FilterColumn . E.mkExistsFilter $ \row criterion ->
E.from $ \(usrComp `E.InnerJoin` comp) -> do
let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf`
(E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text)))
testnumber nr = E.val nr E.==. comp E.^. CompanyAvsId
testcrit = maybe testname testnumber $ readMay $ CI.original criterion
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.&&. testcrit
)
, single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification now))
, single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion ->
)
, ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification now))
, ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion ->
if | Just renewal <- mbRenewal
, Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal
E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday
| otherwise -> E.true
)
, single ("tobe-notified", FilterColumn $ \row criterion ->
, ("tobe-notified", FilterColumn $ \row criterion ->
if | Just True <- getLast criterion -> quserToNotify now (queryQualUser row) (queryQualBlock row)
| otherwise -> E.true
)
, single ("status" , FilterColumn . E.mkExactFilterMaybeLast' (views (to queryLmsUser) (E.?. LmsUserId)) $ views (to queryLmsUser) (E.?. LmsUserStatus))
, ("status" , FilterColumn . E.mkExactFilterMaybeLast' (views (to queryLmsUser) (E.?. LmsUserId)) $ views (to queryLmsUser) (E.?. LmsUserStatus))
]
dbtFilterUI mPrev = mconcat
[ fltrUserNameEmailHdrUI MsgLmsUser mPrev
, prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany)
, prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber)
, prismAForm (singletonFilter "avs-card" ) mPrev $ aopt textField (fslI MsgAvsCardNo)
, prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo)
, fltrAVSCardNosUI mPrev
, prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo)
, prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid)
, if isNothing mbRenewal then mempty
else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal)
@ -470,34 +461,29 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
doEncode' = QualificationTableCsv
<$> view (resultUser . _entityVal . _userDisplayName)
<*> view (resultUser . _entityVal . _userDisplayEmail)
<*> (view resultCompanyUser >>= getCompanies)
<*> (view resultCompanyUser >>= getCompanyNos)
<*> preview (resultCompanyId . to getCompanyName . _CI)
<*> view (resultQualUser . _entityVal . _qualificationUserValidUntil)
<*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh)
<*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh)
<*> preview (resultQualBlock. _entityVal . _qualificationUserBlockUnblock . _not)
<*> preview (resultQualBlock. _entityVal . _qualificationUserBlockFrom)
<*> preview (resultQualBlock. _entityVal . _qualificationUserBlockFrom)
<*> view (resultQualUser . _entityVal . _qualificationUserScheduleRenewal)
<*> getStatusPlusTxt
<*> getStatusPlusDay
getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of
[] -> pure Nothing
somecmps -> pure $ Just $ intercalate ", " $ fmap (view (_companyName . _CI)) somecmps
getCompanyNos = pure . CsvSemicolonList . mapMaybe (preview (_Just . _companyAvsId) . flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany))
getStatusPlusTxt =
(join . preview (resultLmsUser . _entityVal . _lmsUserStatus)) >>= \case
getStatusPlusTxt =
(join . preview (resultLmsUser . _entityVal . _lmsUserStatus)) >>= \case
Just LmsBlocked{} -> return $ Just "Failed"
Just LmsExpired{} -> return $ Just "Expired"
Just LmsSuccess{} -> return $ Just "Success"
Nothing -> maybeM (return Nothing) (const $ return $ Just "Open") $
preview (resultLmsUser . _entityVal . _lmsUserStarted)
getStatusPlusDay =
(join . preview (resultLmsUser . _entityVal . _lmsUserStatusDay)) >>= \case
getStatusPlusDay =
(join . preview (resultLmsUser . _entityVal . _lmsUserStatusDay)) >>= \case
lsd@(Just _) -> return lsd
Nothing -> preview (resultLmsUser . _entityVal . _lmsUserStarted)
dbtCsvDecode = Nothing
dbtExtraReps = []
dbtExtraReps = []
dbtParams = DBParamsForm
{ dbParamsFormMethod = POST
, dbParamsFormAction = Nothing
@ -525,31 +511,32 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
getQualificationR, postQualificationR :: SchoolId -> QualificationShorthand -> Handler Html
getQualificationR = postQualificationR
postQualificationR sid qsh = do
postQualificationR sid qsh = do
isAdmin <- hasReadAccessTo AdminR
msgGrantWarning <- messageIconI Warning IconWarning MsgQualificationActGrantWarning
msgUnexpire <- messageIconI Info IconWarning MsgQualificationActUnexpireWarning
now <- liftIO getCurrentTime
let nowaday = utctDay now
((lmsRes, qualificationTable), Entity qid quali) <- runDB $ do
((lmsRes, qualificationTable), Entity qid quali, lmsQualiReused) <- runDB $ do
qent@Entity{
entityKey=qid
, entityVal=Qualification{
qualificationAuditDuration=auditMonths
, qualificationValidDuration=validMonths
, qualificationLmsReuses =reuseQuali
}} <- getBy404 $ SchoolQualificationShort sid qsh
lmsQualiReused <- traverseJoin get reuseQuali
-- Block copied to Handler/Qualifications TODO: refactor
let getBlockReasons unblk = Ex.select $ do
(quser :& qblock) <- Ex.from $ Ex.table @QualificationUser
let getBlockReasons unblk = Ex.select $ do
(quser :& qblock) <- Ex.from $ Ex.table @QualificationUser
`Ex.innerJoin` Ex.table @QualificationUserBlock
`Ex.on` (\(quser :& qblock) -> quser Ex.^. QualificationUserId Ex.==. qblock Ex.^. QualificationUserBlockQualificationUser)
Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. Ex.val qid
Ex.&&. unblk (qblock Ex.^. QualificationUserBlockUnblock)
Ex.groupBy (qblock Ex.^. QualificationUserBlockReason)
Ex.groupBy (qblock Ex.^. QualificationUserBlockReason)
let countRows' :: Ex.SqlExpr (Ex.Value Int64) = Ex.countRows
Ex.orderBy [Ex.desc countRows']
Ex.limit 7
Ex.limit 9
pure (qblock Ex.^. QualificationUserBlockReason)
mkOption :: Ex.Value Text -> Option Text
mkOption (Ex.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t }
@ -560,64 +547,78 @@ postQualificationR sid qsh = do
acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData)
acts = mconcat $
[ singletonMap QualificationActExpire $ pure QualificationActExpireData
, singletonMap QualificationActUnexpire $ QualificationActUnexpireData
<$ aformMessage msgUnexpire
] ++ bool
, singletonMap QualificationActUnexpire $ QualificationActUnexpireData
<$ aformMessage msgUnexpire
] ++ bool
-- nonAdmin actions, ie. Supervisor
[ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ]
[ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ]
-- Admin-only actions
[ singletonMap QualificationActUnblock $ QualificationActUnblockData
<$> apreq (textField & cfStrip & addDatalist suggestionsUnblock) (fslI MsgQualificationGrantReason) Nothing
<*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False)
, singletonMap QualificationActBlock $ QualificationActBlockData
, singletonMap QualificationActBlock $ QualificationActBlockData
<$> apreq (textField & cfStrip & addDatalist suggestionsBlock) (fslI MsgQualificationBlockReason) Nothing
<*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False)
<*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockRemoveSupervisor) (Just False)
, singletonMap QualificationActRenew $ QualificationActRenewData
<$> apreq (textField & cfStrip & addDatalist suggestionsBlock) (fslI MsgQualificationRenewReason) Nothing
, singletonMap QualificationActGrant $ QualificationActGrantData
, singletonMap QualificationActGrant $ QualificationActGrantData
<$> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry
<* aformMessage msgGrantWarning
, singletonMap QualificationActStartELearning $ pure QualificationActStartELearningData
-- <$> aopt dayField (fslI MsgQualificationReduceValidUntil) Nothing
] isAdmin
linkLmsUser = toMaybe isAdmin (LmsUserR sid qsh)
linkUserName = bool ForProfileR ForProfileDataR isAdmin
colChoices cmpMap = mconcat
linkUserName = bool ForProfileR ForProfileDataR isAdmin
colChoices getCompanyName = mconcat
[ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
, colUserNameModalHdr MsgLmsUser linkUserName
, colUserEmail
, sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) ->
let cs = [ companyCell (unCompanyKey cmpId) cmpName cmpSpr
| Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps
, let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap
]
in intercalate spacerCell cs
, colUserEmail
, sortable (Just "user-company") (i18nCell MsgTablePrimeCompany) $ \(preview resultCompanyId -> mcid) ->
maybeEmpty mcid $ \cid -> companyCell (unCompanyKey cid) (getCompanyName cid) False
, guardMonoid isAdmin $ colUserMatriclenr isAdmin
-- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser)
, sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d
, sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d
, sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d
, sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) (dayCell . view ( resultQualUser . _entityVal . _qualificationUserValidUntil))
, sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ \row ->
, sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ \row ->
qualificationValidReasonCell' (Just $ LmsUserR sid qsh) isAdmin nowaday (row ^? resultQualBlock) row
, sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip
) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification
, sortable (Just "lms-status-plus")(i18nCell MsgTableLmsStatus & cellTooltipWgt Nothing (lmsStatusInfoCell isAdmin auditMonths))
$ \(preview $ resultLmsUser . _entityVal -> lu) -> foldMap (lmsStatusCell isAdmin linkLmsUser) lu
, sortable (Just "last-notified") (i18nCell MsgTableQualificationLastNotified) $ \( view $ resultQualUser . _entityVal . _qualificationUserLastNotified -> d) -> dateTimeCell d
-- QualificationUserLastNotified is about notification on actual validity changes. If a user's licence is about to expire and renewed before expiry via e-learning, this value does not change.
-- NOTE: If this column is reinstatiated, header and tooltip were already updated to avoid any confusion!
-- , sortable (Just "last-notified") (i18nCell MsgTableQualificationLastNotified & cellTooltip MsgTableQualificationLastNotifiedTooltip)
-- $ \( view $ resultQualUser . _entityVal . _qualificationUserLastNotified -> d) -> dateTimeCell d
]
psValidator = def & defaultSorting [SortDescBy "last-refresh"]
tbl <- mkQualificationTable isAdmin qent acts colChoices psValidator
return (tbl, qent)
return (tbl, qent, lmsQualiReused)
formResult lmsRes $ \case
(QualificationActRenewData renewReason, selectedUsers) | isAdmin -> do
noks <- runDB $ renewValidQualificationUsers qid (canonical $ Just $ Left renewReason) Nothing $ Set.toList selectedUsers
noks <- runDB $ renewValidQualificationUsers qid (canonical $ Just $ Left renewReason) Nothing $ Set.toList selectedUsers
addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks
reloadKeepGetParams $ QualificationR sid qsh
(QualificationActGrantData grantValidday, selectedUsers) | isAdmin -> do
(QualificationActGrantData grantValidday, selectedUsers) | isAdmin -> do
runDB . forM_ selectedUsers $ upsertQualificationUser qid now grantValidday Nothing "Admin"
addMessageI (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
reloadKeepGetParams $ QualificationR sid qsh
(action, selectedUsers) | isExpiryAct action -> do
(QualificationActStartELearningData, Set.toList -> selectedUsers) | isAdmin -> do
-- whenIsJust mbExpDay $ \expDay ->
-- when expDay > nowaday $
-- -- updateWhere [QualificationUserQualification ==. qid, QualificationUserUser <-. selectedUsers, QualificationUserValidUntil >. expDay] [QualificationUserValidUntil =. expDay] -- DO NOT USE: no audit
-- NOTE: if needed, create function Handler.Utils.Qualification.updateQualificationUser qid QualificationChangeReason -> Day -> [UserId] -> DB Int
validQualHolderEnts <- runDB $ selectValidQualifications qid selectedUsers now
let validQualHolders = view (_entityVal . _qualificationUserUser) <$> validQualHolderEnts
jobs <- forM validQualHolders $ queueJob . JobLmsEnqueueUser qid
let nrTodo = length selectedUsers
nrEnqueued = length $ catMaybes jobs
addMessageI (bool Warning Success $ nrEnqueued > 0 && nrEnqueued == nrTodo) $ MsgQualificationActStartELearningStatus qsh nrEnqueued nrTodo
-- transaction audit identical to automatic start, performed by JobLmsEnqueueUser
reloadKeepGetParams $ QualificationR sid qsh
(action, selectedUsers) | isExpiryAct action -> do
let isUnexpire = action == QualificationActUnexpireData
upd <- runDB $ do
forM_ selectedUsers $ \uid -> audit TransactionQualificationUserScheduleRenewal
@ -632,18 +633,18 @@ postQualificationR sid qsh = do
msgVal = upd & if isUnexpire then MsgQualificationSetUnexpire else MsgQualificationSetExpire
addMessageI msgKind msgVal
reloadKeepGetParams $ QualificationR sid qsh
(action, selectedUsers) | isBlockAct action && (isAdmin || action == QualificationActBlockSupervisorData) -> do
(action, selectedUsers) | isBlockAct action && (isAdmin || action == QualificationActBlockSupervisorData) -> do
let selUserIds = Set.toList selectedUsers
(unblock, reason) = case action of
QualificationActBlockSupervisorData -> (False, Right QualificationBlockReturnedByCompany)
(unblock, reason) = case action of
QualificationActBlockSupervisorData -> (False, Right QualificationBlockReturnedByCompany)
QualificationActBlockData{..} -> (False, Left qualTableActBlockReason)
QualificationActUnblockData{..} -> (True , Left qualTableActBlockReason)
_ -> error "Handle.Qualification.isBlockAct returned non-block action" -- cannot occur due to earlier checks
notify = case action of
notify = case action of
QualificationActBlockData{qualTableActNotify} -> qualTableActNotify
_ -> False
oks <- runDB $ do
oks <- runDB $ do
when (blockActRemoveSupervisors action) $ deleteWhere [UserSupervisorUser <-. selUserIds]
qualificationUserBlocking qid selUserIds unblock Nothing reason notify
let nrq = length selectedUsers

50
src/Handler/SAP.hs
View File

@ -27,10 +27,10 @@ import qualified Database.Esqueleto.Utils as E
data SapUserTableCsv = SapUserTableCsv -- for csv export only
{ csvSUTpersonalNummer :: Text
{ csvSUTpersonalNummer :: Text
, csvSUTqualifikation :: Text
, csvSUTgültigVon :: Day
, csvSUTgültigBis :: Day
, csvSUTgültigBis :: Day
-- , csvSUTsupendiertBis :: Maybe Day
, csvSUTausprägung :: Text
}
@ -38,7 +38,7 @@ data SapUserTableCsv = SapUserTableCsv -- for csv export only
makeLenses_ ''SapUserTableCsv
sapUserTableCsvHeader :: Csv.Header
sapUserTableCsvHeader = Csv.header
sapUserTableCsvHeader = Csv.header
[ "PersonalNummer"
, "Qualifikation"
, "GültigVon"
@ -51,40 +51,40 @@ instance ToNamedRecord SapUserTableCsv where
toNamedRecord SapUserTableCsv{..} = Csv.namedRecord
[ "PersonalNummer" Csv..= csvSUTpersonalNummer
, "Qualifikation" Csv..= csvSUTqualifikation
, "GültigVon" Csv..= csvSUTgültigVon
, "GültigBis" Csv..= csvSUTgültigBis
, "GültigVon" Csv..= csvSUTgültigVon
, "GültigBis" Csv..= csvSUTgültigBis
-- , "SupendiertBis" Csv..= csvSUTsupendiertBis
, "Ausprägung" Csv..= csvSUTausprägung
, "Ausprägung" Csv..= csvSUTausprägung
]
-- | Removes all personalNummer which are not numbers between 10000 and 99999 (also excludes E-Accounts), which should not be returned by the query anyway (only qualfications with sap id and users with internal personnel number must be transmitted)
-- | Removes all personalNummer which are not numbers between 10000 and 99999 (also excludes E-Accounts), which should not be returned by the query anyway (only qualifications with sap id and users with internal personnel number must be transmitted)
-- temporary suspensions are transmitted to SAP in multiple rows: firstheld->suspension1, reinstate1->suspension2, reinstate2->validTo
sapRes2csv :: [(E.Value (Maybe Text), E.Value (Maybe Text), E.Value Day, E.Value Day, E.Value (Maybe [Maybe Day]), E.Value (Maybe [Maybe Bool]))] -> [SapUserTableCsv]
sapRes2csv = concatMap procRes
where
where
procRes (E.Value pn@(Just persNo), E.Value (Just sapId), E.Value firstHeld, E.Value validUntil, E.Value (fromMaybe [] -> qubFroms), E.Value (fromMaybe [] -> qubUnblocks))
| validFraportPersonalNumber pn -- between 10000 and 99999 also see Handler.Utils.Profile.validFraportPersonalNumber
= let mkSap (dfrom,duntil) = SapUserTableCsv
{ csvSUTpersonalNummer = persNo
, csvSUTqualifikation = sapId
, csvSUTgültigVon = dfrom
, csvSUTgültigBis = duntil
, csvSUTgültigBis = duntil
, csvSUTausprägung = "J"
}
in fmap mkSap $ compileBlocks firstHeld validUntil $ zipMaybes qubFroms qubUnblocks
procRes _ = []
-- | compute a series of valid periods, assume that lists is already sorted by Day
-- the lists encodes qualification_user_blocks with block=False/unblock=True
-- the lists encodes qualification_user_blocks with block=False/unblock=True
compileBlocks :: Day -> Day -> [(Day,Bool)] -> [(Day, Day)]
compileBlocks dStart dEnd = go (dStart, True)
where
compileBlocks dStart dEnd = go (dStart, True)
where
go :: (Day,Bool) -> [(Day,Bool)] -> [(Day, Day)]
go (d,s) (p1@(d1,s1):r1@((d2,s2):r2))
| s1 == s2 && d <= d1 = go (d,s) (p1:r2) -- ignore unnecessary 2nd change
| d1 == d2 || succ d1 == d2 || s == s1 || d > d1 = go (d,s) r1 -- ignore unnecessary 1st change
| s1 == s2 && d <= d1 = go (d,s) (p1:r2) -- ignore unnecessary 2nd change
| d1 == d2 || succ d1 == d2 || s == s1 || d > d1 = go (d,s) r1 -- ignore unnecessary 1st change
go (d,s) ((d1,s1):r1)
| dEnd <= d1 = go (d ,s ) [] -- remaining dates extend validity
| dEnd <= d1 = go (d ,s ) [] -- remaining dates extend validity
| s, not s1, d < d1 = (d,d1) : go (d1,s1) r1 -- valid interval found
| s == s1 = go (d ,s ) r1 -- no change
| otherwise = go (d1,s1) r1 -- ignore invalid interval
@ -95,18 +95,18 @@ compileBlocks dStart dEnd = go (dStart, True)
-- | Deliver all employess with a successful LDAP synch within the last 3 months
getQualificationSAPDirectR :: Handler TypedContent
getQualificationSAPDirectR = do
now <- liftIO getCurrentTime
fdate <- formatTime' "%Y%m%d_%H-%M" now
now <- liftIO getCurrentTime
fdate <- formatTime' "%Y%m%d_%H-%M" now
let ldap_cutoff = addDiffDaysRollOver (fromMonths $ -3) now
qualUsers <- runDB $ E.select $ do
(qual :& qualUser :& user :& qualBlock) <-
E.from $ E.table @Qualification
qualUsers <- runDBRead $ E.select $ do
(qual :& qualUser :& user :& qualBlock) <-
E.from $ E.table @Qualification
`E.innerJoin` E.table @QualificationUser
`E.on` (\(qual :& qualUser) -> qual E.^. QualificationId E.==. qualUser E.^. QualificationUserQualification)
`E.innerJoin` E.table @User
`E.on` (\(_ :& qualUser :& user) -> qualUser E.^. QualificationUserUser E.==. user E.^. UserId)
`E.leftJoin` E.table @QualificationUserBlock
`E.on` (\(_ :& qualUser :& _ :& qualBlock) ->
`E.on` (\(_ :& qualUser :& _ :& qualBlock) ->
qualUser E.^. QualificationUserId E.=?. qualBlock E.?. QualificationUserBlockQualificationUser
E.&&. E.val now E.>~. qualBlock E.?. QualificationUserBlockFrom
)
@ -116,19 +116,19 @@ getQualificationSAPDirectR = do
E.&&. (E.justVal ldap_cutoff E.<=. user E.^. UserLastLdapSynchronisation)
E.groupBy ( user E.^. UserCompanyPersonalNumber
, qualUser E.^. QualificationUserFirstHeld
, qualUser E.^. QualificationUserValidUntil
, qualUser E.^. QualificationUserValidUntil
, qual E.^. QualificationSapId
)
let blockOrder = [E.asc $ qualBlock E.?. QualificationUserBlockFrom, E.asc $ qualBlock E.?. QualificationUserBlockId]
-- blockAgg f = E.arrayAggWith E.AggModeAll (qualBlock E.^. f) blockOrder
return
return
( user E.^. UserCompanyPersonalNumber
, qual E.^. QualificationSapId
, qualUser E.^. QualificationUserFirstHeld
, qualUser E.^. QualificationUserValidUntil
, E.arrayAggWith E.AggModeAll (E.dayMaybe $ qualBlock E.?. QualificationUserBlockFrom ) blockOrder
, E.arrayAggWith E.AggModeAll ( qualBlock E.?. QualificationUserBlockUnblock) blockOrder
)
)
let csvRendered = toCsvRendered sapUserTableCsvHeader $ sapRes2csv qualUsers
fmtOpts = (review csvPreset CsvPresetRFC)
{ csvIncludeHeader = True
@ -144,7 +144,7 @@ getQualificationSAPDirectR = do
let logInt = runDB $ logInterface "SAP" quals True (Just nr) ""
addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\""
csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered <* logInt
-- direct Download see:
-- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod

403
src/Handler/School/DayTasks.hs Normal file
View File

@ -0,0 +1,403 @@
-- SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} -- TODO during development only
{-# OPTIONS_GHC -fno-warn-unused-imports #-} -- TODO during development only
module Handler.School.DayTasks
( getSchoolDayR, postSchoolDayR
) where
import Import
import Handler.Utils
import Handler.Utils.Company
import Handler.Utils.Occurrences
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.Aeson as Aeson
import qualified Data.Text as Text
-- import Database.Persist.Sql (updateWhereCount)
import Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Experimental as E
import qualified Database.Esqueleto.PostgreSQL as E
import qualified Database.Esqueleto.Legacy as EL (on, from) -- only `on` and `from` are different, needed for dbTable using Esqueleto.Legacy
import qualified Database.Esqueleto.Utils as E
import Database.Esqueleto.PostgreSQL.JSON ((@>.))
import qualified Database.Esqueleto.PostgreSQL.JSON as E hiding ((?.))
import Database.Esqueleto.Utils.TH
data DailyTableAction = DailyActDummy -- just a dummy, since we don't now yet which actions we will be needing
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
instance Universe DailyTableAction
instance Finite DailyTableAction
nullaryPathPiece ''DailyTableAction $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''DailyTableAction id
data DailyTableActionData = DailyActDummyData
deriving (Eq, Ord, Read, Show, Generic)
-- | partial JSON object to be used for filtering with "@>"
-- ensure that a GIN index for the jsonb column is created in Model.Migration.Definitions
occurrenceDayValue :: Day -> Value
occurrenceDayValue d = Aeson.object
[ "exceptions" Aeson..=
[ Aeson.object
[ "exception" Aeson..= ("occur"::Text)
, "day" Aeson..= d
] ] ]
{- More efficient DB-only version, but ignores regular schedules
getDayTutorials :: SchoolId -> Day -> DB [TutorialId]
getDayTutorials ssh d = E.unValue <<$>> E.select (do
(trm :& crs :& tut) <- E.from $ E.table @Term
`E.innerJoin` E.table @Course `E.on` (\(trm :& crs) -> crs E.^. CourseTerm E.==. trm E.^. TermId)
`E.innerJoin` E.table @Tutorial `E.on` (\(_ :& crs :& tut) -> crs E.^. CourseId E.==. tut E.^. TutorialCourse)
E.where_ $ E.between (E.val d) (trm E.^. TermStart, trm E.^. TermEnd)
E.&&. crs E.^. CourseSchool E.==. E.val ssh
E.&&. (E.just (tut E.^. TutorialTime) @>. E.jsonbVal (occurrenceDayValue d))
return $ tut E.^. TutorialId
)
-}
-- Datatype to be used for memcaching occurrences
data OccurrenceCacheKey = OccurrenceCacheKeyTutorials SchoolId (Day,Day)
deriving (Eq, Ord, Read, Show, Generic)
deriving anyclass (Hashable, Binary)
getDayTutorials :: SchoolId -> (Day,Day) -> DB [TutorialId]
getDayTutorials ssh dlimit@(dstart, dend )
| dstart > dend = return mempty
| otherwise = memcachedByClass MemcachedKeyClassTutorialOccurrences (Just . Right $ 12 * diffDay) (OccurrenceCacheKeyTutorials ssh dlimit) $ do
candidates <- E.select $ do
(trm :& crs :& tut) <- E.from $ E.table @Term
`E.innerJoin` E.table @Course `E.on` (\(trm :& crs) -> crs E.^. CourseTerm E.==. trm E.^. TermId)
`E.innerJoin` E.table @Tutorial `E.on` (\(_ :& crs :& tut) -> crs E.^. CourseId E.==. tut E.^. TutorialCourse)
E.where_ $ crs E.^. CourseSchool E.==. E.val ssh
E.&&. trm E.^. TermStart E.<=. E.val dend
E.&&. trm E.^. TermEnd E.>=. E.val dstart
return (trm, tut, E.just (tut E.^. TutorialTime) @>. E.jsonbVal (occurrenceDayValue dstart))
-- logErrorS "DAILY" $ foldMap (\(Entity{entityVal=someTerm},Entity{entityVal=Tutorial{..}},_) -> tshow someTerm <> " *** " <> ciOriginal tutorialName <> ": " <> tshow (unJSONB tutorialTime)) candidates
return $ mapMaybe checkCandidate candidates
where
period = Set.fromAscList [dstart..dend]
checkCandidate (_, Entity{entityKey=tutId}, E.unValue -> True) = Just tutId -- most common case
checkCandidate (Entity{entityVal=trm}, Entity{entityKey=tutId, entityVal=Tutorial{tutorialTime=JSONB occ}}, _)
| not $ Set.null $ Set.intersection period $ occurrencesCompute' trm occ
= Just tutId
| otherwise
= Nothing
-- Datatype to be used for memcaching occurrences
data LessonCacheKey = LessonCacheKeyTutorials SchoolId (Day,Day)
deriving (Eq, Ord, Read, Show, Generic)
deriving anyclass (Hashable, Binary)
-- | like getDayTutorials, but also returns the lessons occurring within the given time frame
getDayTutorials' :: SchoolId -> (Day,Day) -> DB (Map TutorialId [LessonTime])
getDayTutorials' ssh dlimit@(dstart, dend )
| dstart > dend = return mempty
| otherwise = memcachedByClass MemcachedKeyClassTutorialOccurrences (Just . Right $ 12 * diffDay) (LessonCacheKeyTutorials ssh dlimit) $ do
candidates <- E.select $ do
(trm :& crs :& tut) <- E.from $ E.table @Term
`E.innerJoin` E.table @Course `E.on` (\(trm :& crs) -> crs E.^. CourseTerm E.==. trm E.^. TermId)
`E.innerJoin` E.table @Tutorial `E.on` (\(_ :& crs :& tut) -> crs E.^. CourseId E.==. tut E.^. TutorialCourse)
E.where_ $ crs E.^. CourseSchool E.==. E.val ssh
E.&&. trm E.^. TermStart E.<=. E.val dend
E.&&. trm E.^. TermEnd E.>=. E.val dstart
return (trm, tut)
-- logErrorS "DAILY" $ foldMap (\(Entity{entityVal=someTerm},Entity{entityVal=Tutorial{..}},_) -> tshow someTerm <> " *** " <> ciOriginal tutorialName <> ": " <> tshow (unJSONB tutorialTime)) candidates
return $ foldMap checkCandidate candidates
where
checkCandidate :: (Entity Term, Entity Tutorial) -> Map TutorialId [LessonTime]
checkCandidate (Entity{entityVal=trm}, Entity{entityKey=tutId, entityVal=Tutorial{tutorialTime=JSONB occ}})
| let lessons = Set.filter lessonFltr $ occurringLessons trm occ
, notNull lessons
= Map.singleton tutId $ Set.toAscList lessons -- due to Set not having a Functor instance, we need mostly need lists anyway
| otherwise
= mempty
lessonFltr :: LessonTime -> Bool
lessonFltr LessonTime{..} = dstart <= localDay lessonStart
&& dend >= localDay lessonEnd
type DailyTableExpr =
( E.SqlExpr (Entity Course)
`E.InnerJoin` E.SqlExpr (Entity Tutorial)
`E.InnerJoin` E.SqlExpr (Entity TutorialParticipant)
`E.InnerJoin` E.SqlExpr (Entity User)
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity UserAvs))
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity UserDay))
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity TutorialParticipantDay))
)
type DailyTableOutput = E.SqlQuery
( E.SqlExpr (Entity Course)
, E.SqlExpr (Entity Tutorial)
, E.SqlExpr (Entity TutorialParticipant)
, E.SqlExpr (Entity User)
, E.SqlExpr (Maybe (Entity UserAvs))
, E.SqlExpr (Maybe (Entity UserDay))
, E.SqlExpr (Maybe (Entity TutorialParticipantDay))
, E.SqlExpr (E.Value (Maybe CompanyId))
, E.SqlExpr (E.Value (Maybe [QualificationId]))
)
type DailyTableData = DBRow
( Entity Course
, Entity Tutorial
, Entity TutorialParticipant
, Entity User
, Maybe (Entity UserAvs)
, Maybe (Entity UserDay)
, Maybe (Entity TutorialParticipantDay)
, E.Value (Maybe CompanyId)
, E.Value (Maybe [QualificationId])
)
-- force declarations before this point to avoid staging restrictions
$(return [])
queryCourse :: DailyTableExpr -> E.SqlExpr (Entity Course)
queryCourse = $(sqlMIXproj' ''DailyTableExpr 1)
queryTutorial :: DailyTableExpr -> E.SqlExpr (Entity Tutorial)
queryTutorial = $(sqlMIXproj' ''DailyTableExpr 2)
queryParticipant :: DailyTableExpr -> E.SqlExpr (Entity TutorialParticipant)
queryParticipant = $(sqlMIXproj' ''DailyTableExpr 3) -- TODO reify seems problematic for now
-- queryParticipant = $(sqlMIXproj DAILY_TABLE_JOIN 3)
queryUser :: DailyTableExpr -> E.SqlExpr (Entity User)
queryUser = $(sqlMIXproj' ''DailyTableExpr 4)
queryUserAvs :: DailyTableExpr -> E.SqlExpr (Maybe (Entity UserAvs))
queryUserAvs = $(sqlMIXproj' ''DailyTableExpr 5)
queryUserDay :: DailyTableExpr -> E.SqlExpr (Maybe (Entity UserDay))
queryUserDay = $(sqlMIXproj' ''DailyTableExpr 6)
queryParticipantDay :: DailyTableExpr -> E.SqlExpr (Maybe (Entity TutorialParticipantDay))
queryParticipantDay = $(sqlMIXproj' ''DailyTableExpr 7)
resultCourse :: Lens' DailyTableData (Entity Course)
resultCourse = _dbrOutput . _1
resultTutorial :: Lens' DailyTableData (Entity Tutorial)
resultTutorial = _dbrOutput . _2
resultParticipant :: Lens' DailyTableData (Entity TutorialParticipant)
resultParticipant = _dbrOutput . _3
resultUser :: Lens' DailyTableData (Entity User)
resultUser = _dbrOutput . _4
resultUserAvs :: Traversal' DailyTableData UserAvs
resultUserAvs = _dbrOutput . _5 . _Just . _entityVal
resultUserDay :: Traversal' DailyTableData UserDay
resultUserDay = _dbrOutput . _6 . _Just . _entityVal
resultParticipantDay :: Traversal' DailyTableData TutorialParticipantDay
resultParticipantDay = _dbrOutput . _7 . _Just . _entityVal
resultCompanyId :: Traversal' DailyTableData CompanyId
resultCompanyId = _dbrOutput . _8 . _unValue . _Just
resultCourseQualis :: Traversal' DailyTableData [QualificationId]
resultCourseQualis = _dbrOutput . _9 . _unValue . _Just
instance HasEntity DailyTableData User where
hasEntity = resultUser
instance HasUser DailyTableData where
hasUser = resultUser . _entityVal
-- see colRatedField' for an example of formCell usage
drivingPermitField :: (RenderMessage (HandlerSite m) FormMessage, MonadHandler m, HandlerSite m ~ UniWorX) => Field m UserDrivingPermit
drivingPermitField = selectField' Nothing optionsFinite
-- eyeExamField :: Field (HandlerFor UniWorX) UserEyeExam
-- eyeExamField = selectField optionsFinite
-- This does not type:
-- colParticipantPermitField :: ASetter' a (Maybe UserDrivingPermit) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData)))
-- colParticipantPermitField l = sortable (Just "permit") (i18nCell MsgTutorialNote) $ formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table
-- (views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result
-- (\(view (resultParticipant . _entityVal . _tutorialParticipantDrivingPermit) -> x) mkUnique ->
-- over (_1.mapped) (l .~) . over _2 fvWidget <$> mopt drivingPermitField (fsUniq mkUnique "permit") $ Just x
-- ) -- Given the row data and a callback to make an input name suitably unique generate the MForm
-- colEyeExamField :: TODO
colParticipantNoteField :: ASetter' a (Maybe Text) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData)))
colParticipantNoteField l = sortable (Just "note-participant") (i18nCell MsgTutorialNote) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table
(views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result
(\(view (resultParticipant . _entityVal . _tutorialParticipantNote) -> note) mkUnique ->
over (_1.mapped) ((l .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$>
mopt textareaField (fsUniq mkUnique "note-participant") (Just $ Textarea <$> note)
) -- Given the row data and a callback to make an input name suitably unique generate the MForm
colAttendanceField :: Text -> ASetter' a Bool -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData)))
colAttendanceField dday l = sortable (Just "attendance") (i18nCell $ MsgTutorialDayAttendance dday) $ formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table
(views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result
(\(preview (resultParticipantDay . _tutorialParticipantDayAttendance) -> attendance) mkUnique ->
over (_1.mapped) (l .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "attendance") attendance
) -- Given the row data and a callback to make an input name suitably unique generate the MForm
colAttendnaceNoteField :: Text -> ASetter' a (Maybe Text) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData)))
colAttendnaceNoteField dday l = sortable (Just "note-attendance") (i18nCell $ MsgTutorialDayNote dday) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table
(views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result
(\(preview (resultParticipantDay . _tutorialParticipantDayNote) -> note) mkUnique ->
over (_1.mapped) ((l .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$>
mopt textareaField (fsUniq mkUnique "note-attendance") (Textarea <<$>> note)
) -- Given the row data and a callback to make an input name suitably unique generate the MForm
colParkingField :: ASetter' a Bool -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData)))
colParkingField l = sortable (Just "parking") (i18nCell MsgTableUserParkingToken) $ formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table
(views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result
(\(preview (resultUserDay . _userDayParkingToken) -> parking) mkUnique ->
over (_1.mapped) (l .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "parktoken") parking
) -- Given the row data and a callback to make an input name suitably unique generate the MForm
mkDailyTable :: Bool -> SchoolId -> Day -> DB (FormResult (DailyTableActionData, Set TutorialId), Widget)
mkDailyTable isAdmin ssh nd = do
tutLessons <- getDayTutorials' ssh (nd,nd)
dday <- formatTime SelFormatDate nd
let
tutIds = Map.keys tutLessons
dbtSQLQuery :: DailyTableExpr -> DailyTableOutput
dbtSQLQuery (crs `E.InnerJoin` tut `E.InnerJoin` tpu `E.InnerJoin` usr `E.LeftOuterJoin` avs `E.LeftOuterJoin` udy `E.LeftOuterJoin` tdy) = do
EL.on $ tut E.^. TutorialId E.=?. tdy E.?. TutorialParticipantDayTutorial
E.&&. usr E.^. UserId E.=?. tdy E.?. TutorialParticipantDayUser
E.&&. E.val nd E.=?. tdy E.?. TutorialParticipantDayDay
EL.on $ usr E.^. UserId E.=?. udy E.?. UserDayUser
E.&&. E.val nd E.=?. udy E.?. UserDayDay
EL.on $ usr E.^. UserId E.=?. avs E.?. UserAvsUser
EL.on $ usr E.^. UserId E.==. tpu E.^. TutorialParticipantUser
EL.on $ tut E.^. TutorialId E.==. tpu E.^. TutorialParticipantTutorial
EL.on $ tut E.^. TutorialCourse E.==. crs E.^. CourseId
E.where_ $ tut E.^. TutorialId `E.in_` E.valList tutIds
let associatedQualifications = E.subSelectMaybe . EL.from $ \cq -> do
E.where_ $ cq E.^. CourseQualificationCourse E.==. crs E.^. CourseId
let cqQual = cq E.^. CourseQualificationQualification
cqOrder = [E.asc $ cq E.^. CourseQualificationSortOrder, E.asc cqQual]
return $ E.arrayAggWith E.AggModeAll cqQual cqOrder
return (crs, tut, tpu, usr, avs, udy, tdy, selectCompanyUserPrime usr, associatedQualifications)
dbtRowKey = queryParticipant >>> (E.^. TutorialParticipantId)
dbtProj = dbtProjId
dbtColonnade = mconcat
[ -- dbSelect (applying _2) id (return . view (resultTutorial . _entityKey))
sortable (Just "course") (i18nCell MsgFilterCourse) $ \(view $ resultCourse . _entityVal -> c) -> courseCell c
, sortable (Just "tutorial") (i18nCell MsgCourseTutorial) $ \row ->
let Course{courseTerm=tid, courseSchool=cssh, courseShorthand=csh}
= row ^. resultCourse . _entityVal
tutName = row ^. resultTutorial . _entityVal . _tutorialName
in anchorCell (CTutorialR tid cssh csh tutName TUsersR) $ citext2widget tutName
, sortable Nothing (i18nCell MsgTableTutorialOccurrence) $ \(view $ resultTutorial . _entityKey -> tutId) -> cellMaybe (lessonTimesCell False) $ Map.lookup tutId tutLessons
, sortable Nothing (i18nCell MsgTableTutorialRoom) $ \(view $ resultTutorial . _entityKey -> tutId) ->
-- listInlineCell (nubOrd . concat $ mapMM lessonRoom $ Map.lookup tutId tutLessons) roomReferenceCell
cellMaybe ((`listInlineCell` roomReferenceCell) . nubOrd) $ mapMM lessonRoom $ Map.lookup tutId tutLessons
-- , sortable Nothing (i18nCell MsgTableTutorialRoom) $ \(view $ resultTutorial . _entityKey -> _) -> listCell ["A","D","C","B"] textCell -- DEMO: listCell reverses the order, for list-types! listInlineCell is fixed now
, sortable Nothing (i18nCell $ MsgCourseQualifications 3) $ \(preview resultCourseQualis -> cqs) -> maybeCell cqs $ flip listInlineCell qualificationIdShortCell
, sortable (Just "user-company") (i18nCell MsgTablePrimeCompany) $ \(preview resultCompanyId -> mcid) -> cellMaybe companyIdCell mcid
, sortable (Just "booking-company") (i18nCell MsgTableBookingCompany) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantCompany -> mcid) -> cellMaybe companyIdCell mcid
, colUserNameModalHdr MsgCourseParticipant ForProfileDataR
, colUserMatriclenr isAdmin
, sortable (Just "card-no") (i18nCell MsgAvsCardNo) $ \(preview $ resultUserAvs . _userAvsLastCardNo . _Just -> cn :: Maybe AvsFullCardNo) -> cellMaybe (textCell . tshowAvsFullCardNo) cn
, sortable (Just "permit") (i18nCell MsgTutorialDrivingPermit) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantDrivingPermit -> x) -> x & cellMaybe i18nCell
, sortable (Just "eye-exam") (i18nCell MsgTutorialEyeExam) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantEyeExam -> x) -> x & cellMaybe i18nCell
, sortable (Just "note-tutorial") (i18nCell MsgTutorialNote) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantNote -> x) -> x & cellMaybe textCell
, sortable (Just "attendance") (i18nCell $ MsgTutorialDayAttendance dday) $ \(preview $ resultParticipantDay . _tutorialParticipantDayAttendance -> x) -> x & cellMaybe tickmarkCell
, sortable (Just "note-attend") (i18nCell $ MsgTutorialDayNote dday) $ \(preview $ resultParticipantDay . _tutorialParticipantDayNote . _Just -> x) -> x & cellMaybe textCell
, sortable (Just "parking") (i18nCell MsgTableUserParkingToken) $ \(preview $ resultUserDay . _userDayParkingToken -> x) -> maybeCell x tickmarkCell
-- , colParkingField id
]
dbtSorting = Map.fromList
[ sortUserNameLink queryUser
, sortUserMatriclenr queryUser
, ("course" , SortColumn $ queryCourse >>> (E.^. CourseName))
, ("tutorial" , SortColumn $ queryTutorial >>> (E.^. TutorialName))
, ("user-company" , SortColumn $ queryUser >>> selectCompanyUserPrime)
, ("booking-company", SortColumn $ queryParticipant >>> (E.^. TutorialParticipantCompany))
, ("card-no" , SortColumn $ queryUserAvs >>> (E.?. UserAvsLastCardNo))
, ("permit" , SortColumnNullsInv $ queryParticipant >>> (E.^. TutorialParticipantDrivingPermit))
, ("eye-exam" , SortColumnNullsInv $ queryParticipant >>> (E.^. TutorialParticipantEyeExam))
, ("note-tutorial" , SortColumn $ queryParticipant >>> (E.^. TutorialParticipantNote))
, ("attendance" , SortColumnNullsInv $ queryParticipantDay >>> (E.?. TutorialParticipantDayAttendance))
, ("note-attend" , SortColumn $ queryParticipantDay >>> (E.?. TutorialParticipantDayNote))
, ("parking" , SortColumnNullsInv $ queryUserDay >>> (E.?. UserDayParkingToken))
]
dbtFilter = Map.fromList
[ fltrUserNameEmail queryUser
, fltrUserMatriclenr queryUser
, ("course" , FilterColumn . E.mkContainsFilter $ queryCourse >>> (E.^. CourseName))
, ("tutorial" , FilterColumn . E.mkContainsFilter $ queryTutorial >>> (E.^. TutorialName))
, ("user-company" , FilterColumn . E.mkContainsFilter $ queryUser >>> selectCompanyUserPrime)
]
dbtFilterUI mPrev = mconcat
[ prismAForm (singletonFilter "course" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgFilterCourse)
, prismAForm (singletonFilter "tutorial" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgCourseTutorial)
, prismAForm (singletonFilter "user-company" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTablePrimeCompany)
, fltrUserNameEmailUI mPrev
, fltrUserMatriclenrUI mPrev
]
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout}
dbtIdent :: Text
dbtIdent = "daily"
dbtCsvEncode = noCsvEncode
dbtCsvDecode = Nothing
dbtExtraReps = []
dbtParams = DBParamsForm
{ dbParamsFormMethod = POST
, dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute
, dbParamsFormAttrs = []
, dbParamsFormSubmit = FormNoSubmit
, dbParamsFormAdditional = \_csrf -> return (FormMissing, mempty)
-- , dbParamsFormSubmit = FormSubmit
-- , dbParamsFormAdditional
-- = let acts :: Map MCTableAction (AForm Handler MCTableActionData)
-- acts = mconcat
-- [ singletonMap MCActDummy $ pure MCActDummyData
-- ]
-- in renderAForm FormStandard
-- $ (, mempty) . First . Just
-- <$> multiActionA acts (fslI MsgTableAction) Nothing
, dbParamsFormEvaluate = liftHandler . runFormPost
, dbParamsFormResult = id
, dbParamsFormIdent = def
}
postprocess :: FormResult (First DailyTableActionData, DBFormResult TutorialId Bool DailyTableData)
-> FormResult ( DailyTableActionData, Set TutorialId)
postprocess inp = do
(First (Just act), jobMap) <- inp
let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap
return (act, jobSet)
psValidator = def & defaultSorting [SortAscBy "user-name", SortAscBy "course", SortAscBy "tutorial"]
over _1 postprocess <$> dbTable psValidator DBTable{..}
getSchoolDayR, postSchoolDayR :: SchoolId -> Day -> Handler Html
getSchoolDayR = postSchoolDayR
postSchoolDayR ssh nd = do
isAdmin <- hasReadAccessTo AdminR
dday <- formatTime SelFormatDate nd
(_,tableDaily) <- runDB $ mkDailyTable isAdmin ssh nd
siteLayoutMsg (MsgMenuSchoolDay ssh dday) $ do
setTitleI (MsgMenuSchoolDay ssh dday)
[whamlet|TODO Overview School #{ciOriginal (unSchoolKey ssh)}
^{tableDaily}
|]

4
src/Handler/Sheet/Download.hs
View File

@ -66,7 +66,7 @@ getSArchiveR tid ssh csh shn = do
| otherwise = f & _FileReference . _1 . _fileReferenceTitle %~ (unpack (mr $ SheetArchiveFileTypeDirectory (sft f)) <//>)
sftDirectories <- if
| not multipleSFTs -> return mempty
| otherwise -> runDB . fmap (mapMaybe $ \(sft, mTime) -> (sft, ) <$> mTime) . forM allowedSFTs $ \sft -> fmap ((sft, ) . (=<<) E.unValue) . E.selectMaybe . E.from $ \(sFile `E.FullOuterJoin` psFile) -> do
| otherwise -> runDB . fmap (mapMaybe $ \(sft, mTime) -> (sft, ) <$> mTime) . forM allowedSFTs $ \sft -> fmap ((sft, ) . (=<<) E.unValue) . E.selectOne . E.from $ \(sFile `E.FullOuterJoin` psFile) -> do
E.on $ sFile E.?. SheetFileSheet E.==. psFile E.?. PersonalisedSheetFileSheet
E.&&. sFile E.?. SheetFileType E.==. psFile E.?. PersonalisedSheetFileType
E.&&. sFile E.?. SheetFileTitle E.==. psFile E.?. PersonalisedSheetFileTitle
@ -78,7 +78,7 @@ getSArchiveR tid ssh csh shn = do
[ sFile E.?. SheetFileModified
, psFile E.?. PersonalisedSheetFileModified
]
serveZipArchive archiveName $ do
forM_ sftDirectories $ \(sft, mTime) -> yield . Left $ SheetFile
{ sheetFileType = sft

2
src/Handler/Sheet/Show.hs
View File

@ -128,7 +128,7 @@ getSShowR tid ssh csh shn = do
[ wouldHaveWriteAccessToIff [(AuthExamRegistered, True)] $ CSheetR tid ssh csh shn SubmissionNewR
, wouldHaveReadAccessToIff [(AuthExamRegistered, True)] $ CSheetR tid ssh csh shn SArchiveR
]
mRequiredExam <- fmap join . for (guardOnM checkExamRegistration $ sheetRequireExamRegistration sheet) $ \eId -> fmap (fmap $(E.unValueN 4)) . runDB . E.selectMaybe . E.from $ \(exam `E.InnerJoin` course) -> do
mRequiredExam <- fmap join . for (guardOnM checkExamRegistration $ sheetRequireExamRegistration sheet) $ \eId -> fmap (fmap $(E.unValueN 4)) . runDB . E.selectOne . E.from $ \(exam `E.InnerJoin` course) -> do
E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId
E.where_ $ exam E.^. ExamId E.==. E.val eId
return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand, exam E.^. ExamName)

22
src/Handler/Submission/List.hs
View File

@ -48,14 +48,14 @@ import Data.List (genericLength)
import qualified Data.Csv as Csv
{-# ANN module ("HLint: ignore Functor law" :: String) #-}
data CorrectionTableFilterProj = CorrectionTableFilterProj
{ corrProjFilterSubmission :: Maybe (Set [CI Char])
, corrProjFilterPseudonym :: Maybe (Set [CI Char])
, corrProjFilterAuthorshipStatementState :: Last AuthorshipStatementSubmissionState
}
instance Default CorrectionTableFilterProj where
def = CorrectionTableFilterProj
{ corrProjFilterSubmission = Nothing
@ -64,7 +64,7 @@ instance Default CorrectionTableFilterProj where
}
makeLenses_ ''CorrectionTableFilterProj
type CorrectionTableExpr = ( E.SqlExpr (Entity Course)
`E.InnerJoin` E.SqlExpr (Entity Sheet)
@ -135,7 +135,7 @@ resultSubmittors = _dbrOutput . _6 . itraversed
resultUserUser :: Lens' CorrectionTableUserData User
resultUserUser = _1
resultUserPseudonym :: Traversal' CorrectionTableUserData Pseudonym
resultUserPseudonym = _2 . _Just
@ -207,7 +207,7 @@ instance Csv.ToNamedRecord CorrectionTableCsv where
, "rating-points" Csv..= csvCorrectionRatingPoints
, "rating-comment" Csv..= csvCorrectionRatingComment
]
where
where
mkEmpty = \case
[Nothing] -> []
x -> x
@ -269,7 +269,7 @@ data CorrectionTableCsvQualification
= CorrectionTableCsvNoQualification
| CorrectionTableCsvQualifySheet
| CorrectionTableCsvQualifyCourse
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
deriving anyclass (Universe, Finite)
correctionTableCsvHeader :: Bool -- ^ @showCorrector@
@ -402,7 +402,7 @@ colSubmissionLink = sortable (Just "submission") (i18nCell MsgTableSubmission) $
colSelect :: forall act h epId. (Semigroup act, Monoid act, Headedness h, Ord epId) => Colonnade h CorrectionTableData (DBCell _ (FormResult (act, DBFormResult CryptoFileNameSubmission Bool CorrectionTableData), SheetTypeSummary epId))
colSelect = dbSelect (_1 . applying _2) id $ views resultCryptoID return
colSubmittors :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \x ->
let tid = x ^. resultCourseTerm
@ -457,7 +457,7 @@ colRating' l = sortable (Just "rating") (i18nCell MsgTableRating) $ \x ->
]
colAssigned :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
colAssigned = sortable (Just "assignedtime") (i18nCell MsgAssignedTime) $ \x -> maybeCell (x ^? resultSubmission . _entityVal . _submissionRatingAssigned . _Just) dateTimeCell
colAssigned = sortable (Just "assignedtime") (i18nCell MsgAssignedTime) $ \x -> maybeCell (x ^? resultSubmission . _entityVal . _submissionRatingAssigned . _Just) dateTimeCell
colRated :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
colRated = sortable (Just "ratingtime") (i18nCell MsgTableRatingTime) $ \x -> maybeCell (x ^? resultSubmission . _entityVal . _submissionRatingTime . _Just) dateTimeCell
@ -515,7 +515,7 @@ colAuthorshipStatementState = sortable (Just "as-state") (i18nCell MsgSubmission
csh = x ^. resultCourseShorthand
shn = x ^. resultSheet . _entityVal . _sheetName
cID = x ^. resultCryptoID
asRoute = CSubmissionR tid ssh csh shn cID SubAuthorshipStatementsR
in maybeCell (guardOnM (x ^. resultNonAnonymousAccess) $ x ^. resultASState) (\s -> heatC s $ anchorCell asRoute (i18n s :: Widget))
@ -537,7 +537,7 @@ filterUIIsRated = flip (prismAForm $ singletonFilter "israted" . maybePrism _Pat
filterUISubmission :: DBFilterUI
filterUISubmission = flip (prismAForm $ singletonFilter "submission") $ aopt (lift `hoistField` textField) (fslI MsgTableSubmission)
filterUIPseudonym :: DBFilterUI
filterUIPseudonym = flip (prismAForm $ singletonFilter "pseudonym") $ aopt (lift `hoistField` textField) (fslI MsgSubmissionPseudonym)
@ -809,7 +809,7 @@ correctionsR whereClause displayColumns dbtFilterUI csvSettings psValidator acti
fmap toTypedContent . defaultLayout $ do
setTitleI MsgCourseCorrectionsTitle
$(widgetFile "corrections")
correctionsR' :: CorrectionTableWhere -> _ -> _ -> Maybe CorrectionTableCsvSettings -> _ -> Map ActionCorrections (AForm (HandlerFor UniWorX) ActionCorrectionsData) -> Handler (Widget, SheetTypeSummary SqlBackendKey)
correctionsR' whereClause displayColumns dbtFilterUI csvSettings psValidator actions = do
currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler

13
src/Handler/Term.hs
View File

@ -29,7 +29,7 @@ import qualified Control.Monad.State.Class as State
validateTerm :: (MonadHandler m, HandlerSite m ~ UniWorX)
=> FormValidator TermForm m ()
validateTerm = do
TermForm{..} <- State.get
TermForm{..} <- State.get
guardValidation MsgTermEndMustBeAfterStart $ tfStart < tfEnd
guardValidation MsgTermLectureEndMustBeAfterStart $ tfLectureStart < tfLectureEnd
guardValidation MsgTermStartMustBeBeforeLectureStart $ tfStart <= tfLectureStart
@ -87,7 +87,7 @@ getTermShowR = do
$of Left singleHoliday
^{formatTimeW SelFormatDate singleHoliday}
$of Right (startD, endD)
^{formatTimeRangeW SelFormatDate startD (Just endD)}
^{formatTimeRangeW SelFormatDate startD (Just endD)}
|]
]
dbtSorting = Map.fromList
@ -150,11 +150,11 @@ postTermEditR = do
Set.unions $ bankHolidaysAreaSet Fraport <$> [getYear tStart..getYear tEnd]
in mempty
{ tftName = Just ntid
, tftStart = Just tStart
, tftEnd = Just tEnd
, tftStart = Just tStart
, tftEnd = Just tEnd
, tftLectureStart = Just tLecStart
, tftLectureEnd = Just tLecEnd
, tftHolidays = Just tHolys
, tftHolidays = Just tHolys
}
termEditHandler Nothing template
@ -201,6 +201,7 @@ termEditHandler mtid template = do
, termActiveFor = tafFor
}
lift . audit $ TransactionTermEdit tid
memcachedFlushClass MemcachedKeyClassTutorialOccurrences
addMessageI Success $ MsgTermEdited tid
redirect TermShowR
FormMissing -> return ()
@ -332,7 +333,7 @@ newTermForm mtid template = validateForm validateTerm $ \html -> do
(fromRes, fromView) <- mpreq utcTimeField ("" & addName (mkUnique "from")) Nothing
(toRes, toView) <- mopt utcTimeField ("" & addName (mkUnique "to")) Nothing
(forRes, forView) <- mopt (checkMap (first $ const MsgTermFormActiveUserNotFound) Right $ userField False Nothing) ("" & addName (mkUnique "for") & addPlaceholder (mr MsgTermActiveForPlaceholder)) Nothing
let res = TermActiveForm <$> fromRes <*> toRes <*> forRes
res' = res <&> \newDat oldDat -> if
| newDat `elem` oldDat

11
src/Handler/Tutorial/Edit.hs
View File

@ -25,21 +25,20 @@ getTEditR, postTEditR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -
getTEditR = postTEditR
postTEditR tid ssh csh tutn = do
(cid, tutid, template) <- runDB $ do
(cid, Entity tutid Tutorial{..}) <- fetchCourseIdTutorial tid ssh csh tutn
(cid, Entity tutid Tutorial{..}) <- fetchCourseIdTutorial tid ssh csh tutn
tutorIds <- fmap (map E.unValue) . E.select . E.from $ \tutor -> do
E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid
return $ tutor E.^. TutorUser
tutorInvites <- sourceInvitationsF @Tutor tutid
let
let
template = TutorialForm
{ tfName = tutorialName
, tfType = tutorialType
, tfCapacity = tutorialCapacity
, tfRoom = tutorialRoom
, tfRoomHidden = tutorialRoomHidden
, tfTime = tutorialTime
, tfTime = tutorialTime & unJSONB
, tfRegGroup = tutorialRegGroup
, tfRegisterFrom = tutorialRegisterFrom
, tfRegisterTo = tutorialRegisterTo
@ -62,9 +61,8 @@ postTEditR tid ssh csh tutn = do
, tutorialCourse = cid
, tutorialType = tfType
, tutorialCapacity = tfCapacity
, tutorialRoom = tfRoom
, tutorialRoomHidden = tfRoomHidden
, tutorialTime = tfTime
, tutorialTime = tfTime & JSONB
, tutorialRegGroup = tfRegGroup
, tutorialRegisterFrom = tfRegisterFrom
, tutorialRegisterTo = tfRegisterTo
@ -88,6 +86,7 @@ postTEditR tid ssh csh tutn = do
case insertRes of
Just _ -> addMessageI Error $ MsgTutorialNameTaken tfName
Nothing -> do
memcachedFlushClass MemcachedKeyClassTutorialOccurrences
addMessageI Success $ MsgTutorialEdited tfName
redirect $ CourseR tid ssh csh CTutorialListR

4
src/Handler/Tutorial/Form.hs
View File

@ -25,7 +25,6 @@ data TutorialForm = TutorialForm
, tfRegGroup :: Maybe (CI Text)
, tfTutorControlled :: Bool
, tfCapacity :: Maybe Int
, tfRoom :: Maybe RoomReference
, tfRoomHidden :: Bool
, tfTime :: Occurrences
, tfRegisterFrom :: Maybe UTCTime
@ -75,7 +74,6 @@ tutorialForm cid template html = do
<*> aopt (textField & cfStrip & cfCI) (fslI MsgTutorialRegGroup & setTooltip MsgTutorialRegGroupTip) ((tfRegGroup <$> template) <|> Just (Just "tutorial"))
<*> apopt checkBoxField (fslI MsgTutorialTutorControlled & setTooltip MsgTutorialTutorControlledTip) (tfTutorControlled <$> template)
<*> aopt (natFieldI MsgTutorialCapacityNonPositive) (fslpI MsgTutorialCapacity (mr MsgTutorialCapacity) & setTooltip MsgTutorialCapacityTip) (tfCapacity <$> template)
<*> roomReferenceFormOpt (fslI MsgTableTutorialRoom) (tfRoom <$> template)
<*> apopt checkBoxField (fslI MsgTableTutorialRoomHidden & setTooltip MsgTutorialRoomHiddenTip) (tfRoomHidden <$> template <|> Just False)
<*> occurrencesAForm ("occurrences" :: Text) (tfTime <$> template)
<*> aopt utcTimeField (fslpI MsgRegisterFrom (mr MsgTutorialDate)
@ -91,7 +89,7 @@ tutorialForm cid template html = do
where
tutTypeDatalist :: HandlerFor UniWorX (OptionList (CI Text))
tutTypeDatalist = fmap (mkOptionList . map (\t -> Option (CI.original t) t (toPathPiece $ CI.original t)) . Set.toAscList) . runDB $
fmap (setOf $ folded . _Value) . E.select . E.from $ \tutorial -> do
fmap (setOf $ folded . _Value) . E.select . E.distinct . E.from $ \tutorial -> do
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
return $ tutorial E.^. TutorialType

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