Merge branch 'master' into test
This commit is contained in:
commit
4eb28c3c5b
215
CHANGELOG.md
215
CHANGELOG.md
@ -1749,6 +1749,221 @@ them together now)
|
||||
* **model:** separate user authentication data from User table; add ExternalAuth and InternalAuth models ([54f2430](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/54f2430b3e79d3b7c396ac4cf1d4d0da860e3d02))
|
||||
* **settings:** rename userdb app settings ([9f299c8](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/9f299c854c9d2d2f1b1127c85a31b787f85fa210))
|
||||
|
||||
## [27.4.79](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.78...v27.4.79) (2024-09-10)
|
||||
|
||||
|
||||
### Bug Fixes
|
||||
|
||||
* **notifications:** fix [#180](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/180) qualification expiry notification are sent only once ([74f7633](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/74f7633837870448f7cab1013719f42ab49941fe))
|
||||
* **supervision:** fix [#181](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/181) by unifying deletion of supervision ([6a070a6](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/6a070a67756bd4ef4b9b5efc176f34c7ed183f1a))
|
||||
|
||||
## [27.4.78](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.77...v27.4.78) (2024-09-05)
|
||||
|
||||
|
||||
### Bug Fixes
|
||||
|
||||
* **avs:** acs auto synch had inverted success/failure ([4f7855b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/4f7855b9ee7133c5ee7e2ca63d63e5d9f060d62f))
|
||||
* **avs:** fix [#124](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/124) avs auto synch filter working ([2a27a1e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/2a27a1efa673a4245a7e8667bd30c79ac1891b9c))
|
||||
* **avs:** fix [#178](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/178) by deleting old superiors for individual users ([ade27e6](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ade27e647913ffe4432b41d585b3e00d1c68d4a0))
|
||||
* **avs:** typo in superior remark, towards [#178](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/178) ([3c5edb1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3c5edb1b970c8c154d9957837007815b29e23964))
|
||||
* **mail:** fix [#179](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/179) by adding download links for PDF attachments ([620e3e4](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/620e3e470080831826ccc960dd876e7bb4fcea03))
|
||||
|
||||
## [27.4.77](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.76...v27.4.77) (2024-09-02)
|
||||
|
||||
|
||||
### Bug Fixes
|
||||
|
||||
* **avs:** attempt LDAP upsert before creating avs users ([cfe2318](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/cfe2318f81c951a7f7310e8bcd9ec25d79417587))
|
||||
* **avs:** company superiors are now irregular supervisors and old ones are deleted ([7e5c256](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/7e5c256b4c15a15f7218dd7c1490d5e7add4b1c1))
|
||||
* **avs:** fix [#124](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/124) implement automatic avs driving licence synchronisation ([cc5da9a](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/cc5da9a2a9bfc8a29f6fe19260bd6dc5412ad4a1))
|
||||
* **avs:** switch company did not always increase priority ([8ec2875](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/8ec2875590718f28c3bab8c10141065e11f1405c))
|
||||
* **build:** minor linter fix ([be5e609](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/be5e609b1fe879428784d78fa62a559d0764a85a))
|
||||
* **firm:** fix [#174](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/174) by adding address search filter to all company view ([40dadd5](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/40dadd58762156005b5889b93a56ffdc044b4460))
|
||||
* **firm:** fix [#175](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/175) by separating superiors in firm tables and selections ([8397c46](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/8397c468a04af42ba3baee2f84a0051adbc74374))
|
||||
* **ldap:** no more timeout for ldap synch all button ([f946e99](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f946e99da3bc37514a4e3621438ac133cdc16732))
|
||||
* **linter:** minor bug in exam-correct.hs ([8bc3663](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/8bc3663ee2e4ded19091ebe350de82cd693093fc))
|
||||
* **mail:** display html emails no longer distorts page ([b0972bb](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b0972bb154f453edd545fb4f658d9f5ff79966eb)), closes [#2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/2)
|
||||
* **model:** flip erroneous boolean SQL default for CompanyPostalAddress ([b7e5b8f](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b7e5b8f111b5115d816d984c6ef2f12edfcef5bb))
|
||||
* **user:** fix pagination and count for supervision tables ([9c82558](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/9c82558d71a032dad27e892c489c7004d091e088))
|
||||
|
||||
## [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)
|
||||
|
||||
|
||||
|
||||
@ -81,6 +81,10 @@ health-check-ldap-admins-timeout: "_env:HEALTHCHECK_LDAP_ADMINS_TIMEOUT:60" # TO
|
||||
health-check-http-reachable-timeout: "_env:HEALTHCHECK_HTTP_REACHABLE_TIMEOUT:2"
|
||||
health-check-matching-cluster-config-timeout: "_env:HEALTHCHECK_MATCHING_CLUSTER_CONFIG_TIMEOUT:2"
|
||||
|
||||
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
|
||||
|
||||
@ -88,8 +92,8 @@ 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
|
||||
job-lms-qualifications-enqueue-hour: 16
|
||||
job-lms-qualifications-dequeue-hour: 4
|
||||
|
||||
log-settings:
|
||||
detailed: "_env:DETAILED_LOGGING:false"
|
||||
@ -177,10 +181,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"
|
||||
@ -298,8 +304,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
|
||||
|
||||
6
fixtest.sh
Executable file
6
fixtest.sh
Executable 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
|
||||
@ -301,7 +301,7 @@ export class ExamCorrect {
|
||||
users: [user],
|
||||
status: STATUS.LOADING,
|
||||
};
|
||||
if (results && results != {}) rowInfo.results = results;
|
||||
if (results && Object.keys(results).length > 0) rowInfo.results = results;
|
||||
if (result !== undefined) rowInfo.result = result;
|
||||
this._addRow(rowInfo);
|
||||
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
|
||||
# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>,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"}!
|
||||
@ -132,4 +152,13 @@ InterfaceWrite: Schreibend
|
||||
AdminUserPassword: Passwort
|
||||
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
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Winnie Ros <winnie.ros@campus.lmu.de>
|
||||
# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.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"}!
|
||||
@ -132,4 +152,13 @@ InterfaceWrite: Write
|
||||
AdminUserPassword: Password
|
||||
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
|
||||
|
||||
@ -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.
|
||||
@ -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.
|
||||
@ -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}
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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!
|
||||
|
||||
@ -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!
|
||||
|
||||
@ -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
|
||||
@ -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
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
SynchroniseUserdbUserQueued n@Int: Benutzerdatenbank-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen
|
||||
SynchroniseUserdbAllUsersQueued: Benutzerdatenbank-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!
|
||||
SynchroniseUserdbUserQueued n@Int: Benutzerdatenbank-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen, die Ausführung wird mehrere Minuten benötigen!
|
||||
SynchroniseUserdbAllUsersQueued: Benutzerdatenbank-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
|
||||
@ -90,17 +92,29 @@ 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
|
||||
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
|
||||
AdminUserAuthentication: Authentification
|
||||
AdminUserAuthLastSync: Zuletzt synchronisiert
|
||||
AuthKindLDAP: Fraport-AG-Kennung (LDAP)
|
||||
|
||||
@ -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"}.
|
||||
SynchroniseUserdbUserQueued n: Triggered user database synchronisation of #{n} #{pluralEN n "user" "users"}.
|
||||
SynchroniseUserdbAllUsersQueued: Triggered user database 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.
|
||||
SynchroniseUserdbUserQueued n: Triggered user database synchronisation of #{n} #{pluralEN n "user" "users"}, which may take several minutes to complete.
|
||||
SynchroniseUserdbAllUsersQueued: Triggered user database 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
|
||||
@ -90,16 +92,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
|
||||
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"}.
|
||||
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
|
||||
|
||||
AdminUserAuthentication: Authentifizierung
|
||||
AdminUserAuthLastSync: Last synchronised
|
||||
|
||||
@ -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
|
||||
@ -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
|
||||
@ -144,12 +144,18 @@ MenuSap: SAP Schnittstelle
|
||||
MenuAvs: AVS Schnittstelle
|
||||
MenuAvsSynchError: AVS Problemübersicht
|
||||
MenuExternalUser: Externe Benutzer
|
||||
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)
|
||||
|
||||
|
||||
@ -144,12 +144,18 @@ MenuSap: SAP Interface
|
||||
MenuAvs: AVS Interface
|
||||
MenuAvsSynchError: AVS Problem Overview
|
||||
MenuExternalUser: External users
|
||||
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)
|
||||
|
||||
|
||||
@ -73,15 +73,19 @@ 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
|
||||
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 +95,11 @@ TableCompanyNrSupersDefault: Standard Ansprechpartner
|
||||
TableCompanyNrForeignSupers: Firmenfremde Ansprechpartner
|
||||
TableCompanyNrRerouteDefault: Standard Umleitungen
|
||||
TableCompanyNrRerouteActive: Aktive Umleitungen
|
||||
TableRerouteActive: Umleitung
|
||||
TableCompanyPostalPreference: Benachrichtigungspräferenz neue Firmenangehörige
|
||||
TableSupervisor: Ansprechpartner
|
||||
TableSupervisee: Ansprechpartner für
|
||||
TableReason: Begründung
|
||||
TableCreationTime: Erstellungszeit
|
||||
TableJob !ident-ok: Job
|
||||
TableJobContent !ident-ok: Parameter
|
||||
@ -100,9 +107,11 @@ 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
|
||||
|
||||
@ -73,15 +73,19 @@ 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
|
||||
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 +95,11 @@ TableCompanyNrSupersDefault: Default supervisors
|
||||
TableCompanyNrForeignSupers: External Supervisors
|
||||
TableCompanyNrRerouteDefault: Default reroutes
|
||||
TableCompanyNrRerouteActive: Active reroutes
|
||||
TableRerouteActive: Reroute
|
||||
TableCompanyPostalPreference: Default notification preference
|
||||
TableSupervisor: Supervisor
|
||||
TableSupervisee: Supervisor for
|
||||
TableReason: Reason
|
||||
TableCreationTime: Creation
|
||||
TableJob !ident-ok: Job
|
||||
TableJobContent !ident-ok: Parameters
|
||||
@ -100,9 +107,11 @@ 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
|
||||
|
||||
@ -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
|
||||
@ -96,6 +98,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
|
||||
|
||||
@ -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
|
||||
@ -96,6 +98,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
|
||||
|
||||
@ -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
|
||||
@ -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
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
@ -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
|
||||
|
||||
-- TODOs:
|
||||
-- - Enstehen Kosten, wenn Teilnehmer für KnowHow eingereiht werden, aber nicht am Kurs teilnehmen?
|
||||
@ -40,20 +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
|
||||
-- deriving Generic
|
||||
--
|
||||
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 Qualifications with Exams!?
|
||||
|
||||
@ -61,7 +63,7 @@ QualificationEdit
|
||||
user UserId
|
||||
time UTCTime
|
||||
qualification QualificationId OnDeleteCascade OnUpdateCascade
|
||||
deriving Generic
|
||||
deriving Generic Show
|
||||
|
||||
QualificationUser
|
||||
user UserId OnDeleteCascade OnUpdateCascade
|
||||
@ -70,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
|
||||
@ -132,7 +134,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
|
||||
@ -150,7 +152,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
|
||||
@ -162,4 +164,4 @@ LmsReportLog
|
||||
lock Bool -- (0|1)
|
||||
timestamp UTCTime default=now()
|
||||
missing Bool default=false
|
||||
deriving Generic
|
||||
deriving Generic Show
|
||||
@ -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
|
||||
@ -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@cip.ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.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>, Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
@ -18,9 +18,14 @@ User json -- Each Uni2work user has a corresponding row in this table; create
|
||||
lastAuthentication UTCTime Maybe -- When did the user last authenticate?
|
||||
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
|
||||
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 -- 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
|
||||
@ -43,9 +48,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
|
||||
@ -69,41 +74,47 @@ 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
|
||||
|
||||
|
||||
8181
package-lock.json
generated
8181
package-lock.json
generated
File diff suppressed because it is too large
Load Diff
@ -1,6 +1,6 @@
|
||||
{
|
||||
"name": "fradrive",
|
||||
"version": "27.4.59",
|
||||
"version": "27.4.79",
|
||||
"description": "",
|
||||
"keywords": [],
|
||||
"author": "",
|
||||
|
||||
44
routes
44
routes
@ -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>,Wolfgang Witt <Wolfgang.Witt@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>,Wolfgang Witt <Wolfgang.Witt@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
@ -56,30 +56,38 @@
|
||||
|
||||
/ 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
|
||||
!/users/functionary-invite AdminFunctionaryInviteR GET POST
|
||||
!/users/add AdminUserAddR GET POST
|
||||
/admin AdminR GET
|
||||
/admin/test AdminTestR GET POST
|
||||
/admin/test/pdf AdminTestPdfR GET
|
||||
/admin/errMsg AdminErrMsgR GET POST
|
||||
/admin/tokens AdminTokensR GET POST
|
||||
/admin/crontab AdminCrontabR GET
|
||||
/admin/crontab/jobs AdminJobsR GET POST
|
||||
/admin/avs AdminAvsR GET POST
|
||||
/admin/avs/#CryptoUUIDUser AdminAvsUserR GET
|
||||
!/users/add AdminUserAddR GET POST
|
||||
/admin AdminR GET
|
||||
/admin/test AdminTestR GET POST
|
||||
/admin/test/pdf AdminTestPdfR GET
|
||||
/admin/errMsg AdminErrMsgR GET POST
|
||||
/admin/tokens AdminTokensR GET POST
|
||||
/admin/crontab AdminCrontabR GET
|
||||
/admin/crontab/jobs AdminJobsR GET POST
|
||||
/admin/avs AdminAvsR GET POST
|
||||
/admin/avs/#CryptoUUIDUser AdminAvsUserR GET POST
|
||||
/admin/external-user AdminExternalUserR GET POST
|
||||
/admin/problems AdminProblemsR GET
|
||||
/admin/problems/no-contact ProblemUnreachableR GET
|
||||
/admin/ldap AdminLdapR GET POST
|
||||
/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/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
|
||||
|
||||
@ -320,13 +320,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
|
||||
;
|
||||
})
|
||||
|
||||
@ -110,6 +110,20 @@ import Data.Maybe (fromJust)
|
||||
import Auth.OAuth2 (azureMockServer)
|
||||
#endif
|
||||
|
||||
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 (mkAvsQuery)
|
||||
|
||||
-- Import all relevant handler modules here.
|
||||
-- (HPack takes care to add new modules to our cabal file nowadays.)
|
||||
@ -142,6 +156,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
|
||||
@ -386,15 +402,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
|
||||
@ -634,7 +650,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
|
||||
@ -723,8 +739,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
36
src/Audit.hs
@ -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)
|
||||
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -59,6 +59,7 @@ decCryptoIDs [ ''SubmissionId
|
||||
, ''MaterialFileId
|
||||
, ''PrintJobId
|
||||
, ''QualificationId
|
||||
, ''SentMailId
|
||||
]
|
||||
|
||||
decCryptoIDKeySize
|
||||
|
||||
@ -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
|
||||
@ -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,19 @@ 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 +67,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 +166,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 +350,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 +379,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 +387,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 +395,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 +406,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 +417,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 +431,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 +491,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 +550,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 +650,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 +689,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 +717,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)
|
||||
|
||||
@ -688,10 +742,21 @@ selectCountDistinct q = do
|
||||
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") []
|
||||
@ -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
|
||||
@ -600,12 +612,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 <> ">"
|
||||
|
||||
@ -89,9 +89,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
|
||||
@ -124,6 +124,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
|
||||
@ -131,7 +132,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
|
||||
@ -1454,6 +1461,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
|
||||
@ -2468,6 +2481,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
|
||||
@ -2475,6 +2532,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
|
||||
|
||||
@ -15,7 +15,7 @@ module Foundation.Type
|
||||
, _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
|
||||
@ -43,7 +43,7 @@ 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
|
||||
@ -124,8 +124,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
|
||||
|
||||
@ -234,14 +234,26 @@ maybeUpsertUser _upsertMode (Just upsertData) = do
|
||||
now <- liftIO getCurrentTime
|
||||
userDefaultConf <- getsYesod $ view _appUserDefaults
|
||||
|
||||
(newUser,userUpdate) <- decodeUser now userDefaultConf upsertData
|
||||
(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 <- selectKeysList [ UserIdent ==. userIdent newUser ] []
|
||||
|
||||
user@(Entity userId _userRec) <- case oldUsers of
|
||||
[oldUserId] -> updateGetEntity oldUserId userUpdate
|
||||
_other -> upsertBy (UniqueAuthentication (newUser ^. _userIdent)) newUser userUpdate
|
||||
user@(Entity userId userRec) <- case oldUsers of
|
||||
Just [oldUserId] -> updateGetEntity oldUserId userUpdate
|
||||
_other -> upsertBy (UniqueAuthentication (newUser ^. _userIdent)) newUser userUpdate
|
||||
unless (validDisplayName (newUser ^. _userTitle)
|
||||
(newUser ^. _userFirstName)
|
||||
(newUser ^. _userSurname)
|
||||
(userRec ^. _userDisplayName)) $
|
||||
update userId [ UserDisplayName =. (newUser ^. _userDisplayName) ]
|
||||
when (validEmail' (userRec ^. _userEmail)) $ do
|
||||
let emUps = [ UserDisplayEmail =. (newUser ^. _userEmail) | not (validEmail' (userRec ^. _userDisplayEmail)) ]
|
||||
++ [ UserAuthentication =. AuthLDAP | is _AuthNoLogin (userRec ^. _userAuthentication) ]
|
||||
unless (null emUps) $ update userId emUps
|
||||
-- Attempt to update ident, too:
|
||||
unless (validEmail' (userRec ^. _userIdent)) $
|
||||
void $ maybeCatchAll (update userId [ UserIdent =. (newUser ^. _userEmail) ] >> return (Just ()))
|
||||
|
||||
let
|
||||
userSystemFunctions = determineSystemFunctions . Set.fromList $ map CI.mk userSystemFunctions'
|
||||
@ -265,26 +277,38 @@ maybeUpsertUser _upsertMode (Just upsertData) = do
|
||||
|
||||
return $ Just user
|
||||
|
||||
upsertUser :: forall m.
|
||||
( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
, MonadCatch m
|
||||
)
|
||||
=> UpsertUserMode
|
||||
-> NonEmpty UpsertUserData
|
||||
-> SqlPersistT m (Entity User)
|
||||
upsertUser upsertMode upsertData = maybeUpsertUser upsertMode (Just upsertData) >>= \case
|
||||
Nothing -> error "upsertUser: No user result from maybeUpsertUser!"
|
||||
Just user -> return user
|
||||
decodeUserTest :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m)
|
||||
=> Maybe UserIdent -> Ldap.AttrList [] -> m (Either CampusUserConversionException (User, [Update User]))
|
||||
decodeUserTest mbIdent ldapData = do
|
||||
now <- liftIO getCurrentTime
|
||||
userDefaultConf <- getsYesod $ view _appUserDefaults
|
||||
let mode = maybe UpsertCampusUserLoginLdap UpsertCampusUserLoginDummy mbIdent
|
||||
try $ decodeUser now userDefaultConf mode ldapData
|
||||
|
||||
|
||||
decodeUser :: ( MonadThrow m
|
||||
)
|
||||
=> UTCTime -- ^ Now
|
||||
-> UserDefaultConf
|
||||
-> NonEmpty UpsertUserData -- ^ Raw source data
|
||||
-> m (User,_) -- ^ Data for new User entry and updating existing User entries
|
||||
decodeUser now UserDefaultConf{..} upsertData = do
|
||||
decodeUser :: (MonadThrow m) => UTCTime -> UserDefaultConf -> UpsertCampusUserMode -> Ldap.AttrList [] -> m (User,_)
|
||||
decodeUser now UserDefaultConf{..} upsertMode ldapData = do
|
||||
let
|
||||
userTelephone = decodeLdap ldapUserTelephone
|
||||
userMobile = decodeLdap ldapUserMobile
|
||||
userCompanyPersonalNumber = decodeLdap ldapUserFraportPersonalnummer
|
||||
userCompanyDepartment = decodeLdap ldapUserFraportAbteilung
|
||||
|
||||
userAuthentication
|
||||
| is _UpsertCampusUserLoginOther upsertMode
|
||||
= AuthNoLogin -- AuthPWHash (error "Non-LDAP logins should only work for users that are already known")
|
||||
| otherwise = AuthLDAP
|
||||
userLastAuthentication = guardOn isLogin now
|
||||
isLogin = has (_UpsertCampusUserLoginLdap <> _UpsertCampusUserLoginOther . united) upsertMode
|
||||
|
||||
userTitle = decodeLdap ldapUserTitle -- CampusUserInvalidTitle
|
||||
userFirstName = decodeLdap' ldapUserFirstName -- CampusUserInvalidGivenName
|
||||
userSurname = decodeLdap' ldapUserSurname -- CampusUserInvalidSurname
|
||||
userDisplayName <- decodeLdap1 ldapUserDisplayName CampusUserInvalidDisplayName <&> fixDisplayName -- do not check LDAP-given userDisplayName
|
||||
|
||||
--userDisplayName <- decodeLdap1 ldapUserDisplayName CampusUserInvalidDisplayName >>=
|
||||
-- (maybeThrow CampusUserInvalidDisplayName . checkDisplayName userTitle userFirstName userSurname)
|
||||
|
||||
userIdent <- if
|
||||
| Just azureData <- mbAzureData
|
||||
, [Text.decodeUtf8' -> Right azureUserPrincipalName'] <- azureData !!! azureUserPrincipalName
|
||||
@ -295,50 +319,25 @@ decodeUser now UserDefaultConf{..} upsertData = do
|
||||
, Just ldapPrimaryKey'' <- assertM' (not . Text.null) $ Text.strip ldapPrimaryKey'
|
||||
-> return $ CI.mk ldapPrimaryKey''
|
||||
| otherwise
|
||||
-> throwM DecodeUserInvalidIdent
|
||||
-> throwM CampusUserInvalidIdent
|
||||
|
||||
userEmail <- if -- TODO: refactor! NOTE: LDAP doesnt know email for all users; we use userPrincialName instead; however validEmail refutes `E<number@fraport.de` here, too strong! Make Email-Field optional!
|
||||
| userEmail : _ <- mapMaybe (assertM (elem '@') . either (const Nothing) Just . Text.decodeUtf8') (lookupSome ldapMap $ toList ldapUserEmail)
|
||||
-> return $ CI.mk userEmail
|
||||
-- | userEmail : _ <- mapMaybe (assertM validEmail . either (const Nothing) Just . Text.decodeUtf8') (lookupSome ldapMap $ toList ldapUserEmail) -- TOO STRONG, see above!
|
||||
-- -> return $ CI.mk userEmail
|
||||
| otherwise
|
||||
-> throwM CampusUserInvalidEmail
|
||||
|
||||
userLdapPrimaryKey <- if
|
||||
| [bs] <- ldapMap !!! ldapPrimaryKey
|
||||
, Right userLdapPrimaryKey'' <- Text.decodeUtf8' bs
|
||||
, Just userLdapPrimaryKey''' <- assertM' (not . Text.null) $ Text.strip userLdapPrimaryKey''
|
||||
-> return $ Just userLdapPrimaryKey'''
|
||||
| otherwise
|
||||
-> return Nothing
|
||||
|
||||
let
|
||||
(azureSurname, azureFirstName, azureDisplayName, azureEmail, azureTelephone, azureMobile, azureLanguages)
|
||||
| Just azureData <- mbAzureData
|
||||
= ( azureData `decodeAzure` azureUserSurname
|
||||
, azureData `decodeAzure` azureUserGivenName
|
||||
, azureData `decodeAzure` azureUserDisplayName
|
||||
, azureData `decodeAzure` azureUserMail
|
||||
, azureData `decodeAzure` azureUserTelephone
|
||||
, azureData `decodeAzure` azureUserMobile
|
||||
, Nothing -- azureData `decodeAzure` azureUserPreferredLanguage -- TODO: parse Languages from azureUserPreferredLanguage
|
||||
)
|
||||
| otherwise
|
||||
= ( Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing )
|
||||
|
||||
(ldapSurname, ldapFirstName, ldapDisplayName, ldapEmail, ldapTelephone, ldapMobile, ldapCompanyPersonalNumber, ldapCompanyDepartment)
|
||||
| Just ldapData <- mbLdapData
|
||||
= ( ldapData `decodeLdap` ldapUserSurname
|
||||
, ldapData `decodeLdap` ldapUserFirstName
|
||||
, ldapData `decodeLdap` ldapUserDisplayName
|
||||
, ldapData `decodeLdap` Ldap.Attr "mail" -- TODO: use ldapUserEmail?
|
||||
, ldapData `decodeLdap` ldapUserTelephone
|
||||
, ldapData `decodeLdap` ldapUserMobile
|
||||
, ldapData `decodeLdap` ldapUserFraportPersonalnummer
|
||||
, ldapData `decodeLdap` ldapUserFraportAbteilung
|
||||
)
|
||||
| otherwise
|
||||
= ( Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing )
|
||||
|
||||
-- TODO: throw on collisions?
|
||||
|
||||
-- TODO: use user-auth precedence from app config when implementing multi-source support
|
||||
let
|
||||
userSurname = fromMaybe mempty $ azureSurname <|> ldapSurname
|
||||
userFirstName = fromMaybe mempty $ azureFirstName <|> ldapFirstName
|
||||
userDisplayName = fromMaybe mempty $ azureDisplayName <|> ldapDisplayName
|
||||
userEmail = maybe mempty CI.mk $ azureEmail <|> ldapEmail
|
||||
userTelephone = azureTelephone <|> ldapTelephone
|
||||
userMobile = azureMobile <|> ldapMobile
|
||||
userLanguages = azureLanguages
|
||||
userCompanyPersonalNumber = ldapCompanyPersonalNumber
|
||||
userCompanyDepartment = ldapCompanyDepartment
|
||||
|
||||
newUser = User
|
||||
{ userMaxFavourites = userDefaultMaxFavourites
|
||||
, userMaxFavouriteTerms = userDefaultMaxFavouriteTerms
|
||||
@ -369,16 +368,19 @@ decodeUser now UserDefaultConf{..} upsertData = do
|
||||
, userLastSync = Just now
|
||||
, ..
|
||||
}
|
||||
userUpdate =
|
||||
[ UserSurname =. userSurname
|
||||
, UserFirstName =. userFirstName
|
||||
-- , UserDisplayName =. userDisplayName -- not updated, since users are allowed to change their DisplayName
|
||||
, UserEmail =. userEmail
|
||||
, UserTelephone =. userTelephone
|
||||
, UserMobile =. userMobile
|
||||
, UserCompanyPersonalNumber =. userCompanyPersonalNumber
|
||||
, UserCompanyDepartment =. userCompanyDepartment
|
||||
, UserLastSync =. Just now
|
||||
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
|
||||
UserFirstName =. userFirstName
|
||||
, UserSurname =. userSurname
|
||||
, UserLastLdapSynchronisation =. Just now
|
||||
, UserLdapPrimaryKey =. userLdapPrimaryKey
|
||||
, UserMobile =. userMobile
|
||||
, UserTelephone =. userTelephone
|
||||
, UserCompanyPersonalNumber =. userCompanyPersonalNumber
|
||||
, UserCompanyDepartment =. userCompanyDepartment
|
||||
]
|
||||
return (newUser, userUpdate)
|
||||
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>
|
||||
-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>,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
|
||||
@ -33,12 +39,34 @@ import Handler.Admin.Crontab as Handler.Admin
|
||||
import Handler.Admin.Avs as Handler.Admin
|
||||
import Handler.Admin.ExternalUser as Handler.Admin
|
||||
|
||||
-- avoids repetition of local definitions
|
||||
single :: (k,a) -> Map k a
|
||||
single = uncurry Map.singleton
|
||||
|
||||
|
||||
-- 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 +78,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 +107,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 +115,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 +179,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 +194,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 +210,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 +259,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 +278,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 +300,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 = mconcat
|
||||
[ single ("time" , SortColumn $ queryProblem >>> (E.^. ProblemLogTime))
|
||||
, single ("info" , SortColumn $ queryProblem >>> (E.^. ProblemLogInfo))
|
||||
-- , single ("firm" , SortColumn ((E.->>. "company" ).(queryProblem >>> (E.^. ProblemLogInfo))))
|
||||
, single ("firm" , SortColumn $ \r -> queryProblem r E.^. ProblemLogInfo E.->>. "company")
|
||||
, single ("user" , sortUserNameBareM queryUser)
|
||||
, single ("solved", SortColumn $ queryProblem >>> (E.^. ProblemLogSolved))
|
||||
, single ("solver", sortUserNameBareM querySolver)
|
||||
]
|
||||
dbtFilter = mconcat
|
||||
[ single ("user" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryUser) (E.?. UserDisplayName))
|
||||
, single ("solver" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to querySolver) (E.?. UserDisplayName))
|
||||
, single ("company" , FilterColumn . E.mkContainsFilter $ views (to queryProblem) ((E.->>. "company").(E.^. ProblemLogInfo)))
|
||||
, single ("solved" , FilterColumn . E.mkExactFilterLast $ views (to queryProblem) (E.isJust . (E.^. ProblemLogSolved)))
|
||||
-- , single ("problem" , FilterColumn . E.mkContainsFilter $ views (to queryProblem) ((E.->>. "problem").(E.^. ProblemLogInfo))) -- not stored in plaintext!
|
||||
, single ("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 = mconcat
|
||||
[ singletonMap ProblemTableMarkSolved $ pure ProblemTableMarkSolvedData
|
||||
, singletonMap 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
|
||||
|
||||
@ -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
|
||||
@ -43,6 +42,13 @@ import qualified Database.Esqueleto.Utils as E
|
||||
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 +59,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 +93,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 +103,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 +121,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 +147,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 +473,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 +487,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 +518,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 +529,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 +545,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 +571,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 +624,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 +659,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
|
||||
@ -605,14 +724,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 +741,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 +788,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,9 +1003,9 @@ 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)
|
||||
return (usravs, user) -- , E.substring (usravs E.^. UserAvsLastSynchError) (E.val ("'#\"%#\" %'") (E.val "#")) -- needs a different type on substring
|
||||
qerryUsrAvs :: (E.SqlExpr (Entity UserAvs) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity UserAvs)
|
||||
qerryUsrAvs = $(E.sqlIJproj 2 1)
|
||||
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)
|
||||
reserrUsrAvs :: Lens' (DBRow (Entity UserAvs, Entity User)) (Entity UserAvs)
|
||||
@ -788,4 +1051,3 @@ getProblemAvsErrorR = do
|
||||
siteLayoutMsg MsgMenuAvsSynchError $ do
|
||||
setTitleI MsgMenuAvsSynchError
|
||||
[whamlet|^{avsSyncErrTbl}|]
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
152
src/Handler/CommCenter.hs
Normal file
152
src/Handler/CommCenter.hs
Normal file
@ -0,0 +1,152 @@
|
||||
-- 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
|
||||
|
||||
|
||||
-- avoids repetition of local definitions
|
||||
single :: (k,a) -> Map k a
|
||||
single = uncurry Map.singleton
|
||||
|
||||
|
||||
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 = mconcat
|
||||
[ single ("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
|
||||
, single ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just
|
||||
$ \row -> E.coalesce [queryRecipientPrint row E.?. UserDisplayName, queryRecipientMail row E.?. UserDisplayName])
|
||||
, single ("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")
|
||||
|
||||
@ -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,9 @@ 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)
|
||||
|
||||
addMessageI Success $ MsgCourseEditOk tid ssh csh
|
||||
return True
|
||||
when success $ redirect $ CourseR tid ssh csh CShowR
|
||||
@ -420,3 +463,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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -129,11 +129,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 +194,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
|
||||
@ -416,12 +416,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,7 +733,7 @@ postCUsersR tid ssh csh = do
|
||||
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
|
||||
@ -757,7 +757,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
|
||||
|
||||
@ -19,6 +19,7 @@ import Import
|
||||
|
||||
-- import Jobs
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Company
|
||||
import Handler.Utils.Communication
|
||||
import Handler.Utils.Avs (guessAvsUser)
|
||||
|
||||
@ -28,11 +29,12 @@ import qualified Data.Map as Map
|
||||
-- import qualified Data.Text as T
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
-- import qualified Data.Conduit.List as C
|
||||
import Database.Persist.Sql (deleteWhereCount, updateWhereCount)
|
||||
-- import Database.Persist.Sql (deleteWhereCount, updateWhereCount)
|
||||
import Database.Persist.Postgresql
|
||||
import Database.Esqueleto.Experimental ((:&)(..))
|
||||
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
|
||||
import qualified Database.Esqueleto.Legacy as EL (on)
|
||||
import qualified Database.Esqueleto.PostgreSQL as E
|
||||
import qualified Database.Esqueleto.Legacy as EL (on) -- needed for legacy join expected by dbTable
|
||||
-- import qualified Database.Esqueleto.PostgreSQL as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
import Database.Esqueleto.Utils.TH
|
||||
|
||||
@ -55,7 +57,7 @@ postalEmailField = boolFieldCustom (SomeMessage MsgUtilPostal) (SomeMessage MsgU
|
||||
|
||||
data FirmAction = FirmActNotify
|
||||
| FirmActResetSupervision
|
||||
| FirmActAddSupersvisors
|
||||
| FirmActAddSupervisors
|
||||
| FirmActChangeContactFirm
|
||||
| FirmActChangeContactUser
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
||||
@ -69,10 +71,11 @@ data FirmActionData = FirmActNotifyData
|
||||
{ firmActResetKeepOldSupers :: Maybe Bool
|
||||
, firmActResetMutualSupervision :: Maybe Bool
|
||||
}
|
||||
| FirmActAddSupersvisorsData
|
||||
| FirmActAddSupervisorsData
|
||||
{ firmActAddSupervisorIds :: Set Text
|
||||
, firmActAddSupervisorReroute :: Bool
|
||||
, firmActAddSupervisorPostal :: Maybe Bool
|
||||
, firmActAddSupervisorReason :: Maybe Text
|
||||
}
|
||||
| FirmActChangeContactFirmData
|
||||
{ firmActCCFPostalAddr :: Maybe StoredMarkup
|
||||
@ -81,6 +84,7 @@ data FirmActionData = FirmActNotifyData
|
||||
}
|
||||
| FirmActChangeContactUserData
|
||||
{ firmActCCUPostalAddr :: Maybe StoredMarkup
|
||||
, firmActCCUUseCompanyPostal :: Maybe Bool
|
||||
, firmActCCUPostalPref :: Maybe Bool
|
||||
}
|
||||
deriving (Eq, Ord, Read, Show, Generic)
|
||||
@ -90,21 +94,31 @@ firmActionMap mr isAdmin acts = mconcat (mkAct isAdmin <$> acts)
|
||||
where
|
||||
mkAct True FirmActNotify = singletonMap FirmActNotify $ pure FirmActNotifyData
|
||||
mkAct _ FirmActResetSupervision = singletonMap FirmActResetSupervision $ FirmActResetSupervisionData
|
||||
<$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False)
|
||||
<*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True )
|
||||
mkAct _ FirmActAddSupersvisors = singletonMap FirmActAddSupersvisors $ FirmActAddSupersvisorsData
|
||||
<$> areq (textField & cfAnySeparatedSet) (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
|
||||
<$> aopt boolField' (fslI MsgFirmActResetSuperKeep) (Just $ Just False)
|
||||
<*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True )
|
||||
mkAct _ FirmActAddSupervisors = singletonMap FirmActAddSupervisors $ FirmActAddSupervisorsData
|
||||
<$> areq (textField & cfAnySeparatedSet) (fslI MsgFirmSuperDefault & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
|
||||
<*> areq checkBoxField (fslI MsgTableIsDefaultReroute) (Just True)
|
||||
<*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing
|
||||
<*> aopt (textField & cfStrip & addDatalist ucdefSuperReasons)
|
||||
(fslI MsgUserCompanyReason & setTooltip MsgUserCompanyReasonTooltip) Nothing
|
||||
mkAct _ FirmActChangeContactFirm = singletonMap FirmActChangeContactFirm $ FirmActChangeContactFirmData
|
||||
<$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing
|
||||
<*> aopt (emailField & cfStrip & cfCI) (fslI MsgUserDisplayEmail & setTooltip MsgUtilEmptyNoChangeTip) Nothing
|
||||
<*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing
|
||||
<*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFirmDefaultPreferenceInfo) Nothing
|
||||
<* aformMessage (Message Info (toHtml $ mr MsgFirmActChangeContactFirmInfo) (Just IconNotificationNonactive))
|
||||
mkAct _ FirmActChangeContactUser = singletonMap FirmActChangeContactUser $ FirmActChangeContactUserData
|
||||
<$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing
|
||||
<*> aopt boolField' (fslI MsgCompanyUserUseCompanyAddress & setTooltip MsgCompanyUserUseCompanyAddressTip) Nothing
|
||||
<*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing
|
||||
mkAct _ _ = mempty
|
||||
ucdefSuperReasons :: HandlerFor UniWorX (OptionList Text)
|
||||
ucdefSuperReasons = fmap (mkOptionList . map (\t -> Option t t t) . Set.toAscList) . runDB $
|
||||
fmap (setOf $ folded . _Value . _Just) . E.select . E.distinct $ do
|
||||
usrc <- E.from $ E.table @UserCompany
|
||||
E.where_ $ E.isJust $ usrc E.^. UserCompanyReason
|
||||
return $ usrc E.^. UserCompanyReason
|
||||
|
||||
|
||||
firmActionForm :: _ -> Bool -> [FirmAction] -> AForm Handler FirmActionData
|
||||
firmActionForm mr isAdmin acts = multiActionA (firmActionMap mr isAdmin acts) (fslI MsgTableAction) Nothing
|
||||
@ -118,7 +132,7 @@ firmActionHandler route isAdmin = flip formResult faHandler
|
||||
faHandler (_,fids) | null fids = addMessageI Error MsgNoCompanySelected
|
||||
|
||||
faHandler (FirmActNotifyData, Set.toList -> fids) = do
|
||||
usrs <- runDB $ E.select $ E.distinct $ do
|
||||
usrs <- runDBRead $ E.select $ E.distinct $ do
|
||||
(usr :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser)
|
||||
E.where_ $ uc E.^. UserCompanyCompany `E.in_` E.valList fids
|
||||
return $ usr E.^. UserId
|
||||
@ -135,17 +149,19 @@ firmActionHandler route isAdmin = flip formResult faHandler
|
||||
delSupers <- if firmActResetKeepOldSupers == Just False
|
||||
then E.deleteCount $ do
|
||||
spr <- E.from $ E.table @UserSupervisor
|
||||
E.where_ $ suprFltr spr E.&&. E.exists (do
|
||||
usr <- E.from $ E.table @UserCompany
|
||||
E.where_ $ usr E.^. UserCompanyCompany `E.in_` E.vals fids
|
||||
E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser
|
||||
)
|
||||
E.where_ $ suprFltr spr
|
||||
E.&&. spr E.^. UserSupervisorReason E.~=. E.val (tshow SupervisorReasonCompanyDefault)
|
||||
E.&&. E.exists (do
|
||||
usr <- E.from $ E.table @UserCompany
|
||||
E.where_ $ usr E.^. UserCompanyCompany `E.in_` E.vals fids
|
||||
E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser
|
||||
)
|
||||
else return 0
|
||||
newSupers <- addDefaultSupervisorsFor madId (firmActResetMutualSupervision /= Just False) fids
|
||||
newSupers <- addDefaultSupervisorsFor (Just $ tshow SupervisorReasonCompanyDefault) madId (firmActResetMutualSupervision /= Just False) fids
|
||||
addMessageI Success $ MsgFirmResetSupervision delSupers newSupers
|
||||
reloadKeepGetParams route -- reload to reflect changes
|
||||
|
||||
faHandler (FirmActAddSupersvisorsData{..}, Set.toList -> [cid]) = do
|
||||
faHandler (FirmActAddSupervisorsData{..}, Set.toList -> [cid]) = do
|
||||
avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser firmActAddSupervisorIds
|
||||
let (usersFound', usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers
|
||||
usersFound = mapMaybe snd usersFound'
|
||||
@ -161,7 +177,9 @@ firmActionHandler route isAdmin = flip formResult faHandler
|
||||
addMessageI Warning MsgFirmActAddSupersEmpty
|
||||
reloadKeepGetParams route
|
||||
runDB $ do
|
||||
putMany [UserCompany uid cid True firmActAddSupervisorReroute | uid <- usersFound]
|
||||
-- putMany [UserCompany uid cid True firmActAddSupervisorReroute 0 False | uid <- usersFound] -- putMany always overwrites existing records, which would destroy priority and useCompanyAddress here
|
||||
-- upsertManyWhere [UserCompany uid cid True firmActAddSupervisorReroute 0 False | uid <- usersFound] [copyField UserCompanySupervisor, copyField UserCompanySupervisorReroute] [] [] -- overwrite Supervisor and SupervisorReroute, keep priority and useCompanyAddress
|
||||
upsertManyWhere [UserCompany uid cid True firmActAddSupervisorReroute 0 False firmActAddSupervisorReason| uid <- usersFound] [] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. firmActAddSupervisorReroute, UserCompanyReason =. firmActAddSupervisorReason] [] -- identical to previous line, but perhaps more clear?
|
||||
whenIsJust firmActAddSupervisorPostal $ \prefPostal ->
|
||||
updateWhere [UserId <-. usersFound] [UserPrefersPostal =. prefPostal]
|
||||
addMessageI Success $ MsgFirmActAddSupersSet (fromIntegral $ length usersFound) firmActAddSupervisorPostal
|
||||
@ -174,25 +192,34 @@ firmActionHandler route isAdmin = flip formResult faHandler
|
||||
, (CompanyPrefersPostal =.) <$> firmActCCFPostalPref
|
||||
]
|
||||
in unless (null changes) $ do
|
||||
runDB $ updateBy (UniqueCompanyShorthand $ unCompanyKey cid) changes
|
||||
runDB $ update cid changes
|
||||
addMessageI Success MsgFirmActChangeContactFirmResult
|
||||
reloadKeepGetParams route
|
||||
|
||||
faHandler (FirmActChangeContactUserData{..}, Set.toList -> [cid]) =
|
||||
let changes = catMaybes
|
||||
[ (UserPostAddress E.=.) . E.justVal <$> canonical firmActCCUPostalAddr -- note that Nothing means no change and not delete address!
|
||||
, (UserPrefersPostal E.=.) . E.val <$> firmActCCUPostalPref
|
||||
]
|
||||
in unless (null changes) $ do
|
||||
nrChanged <- runDB $ E.updateCount $ \usr -> do
|
||||
E.set usr changes
|
||||
E.where_ $ E.exists $ do
|
||||
usrCmpy <- E.from $ E.table @UserCompany
|
||||
E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. E.val cid
|
||||
E.&&. usrCmpy E.^. UserCompanyUser E.==. usr E.^. UserId
|
||||
addMessageI Success $ MsgFirmUserChanges nrChanged
|
||||
reloadKeepGetParams route -- reload to reflect changes
|
||||
|
||||
faHandler (FirmActChangeContactUserData{..}, Set.toList -> [cid])
|
||||
| firmActCCUUseCompanyPostal == Just True, isJust firmActCCUPostalAddr =
|
||||
addMessageI Error MsgCompanyUserUseCompanyPostalError
|
||||
| otherwise = do
|
||||
let changes = catMaybes
|
||||
[ toMaybe (firmActCCUUseCompanyPostal == Just True) (UserPostAddress E.=. E.nothing) -- precondition ensures that only one update applies for UserPostAddress
|
||||
, (UserPostAddress E.=.) . E.justVal <$> canonical firmActCCUPostalAddr -- note that Nothing means no change and not delete address!
|
||||
, (UserPrefersPostal E.=.) . E.val <$> firmActCCUPostalPref
|
||||
]
|
||||
(total, nrChanged) <- runDB $ do
|
||||
nrUsrChange <- E.updateCount $ \usr -> do
|
||||
E.set usr changes
|
||||
E.where_ $ E.exists $ do
|
||||
usrCmpy <- E.from $ E.table @UserCompany
|
||||
E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. E.val cid
|
||||
E.&&. usrCmpy E.^. UserCompanyUser E.==. usr E.^. UserId
|
||||
nrUseComp <- case firmActCCUUseCompanyPostal of
|
||||
Just x -> updateWhereCount [UserCompanyCompany ==. cid] [UserCompanyUseCompanyAddress =. x]
|
||||
Nothing -> return 0
|
||||
nrCid <- count [UserCompanyCompany ==. cid]
|
||||
return (fromIntegral nrCid, max nrUsrChange nrUseComp)
|
||||
let allok = bool Warning Success $ nrChanged == total
|
||||
addMessageI allok $ MsgFirmUserActChangeResult nrChanged total
|
||||
reloadKeepGetParams route -- reload to reflect changes
|
||||
faHandler _ = addMessageI Error MsgErrorUnknownFormAction
|
||||
|
||||
|
||||
@ -227,89 +254,35 @@ runFirmActionFormPost cid route isAdmin acts = do
|
||||
-- Firm specific utilities
|
||||
-- for filters and counts also see before FirmAllR Handlers
|
||||
|
||||
|
||||
|
||||
-- remove supervisors:
|
||||
deleteSupervisors :: NonEmpty UserId -> DB Int64
|
||||
deleteSupervisors usrs = deleteWhereCount [UserSupervisorUser <-. toList usrs]
|
||||
|
||||
-- reset supervisors given employees of a company to default company supervision, deleting all other supervisors
|
||||
resetSupervisors :: CompanyId -> NonEmpty UserId -> DB Int64
|
||||
resetSupervisors cid employees = do
|
||||
nr_del <- deleteSupervisors employees
|
||||
nr_add <- addDefaultSupervisors cid employees
|
||||
return $ max nr_del nr_add
|
||||
|
||||
-- adds the default company supervisors as supervisor to a given set of users, which themselves may belong to any company
|
||||
addDefaultSupervisors :: CompanyId -> NonEmpty UserId -> DB Int64
|
||||
addDefaultSupervisors cid employees = do
|
||||
E.insertSelectWithConflictCount UniqueUserSupervisor
|
||||
(do
|
||||
(spr :& usr) <- E.from $ E.table @UserCompany `E.crossJoin` E.toValues employees
|
||||
E.where_ $ spr E.^. UserCompanyCompany E.==. E.val cid
|
||||
E.&&. spr E.^. UserCompanySupervisor
|
||||
E.distinct $ return $ UserSupervisor
|
||||
E.<# (spr E.^. UserCompanyUser)
|
||||
E.<&> usr
|
||||
E.<&> (spr E.^. UserCompanySupervisorReroute)
|
||||
)
|
||||
(\_old new -> [UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications])
|
||||
|
||||
-- like `addDefaultSupervisors`, but selects all employees of given companies from database, optionally filtered by being under supervision of a given individual
|
||||
addDefaultSupervisorsFor :: (CompanyId ~ Element mono, MonoFoldable mono) => Maybe UserId -> Bool -> mono -> DB Int64
|
||||
addDefaultSupervisorsFor mbSuperId mutualSupervision cids = do
|
||||
E.insertSelectWithConflictCount UniqueUserSupervisor
|
||||
(do
|
||||
(spr :& usr) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @UserCompany `E.on` (\(spr :& usr) -> spr E.^. UserCompanyCompany E.==. usr E.^. UserCompanyCompany)
|
||||
E.where_ $ E.and $ guardMonoid (not mutualSupervision)
|
||||
[ E.not_ $ usr E.^. UserCompanySupervisor ]
|
||||
<> maybeEmpty mbSuperId (\sprId -> [E.exists $ do
|
||||
superv <- E.from $ E.table @UserSupervisor
|
||||
E.where_ $ superv E.^. UserSupervisorSupervisor E.==. E.val sprId
|
||||
E.&&. superv E.^. UserSupervisorUser E.==. usr E.^. UserCompanyUser
|
||||
])
|
||||
<> [ spr E.^. UserCompanySupervisor
|
||||
, spr E.^. UserCompanyCompany `E.in_` E.vals cids
|
||||
, usr E.^. UserCompanyCompany `E.in_` E.vals cids
|
||||
]
|
||||
E.distinct $ return $ UserSupervisor
|
||||
E.<# (spr E.^. UserCompanyUser)
|
||||
E.<&> (usr E.^. UserCompanyUser)
|
||||
E.<&> (spr E.^. UserCompanySupervisorReroute)
|
||||
)
|
||||
(\_old new -> [UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications] )
|
||||
|
||||
-- like `addDefaultSupervisors`, but selects all employees of given companies from database
|
||||
addDefaultSupervisorsAll :: (CompanyId ~ Element mono, MonoFoldable mono) => Bool -> mono -> DB Int64
|
||||
addDefaultSupervisorsAll mutualSupervision cids = do
|
||||
E.insertSelectWithConflictCount UniqueUserSupervisor
|
||||
(do
|
||||
(spr :& usr) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @UserCompany `E.on` (\(spr :& usr) -> spr E.^. UserCompanyCompany E.==. usr E.^. UserCompanyCompany)
|
||||
E.where_ $ E.and $ guardMonoid (not mutualSupervision)
|
||||
[ E.not_ $ usr E.^. UserCompanySupervisor ]
|
||||
<> [ spr E.^. UserCompanySupervisor
|
||||
, spr E.^. UserCompanyCompany `E.in_` E.vals cids
|
||||
, usr E.^. UserCompanyCompany `E.in_` E.vals cids
|
||||
]
|
||||
E.distinct $ return $ UserSupervisor
|
||||
E.<# (spr E.^. UserCompanyUser)
|
||||
E.<&> (usr E.^. UserCompanyUser)
|
||||
E.<&> (spr E.^. UserCompanySupervisorReroute)
|
||||
)
|
||||
(\_old new -> [UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications] )
|
||||
|
||||
|
||||
------------------------------
|
||||
-- repeatedly useful queries
|
||||
|
||||
usrPrimaryCompanies :: E.SqlExpr (Entity Company) -> E.SqlExpr (Entity UserCompany) -> E.SqlQuery ()
|
||||
-- usrPrimaryCompanies :: E.SqlExpr (E.Value CompanyId) -> E.SqlExpr (Entity UserCompany) -> E.SqlQuery (Entity UserCompany) -- possible alternative
|
||||
usrPrimaryCompanies cmp usr = do
|
||||
othr <- E.from $ E.table @UserCompany
|
||||
E.where_ $ othr E.^. UserCompanyPriority E.>. usr E.^. UserCompanyPriority
|
||||
E.&&. othr E.^. UserCompanyUser E.==. usr E.^. UserCompanyUser
|
||||
E.&&. othr E.^. UserCompanyCompany E.!=. cmp E.^. CompanyId -- redundant due to > above, but likely performance improving
|
||||
-- return othr
|
||||
|
||||
fromUserCompany :: Maybe (E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity Company) -> E.SqlQuery ()
|
||||
fromUserCompany mbFltr cmpy = do
|
||||
usrCmpy <- E.from $ E.table @UserCompany
|
||||
let basecond = usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId
|
||||
E.where_ $ maybe basecond ((basecond E.&&.).($ usrCmpy)) mbFltr
|
||||
|
||||
firmCountUsers :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
|
||||
firmCountUsers = E.subSelectCount . fromUserCompany Nothing
|
||||
firmCountUsers :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
|
||||
firmCountUsers = E.subSelectCount . fromUserCompany Nothing
|
||||
|
||||
firmCountUsersPrimary :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
|
||||
firmCountUsersPrimary cmp = E.subSelectCount $ fromUserCompany (Just primFltr) cmp
|
||||
where
|
||||
primFltr = E.notExists . usrPrimaryCompanies cmp
|
||||
|
||||
firmCountUsersSecondary :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
|
||||
firmCountUsersSecondary cmp = E.subSelectCount $ fromUserCompany (Just primFltr) cmp
|
||||
where
|
||||
primFltr = E.exists . usrPrimaryCompanies cmp
|
||||
|
||||
firmCountSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
|
||||
firmCountSupervisors = E.subSelectCount . fromUserCompany (Just (E.^. UserCompanySupervisor))
|
||||
@ -422,7 +395,7 @@ type AllCompanyTableExpr = E.SqlExpr (Entity Company)
|
||||
queryAllCompany :: AllCompanyTableExpr -> E.SqlExpr (Entity Company)
|
||||
queryAllCompany = id
|
||||
|
||||
type AllCompanyTableData = DBRow (Entity Company, E.Value Word64, E.Value Bool, E.Value Bool)
|
||||
type AllCompanyTableData = DBRow (Entity Company, E.Value Word64, E.Value Bool, E.Value Bool, E.Value Word64)
|
||||
resultAllCompanyEntity :: Lens' AllCompanyTableData (Entity Company)
|
||||
resultAllCompanyEntity = _dbrOutput . _1
|
||||
|
||||
@ -438,10 +411,12 @@ resultAllCompanySupervisors = _dbrOutput . _3 . _unValue
|
||||
resultAllCompanyDefaultReroutes :: Lens' AllCompanyTableData Bool
|
||||
resultAllCompanyDefaultReroutes = _dbrOutput . _4 . _unValue
|
||||
|
||||
resultAllCompanyUsersSecondary :: Lens' AllCompanyTableData Word64
|
||||
resultAllCompanyUsersSecondary = _dbrOutput . _5 . _unValue
|
||||
|
||||
mkFirmAllTable :: Bool -> UserId -> DB (FormResult (FirmActionData, Set CompanyId), Widget)
|
||||
mkFirmAllTable isAdmin uid = do
|
||||
-- now <- liftIO getCurrentTime
|
||||
now <- liftIO getCurrentTime
|
||||
mr <- getMessageRender
|
||||
let
|
||||
resultDBTable = DBTable{..}
|
||||
@ -460,12 +435,13 @@ mkFirmAllTable isAdmin uid = do
|
||||
, cmpy & firmCountUsers -- 2
|
||||
, cmpy & firmHasSupervisors -- 3
|
||||
, cmpy & firmHasDefaultReroutes -- 4
|
||||
-- , cmpy & firmCountEmployeeSupervised -- 4
|
||||
-- , cmpy & firmCountEmployeeRerouted -- 5
|
||||
-- , cmpy & firmCountEmployeeRerPost -- 6
|
||||
-- , cmpy & firmCountForeignSupervisors -- 7
|
||||
-- , cmpy & firmCountActiveReroutes -- 9
|
||||
-- , cmpy & firmCountActiveReroutes' -- 10
|
||||
, cmpy & firmCountUsersSecondary -- 5
|
||||
-- , cmpy & firmCountEmployeeSupervised
|
||||
-- , cmpy & firmCountEmployeeRerouted
|
||||
-- , cmpy & firmCountEmployeeRerPost
|
||||
-- , cmpy & firmCountForeignSupervisors
|
||||
-- , cmpy & firmCountActiveReroutes
|
||||
-- , cmpy & firmCountActiveReroutes'
|
||||
)
|
||||
dbtRowKey = (E.^. CompanyId)
|
||||
dbtProj = dbtProjFilteredPostId
|
||||
@ -478,6 +454,7 @@ mkFirmAllTable isAdmin uid = do
|
||||
in anchorCell (FirmSupersR fsh) $ toWgt fsh
|
||||
, sortable (Just "avsnr") (i18nCell MsgTableCompanyNo) $ \(view resultAllCompany -> firm) -> numCell $ companyAvsId firm
|
||||
, sortable (Just "users") (i18nCell MsgTableCompanyNrUsers) $ \(view resultAllCompanyUsers -> nr) -> wgtCell $ word2widget nr
|
||||
, sortable (Just "secondary") (i18nCell MsgTableCompanyNrSecondaryUsers) $ \(view resultAllCompanyUsersSecondary -> nr) -> wgtCell $ word2widget nr
|
||||
, sortable (Just "supervisors") (i18nCell MsgTableCompanyNrSupersDefault) $ \row ->
|
||||
anchorCell (FirmSupersR $ row ^. resultAllCompany . _companyShorthand) $ toWgt $ hasTickmark $ row ^. resultAllCompanySupervisors
|
||||
, sortable (Just "reroute-def") (i18nCell MsgTableCompanyNrRerouteDefault) $ \(view resultAllCompanyDefaultReroutes -> ok) -> tickmarkCell ok
|
||||
@ -495,6 +472,7 @@ mkFirmAllTable isAdmin uid = do
|
||||
, singletonMap "avsnr" $ SortColumn (E.^. CompanyAvsId)
|
||||
, singletonMap "postal-pref" $ SortColumn (E.^. CompanyPrefersPostal)
|
||||
, singletonMap "users" $ SortColumn firmCountUsers
|
||||
, singletonMap "secondary" $ SortColumn firmCountUsersSecondary
|
||||
, singletonMap "supervisors" $ SortColumn firmHasSupervisors
|
||||
-- , singletonMap "emp-supervised" $ SortColumn firmCountEmployeeSupervised
|
||||
-- , singletonMap "emp-rerouted" $ SortColumn firmCountEmployeeRerouted
|
||||
@ -575,7 +553,7 @@ mkFirmAllTable isAdmin uid = do
|
||||
-- ))
|
||||
-- )
|
||||
-- )
|
||||
-- , single ("is-supervisor", FilterColumn $ \row (getLast -> criterion) ->
|
||||
-- , single ("is-supervisor", FilterColumn $ \row (getLast -> criterion) ->
|
||||
-- case criterion of
|
||||
-- Nothing -> E.true
|
||||
-- (Just (crit::Text)) -> E.exists $ do
|
||||
@ -595,11 +573,11 @@ mkFirmAllTable isAdmin uid = do
|
||||
-- ))
|
||||
-- )
|
||||
-- )
|
||||
, single ("is-supervisor", mkFilterProjectedPost $ \(getLast -> criterion) dbr ->
|
||||
, single ("is-supervisor", mkFilterProjectedPost $ \(getLast -> criterion) dbr ->
|
||||
case criterion of
|
||||
Nothing -> return True :: DB Bool
|
||||
(Just (crit::Text)) -> do
|
||||
critFirms <- memcachedBy (Just . Right $ 5 * diffMinute) ("svr:"<>crit) $ fmap (Set.fromAscList . fmap E.unValue) $ E.select $ E.distinct $ do
|
||||
critFirms <- memcachedBy (Just . Right $ 3 * diffMinute) ("SVR:"<>crit) $ fmap (Set.fromList . fmap E.unValue) $ E.select $ E.distinct $ do
|
||||
(usr :& cmp) <- E.from $ E.table @User `E.innerJoin` E.table @Company
|
||||
`E.on` (\(usr :& cmp) -> E.exists (do
|
||||
usrCmp <- E.from $ E.table @UserCompany
|
||||
@ -612,13 +590,13 @@ mkFirmAllTable isAdmin uid = do
|
||||
E.&&. E.exists (do
|
||||
usrSub <- E.from $ E.table @UserCompany
|
||||
E.where_ $ usrSub E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorUser
|
||||
E.&&. usrSub E.^. UserCompanyCompany E.==. cmp E.^. CompanyId
|
||||
E.&&. usrSub E.^. UserCompanyCompany E.==. cmp E.^. CompanyId
|
||||
)
|
||||
))
|
||||
E.where_ $ (usr E.^. UserDisplayName `E.hasInfix` E.val crit)
|
||||
E.where_ $ (usr E.^. UserDisplayName `E.hasInfix` E.val crit )
|
||||
E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk crit))
|
||||
E.||. (usr E.^. UserSurname `E.hasInfix` E.val crit)
|
||||
E.orderBy [E.asc $ cmp E.^. CompanyId]
|
||||
E.||. (usr E.^. UserSurname `E.hasInfix` E.val crit )
|
||||
-- E.orderBy [E.asc $ cmp E.^. CompanyId]
|
||||
return $ cmp E.^. CompanyId
|
||||
let cid = dbr ^. resultAllCompanyEntity . _entityKey
|
||||
return $ Set.member cid critFirms
|
||||
@ -678,6 +656,18 @@ mkFirmAllTable isAdmin uid = do
|
||||
Just False -> E.notExists checkSuper
|
||||
)
|
||||
, single ("company-postal", FilterColumn $ E.mkExactFilterLast $ views (to queryAllCompany) (E.isJust . (E.^. CompanyPostAddress)))
|
||||
, single ("qualification" , FilterColumn . E.mkExistsFilter $ \row (CI.mk -> criterion :: CI Text) -> do
|
||||
(usrCmp :& usrQual :& qual) <- E.from $ E.table @UserCompany
|
||||
`E.innerJoin` E.table @QualificationUser
|
||||
`E.on` (\(usrCmp :& usrQual) -> usrCmp E.^. UserCompanyUser E.==. usrQual E.^. QualificationUserUser)
|
||||
`E.innerJoin` E.table @Qualification
|
||||
`E.on` (\(_ :& usrQual :& qual) -> qual E.^. QualificationId E.==. usrQual E.^. QualificationUserQualification)
|
||||
E.where_ $ usrCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId
|
||||
E.&&. qual E.^. QualificationShorthand E.==. E.val criterion
|
||||
E.&&. validQualification now usrQual
|
||||
)
|
||||
, single ("company-address", FilterColumn $ E.mkContainsFilterWithCommaPlus id $ views (to queryAllCompany) ((E.->>. "markup-input").(E.^. CompanyPostAddress))
|
||||
)
|
||||
]
|
||||
dbtFilterUI mPrev = mconcat
|
||||
[ fltrCompanyNameUI mPrev
|
||||
@ -687,7 +677,9 @@ mkFirmAllTable isAdmin uid = do
|
||||
, prismAForm (singletonFilter "is-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor)
|
||||
, prismAForm (singletonFilter "is-default-supervisor") mPrev $ aopt textField (fslI MsgFirmSuperDefault)
|
||||
, prismAForm (singletonFilter "foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterForeignSupervisor)
|
||||
, prismAForm (singletonFilter "company-postal" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmExtern)
|
||||
, prismAForm (singletonFilter "company-postal" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmExtern & setTooltip MsgFilterFirmExternTooltip)
|
||||
, prismAForm (singletonFilter "company-address") mPrev $ aopt textField (fslI MsgFirmAddress)
|
||||
, fltrQualificationHdrUI MsgFilterHasQualification mPrev
|
||||
]
|
||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||||
dbtParams = DBParamsForm
|
||||
@ -739,7 +731,9 @@ data FirmUserAction = FirmUserActNotify
|
||||
| FirmUserActResetSupervision
|
||||
| FirmUserActSetSupervisor
|
||||
| FirmUserActMkSuper
|
||||
| FirmUserActChangeDetails
|
||||
| FirmUserActChangeContact
|
||||
| FirmUserActRemove
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
||||
deriving anyclass (Universe, Finite)
|
||||
|
||||
@ -748,20 +742,28 @@ embedRenderMessage ''UniWorX ''FirmUserAction id
|
||||
|
||||
data FirmUserActionData = FirmUserActNotifyData
|
||||
| FirmUserActResetSupervisionData
|
||||
{ firmUserActResetKeepOldSupers :: Maybe Bool
|
||||
-- , firmUserActResetMutualSupervision :: Maybe Bool
|
||||
{ firmUserActResetSupers :: Maybe Bool
|
||||
}
|
||||
| FirmUserActSetSupervisorData
|
||||
{ firmUserActSetSuperNames :: Maybe (Set Text)
|
||||
, firmUserActSetSuperIds :: Maybe [UserId]
|
||||
, firmUserActSetSuperReroute :: Bool
|
||||
, firmUserActSetSuperKeep :: Bool
|
||||
{ firmUserActSetSuperNames :: Maybe (Set Text)
|
||||
, firmUserActSetSuperIds :: Maybe [UserId]
|
||||
, firmUserActSetSuperReason :: Maybe Text
|
||||
, firmUserActSetSuperReroute :: Bool
|
||||
, firmUserActResetSupers :: Maybe Bool
|
||||
}
|
||||
| FirmUserActMkSuperData
|
||||
{ firmUserActMkSuperReroute :: Maybe Bool }
|
||||
{ firmUserActMkSuperReroute :: Maybe Bool }
|
||||
| FirmUserActChangeDetailsData
|
||||
{ firmUserActDetailPriority :: Maybe Int
|
||||
, firmUserActDetailReason :: Maybe Text
|
||||
}
|
||||
| FirmUserActChangeContactData
|
||||
{ firmUserActPostalAddr :: Maybe StoredMarkup
|
||||
, firmUserActPostalPref :: Maybe Bool
|
||||
{ firmUserActPostalAddr :: Maybe StoredMarkup
|
||||
, firmUserActUseCompanyPostal :: Maybe Bool
|
||||
, firmUserActPostalPref :: Maybe Bool
|
||||
}
|
||||
| FirmUserActRemoveData
|
||||
{ firmUserActRemoveSupers :: Bool
|
||||
}
|
||||
deriving (Eq, Ord, Show, Generic)
|
||||
|
||||
@ -773,7 +775,7 @@ queryUserUser = $(sqlIJproj 2 1)
|
||||
queryUserUserCompany :: UserCompanyTableExpr -> E.SqlExpr (Entity UserCompany)
|
||||
queryUserUserCompany = $(sqlIJproj 2 2)
|
||||
|
||||
type UserCompanyTableData = DBRow (Entity User, Entity UserCompany, E.Value Word64, E.Value Word64)
|
||||
type UserCompanyTableData = DBRow (Entity User, Entity UserCompany, E.Value Word64, E.Value Word64, E.Value Bool)
|
||||
|
||||
resultUserUser :: Lens' UserCompanyTableData (Entity User)
|
||||
resultUserUser = _dbrOutput . _1
|
||||
@ -787,6 +789,9 @@ resultUserCompanySupervisors = _dbrOutput . _3 . _unValue
|
||||
resultUserCompanyReroutes :: Lens' UserCompanyTableData Word64
|
||||
resultUserCompanyReroutes = _dbrOutput . _4 . _unValue
|
||||
|
||||
resultUserCompanyPrimary :: Lens' UserCompanyTableData Bool
|
||||
resultUserCompanyPrimary = _dbrOutput . _5 . _unValue
|
||||
|
||||
instance HasEntity UserCompanyTableData User where
|
||||
hasEntity = resultUserUser
|
||||
|
||||
@ -798,37 +803,44 @@ mkFirmUserTable :: Bool -> CompanyId -> DB (FormResult (FirmUserActionData, Set
|
||||
mkFirmUserTable isAdmin cid = do
|
||||
mr <- getMessageRender
|
||||
let
|
||||
mkSprOption (E.Value uid, E.Value udn, E.Value mbSpr) = do
|
||||
reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior
|
||||
mkSprOption (E.Value uid, E.Value udn, E.Value mbSpr, E.Value mbmbReason) = do
|
||||
uuid <- toPathPiece <$> encryptUser uid
|
||||
return (Option{ optionDisplay = udn, optionInternalValue = uid, optionExternalValue = uuid }, mbSpr)
|
||||
return (Option{ optionDisplay = udn, optionInternalValue = uid, optionExternalValue = uuid }, mbSpr, mbmbReason == Just reasonSuperior)
|
||||
|
||||
procOptions rawSupers = do
|
||||
procSupers <- traverse mkSprOption rawSupers
|
||||
return $ mkOptionListGrouped $ filter (notNull . snd)
|
||||
[ (mr MsgFirmSuperDefault , [opt | (opt, Just True ) <- procSupers])
|
||||
, (mr MsgFirmSuperIrregular, [opt | (opt, Just False) <- procSupers])
|
||||
, (mr MsgFirmSuperForeign , [opt | (opt, Nothing ) <- procSupers])
|
||||
[ (mr MsgTableSuperior , [opt | (opt, _ , True ) <- procSupers])
|
||||
, (mr MsgFirmSuperDefault , [opt | (opt, Just True , False) <- procSupers])
|
||||
, (mr MsgFirmSuperIrregular, [opt | (opt, Just False, False) <- procSupers])
|
||||
, (mr MsgFirmSuperForeign , [opt | (opt, Nothing , False) <- procSupers])
|
||||
]
|
||||
|
||||
rawSupers <- E.select $ do
|
||||
(usr :& usrCmp) <- E.from $ E.table @User `E.leftJoin` E.table @UserCompany
|
||||
`E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser E.&&. usrCmp E.?. UserCompanyCompany E.==. E.justVal cid)
|
||||
E.where_ $ E.isTrue (usrCmp E.?. UserCompanySupervisor)
|
||||
E.||. (usrCmp E.?. UserCompanyReason E.?=. E.val reasonSuperior)
|
||||
E.||. E.exists (firmQuerySupervisedBy cid Nothing usr)
|
||||
return (usr E.^. UserId, usr E.^. UserDisplayName, usrCmp E.?. UserCompanySupervisor)
|
||||
return (usr E.^. UserId, usr E.^. UserDisplayName, usrCmp E.?. UserCompanySupervisor, usrCmp E.?. UserCompanyReason)
|
||||
let
|
||||
-- supervisorField :: Field Handler UserId
|
||||
-- supervisorField = selectField' (Just $ SomeMessage MsgMultiNoSelection) $ procOptions rawSupers
|
||||
supervisorsField = multiSelectField' (Just $ SomeMessage MsgMultiNoSelection) $ procOptions rawSupers
|
||||
|
||||
|
||||
fsh = unCompanyKey cid
|
||||
resultDBTable = DBTable{..}
|
||||
where
|
||||
dbtSQLQuery = \(usr `E.InnerJoin` usrCmp) -> do
|
||||
EL.on $ usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser
|
||||
E.where_ $ usrCmp E.^. UserCompanyCompany E.==. E.val cid
|
||||
return (usr, usrCmp, firmCountUserSupervisors usrCmp, firmCountUserSupervisorsReroute usrCmp)
|
||||
let isPrimary = E.notExists (do
|
||||
other <- E.from $ E.table @UserCompany
|
||||
E.where_ $ other E.^. UserCompanyUser E.==. usrCmp E.^. UserCompanyUser
|
||||
E.&&. other E.^. UserCompanyPriority E.>. usrCmp E.^. UserCompanyPriority
|
||||
)
|
||||
return (usr, usrCmp, firmCountUserSupervisors usrCmp, firmCountUserSupervisorsReroute usrCmp, isPrimary)
|
||||
dbtRowKey = queryUserUser >>> (E.^. UserId)
|
||||
dbtProj = dbtProjId
|
||||
dbtColonnade = formColonnade $ mconcat
|
||||
@ -839,7 +851,16 @@ mkFirmUserTable isAdmin cid = do
|
||||
, sortable (Just "supervisors") (i18nCell MsgTableCompanyNrSupers ) $ \(view resultUserCompanySupervisors -> nr) -> wgtCell $ word2widget nr
|
||||
, sortable (Just "reroutes") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultUserCompanyReroutes -> nr) -> wgtCell $ word2widget nr
|
||||
, sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultUserUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b
|
||||
, sortable Nothing (i18nCell MsgCompanyUserUseCompanyAddress) $ \row ->
|
||||
let noUsrAddr = isNothing $ row ^. resultUserUser . _userPostAddress
|
||||
useCompA = row ^. resultUserUserCompany . _entityVal . _userCompanyUseCompanyAddress
|
||||
in tickmarkCell $ noUsrAddr && useCompA
|
||||
, colUserEmail
|
||||
, sortable (Just "usr-reason") (i18nCell MsgTableCompanyReason) $ \(view $ resultUserUserCompany . _entityVal . _userCompanyReason -> r) -> cellMaybe textCell r
|
||||
, sortable (Just "priority") (i18nCell MsgCompanyUserPriority) $ \row ->
|
||||
let prio :: Int = row ^. resultUserUserCompany . _entityVal . _userCompanyPriority
|
||||
isPrime = row ^. resultUserCompanyPrimary
|
||||
in numCell prio <> spacerCell <> ifIconCell isPrime IconTop
|
||||
, sortable Nothing (i18nCell MsgTableUserEdit) $ \(view resultUserUser -> entUsr) -> cellEditUserModal entUsr
|
||||
]
|
||||
dbtSorting = mconcat
|
||||
@ -850,6 +871,8 @@ mkFirmUserTable isAdmin cid = do
|
||||
, singletonMap "personal-number" $ SortColumn $ queryUserUser >>> (E.^. UserCompanyPersonalNumber)
|
||||
, singletonMap "supervisors" $ SortColumn $ queryUserUserCompany >>> firmCountUserSupervisors
|
||||
, singletonMap "reroutes" $ SortColumn $ queryUserUserCompany >>> firmCountUserSupervisorsReroute
|
||||
, singletonMap "usr-reason" $ SortColumn $ queryUserUserCompany >>> (E.^. UserCompanyReason)
|
||||
, singletonMap "priority" $ SortColumn $ queryUserUserCompany >>> (E.^. UserCompanyPriority)
|
||||
]
|
||||
dbtFilter = mconcat
|
||||
[ single $ fltrUserNameEmail queryUserUser
|
||||
@ -905,33 +928,63 @@ mkFirmUserTable isAdmin cid = do
|
||||
usrSpr <- E.from $ E.table @UserSupervisor
|
||||
E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId
|
||||
E.&&. usrSpr E.^. UserSupervisorSupervisor `E.in_` E.vals criteria
|
||||
, singletonMap "is-primary-company" $ FilterColumn $ \row (getLast -> criterion) ->
|
||||
let checkPrimary = do
|
||||
other <- E.from $ E.table @UserCompany
|
||||
E.where_ $ other E.^. UserCompanyUser E.==. queryUserUserCompany row E.^. UserCompanyUser
|
||||
E.&&. other E.^. UserCompanyPriority E.>. queryUserUserCompany row E.^. UserCompanyPriority
|
||||
in case criterion of
|
||||
Nothing -> E.true
|
||||
Just False -> E.exists checkPrimary
|
||||
Just True -> E.notExists checkPrimary
|
||||
]
|
||||
-- superField = selectField $ ????
|
||||
dbtFilterUI mPrev = mconcat
|
||||
[ fltrUserNameEmailHdrUI MsgTableCompanyUser mPrev
|
||||
-- , prismAForm (singletonFilter "supervisor-is" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift supervisorField) (fslI MsgFilterSupervisor)
|
||||
, prismAForm (multiFilter "supervisors-are" . maybePrism monoPathPieces) mPrev $ aopt (hoistField lift supervisorsField) (fslI MsgFilterSupervisor & setTooltip MsgMultiSelectTip)
|
||||
, prismAForm (singletonFilter "has-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterSupervisor)
|
||||
, prismAForm (singletonFilter "has-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterSupervisor)
|
||||
, prismAForm (singletonFilter "has-company-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorCompany fsh)
|
||||
, prismAForm (singletonFilter "has-foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorForeign fsh)
|
||||
, prismAForm (singletonFilter "is-primary-company" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmPrimary)
|
||||
]
|
||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||||
userReasons :: HandlerFor UniWorX (OptionList Text)
|
||||
userReasons = fmap (mkOptionList . map (\t -> Option t t t) . Set.toAscList) . runDB $
|
||||
fmap (setOf $ folded . _Value . _Just) . E.select . E.distinct $ do
|
||||
usrc <- E.from $ E.table @UserCompany
|
||||
E.where_ $ E.isJust (usrc E.^. UserCompanyReason)
|
||||
E.&&. usrc E.^. UserCompanyCompany E.==. E.val cid
|
||||
return $ usrc E.^. UserCompanyReason
|
||||
superReasons :: HandlerFor UniWorX (OptionList Text)
|
||||
superReasons = fmap (mkOptionList . map (\t -> Option t t t) . Set.toAscList) . runDB $
|
||||
fmap (setOf $ folded . _Value . _Just) . E.select . E.distinct $ do
|
||||
usrc <- E.from $ E.table @UserSupervisor
|
||||
E.where_ $ E.isJust (usrc E.^. UserSupervisorReason)
|
||||
E.&&. usrc E.^. UserSupervisorCompany E.~=. E.val cid
|
||||
return $ usrc E.^. UserSupervisorReason
|
||||
acts :: Map FirmUserAction (AForm Handler FirmUserActionData)
|
||||
acts = mconcat
|
||||
[ guardMonoid isAdmin $ singletonMap FirmUserActNotify $ pure FirmUserActNotifyData
|
||||
, singletonMap FirmUserActResetSupervision $ FirmUserActResetSupervisionData
|
||||
<$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False)
|
||||
-- <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True )
|
||||
<$> aopt (boolFieldCustom (SomeMessage MsgFirmActResetSupersRemoveAll) (SomeMessage MsgFirmActResetSupersRemoveAps) $ Just $ SomeMessage MsgFirmActResetSupersKeepAll) (fslI MsgFirmActResetSuperKeep) (Just $ Just False)
|
||||
, singletonMap FirmUserActSetSupervisor $ FirmUserActSetSupervisorData
|
||||
<$> aopt (textField & cfAnySeparatedSet) (fslI MsgFirmNewSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
|
||||
<*> aopt supervisorsField (fslI MsgFirmSetSupervisor & setTooltip MsgMultiSelectTip) Nothing
|
||||
<*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just False)
|
||||
<*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just False)
|
||||
<*> aopt (textField & cfStrip & addDatalist superReasons) (fslI MsgUserSupervisorReason & setTooltip MsgUserSupervisorReasonTooltip) Nothing
|
||||
<*> areq boolField' (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just False)
|
||||
<*> aopt (boolFieldCustom (SomeMessage MsgFirmActResetSupersRemoveAll) (SomeMessage MsgFirmActResetSupersRemoveAps) $ Just $ SomeMessage MsgFirmActResetSupersKeepAll) (fslI MsgFirmActResetSuperKeep) (Just $ Just False)
|
||||
, singletonMap FirmUserActMkSuper $ FirmUserActMkSuperData
|
||||
<$> aopt checkBoxField (fslI MsgTableIsDefaultReroute) (Just $ Just True)
|
||||
, singletonMap FirmUserActChangeContact $ FirmUserActChangeContactData
|
||||
<$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing
|
||||
<*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing
|
||||
<$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing
|
||||
<*> aopt boolField' (fslI MsgCompanyUserUseCompanyAddress & setTooltip MsgCompanyUserUseCompanyAddressTip) Nothing
|
||||
<*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing
|
||||
, singletonMap FirmUserActChangeDetails $ FirmUserActChangeDetailsData
|
||||
<$> aopt intField (fslI MsgCompanyUserPriority & setTooltip MsgCompanyUserPriorityTip) Nothing
|
||||
<*> aopt (textField & cfStrip & addDatalist userReasons) (fslI MsgUserCompanyReason & setTooltip (SomeMessages [SomeMessage MsgUserCompanyReasonTooltip, SomeMessage MsgNullDeletes])) Nothing
|
||||
, singletonMap FirmUserActRemove $ FirmUserActRemoveData
|
||||
<$> areq boolField' (fslI MsgFirmActRemoveSupers) (Just True)
|
||||
]
|
||||
dbtParams = DBParamsForm
|
||||
{ dbParamsFormMethod = POST
|
||||
@ -998,6 +1051,10 @@ postFirmUsersR fsh = do
|
||||
-- return usr
|
||||
<*> mkFirmUserTable isAdmin cid
|
||||
|
||||
let resetSupers :: Maybe Bool -> NonEmpty UserId -> DB Int64
|
||||
resetSupers Nothing _ = return 0
|
||||
resetSupers (Just False) uids = deleteDefaultSupervisorsForUsers [] [] uids
|
||||
resetSupers (Just True ) uids = deleteWhereCount [UserSupervisorUser <-. toList uids]
|
||||
formResult fusrRes $ \case
|
||||
(_, uids) | null uids -> addMessageI Error MsgUtilEmptyChoice
|
||||
(FirmUserActNotifyData , uids) -> do
|
||||
@ -1005,10 +1062,8 @@ postFirmUsersR fsh = do
|
||||
redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids])
|
||||
(FirmUserActResetSupervisionData{..}, set2NonEmpty (error "Unexpected empty user list in getFirmUserR action handler.") -> uids) -> do -- set guaranteed to be non-empty due to first case clause
|
||||
runDB $ do
|
||||
delSupers <- if firmUserActResetKeepOldSupers == Just False
|
||||
then deleteSupervisors uids
|
||||
else return 0
|
||||
newSupers <- addDefaultSupervisors cid uids
|
||||
delSupers <- resetSupers firmUserActResetSupers uids
|
||||
newSupers <- addDefaultSupervisors Nothing cid uids
|
||||
addMessageI Info $ MsgFirmResetSupervision delSupers newSupers
|
||||
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
|
||||
(FirmUserActSetSupervisorData{..}, set2NonEmpty (error "Unexpected empty user list in getFirmUserR action handler.") -> uids) -> do
|
||||
@ -1026,27 +1081,55 @@ postFirmUsersR fsh = do
|
||||
<li>#{usr}
|
||||
|]
|
||||
in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent)
|
||||
delSupers <- runDB
|
||||
$ bool (deleteSupervisors uids) (return 0) firmUserActSetSuperKeep
|
||||
<* putMany [UserSupervisor s u firmUserActSetSuperReroute | u <- toList uids, s <- newSupers]
|
||||
delSupers <- runDB $ resetSupers firmUserActResetSupers uids
|
||||
<* putMany [UserSupervisor s u firmUserActSetSuperReroute (Just cid) firmUserActSetSuperReason | u <- toList uids, s <- newSupers]
|
||||
addMessageI Success $ MsgFirmSetSupersReport nrUsers nrSupers delSupers
|
||||
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
|
||||
|
||||
(FirmUserActMkSuperData{..}, Set.toList -> uids) -> do
|
||||
nrMkSuper <- runDB $ updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. (firmUserActMkSuperReroute == Just True)]
|
||||
addMessageI Info $ MsgFirmActAddSupersSet nrMkSuper Nothing
|
||||
nrUpd <- runDB $ updateWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. uids] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. (firmUserActMkSuperReroute == Just True)]
|
||||
addMessageI Success $ MsgFirmActAddSupersSet nrUpd Nothing
|
||||
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
|
||||
(FirmUserActChangeContactData{..}, Set.toList -> uids) ->
|
||||
let changes = catMaybes
|
||||
[ (UserPostAddress =.) . Just <$> canonical firmUserActPostalAddr -- note that Nothing means no change and not delete address!
|
||||
, (UserPrefersPostal =.) <$> firmUserActPostalPref
|
||||
]
|
||||
in unless (null changes) $ do
|
||||
nrChanged <- runDB $ updateWhereCount [UserId <-. uids] changes
|
||||
addMessageI Success $ MsgFirmUserChanges nrChanged
|
||||
(FirmUserActChangeDetailsData{..}, Set.toList -> uids) -> do
|
||||
let upReason = case canonical firmUserActDetailReason of
|
||||
Nothing -> Nothing
|
||||
Just "NULL" -> Just $ UserCompanyReason =. Nothing
|
||||
other -> Just $ UserCompanyReason =. other
|
||||
nrUpd <- runDB $ updateWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. uids] $ catMaybes [upReason, (UserCompanyPriority =.) <$> firmUserActDetailPriority]
|
||||
let total = fromIntegral $ length uids
|
||||
allok = bool Warning Success $ nrUpd == total
|
||||
addMessageI allok $ MsgFirmUserActChangeDetailsResult nrUpd total
|
||||
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
|
||||
(FirmUserActChangeContactData{..}, Set.toList -> uids)
|
||||
| firmUserActUseCompanyPostal == Just True, isJust firmUserActPostalAddr ->
|
||||
addMessageI Error MsgCompanyUserUseCompanyPostalError
|
||||
| otherwise -> do
|
||||
let changes = catMaybes
|
||||
[ toMaybe (firmUserActUseCompanyPostal == Just True) (UserPostAddress =. Nothing) -- precondition ensures that only one update applies for UserPostAddress
|
||||
, (UserPostAddress =.) . Just <$> canonical firmUserActPostalAddr -- note that Nothing means no change and not delete address!
|
||||
, (UserPrefersPostal =.) <$> firmUserActPostalPref
|
||||
]
|
||||
nrChanged <- runDB $ do
|
||||
nrUsrChange <- updateWhereCount [UserId <-. uids] changes
|
||||
nrUseComp <- case firmUserActUseCompanyPostal of
|
||||
Just x -> updateWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. uids] [UserCompanyUseCompanyAddress =. x]
|
||||
Nothing -> return 0
|
||||
return $ max nrUsrChange nrUseComp
|
||||
let total = fromIntegral $ length uids
|
||||
allok = bool Warning Success $ nrChanged == total
|
||||
addMessageI allok $ MsgFirmUserActChangeResult nrChanged total
|
||||
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
|
||||
(FirmUserActRemoveData{..}, Set.toList -> uids) -> do
|
||||
let optRemove = if firmUserActRemoveSupers then id else const $ return 0
|
||||
(nrUc, nrSuper, nrSubs) <- runDB $ (,,)
|
||||
<$> deleteWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. uids]
|
||||
<*> optRemove (deleteWhereCount [UserSupervisorCompany ==. Just cid, UserSupervisorSupervisor <-. uids])
|
||||
<*> optRemove (deleteWhereCount [UserSupervisorCompany ==. Just cid, UserSupervisorUser <-. uids])
|
||||
let total = fromIntegral $ length uids
|
||||
allok = bool Warning Success $ total == nrUc
|
||||
addMessageI allok $ someMessages [MsgFirmUserActRemoveResult nrUc, MsgFirmRemoveSupervision nrSuper nrSubs]
|
||||
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
|
||||
|
||||
formFirmAction <- runFirmActionFormPost cid (FirmUsersR fsh) isAdmin [FirmActNotify, FirmActResetSupervision, FirmActAddSupersvisors, FirmActChangeContactFirm, FirmActChangeContactUser]
|
||||
formFirmAction <- runFirmActionFormPost cid (FirmUsersR fsh) isAdmin [FirmActNotify, FirmActResetSupervision, FirmActAddSupervisors, FirmActChangeContactFirm, FirmActChangeContactUser]
|
||||
|
||||
siteLayout (citext2widget companyName) $ do
|
||||
setTitle $ toHtml $ CI.original companyShorthand <> "-" <> tshow companyAvsId
|
||||
@ -1073,7 +1156,7 @@ data FirmSuperActionData = FirmSuperActNotifyData
|
||||
, firmSuperActSwitchReroute :: Maybe Bool
|
||||
}
|
||||
| FirmSuperActRMSuperDefData
|
||||
{ firmSuperActRMSuperActive :: Maybe Bool }
|
||||
{ firmSuperActRMSuperActive :: Bool }
|
||||
|
||||
deriving (Eq, Ord, Show, Generic)
|
||||
|
||||
@ -1089,6 +1172,7 @@ querySuperUserCompany = $(sqlLOJproj 2 2)
|
||||
type SuperCompanyTableData = DBRow (Entity User, E.Value Word64, E.Value Word64
|
||||
, [(E.Value CompanyName, E.Value CompanyShorthand, E.Value Bool)]
|
||||
, E.Value (Maybe Bool), E.Value (Maybe Bool) -- Maybe (Entity UserCompany)
|
||||
, E.Value Bool
|
||||
)
|
||||
|
||||
resultSuperUser :: Lens' SuperCompanyTableData (Entity User)
|
||||
@ -1109,6 +1193,9 @@ resultSuperCompanyDefaultSuper = _dbrOutput . _5 . _unValue
|
||||
resultSuperCompanyDefaultReroute :: Lens' SuperCompanyTableData (Maybe Bool)
|
||||
resultSuperCompanyDefaultReroute = _dbrOutput . _6 . _unValue
|
||||
|
||||
resultSuperCompanySuperior :: Lens' SuperCompanyTableData Bool
|
||||
resultSuperCompanySuperior = _dbrOutput . _7 . _unValue
|
||||
|
||||
instance HasEntity SuperCompanyTableData User where
|
||||
hasEntity = resultSuperUser
|
||||
|
||||
@ -1120,27 +1207,31 @@ mkFirmSuperTable :: Bool -> CompanyId -> DB (FormResult (FirmSuperActionData, Se
|
||||
mkFirmSuperTable isAdmin cid = do
|
||||
msgSupervisorUnchanged <- messageI Info MsgFirmSuperActSwitchSuperInfo
|
||||
let
|
||||
reasonSuperior = tshow SupervisorReasonAvsSuperior
|
||||
-- fsh = unCompanyKey cid
|
||||
resultDBTable = DBTable{..}
|
||||
where
|
||||
dbtSQLQuery = \(usr `E.LeftOuterJoin` usrCmp) -> do
|
||||
EL.on $ usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser E.&&. usrCmp E.?. UserCompanyCompany E.?=. E.val cid
|
||||
E.where_ $ E.isTrue (usrCmp E.?. UserCompanySupervisor)
|
||||
E.||. E.exists (firmQuerySupervisedBy cid Nothing usr)
|
||||
E.where_ $ E.isTrue (usrCmp E.?. UserCompanySupervisor) E.||. E.exists (firmQuerySupervisedBy cid Nothing usr)
|
||||
-- let uc_reason = E.joinV (usrCmp E.?. UserCompanyReason)
|
||||
return ( usr
|
||||
, usr & firmCountForSupervisor cid Nothing
|
||||
, usr & firmCountForSupervisor cid (Just (E.^. UserSupervisorRerouteNotifications))
|
||||
, usrCmp E.?. UserCompanySupervisor
|
||||
, usrCmp E.?. UserCompanySupervisorReroute
|
||||
-- , (E.isJust uc_reason E.&&. uc_reason E.==. E.justVal reasonSuperior) -- NOTE: this is problematic, as obvious approaches caused errors such as: Failed to parse Haskell type bool, received PersistNull, since the SQL comparison with NULL returns NULL
|
||||
, (E.coalesceDefault [E.joinV (usrCmp E.?. UserCompanyReason)] (E.val mempty) E.==. E.val reasonSuperior) -- works as well
|
||||
E.||. E.exists (firmQuerySupervisedBy cid (Just (\usrSpr -> usrSpr E.^. UserSupervisorReason E.==. E.justVal reasonSuperior)) usr)
|
||||
)
|
||||
dbtRowKey = querySuperUser >>> (E.^. UserId)
|
||||
dbtProj = dbtProjSimple $ \(usr, supervised, rerouted, supervisor, reroute) -> do
|
||||
dbtProj = dbtProjSimple $ \(usr, supervised, rerouted, supervisor, reroute, isSuperior) -> do
|
||||
cmps <- E.select $ 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_ $ usrCmp E.^. UserCompanyUser E.==. E.val (entityKey usr)
|
||||
E.orderBy [E.asc $ cmp E.^. CompanyName]
|
||||
return (cmp E.^. CompanyName, cmp E.^. CompanyShorthand, usrCmp E.^. UserCompanySupervisor)
|
||||
return (usr, supervised, rerouted, cmps, supervisor, reroute)
|
||||
return (usr, supervised, rerouted, cmps, supervisor, reroute, isSuperior)
|
||||
dbtColonnade = formColonnade $ mconcat
|
||||
[ dbSelect (applying _2) id (return . view (resultSuperUser . _entityKey))
|
||||
, colUserNameModalHdr MsgTableSupervisor ForProfileDataR
|
||||
@ -1152,7 +1243,11 @@ mkFirmSuperTable isAdmin cid = do
|
||||
, colUserEmail
|
||||
, sortable (Just "supervised") (i18nCell MsgTableCompanyNrEmpSupervised) $ \(view resultSuperCompanySupervised -> nr) -> wgtCell $ word2widget nr
|
||||
, sortable (Just "rerouted") (i18nCell MsgTableCompanyNrEmpRerouted ) $ \(view resultSuperCompanyReroutes -> nr) -> wgtCell $ word2widget nr
|
||||
, sortable (Just "def-super") (i18nCell MsgTableIsDefaultSupervisor) $ \(view resultSuperCompanyDefaultSuper -> mb) -> case mb of { Nothing -> iconCell IconSupervisorForeign; Just True -> iconCell IconSupervisor; Just False -> iconSpacerCell }
|
||||
, sortable (Just "def-super") (i18nCell MsgTableIsDefaultSupervisor) $ view resultSuperCompanyDefaultSuper >>> \case
|
||||
Nothing -> iconCell IconSupervisorForeign
|
||||
(Just True ) -> iconCell IconSupervisor
|
||||
(Just False) -> iconSpacerCell
|
||||
, sortable Nothing (i18nCell MsgTableSuperior) $ view resultSuperCompanySuperior >>> flip ifIconCell IconSuperior
|
||||
, sortable (Just "def-reroute") (i18nCell MsgTableIsDefaultReroute) $ \(view resultSuperCompanyDefaultReroute -> mb) -> tickmarkCell (mb == Just True)
|
||||
, sortable Nothing (i18nCell MsgTableUserEdit) $ \(view resultSuperUser -> entUsr) -> cellEditUserModal entUsr
|
||||
]
|
||||
@ -1175,20 +1270,40 @@ mkFirmSuperTable isAdmin cid = do
|
||||
]
|
||||
dbtFilter = mconcat
|
||||
[ single $ fltrUserNameEmail querySuperUser
|
||||
, singletonMap "is-foreign-supervisor" $ FilterColumn $ \(querySuperUserCompany -> suc) (getLast -> criterion) ->
|
||||
case criterion of
|
||||
Nothing -> E.true
|
||||
Just True -> E.isNothing $ suc E.?. UserCompanyUser
|
||||
Just False -> E.isJust $ suc E.?. UserCompanyUser
|
||||
, singletonMap "super-relation-foreign" $ FilterColumn $ \row (getLast -> criterion) ->
|
||||
let checkSuper = do
|
||||
usrSpr <- E.from $ E.table @UserSupervisor
|
||||
E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. querySuperUser row E.^. UserId
|
||||
E.&&. E.exists (do
|
||||
usr <- E.from $ E.table @UserCompany
|
||||
E.where_ $ usr E.^. UserCompanyCompany E.!=. E.val cid
|
||||
E.&&. usr E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorUser
|
||||
)
|
||||
in case criterion of
|
||||
Nothing -> E.true
|
||||
Just True -> E.exists checkSuper
|
||||
Just False -> E.notExists checkSuper
|
||||
]
|
||||
dbtFilterUI mPrev = mconcat
|
||||
[ fltrUserNameEmailHdrUI MsgTableSupervisor mPrev
|
||||
, prismAForm (singletonFilter "is-foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmSuperForeign)
|
||||
, prismAForm (singletonFilter "super-relation-foreign" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterIsForeignSupervisee)
|
||||
]
|
||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||||
acts :: Map FirmSuperAction (AForm Handler FirmSuperActionData)
|
||||
acts = mconcat
|
||||
[ guardMonoid isAdmin $ singletonMap FirmSuperActNotify $ pure FirmSuperActNotifyData
|
||||
, singletonMap FirmSuperActSwitchSuper $ FirmSuperActSwitchSuperData
|
||||
<$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableIsDefaultSupervisor) (Just $ Just True)
|
||||
<*> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableIsDefaultReroute) Nothing
|
||||
<$> aopt boolField' (fslI MsgFirmSuperDefault) (Just $ Just True)
|
||||
<*> aopt boolField' (fslI MsgTableIsDefaultReroute) Nothing
|
||||
<* aformMessage msgSupervisorUnchanged
|
||||
, singletonMap FirmSuperActRMSuperDef $ FirmSuperActRMSuperDefData
|
||||
<$> aopt checkBoxField (fslI MsgFirmSuperActRMSuperActive) (Just $ Just True)
|
||||
<$> areq boolField' (fslI MsgFirmSuperActRMSuperActive) (Just True)
|
||||
]
|
||||
dbtParams = DBParamsForm
|
||||
{ dbParamsFormMethod = POST
|
||||
@ -1232,19 +1347,14 @@ postFirmSupersR fsh = do
|
||||
formResult fsprRes $ \case
|
||||
(_, uids) | null uids -> addMessageI Error MsgUtilEmptyChoice
|
||||
(FirmSuperActRMSuperDefData{..}, Set.toList -> uids) -> do
|
||||
(nrRmSuper,nrRmActual) <- runDB $ (,)
|
||||
let optRemove = if firmSuperActRMSuperActive then id else const $ return 0
|
||||
(nrRmSuper,nrRmSupers,nrRmSubs) <- runDB $ (,,)
|
||||
<$> updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False]
|
||||
<*> if firmSuperActRMSuperActive /= Just True
|
||||
then return 0
|
||||
else E.deleteCount $ do
|
||||
spr <- E.from $ E.table @UserSupervisor
|
||||
E.where_ $ spr E.^. UserSupervisorSupervisor `E.in_` E.vals uids
|
||||
E.&&. E.exists (do
|
||||
usr <- E.from $ E.table @UserCompany
|
||||
E.where_ $ usr E.^. UserCompanyCompany E.==. E.val cid
|
||||
E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser
|
||||
)
|
||||
addMessageI Info $ MsgRemoveSupervisors nrRmSuper nrRmActual
|
||||
<*> optRemove (deleteWhereCount [UserSupervisorCompany ==. Just cid, UserSupervisorSupervisor <-. uids])
|
||||
<*> optRemove (deleteWhereCount [UserSupervisorCompany ==. Just cid, UserSupervisorUser <-. uids])
|
||||
let total = fromIntegral $ length uids
|
||||
allok = bool Warning Success $ total == nrRmSuper
|
||||
addMessageI allok $ someMessages [MsgRemoveSupervisors nrRmSuper, MsgFirmRemoveSupervision nrRmSupers nrRmSubs]
|
||||
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
|
||||
(FirmSuperActSwitchSuperData{..}, Set.toList -> uids) -> do
|
||||
let (fltrSpr, changes) = case (firmSuperActSwitchSuper, firmSuperActSwitchReroute) of
|
||||
@ -1262,9 +1372,9 @@ postFirmSupersR fsh = do
|
||||
cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser]
|
||||
redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids])
|
||||
|
||||
formFirmAction <- runFirmActionFormPost cid (FirmSupersR fsh) isAdmin [FirmActAddSupersvisors, FirmActResetSupervision, FirmActChangeContactFirm]
|
||||
formFirmAction <- runFirmActionFormPost cid (FirmSupersR fsh) isAdmin [FirmActAddSupervisors, FirmActResetSupervision, FirmActChangeContactFirm]
|
||||
|
||||
siteLayout (citext2widget fsh) $ do
|
||||
siteLayout (citext2widget companyName) $ do
|
||||
setTitle $ citext2Html $ fsh <> " Supers"
|
||||
let firmContactInfo = $(widgetFile "firm-contact-info")
|
||||
$(i18nWidgetFile "firm-supervisors")
|
||||
@ -1299,14 +1409,14 @@ handleFirmCommR ultDest cs = do
|
||||
csKeys = CompanyKey <$> cs
|
||||
mbUser <- maybeAuthId
|
||||
-- get employees of chosen companies
|
||||
empys <- mkCompanyUsrList <$> runDB (E.select $ do
|
||||
empys <- mkCompanyUsrList <$> runDBRead (E.select $ do
|
||||
(emp :& cmp) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& cmp) -> emp E.^. UserId E.==. cmp E.^. UserCompanyUser)
|
||||
E.where_ $ cmp E.^. UserCompanyCompany `E.in_` E.valList csKeys
|
||||
E.orderBy [E.ascNullsFirst $ cmp E.^. UserCompanyCompany]
|
||||
return (E.just $ cmp E.^. UserCompanyCompany, emp E.^. UserId)
|
||||
)
|
||||
-- get supervisors of employees
|
||||
sprs <- mkCompanyUsrList <$> runDB (E.select $ do
|
||||
sprs <- mkCompanyUsrList <$> runDBRead (E.select $ do
|
||||
(spr :& cmp) <- E.from $ E.table @User `E.leftJoin` E.table @UserCompany `E.on` (\(spr :& cmp) -> spr E.^. UserId E.=?. cmp E.?. UserCompanyUser)
|
||||
E.where_ $ (E.isTrue (cmp E.?. UserCompanySupervisor) E.&&. cmp E.?. UserCompanyCompany `E.in_` E.justValList csKeys)
|
||||
E.||. (spr E.^. UserId E.=?. E.val mbUser)
|
||||
|
||||
@ -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
|
||||
@ -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")
|
||||
@ -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
|
||||
|
||||
@ -81,11 +81,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 +112,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 +149,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 +183,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 +220,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 +241,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 +283,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)
|
||||
@ -309,7 +317,7 @@ queryQualBlock :: LmsTableExpr -> E.SqlExpr (Maybe (Entity QualificationUserBloc
|
||||
queryQualBlock = $(sqlLOJproj 2 2)
|
||||
|
||||
|
||||
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,19 @@ 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
|
||||
primeComp = E.subSelect . E.from $ \uc -> do
|
||||
E.where_ $ user E.^. UserId E.==. uc E.^. UserCompanyUser
|
||||
E.orderBy [E.desc $ uc E.^. UserCompanyPriority, E.asc $ uc E.^. UserCompanyCompany]
|
||||
return (uc E.^. UserCompanyCompany)
|
||||
return (qualUser, user, lmsUser, qualBlock, printAcknowledged, primeComp, validQualification now qualUser)
|
||||
|
||||
|
||||
mkLmsTable :: ( Functor h, ToSortable h
|
||||
@ -423,26 +436,27 @@ 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 $ 15 * 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
|
||||
dbtProj = dbtProjId
|
||||
dbtColonnade = cols getCompanyName
|
||||
dbtSorting = mconcat
|
||||
[ single $ sortUserNameLink queryUser
|
||||
, single $ sortUserEmail queryUser
|
||||
@ -486,43 +500,37 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
|
||||
-- )
|
||||
, single ("notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.^. LmsUserNotified)))
|
||||
, single ("avs-number" , FilterColumn . E.mkExistsFilter $ \row criterion ->
|
||||
E.from $ \usrAvs -> -- do
|
||||
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
|
||||
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)
|
||||
)
|
||||
)
|
||||
, fltrAVSCardNos queryUser
|
||||
, single ("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 +547,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 +605,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 +659,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 +681,7 @@ postLmsR sid qsh = do
|
||||
$maybe ackdate <- mbackdate
|
||||
^{formatTimeW SelFormatDateTime ackdate}
|
||||
$nothing
|
||||
_{MsgPrintJobUnacknowledged}
|
||||
_{MsgPrintJobUnacknowledged}
|
||||
<p>
|
||||
<a href=@{lprLink}>
|
||||
_{MsgPrintJobs}
|
||||
@ -700,58 +700,59 @@ 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
|
||||
then updateWhereCount ([LmsUserQualification ==. qid, LmsUserUser <-. usersList, LmsUserResetTries ==. False, LmsUserEnded ==. Nothing] -- , LmsUserLocked ==. True] -- needs to be locked for reset, but this is counter-intuitive for users; should be harmles, but delays reset until lock is effective
|
||||
++ ([LmsUserStatus ==. Just LmsBlocked] ||. [LmsUserStatus ==. Just LmsExpired])) [LmsUserResetTries =. True]
|
||||
then updateWhereCount ([LmsUserQualification ==. qid, LmsUserUser <-. usersList, LmsUserResetTries ==. False, LmsUserEnded ==. Nothing] -- , LmsUserLocked ==. True] -- needs to be locked for reset, but this is counter-intuitive for users; should be harmless, but delays reset until lock is effective
|
||||
++ ([LmsUserStatus ==. Just LmsBlocked] ||. [LmsUserStatus ==. Just LmsExpired]))
|
||||
(bcons actRestartNotify (LmsUserNotified =. Nothing) [LmsUserResetTries =. True])
|
||||
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 +768,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 +798,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 +823,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 +833,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")
|
||||
|
||||
@ -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)]
|
||||
|
||||
@ -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!
|
||||
@ -92,7 +93,7 @@ instance CsvColumnsExplained LmsUserTableCsv where
|
||||
|
||||
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 +167,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 +175,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 +200,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 +213,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
|
||||
|
||||
@ -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
|
||||
@ -121,7 +125,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 +203,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 +250,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 +267,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 +304,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 +325,7 @@ postLmsReportUploadR sid qsh = do
|
||||
setTitleI MsgMenuLmsUpload
|
||||
[whamlet|$newline never
|
||||
<form method=post enctype=#{enctype}>
|
||||
^{widget}
|
||||
^{widget}
|
||||
<input type=submit>
|
||||
|]
|
||||
|
||||
@ -308,18 +339,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
|
||||
|
||||
375
src/Handler/MailCenter.hs
Normal file
375
src/Handler/MailCenter.hs
Normal file
@ -0,0 +1,375 @@
|
||||
-- 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
|
||||
|
||||
|
||||
|
||||
-- avoids repetition of local definitions
|
||||
single :: (k,a) -> Map k a
|
||||
single = uncurry Map.singleton
|
||||
|
||||
|
||||
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 = mconcat
|
||||
[ single ("sent" , SortColumn $ queryMail >>> (E.^. SentMailSentAt))
|
||||
, single ("recipient" , sortUserNameBareM queryRecipient)
|
||||
]
|
||||
dbtFilter = mconcat
|
||||
[ single ("sent" , FilterColumn . E.mkDayFilterTo $ views (to queryMail) (E.^. SentMailSentAt))
|
||||
, single ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryRecipient) (E.?. UserDisplayName))
|
||||
, single ("subject" , FilterColumn . E.mkContainsFilterWithCommaPlus id $ views (to queryMail) (E.str2text . (E.^. SentMailHeaders)))
|
||||
-- , single ("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
|
||||
@ -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
|
||||
|
||||
@ -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,15 +20,15 @@ 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
|
||||
|
||||
import qualified Data.Aeson as Aeson
|
||||
-- import qualified Data.Text as Text
|
||||
import qualified Data.Text as Text
|
||||
-- import qualified Data.Set as Set
|
||||
|
||||
import Handler.Utils
|
||||
@ -56,7 +56,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 +71,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 +82,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 +94,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 +133,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 +146,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 +171,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,6 +218,7 @@ 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
|
||||
@ -218,6 +231,7 @@ mkPJTable = do
|
||||
, single ("acknowledged" , SortColumn $ queryPrintJob >>> (E.^. PrintJobAcknowledged))
|
||||
, single ("apcid" , SortColumn $ queryPrintJob >>> (E.^. PrintJobApcIdent))
|
||||
, single ("recipient" , sortUserNameBareM queryRecipient)
|
||||
, single ("affected" , sortUserNameBareM queryAffected)
|
||||
, single ("sender" , sortUserNameBareM querySender )
|
||||
, single ("course" , SortColumn $ queryCourse >>> (E.?. CourseName))
|
||||
, single ("qualification", SortColumn $ queryQualification >>> (E.?. QualificationName))
|
||||
@ -230,6 +244,7 @@ mkPJTable = do
|
||||
, 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 ("affected" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryAffected) (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))
|
||||
@ -244,11 +259,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)
|
||||
]
|
||||
@ -440,7 +456,7 @@ postPrintAckR ackDay numAck chksm = do
|
||||
-- | otherwise = pure "ERROR"
|
||||
|
||||
saveApcident :: UTCTime -> Natural -> Text -> JobDB Natural
|
||||
saveApcident t i apci = insert_ (PrintAcknowledge apci t False) >> return (succ i)
|
||||
saveApcident t i apci = insert_ (PrintAcknowledge (Text.strip apci) t False) >> return (succ i)
|
||||
|
||||
|
||||
makeAckUploadForm :: Form FileInfo
|
||||
|
||||
@ -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,72 +590,124 @@ 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)
|
||||
externalUsers <- (\(Entity _ ExternalUser{..}) -> (externalUserUser, externalUserSource, externalUserLastSync)) <<$>> selectList [ ExternalUserUser ==. userIdent ] []
|
||||
|
||||
-- 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")
|
||||
|
||||
@ -657,7 +724,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
|
||||
@ -698,26 +765,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
|
||||
@ -727,7 +804,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 )
|
||||
@ -750,7 +834,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
|
||||
@ -760,9 +844,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
|
||||
@ -773,7 +857,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
|
||||
@ -784,7 +868,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
|
||||
@ -828,14 +912,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
|
||||
@ -844,8 +924,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
|
||||
@ -858,7 +938,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
|
||||
@ -887,10 +967,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
|
||||
@ -898,18 +978,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
|
||||
@ -923,7 +1003,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)
|
||||
@ -960,7 +1040,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
|
||||
@ -974,29 +1054,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
|
||||
@ -1008,6 +1088,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
|
||||
@ -1126,7 +1325,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
|
||||
|
||||
@ -14,12 +14,11 @@ module Handler.Qualification
|
||||
|
||||
import Import
|
||||
|
||||
-- import Jobs
|
||||
import Jobs
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Users
|
||||
import Handler.Utils.LMS
|
||||
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Csv as Csv
|
||||
@ -56,7 +55,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 +65,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 +139,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 +151,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 +173,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 +207,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 +235,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 +249,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 +269,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 +293,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 +337,23 @@ 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)
|
||||
let primeComp = E.subSelect . E.from $ \uc -> do
|
||||
E.where_ $ user E.^. UserId E.==. uc E.^. UserCompanyUser
|
||||
E.orderBy [E.desc $ uc E.^. UserCompanyPriority, E.asc $ uc E.^. UserCompanyCompany]
|
||||
return (uc E.^. UserCompanyCompany)
|
||||
return (qualUser, user, lmsUser, qualBlock, primeComp)
|
||||
|
||||
|
||||
mkQualificationTable ::
|
||||
@ -353,18 +362,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 $ 15 * 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,15 +384,8 @@ 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
|
||||
dbtProj = dbtProjId
|
||||
dbtColonnade = cols getCompanyName
|
||||
dbtSorting = mconcat
|
||||
[ single $ sortUserNameLink queryUser
|
||||
, single $ sortUserEmail queryUser
|
||||
@ -391,7 +395,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
|
||||
, 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)
|
||||
, single ("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))
|
||||
@ -404,32 +408,26 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
|
||||
-- , single ("validity", SortColumn $ queryQualUser >>> validQualification now)
|
||||
]
|
||||
dbtFilter = mconcat
|
||||
[ single $ fltrUserNameEmail queryUser
|
||||
[ single $ fltrUserNameEmail queryUser
|
||||
, single ("avs-number" , FilterColumn . E.mkExistsFilter $ \row criterion ->
|
||||
E.from $ \usrAvs -> -- do
|
||||
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)
|
||||
)
|
||||
, fltrAVSCardNos queryUser
|
||||
, single ("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
|
||||
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 ->
|
||||
if | Just renewal <- mbRenewal
|
||||
@ -447,8 +445,8 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
|
||||
[ 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 +468,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 +518,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 +554,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 +640,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
|
||||
|
||||
@ -25,10 +25,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
|
||||
}
|
||||
@ -36,7 +36,7 @@ data SapUserTableCsv = SapUserTableCsv -- for csv export only
|
||||
makeLenses_ ''SapUserTableCsv
|
||||
|
||||
sapUserTableCsvHeader :: Csv.Header
|
||||
sapUserTableCsvHeader = Csv.header
|
||||
sapUserTableCsvHeader = Csv.header
|
||||
[ "PersonalNummer"
|
||||
, "Qualifikation"
|
||||
, "GültigVon"
|
||||
@ -49,40 +49,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
|
||||
@ -104,7 +104,7 @@ getQualificationSAPDirectR = do
|
||||
_other -> mempty
|
||||
ldapCutoff = addDiffDaysRollOver (fromMonths $ -3) now
|
||||
|
||||
qualUsers <- runDB $ E.select $ do
|
||||
qualUsers <- runDBRead $ E.select $ do
|
||||
(qual :& qualUser :& user :& qualBlock) <-
|
||||
E.from $ E.table @Qualification
|
||||
`E.innerJoin` E.table @QualificationUser
|
||||
@ -112,7 +112,7 @@ getQualificationSAPDirectR = do
|
||||
`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
|
||||
)
|
||||
@ -125,19 +125,19 @@ getQualificationSAPDirectR = do
|
||||
E.&&. externalUser E.^. ExternalUserLastSync E.>=. E.val ldapCutoff
|
||||
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
|
||||
@ -153,7 +153,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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -91,7 +91,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
|
||||
|
||||
|
||||
@ -50,7 +50,7 @@ data TutorialUserActionData
|
||||
| TutorialUserGrantQualificationData
|
||||
{ tuQualification :: QualificationId
|
||||
, tuValidUntil :: Day
|
||||
}
|
||||
}
|
||||
| TutorialUserSendMailData
|
||||
| TutorialUserDeregisterData{}
|
||||
deriving (Eq, Ord, Read, Show, Generic)
|
||||
@ -62,7 +62,7 @@ postTUsersR tid ssh csh tutn = do
|
||||
isAdmin <- hasReadAccessTo AdminR
|
||||
(Entity tutid tut@Tutorial{..}, (participantRes, participantTable), qualifications) <- runDB $ do
|
||||
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
tutEnt@(Entity tutid _) <- fetchTutorial tid ssh csh tutn
|
||||
tutEnt@(Entity tutid _) <- fetchTutorial tid ssh csh tutn
|
||||
qualifications <- getCourseQualifications cid
|
||||
now <- liftIO getCurrentTime
|
||||
let nowaday = utctDay now
|
||||
@ -70,7 +70,7 @@ postTUsersR tid ssh csh tutn = do
|
||||
dayExpiry = flip addGregorianDurationClip nowaday . fromMonths <$> minDur
|
||||
colChoices = mconcat $ catMaybes
|
||||
[ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
|
||||
, pure $ colUserNameModalHdr MsgTableCourseMembers ForProfileDataR
|
||||
, pure $ colUserNameModalHdr MsgTableCourseMembers ForProfileDataR
|
||||
, pure colUserEmail
|
||||
, pure $ colUserMatriclenr isAdmin
|
||||
, pure $ colUserQualifications nowaday
|
||||
@ -80,34 +80,27 @@ postTUsersR tid ssh csh tutn = do
|
||||
& defaultSortingByName
|
||||
& restrictSorting (\name _ -> none (== name) ["note", "registration", "tutorials", "exams", "submission-group", "state"]) -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
|
||||
& restrictFilter (\name _ -> none (== name) ["tutorial", "exam", "submission-group", "active", "has-personalised-sheet-files"])
|
||||
isInTut q = E.exists $ do
|
||||
isInTut q = E.exists $ do
|
||||
tutorialParticipant <- E.from $ E.table @TutorialParticipant
|
||||
E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser q E.^. UserId
|
||||
E.&&. tutorialParticipant E.^. TutorialParticipantTutorial E.==. E.val tutid
|
||||
csvColChoices = flip elem ["name", "matriculation", "email", "qualifications"]
|
||||
|
||||
let
|
||||
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
|
||||
}
|
||||
|
||||
qualOptions = qualificationsOptionList qualifications
|
||||
let
|
||||
acts :: Map TutorialUserAction (AForm Handler TutorialUserActionData)
|
||||
acts = Map.fromList $
|
||||
(if null qualifications then mempty else
|
||||
[ ( TutorialUserRenewQualification
|
||||
, TutorialUserRenewQualificationData
|
||||
<$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing
|
||||
<$> apopt (selectField $ pure qualOptions) (fslI MsgQualificationName) Nothing
|
||||
)
|
||||
, ( TutorialUserGrantQualification
|
||||
, TutorialUserGrantQualificationData
|
||||
<$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing
|
||||
<$> apopt (selectField $ pure qualOptions) (fslI MsgQualificationName) Nothing
|
||||
<*> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry
|
||||
)
|
||||
]
|
||||
)
|
||||
]
|
||||
) ++
|
||||
[ ( TutorialUserSendMail , pure TutorialUserSendMailData )
|
||||
, ( TutorialUserDeregister , pure TutorialUserDeregisterData )
|
||||
@ -122,20 +115,20 @@ postTUsersR tid ssh csh tutn = do
|
||||
rcvr <- requireAuth
|
||||
encRcvr <- encrypt $ entityKey rcvr
|
||||
letters <- runDB $ makeCourseCertificates tut Nothing $ toList selectedUsers
|
||||
let mbAletter = anyone letters
|
||||
case mbAletter of
|
||||
let mbAletter = anyone letters
|
||||
case mbAletter of
|
||||
Nothing -> addMessageI Error MsgErrorUnknownFormAction >> return Nothing -- TODO: better error message
|
||||
Just aletter -> do
|
||||
Just aletter -> do
|
||||
now <- liftIO getCurrentTime
|
||||
apcIdent <- letterApcIdent aletter encRcvr now
|
||||
apcIdent <- letterApcIdent aletter encRcvr now
|
||||
let fName = letterFileName aletter
|
||||
renderLetters rcvr letters apcIdent >>= \case
|
||||
Left err -> sendResponseStatus internalServerError500 $ "PDF generation failed: \n" <> err
|
||||
Left err -> sendResponseStatus internalServerError500 $ "PDF generation failed: \n" <> err
|
||||
Right pdf -> return $ Just (sendByteStringAsFile fName (LBS.toStrict pdf) now)
|
||||
-- sendResponseByteStringFile "demoPDF.pdf" (LBS.toStrict pdf)
|
||||
-- let typePDF :: ContentType
|
||||
-- let typePDF :: ContentType
|
||||
-- typePDF = "application/pdf"
|
||||
-- sendResponse (typePDF, toContent pdf)
|
||||
-- sendResponse (typePDF, toContent pdf)
|
||||
(TutorialUserGrantQualificationData{..}, selectedUsers)
|
||||
| tuQualification `Set.member` courseQids -> do
|
||||
-- today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
|
||||
@ -146,7 +139,7 @@ postTUsersR tid ssh csh tutn = do
|
||||
redirect $ CTutorialR tid ssh csh tutn TUsersR
|
||||
(TutorialUserRenewQualificationData{..}, selectedUsers)
|
||||
| tuQualification `Set.member` courseQids -> do
|
||||
noks <- runDB $ renewValidQualificationUsers tuQualification Nothing Nothing $ Set.toList selectedUsers
|
||||
noks <- runDB $ renewValidQualificationUsers tuQualification Nothing Nothing $ Set.toList selectedUsers
|
||||
addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks
|
||||
redirect $ CTutorialR tid ssh csh tutn TUsersR
|
||||
(TutorialUserSendMailData{}, selectedUsers) -> do
|
||||
@ -160,8 +153,8 @@ postTUsersR tid ssh csh tutn = do
|
||||
addMessageI Success $ MsgTutorialUsersDeregistered nrDel
|
||||
redirect $ CTutorialR tid ssh csh tutn TUsersR
|
||||
_other -> addMessageI Error MsgErrorUnknownFormAction >> return Nothing
|
||||
|
||||
case tcontent of
|
||||
|
||||
case tcontent of
|
||||
Just act -> act -- abort and return produced content
|
||||
Nothing -> do
|
||||
tutors <- runDB $ E.select $ do
|
||||
|
||||
@ -3,6 +3,7 @@
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module Handler.Users
|
||||
( module Handler.Users
|
||||
@ -15,6 +16,9 @@ import Handler.Utils
|
||||
import Handler.Utils.Users
|
||||
import Handler.Utils.Invitations
|
||||
import Handler.Utils.Avs
|
||||
import Handler.Utils.Company
|
||||
|
||||
import qualified Auth.LDAP as Auth
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
@ -22,8 +26,13 @@ import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import qualified Database.Esqueleto.Legacy as E
|
||||
-- import Database.Esqueleto.Experimental ((:&)(..))
|
||||
import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma
|
||||
import qualified Database.Esqueleto.PostgreSQL as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
|
||||
|
||||
|
||||
import Handler.Profile (makeProfileData)
|
||||
|
||||
import qualified Yesod.Auth.Util.PasswordStore as PWStore
|
||||
@ -44,27 +53,28 @@ hijackUserForm = \csrf -> do
|
||||
(btnResult, btnView) <- mopt (buttonField BtnHijack) "" Nothing
|
||||
return (btnResult >>= guard . is _Just, mconcat [toWidget csrf, fvWidget btnView])
|
||||
|
||||
-- In case of refactoring, use this:
|
||||
-- instance HasEntity (DBRow (Entity User)) User where
|
||||
-- hasEntity = _dbrOutput
|
||||
-- instance HasUser (DBRow (Entity USer)) where
|
||||
-- hasUser = _entityVal
|
||||
instance HasEntity (DBRow (Entity User)) User where
|
||||
hasEntity = _dbrOutput
|
||||
instance HasUser (DBRow (Entity User)) where
|
||||
hasUser = _dbrOutput . _entityVal
|
||||
|
||||
data UserAction = UserLdapSync | UserAddSupervisor | UserSetSupervisor | UserRemoveSupervisor | UserAvsSync
|
||||
data UserAction = UserAvsSync | UserLdapSync | UserAddSupervisor | UserSetSupervisor | UserRemoveSupervisor | UserRemoveSubordinates
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
||||
deriving anyclass (Universe, Finite)
|
||||
|
||||
nullaryPathPiece ''UserAction $ camelToPathPiece' 1
|
||||
embedRenderMessage ''UniWorX ''UserAction id
|
||||
|
||||
data UserActionData = UserLdapSyncData
|
||||
data UserActionData = UserAvsSyncData
|
||||
| UserLdapSyncData
|
||||
| UserHijack
|
||||
| UserAddSupervisorData { getActionSupervisors :: Set Text, getActionRerouteNotifications :: Bool }
|
||||
| UserSetSupervisorData { getActionSupervisors :: Set Text, getActionRerouteNotifications :: Bool }
|
||||
| UserAddSupervisorData { getActionSupervisors :: Set Text, getActionRerouteNotifications :: Bool, getActionSupervisorReason :: Maybe Text }
|
||||
| UserSetSupervisorData { getActionSupervisors :: Set Text, getActionRerouteNotifications :: Bool, getActionSupervisorReason :: Maybe Text }
|
||||
| UserRemoveSupervisorData
|
||||
| UserAvsSyncData
|
||||
| UserRemoveSubordinatesData
|
||||
|
||||
deriving (Eq, Ord, Read, Show, Generic)
|
||||
|
||||
|
||||
isNotSetSupervisor :: UserActionData -> Bool
|
||||
isNotSetSupervisor UserSetSupervisorData{} = False
|
||||
isNotSetSupervisor _ = True
|
||||
@ -75,7 +85,7 @@ isActionSupervisor UserSetSupervisorData{} = True
|
||||
isActionSupervisor _ = False
|
||||
|
||||
|
||||
data AllUsersAction = AllUsersLdapSync
|
||||
data AllUsersAction = AllUsersLdapSync | AllUsersAvsSync
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
||||
deriving anyclass (Universe, Finite)
|
||||
|
||||
@ -96,17 +106,9 @@ postUsersR = do
|
||||
(AdminUserR <$> encrypt uid)
|
||||
(nameWidget userDisplayName userSurname)
|
||||
, sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \DBRow{ dbrOutput = entUsr } -> cellHasMatrikelnummerLinkedAdmin entUsr
|
||||
, sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \DBRow{ dbrOutput = Entity 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
|
||||
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 =
|
||||
(\(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 "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
|
||||
, sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ liftHandler $ runDB $ -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX"
|
||||
maybeMonoid <$> wgtCompanies uid
|
||||
-- , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM -- redundant
|
||||
-- (AdminUserR <$> encrypt uid)
|
||||
-- (toWgt userCompanyPersonalNumber)
|
||||
, sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \DBRow{ dbrOutput = Entity _uid User{..} } -> cellMaybe textCell userCompanyPersonalNumber
|
||||
@ -115,21 +117,22 @@ postUsersR = do
|
||||
-- (AdminUserR <$> encrypt uid)
|
||||
-- (toWidget . display $ last $ impureNonNull $ words $ userDisplayName)
|
||||
, sortable (Just "user-supervisor") (i18nCell MsgTableSupervisor) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
|
||||
supervisors' <- liftHandler . runDB . E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
|
||||
supervisors' <- liftHandler . runDBRead . 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 supervisors = intersperse (text2widget ", ") $
|
||||
(\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisors'
|
||||
icnReroute = text2widget " " <> toWgt (icon IconLetter)
|
||||
icnReroute = text2widget " " <> toWgt (icon IconReroute)
|
||||
pure $ mconcat supervisors
|
||||
, sortable (Just "last-login") (i18nCell MsgLastLogin) $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastAuthentication
|
||||
-- , sortable (Just "auth-ldap") (i18nCell MsgAuthMode) $ \DBRow{ dbrOutput = Entity _ User{..} } -> i18nCell userAuthentication -- TODO: reintroduce via ExternalUser
|
||||
-- , sortable (Just "ldap-sync") (i18nCell MsgLdapSynced) $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastLdapSynchronisation -- TODO: reintroduce via ExternalUser
|
||||
, colUserEmail
|
||||
, flip foldMap universeF $ \function ->
|
||||
sortable (Just $ SortingKey $ CI.mk $ toPathPiece function) (i18nCell function) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
|
||||
schools <- liftHandler . runDB . E.select . E.from $ \(school `E.InnerJoin` userFunction) -> do
|
||||
schools <- liftHandler . runDBRead . E.select . E.from $ \(school `E.InnerJoin` userFunction) -> do
|
||||
E.on $ school E.^. SchoolId E.==. userFunction E.^. UserFunctionSchool
|
||||
E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val uid
|
||||
E.&&. userFunction E.^. UserFunctionFunction E.==. E.val function
|
||||
@ -142,7 +145,7 @@ postUsersR = do
|
||||
<li>#{sh}
|
||||
|]
|
||||
, sortable (Just "system-function") (i18nCell MsgUserSystemFunctions) $ \DBRow{ dbrOutput = Entity uid _ } ->
|
||||
let getFunctions = fmap (map $ userSystemFunctionFunction . entityVal) . liftHandler . runDB $ selectList [ UserSystemFunctionUser ==. uid, UserSystemFunctionIsOptOut ==. False ] [ Asc UserSystemFunctionFunction ]
|
||||
let getFunctions = fmap (map $ userSystemFunctionFunction . entityVal) . liftHandler . runDBRead $ selectList [ UserSystemFunctionUser ==. uid, UserSystemFunctionIsOptOut ==. False ] [ Asc UserSystemFunctionFunction ]
|
||||
in listCell' getFunctions i18nCell
|
||||
, sortable Nothing (mempty & cellAttrs <>~ pure ("hide-columns--hider-label", mr MsgTableActionsHead)) $ \inp@DBRow{ dbrOutput = Entity uid _ } -> FormCell
|
||||
{ formCellAttrs = []
|
||||
@ -180,17 +183,27 @@ postUsersR = do
|
||||
let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
|
||||
return (act, usrSet)
|
||||
|
||||
superReasons :: HandlerFor UniWorX (OptionList Text)
|
||||
superReasons = fmap (mkOptionList . map (\t -> Option t t t) . Set.toAscList) . runDB $
|
||||
fmap (setOf $ folded . _Value . _Just) . Ex.select . Ex.distinct $ do
|
||||
usrc <- Ex.from $ Ex.table @UserSupervisor
|
||||
E.where_ $ E.isJust (usrc E.^. UserSupervisorReason)
|
||||
Ex.limit 9
|
||||
return $ usrc E.^. UserSupervisorReason
|
||||
acts :: Map UserAction (AForm Handler UserActionData)
|
||||
acts = mconcat
|
||||
acts = mconcat
|
||||
[ singletonMap UserLdapSync $ pure UserLdapSyncData
|
||||
, singletonMap UserAvsSync $ pure UserAvsSyncData
|
||||
, singletonMap UserAddSupervisor $ UserAddSupervisorData
|
||||
<$> apopt (textField & cfAnySeparatedSet) (fslI MsgTableSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
|
||||
<*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just True)
|
||||
, singletonMap UserSetSupervisor $ UserSetSupervisorData
|
||||
<$> apopt (textField & cfAnySeparatedSet) (fslI MsgTableSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
|
||||
<*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just True)
|
||||
, singletonMap UserAddSupervisor $ UserAddSupervisorData
|
||||
<$> apopt (textField & cfAnySeparatedSet) (fslI MsgTableSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
|
||||
<*> apopt boolField' (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just False)
|
||||
<*> aopt (textField & cfStrip & addDatalist superReasons) (fslI MsgUserSupervisorReason & setTooltip MsgUserSupervisorReasonTooltip) Nothing
|
||||
, singletonMap UserSetSupervisor $ UserSetSupervisorData
|
||||
<$> apopt (textField & cfAnySeparatedSet) (fslI MsgTableSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
|
||||
<*> apopt boolField' (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just False)
|
||||
<*> aopt (textField & cfStrip & addDatalist superReasons) (fslI MsgUserSupervisorReason & setTooltip MsgUserSupervisorReasonTooltip) Nothing
|
||||
, singletonMap UserRemoveSupervisor $ pure UserRemoveSupervisorData
|
||||
, singletonMap UserRemoveSubordinates $ pure UserRemoveSubordinatesData
|
||||
]
|
||||
|
||||
over _1 postprocess <$> dbTable psValidator DBTable
|
||||
@ -200,17 +213,18 @@ postUsersR = do
|
||||
, dbtProj = dbtProjId
|
||||
, dbtSorting = Map.fromList $
|
||||
[ ( SortingKey $ CI.mk $ toPathPiece function
|
||||
, SortColumn $ \user -> E.subSelect $ E.from $ \uf -> do
|
||||
, SortColumn $ \user -> E.subSelect $ E.from $ \uf -> do
|
||||
E.where_ $ uf E.^. UserFunctionUser E.==. user E.^. UserId
|
||||
E.&&. uf E.^. UserFunctionFunction E.==. E.val function
|
||||
return (uf E.^. UserFunctionSchool)
|
||||
) | function <- universeF
|
||||
] ++
|
||||
[ ( "name"
|
||||
, SortColumn $ \user -> user E.^. UserSurname
|
||||
[ sortUserEmail id
|
||||
, ( "name"
|
||||
, SortColumn (E.^. UserSurname)
|
||||
)
|
||||
, ( "display-name"
|
||||
, SortColumn $ \user -> user E.^. UserDisplayName
|
||||
, SortColumn (E.^. UserDisplayName)
|
||||
)
|
||||
, ( "matriculation"
|
||||
, SortColumn $ \user -> user E.^. UserMatrikelnummer
|
||||
@ -245,26 +259,27 @@ postUsersR = do
|
||||
return (usrSpvr E.^. UserDisplayName)
|
||||
)
|
||||
, ( "system-function"
|
||||
, SortColumn $ \user -> E.subSelect $ E.from $ \usf -> do
|
||||
, SortColumn $ \user -> E.subSelect $ E.from $ \usf -> do
|
||||
E.where_ $ usf E.^. UserSystemFunctionUser E.==. user E.^. UserId
|
||||
return $ usf E.^. UserSystemFunctionFunction
|
||||
return $ usf E.^. UserSystemFunctionFunction
|
||||
)
|
||||
]
|
||||
, dbtFilter = Map.fromList -- OverloadedLists does not work with the templates
|
||||
[ ( "user-search", FilterColumn $ \user (criteria :: Set.Set Text) ->
|
||||
if Set.null criteria then E.true else -- TODO: why is this condition not needed?
|
||||
-- Set.foldr (\needle acc -> acc E.||. (user E.^. UserDisplayName) `E.hasInfix` needle) eFalse (criterion :: Set.Set Text)
|
||||
E.any (\c -> user E.^. UserDisplayName `E.hasInfix` E.val c) criteria
|
||||
)
|
||||
, ( "user-ident", FilterColumn $ \user criterion -> case getLast (criterion :: Last Text) of
|
||||
Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
|
||||
Just needle -> E.castString (user E.^. UserIdent) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)
|
||||
)
|
||||
, ( "user-email", FilterColumn $ \user criterion -> case getLast (criterion :: Last Text) of
|
||||
Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
|
||||
Just needle -> (E.castString (user E.^. UserEmail) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
|
||||
E.||. (E.castString (user E.^. UserDisplayEmail) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
|
||||
)
|
||||
[ fltrUserNameEmail id
|
||||
-- , ( "user-search", FilterColumn $ \user (criteria :: Set.Set Text) ->
|
||||
-- if Set.null criteria then E.true else -- TODO: why is this condition not needed?
|
||||
-- -- Set.foldr (\needle acc -> acc E.||. (user E.^. UserDisplayName) `E.hasInfix` needle) eFalse (criterion :: Set.Set Text)
|
||||
-- E.any (\c -> user E.^. UserDisplayName `E.hasInfix` E.val c) criteria
|
||||
-- )
|
||||
-- , ( "user-ident", FilterColumn $ \user criterion -> case getLast (criterion :: Last Text) of
|
||||
-- Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
|
||||
-- Just needle -> E.castString (user E.^. UserIdent) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)
|
||||
-- )
|
||||
-- , ( "user-email", FilterColumn $ \user criterion -> case getLast (criterion :: Last Text) of
|
||||
-- Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
|
||||
-- Just needle -> (E.castString (user E.^. UserEmail) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
|
||||
-- E.||. (E.castString (user E.^. UserDisplayEmail) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
|
||||
-- )
|
||||
, ( "personal-number" , FilterColumn . E.mkContainsFilterWithComma Just $ (E.^. UserCompanyPersonalNumber))
|
||||
, ( "matriculation" , FilterColumn . E.mkContainsFilterWithComma Just $ (E.^. UserMatrikelnummer)) -- allows partial matches
|
||||
, ( "company-department", FilterColumn $ \user (criteria :: Set.Set Text) -> if -- exact filter on table UserAvs
|
||||
@ -289,8 +304,14 @@ postUsersR = do
|
||||
-- in E.maybe E.true (E.<=. E.val minTime) $ user E.^. UserLastLdapSynchronisation
|
||||
-- | otherwise -> E.val True :: E.SqlExpr (E.Value Bool)
|
||||
-- ) -- TODO: reintroduce via ExternalUser
|
||||
, ( "avs-sync", FilterColumn . E.mkExistsFilter $ \user criterion ->
|
||||
E.from $ \usrAvs -> do
|
||||
let minTime = (E.val criterion :: E.SqlExpr (E.Value UTCTime))
|
||||
E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId
|
||||
E.&&. usrAvs E.^. UserAvsLastSynch E.<=. minTime
|
||||
)
|
||||
, ( "user-company", FilterColumn . E.mkExistsFilter $ \user criterion ->
|
||||
E.from $ \(usrComp `E.InnerJoin` comp) -> do
|
||||
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
|
||||
@ -307,24 +328,25 @@ postUsersR = do
|
||||
E.&&. E.any (E.hasInfix (usrSpvr E.^. UserDisplayName)) (E.val <$> Set.toList criteria)
|
||||
)
|
||||
-- , ( "avs-number", FilterColumn $ E.mkExistsFilterWithComma CI.mk $ \user criterion -> -- note that this is an exact filter
|
||||
-- E.from $ \usrAvs -> -- do
|
||||
-- E.from $ \usrAvs -> -- do
|
||||
-- E.where_ $ user E.^. UserId E.==. usrAvs E.^. UserAvsUser
|
||||
-- E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==.
|
||||
-- (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) )
|
||||
-- )
|
||||
, ( "is-supervisor", FilterColumn $ \user criterion -> case criterion of
|
||||
, ( "is-supervisor", FilterColumn $ \user criterion -> case criterion of
|
||||
Last (Just True) -> E.exists . E.from $ \usrSpr -> E.where_ $ user E.^. UserId E.==. usrSpr E.^. UserSupervisorSupervisor
|
||||
Last (Just False) -> E.notExists . E.from $ \usrSpr -> E.where_ $ user E.^. UserId E.==. usrSpr E.^. UserSupervisorSupervisor
|
||||
_ -> E.val True :: E.SqlExpr (E.Value Bool)
|
||||
)
|
||||
]
|
||||
, dbtFilterUI = \mPrev -> mconcat
|
||||
[ prismAForm (singletonFilter "user-search") mPrev $ aopt textField (fslI MsgName)
|
||||
, prismAForm (singletonFilter "user-ident") mPrev $ aopt textField (fslI MsgAdminUserIdent)
|
||||
, prismAForm (singletonFilter "user-email") mPrev $ aopt textField (fslI MsgAdminUserEmail)
|
||||
, prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber & setTooltip MsgTableFilterCommaPlus)
|
||||
, prismAForm (singletonFilter "matriculation") mPrev $ aopt matriculationField (fslI MsgTableMatrikelNr & setTooltip MsgTableFilterCommaPlus) -- contains filter on UserMatrikelnummer
|
||||
-- , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo & setTooltip MsgTableFilterCommaPlus) -- exact filter on table UserAvs
|
||||
[ fltrUserNameEmailHdrUI MsgName mPrev
|
||||
-- , prismAForm (singletonFilter "user-search") mPrev $ aopt textField (fslI MsgName)
|
||||
-- , prismAForm (singletonFilter "user-ident") mPrev $ aopt textField (fslI MsgAdminUserIdent)
|
||||
-- , prismAForm (singletonFilter "user-email") mPrev $ aopt textField (fslI MsgAdminUserEmail)
|
||||
, prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber & setTooltip MsgTableFilterCommaPlusShort)
|
||||
, prismAForm (singletonFilter "matriculation") mPrev $ aopt matriculationField (fslI MsgTableMatrikelNr & setTooltip MsgTableFilterCommaPlusShort) -- contains filter on UserMatrikelnummer
|
||||
-- , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo & setTooltip MsgTableFilterCommaPlusShort) -- exact filter on table UserAvs
|
||||
, prismAForm (singletonFilter "company-department") mPrev $ aopt textField (fslI MsgCompanyDepartment)
|
||||
, prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany)
|
||||
, prismAForm (singletonFilter "user-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor)
|
||||
@ -332,6 +354,7 @@ postUsersR = do
|
||||
, prismAForm (singletonFilter "is-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgUserIsSupervisor)
|
||||
-- , prismAForm (singletonFilter "auth-ldap" . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` selectFieldList [(MsgAuthPWHash "", False), (MsgAuthLDAP, True)]) (fslI MsgAuthMode) -- TODO: reintroduce via ExternalUser
|
||||
-- , prismAForm (singletonFilter "ldap-sync" . maybePrism _PathPiece) mPrev $ aopt utcTimeField (fslI MsgLdapSyncedBefore) -- TODO: reintroduce via ExternalUser
|
||||
, prismAForm (singletonFilter "avs-sync" . maybePrism _PathPiece) mPrev $ aopt utcTimeField (fslI MsgLastAvsSyncedBefore)
|
||||
]
|
||||
, dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||||
, dbtParams = DBParamsForm
|
||||
@ -357,30 +380,34 @@ postUsersR = do
|
||||
formResult usersRes $ \case
|
||||
(act, usersSet)
|
||||
| Set.null usersSet && isNotSetSupervisor act ->
|
||||
addMessageI Info MsgActionNoUsersSelected
|
||||
addMessageI Info MsgActionNoUsersSelected
|
||||
(UserLdapSyncData, userSet) -> do
|
||||
forM_ userSet $ queueJob' . JobSynchroniseUser
|
||||
forM_ userSet $ \uid -> void . queueJob $ JobSynchroniseLdapUser uid
|
||||
addMessageI Success . MsgSynchroniseUserdbUserQueued $ Set.size userSet
|
||||
redirectKeepGetParams UsersR
|
||||
(UserAvsSyncData, userSet) -> do
|
||||
forM_ userSet $ \uid -> queueJob' $ JobSynchroniseAvsUser uid Nothing
|
||||
addMessageI Success . MsgSynchroniseAvsUserQueued $ Set.size userSet
|
||||
n <- runDB $ queueAvsUpdateByUID userSet Nothing
|
||||
addMessageI Success . MsgSynchroniseAvsUserQueued $ fromIntegral n
|
||||
redirectKeepGetParams UsersR
|
||||
(UserHijack, Set.minView -> Just (uid, _)) ->
|
||||
(UserHijack, Set.lookupMin -> Just uid) ->
|
||||
hijackUser uid >>= sendResponse
|
||||
(UserRemoveSupervisorData, userSet) -> do
|
||||
(UserRemoveSupervisorData, userSet) -> do
|
||||
runDB $ deleteWhere [UserSupervisorUser <-. Set.toList userSet]
|
||||
addMessageI Success $ MsgUsersRemoveSupervisors $ Set.size userSet
|
||||
redirectKeepGetParams UsersR
|
||||
(UserRemoveSubordinatesData, userSet) -> do
|
||||
runDB $ deleteWhere [UserSupervisorSupervisor <-. Set.toList userSet]
|
||||
addMessageI Success $ MsgUsersRemoveSubordinates $ Set.size userSet
|
||||
redirectKeepGetParams UsersR
|
||||
(act, usersSet)
|
||||
| isActionSupervisor act -> do
|
||||
| isActionSupervisor act -> do
|
||||
avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser $ getActionSupervisors act
|
||||
let (supersFound, supersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers
|
||||
users = Set.toList usersSet
|
||||
nrSuperNotFound = length supersNotFound
|
||||
nrSuperNotFound = length supersNotFound
|
||||
runDB $ do
|
||||
unless (isNotSetSupervisor act) $ deleteWhere [UserSupervisorUser <-. users]
|
||||
putMany [UserSupervisor s u r
|
||||
putMany [UserSupervisor s u r Nothing (getActionSupervisorReason act)
|
||||
| let r = getActionRerouteNotifications act
|
||||
, (_, Just s) <- supersFound
|
||||
, u <- users
|
||||
@ -391,14 +418,36 @@ postUsersR = do
|
||||
redirectKeepGetParams UsersR
|
||||
_other -> addMessageI Error MsgInvalidFormAction
|
||||
|
||||
((allUsersRes, allUsersWgt), allUsersEnctype) <- runFormPost . identifyForm FIDAllUsersAction $ buttonForm
|
||||
((allUsersRes, allUsersWgt'), allUsersEnctype) <- runFormPost . identifyForm FIDAllUsersAction $ buttonForm
|
||||
|
||||
formResult allUsersRes $ \case
|
||||
AllUsersLdapSync -> do
|
||||
runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseUser . entityKey)
|
||||
-- runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseUser . entityKey) -- to slow to execute directly
|
||||
queueJob' JobSynchroniseUserdbAll
|
||||
addMessageI Success MsgSynchroniseUserdbAllUsersQueued
|
||||
redirect UsersR
|
||||
let allUsersWgt' = wrapForm allUsersWgt def
|
||||
AllUsersAvsSync -> do
|
||||
now <- liftIO getCurrentTime
|
||||
let nowaday = utctDay now
|
||||
n <- runDB $ E.insertSelectWithConflictCount UniqueAvsSyncUser
|
||||
( do
|
||||
usr <- Ex.from $ Ex.table @User
|
||||
return (AvsSync
|
||||
Ex.<# (usr Ex.^. UserId)
|
||||
Ex.<&> E.val now
|
||||
-- Ex.<&> Ex.just (E.day E.now_) -- don't use DB time here, since job handler compares with FRADrive clock
|
||||
Ex.<&> E.justVal nowaday
|
||||
)
|
||||
) (\current excluded ->
|
||||
[ AvsSyncCreationTime E.=. E.least (current E.^. AvsSyncCreationTime) (excluded E.^. AvsSyncCreationTime)
|
||||
, AvsSyncPause E.=. E.greatest (current E.^. AvsSyncPause) (excluded E.^. AvsSyncPause)
|
||||
]
|
||||
)
|
||||
void $ queueJob JobSynchroniseAvsQueue
|
||||
addMessageI Success $ MsgSynchroniseAvsAllUsersQueued n
|
||||
redirect UsersR
|
||||
|
||||
let allUsersWgt = wrapForm allUsersWgt' def
|
||||
{ formSubmit = FormNoSubmit
|
||||
, formAction = Just $ SomeRoute UsersR
|
||||
, formEncoding = allUsersEnctype
|
||||
@ -414,7 +463,7 @@ hijackUser uid = do
|
||||
setCredsRedirect $ Creds apDummy (CI.original userIdent) []
|
||||
|
||||
getAdminHijackUserR :: CryptoUUIDUser -> Handler Html
|
||||
getAdminHijackUserR cID = do
|
||||
getAdminHijackUserR cID = do
|
||||
(hijackWgt, hijackEnctype) <- generateFormPost hijackUserForm
|
||||
let hjForm = wrapForm hijackWgt def{ formSubmit = FormNoSubmit, formEncoding = hijackEnctype, formAction = Just . SomeRoute $ AdminHijackUserR cID }
|
||||
uid :: UserId <- decrypt cID
|
||||
@ -427,7 +476,7 @@ getAdminHijackUserR cID = do
|
||||
|]
|
||||
|
||||
postAdminHijackUserR :: CryptoUUIDUser -> Handler TypedContent
|
||||
postAdminHijackUserR cID = do
|
||||
postAdminHijackUserR cID = do
|
||||
((hijackRes, _), _) <- runFormPost hijackUserForm
|
||||
$logWarnS "HIJACK" $ "Form Result is: " <> tshow hijackRes
|
||||
uid <- decrypt cID
|
||||
@ -458,6 +507,15 @@ nullaryPathPiece ''UserAssimilateButton $ camelToPathPiece' 2
|
||||
embedRenderMessage ''UniWorX ''UserAssimilateButton id
|
||||
|
||||
|
||||
data ThisUserAction = ThisUserLdapSync | ThisUserAvsSync -- ThisUserHijack would make sense, but this 'btn' should not always be visible
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
||||
deriving anyclass (Universe, Finite)
|
||||
|
||||
nullaryPathPiece ''ThisUserAction $ camelToPathPiece' 1
|
||||
embedRenderMessage ''UniWorX ''ThisUserAction id
|
||||
|
||||
instance Button UniWorX ThisUserAction where
|
||||
btnClasses _ = [BCIsButton, BCPrimary]
|
||||
|
||||
|
||||
getAdminUserR, postAdminUserR :: CryptoUUIDUser -> Handler Html
|
||||
@ -465,6 +523,25 @@ getAdminUserR = postAdminUserR
|
||||
postAdminUserR uuid = do
|
||||
adminId <- requireAuthId
|
||||
uid <- decrypt uuid
|
||||
|
||||
((thisUserActRes, thisUserActWgt'), thisUserActEnctype) <- runFormPost . identifyForm FIDThisUserAction $ buttonForm
|
||||
formResult thisUserActRes $ \case
|
||||
ThisUserLdapSync -> do
|
||||
queueJob' $ JobSynchroniseLdapUser uid
|
||||
addMessageI Success $ MsgSynchroniseLdapUserQueued 1
|
||||
redirectKeepGetParams $ AdminUserR uuid
|
||||
ThisUserAvsSync -> do
|
||||
n <- runDB $ queueAvsUpdateByUID (Set.singleton uid) Nothing
|
||||
addMessageI Success $ MsgSynchroniseAvsUserQueued $ fromIntegral n
|
||||
redirectKeepGetParams $ AdminUserR uuid
|
||||
-- ThisUserHijack -> do
|
||||
-- redirect $ AdminHijackUserR uuid
|
||||
let thisUserActWgt = wrapForm thisUserActWgt' def
|
||||
{ formSubmit = FormNoSubmit
|
||||
, formAction = Just $ SomeRoute $ AdminUserR uuid
|
||||
, formEncoding = thisUserActEnctype
|
||||
}
|
||||
|
||||
(user@User{..}, adminSchools, functions, schools, systemFunctions) <- runDB $ do
|
||||
user <- get404 uid
|
||||
|
||||
@ -647,7 +724,7 @@ postAdminUserR uuid = do
|
||||
}
|
||||
userDataWidget <- runDB $ makeProfileData $ Entity uid user
|
||||
siteLayout heading $ do
|
||||
let _deleteWidget = $(i18nWidgetFile "data-delete")
|
||||
let _deleteWidget = $(i18nWidgetFile "data-delete") -- TODO: update deletion text for FRADrive
|
||||
$(widgetFile "adminUser")
|
||||
|
||||
|
||||
|
||||
@ -150,15 +150,99 @@ reload r = getCurrentRoute >>= redirect . fromMaybe r
|
||||
|
||||
-- | like `reload` to current route, but also preserving all GET parameters, using the current route, if known
|
||||
reloadKeepGetParams :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a
|
||||
reloadKeepGetParams r = liftHandler $ do
|
||||
reloadKeepGetParams r = liftHandler $ do
|
||||
getps <- reqGetParams <$> getRequest
|
||||
route <- fromMaybe r <$> getCurrentRoute
|
||||
-- addMessage Info $ toHtml (show getps) -- DEBUG ONLY
|
||||
-- RECALL: redirect GET parameters are used like so: -- redirect (UsersR, [("users-user-company","fraport")])
|
||||
redirect (route, getps)
|
||||
redirect (route, getps)
|
||||
|
||||
-- | like `reloadKeepGetParams`, but always leading to the specific route instead of the current route
|
||||
redirectKeepGetParams :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a
|
||||
redirectKeepGetParams route = liftHandler $ do
|
||||
getps <- reqGetParams <$> getRequest
|
||||
redirect (route, getps)
|
||||
redirectKeepGetParams route = liftHandler $ do
|
||||
getps <- reqGetParams <$> getRequest
|
||||
redirect (route, getps)
|
||||
|
||||
previousSuperior :: (IsDBTable m a) => Maybe UserId -> DBCell m a
|
||||
previousSuperior Nothing = mempty
|
||||
previousSuperior (Just uid) = spacerCell <> i18nCell MsgAdminProblemCompanySuperiorPrevious <> anchorCellM (AdminUserR <$> encrypt uid) (userIdWidget uid)
|
||||
|
||||
adminProblemCell :: (IsDBTable m a) => AdminProblem -> DBCell m a
|
||||
-- note that adminProblemCompany/adminProblemCompanyOld and adminProblemUser are automatically displayed within their own columns
|
||||
-- WARNING: this function should correspond with adminProblem2Text
|
||||
adminProblemCell AdminProblemNewCompany{}
|
||||
= i18nCell MsgAdminProblemNewCompany
|
||||
adminProblemCell AdminProblemSupervisorNewCompany{adminProblemCompanyNew, adminProblemSupervisorReroute}
|
||||
= i18nCell (MsgAdminProblemSupervisorNewCompany adminProblemSupervisorReroute) <> companyIdCell adminProblemCompanyNew
|
||||
adminProblemCell AdminProblemSupervisorLeftCompany{adminProblemSupervisorReroute}
|
||||
= i18nCell (MsgAdminProblemSupervisorLeftCompany adminProblemSupervisorReroute)
|
||||
adminProblemCell AdminProblemCompanySuperiorChange{adminProblemUserOld}
|
||||
= i18nCell MsgAdminProblemCompanySuperiorChange <> previousSuperior adminProblemUserOld
|
||||
adminProblemCell AdminProblemCompanySuperiorNotFound{..}
|
||||
= i18nCell (MsgAdminProblemCompanySuperiorNotFound (fromMaybe "???" adminProblemEmail)) <> previousSuperior adminProblemUserOld
|
||||
adminProblemCell AdminProblemNewlyUnsupervised{adminProblemCompanyNew}
|
||||
= i18nCell MsgAdminProblemNewlyUnsupervised <> companyIdCell adminProblemCompanyNew
|
||||
adminProblemCell AdminProblemUnknown{adminProblemText}
|
||||
= textCell $ "Problem: " <> adminProblemText
|
||||
|
||||
company2msg :: CompanyId -> SomeMessage UniWorX
|
||||
company2msg = text2message . ciOriginal . unCompanyKey
|
||||
|
||||
-- used to enable filtering, must correspond to function adminProblemCell shown above
|
||||
adminProblem2Text :: AdminProblem -> DB Text
|
||||
adminProblem2Text adprob = do
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
case adprob of
|
||||
AdminProblemNewCompany{}
|
||||
-> return $ mr MsgAdminProblemNewCompany
|
||||
AdminProblemSupervisorNewCompany{adminProblemSupervisorReroute, adminProblemCompanyNew}
|
||||
-> return $ mr $ SomeMessages [SomeMessage $ MsgAdminProblemSupervisorNewCompany adminProblemSupervisorReroute, company2msg adminProblemCompanyNew]
|
||||
AdminProblemSupervisorLeftCompany{adminProblemSupervisorReroute}
|
||||
-> return $ mr (MsgAdminProblemSupervisorLeftCompany adminProblemSupervisorReroute)
|
||||
AdminProblemCompanySuperiorChange{adminProblemUserOld=mbuid}
|
||||
-> maybeT (return $ mr MsgAdminProblemCompanySuperiorChange) $ do
|
||||
uid <- MaybeT $ pure mbuid
|
||||
User{userDisplayName = udn, userSurname = usn} <- MaybeT $ get uid
|
||||
pure $ mr $ SomeMessages [SomeMessage MsgAdminProblemCompanySuperiorChange, SomeMessage MsgAdminProblemCompanySuperiorPrevious, SomeMessage udn, SomeMessage usn]
|
||||
-- AdminProblemCompanySuperiorChange{adminProblemUserOld=Nothing}
|
||||
-- -> return $ mr MsgAdminProblemCompanySuperiorChange
|
||||
-- AdminProblemCompanySuperiorChange{adminProblemUserOld=Just uid}
|
||||
-- -> get uid >>= \case
|
||||
-- Nothing ->
|
||||
-- return $ mr MsgAdminProblemCompanySuperiorChange
|
||||
-- Just User{userDisplayName = udn, userSurname = usn} ->
|
||||
-- return $ mr $ SomeMessages [SomeMessage MsgAdminProblemCompanySuperiorChange, SomeMessage MsgAdminProblemCompanySuperiorPrevious, SomeMessage udn, SomeMessage usn]
|
||||
AdminProblemCompanySuperiorNotFound{adminProblemUserOld=mbuid, adminProblemEmail=eml}
|
||||
-> let basemsg = MsgAdminProblemCompanySuperiorNotFound $ fromMaybe "???" eml
|
||||
in maybeT (return $ mr basemsg) $ do
|
||||
uid <- MaybeT $ pure mbuid
|
||||
User{userDisplayName = udn, userSurname = usn} <- MaybeT $ get uid
|
||||
pure $ mr $ SomeMessages [SomeMessage basemsg, SomeMessage MsgAdminProblemCompanySuperiorPrevious, SomeMessage udn, SomeMessage usn]
|
||||
AdminProblemNewlyUnsupervised{adminProblemCompanyNew}
|
||||
-> return $ mr $ SomeMessages [SomeMessage MsgAdminProblemNewlyUnsupervised, company2msg adminProblemCompanyNew]
|
||||
AdminProblemUnknown{adminProblemText}
|
||||
-> return $ "Problem: " <> adminProblemText
|
||||
|
||||
-- | Show AdminProblem as message, used in message pop-up after manually switching companies for a user
|
||||
msgAdminProblem :: AdminProblem -> DB (SomeMessages UniWorX)
|
||||
msgAdminProblem AdminProblemNewCompany{adminProblemCompany=comp} = return $
|
||||
SomeMessages [SomeMessage MsgAdminProblemNewCompany, text2message ": ", company2msg comp]
|
||||
msgAdminProblem AdminProblemSupervisorNewCompany{adminProblemCompany=comp, adminProblemCompanyNew=newComp, adminProblemSupervisorReroute=rer} = return $
|
||||
SomeMessages [SomeMessage $ MsgAdminProblemSupervisorNewCompany rer, text2message ": ", company2msg comp, text2message " -> ", company2msg newComp]
|
||||
msgAdminProblem AdminProblemSupervisorLeftCompany{adminProblemCompany=comp, adminProblemSupervisorReroute=rer} = return $
|
||||
SomeMessages [SomeMessage $ MsgAdminProblemSupervisorLeftCompany rer, text2message ": ", company2msg comp]
|
||||
msgAdminProblem AdminProblemCompanySuperiorChange{adminProblemCompany=comp} = return $
|
||||
SomeMessages [SomeMessage MsgAdminProblemCompanySuperiorChange, text2message ": ", company2msg comp]
|
||||
msgAdminProblem AdminProblemCompanySuperiorNotFound{adminProblemCompany=comp, adminProblemEmail=eml} = return $
|
||||
SomeMessages [SomeMessage $ MsgAdminProblemCompanySuperiorNotFound $ fromMaybe "???" eml, text2message ": ", company2msg comp]
|
||||
msgAdminProblem AdminProblemNewlyUnsupervised{adminProblemCompanyOld=comp, adminProblemCompanyNew=newComp} = return $
|
||||
SomeMessages [SomeMessage MsgAdminProblemNewlyUnsupervised, text2message ": ", maybe (text2message "???") company2msg comp, text2message " -> ", company2msg newComp]
|
||||
msgAdminProblem AdminProblemUnknown{adminProblemText=err} = return $
|
||||
someMessages ["Problem: ", err]
|
||||
|
||||
updateAutomatic :: Bool -> Widget
|
||||
-- updateAutomatic = iconTooltip [whamlet|_{MsgNoAutomaticUpdateTip}|] (Just IconLocked)
|
||||
updateAutomatic True = mempty
|
||||
updateAutomatic False = do
|
||||
msg <- messageIconI Warning IconLocked MsgNoAutomaticUpdateTip
|
||||
messageTooltip msg
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
130
src/Handler/Utils/AvsUpdate.hs
Normal file
130
src/Handler/Utils/AvsUpdate.hs
Normal file
@ -0,0 +1,130 @@
|
||||
-- SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
{-# OPTIONS_GHC -fno-warn-unused-top-binds -fno-warn-orphans #-}
|
||||
-- Module for Template Haskell functions to be executed at compile time
|
||||
-- to allow safe static partial functions
|
||||
|
||||
module Handler.Utils.AvsUpdate where
|
||||
|
||||
|
||||
import Import
|
||||
|
||||
{-# ANN module ("HLint: ignore Use camelCase" :: String) #-}
|
||||
|
||||
-- import Utils.Avs
|
||||
|
||||
|
||||
-- FAILED ATTEMPTS AT COMPILE-TIME-CHECKS USING TEMPLATE HASKELL:
|
||||
-- import Language.Haskell.TH.Lift
|
||||
-- import Language.Haskell.TH.Syntax
|
||||
--
|
||||
-- deriving instance Lift (EntityField User typ) -- possible
|
||||
--
|
||||
-- Lift instances for lenses are not possible:
|
||||
-- type Getting r s a = (a -> Const r a) -> s -> Const r s
|
||||
-- deriving instance Lift (Getting typ AvsPersonInfo typ)
|
||||
-- deriving instance Lift (Getting (First typ) AvsPersonInfo typ)
|
||||
-- deriving instance Lift (CheckUpdate User AvsPersonInfo)
|
||||
-- instance Lift (CheckUpdate User i) where
|
||||
-- -- liftTyped :: forall (m :: Type -> Type). Quote m => t -> Code m t
|
||||
-- liftTyped (CheckUpdate up l) = [||CheckUpdate up l||]
|
||||
-- liftTyped (CheckUpdateOpt up l) = [||CheckUpdateOpt up l||]
|
||||
--
|
||||
-- instance Lift (CheckUpdate record iraw) where
|
||||
-- -- liftTyped :: forall (m :: Type -> Type). Quote m => t -> Code m t
|
||||
-- lift = $(makeLift ''CheckUpdate)
|
||||
-- mkUsrPerUpd upd = getUserPersonUpd $$(liftTyped upd)
|
||||
|
||||
|
||||
{-
|
||||
CheckUpdate is usually a statically known pair between a DB record and a lens.
|
||||
However, lenses cannot be an instance of Lift for compile time checking (see above).
|
||||
Hence we encode the statically known pairs through a type family.
|
||||
-}
|
||||
|
||||
|
||||
class MkCheckUpdate a where
|
||||
type MCU_Rec a :: Type
|
||||
type MCU_Raw a :: Type
|
||||
mkCheckUpdate :: a -> CheckUpdate (MCU_Rec a) (MCU_Raw a)
|
||||
|
||||
data CU_AvsPersonInfo_User
|
||||
= CU_API_UserFirstName
|
||||
| CU_API_UserSurname
|
||||
| CU_API_UserDisplayName
|
||||
| CU_API_UserBirthday
|
||||
| CU_API_UserMobile
|
||||
| CU_API_UserMatrikelnummer
|
||||
| CU_API_UserCompanyPersonalNumber
|
||||
| CU_API_UserLdapPrimaryKey
|
||||
-- CU_API_UserDisplayEmail -- use _avsContactPrimaryEmailAddress instead
|
||||
deriving (Show, Eq)
|
||||
|
||||
instance MkCheckUpdate CU_AvsPersonInfo_User where
|
||||
type MCU_Rec CU_AvsPersonInfo_User = User
|
||||
type MCU_Raw CU_AvsPersonInfo_User = AvsPersonInfo
|
||||
mkCheckUpdate CU_API_UserFirstName = CheckUpdate UserFirstName _avsInfoFirstName
|
||||
mkCheckUpdate CU_API_UserSurname = CheckUpdate UserSurname _avsInfoLastName
|
||||
mkCheckUpdate CU_API_UserDisplayName = CheckUpdate UserDisplayName _avsInfoDisplayName
|
||||
mkCheckUpdate CU_API_UserBirthday = CheckUpdateMay UserBirthday _avsInfoDateOfBirth
|
||||
mkCheckUpdate CU_API_UserMobile = CheckUpdateMay UserMobile _avsInfoPersonMobilePhoneNo
|
||||
mkCheckUpdate CU_API_UserMatrikelnummer = CheckUpdateMay UserMatrikelnummer $ _avsInfoPersonNo . re _Just -- Maybe im User, aber nicht im AvsInfo; also: `re _Just` work like `to Just
|
||||
mkCheckUpdate CU_API_UserCompanyPersonalNumber = CheckUpdateMay UserCompanyPersonalNumber $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just -- Maybe im User und im AvsInfo; needs special treatment, see ldap_ups abov
|
||||
mkCheckUpdate CU_API_UserLdapPrimaryKey = CheckUpdateMay UserLdapPrimaryKey $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just
|
||||
-- mkCheckUpdate CU_API_UserDisplayEmail = CheckUpdateOpt UserDisplayEmail $ _avsInfoPersonEMail . _Just . from _CI -- Maybe im AvsInfo, aber nicht im User, daher Opt
|
||||
|
||||
data CU_AvsDataContcat_User
|
||||
= CU_ADC_UserPostAddress
|
||||
| CU_ADC_UserDisplayEmail
|
||||
deriving (Show, Eq)
|
||||
|
||||
instance MkCheckUpdate CU_AvsDataContcat_User where
|
||||
type MCU_Rec CU_AvsDataContcat_User = User
|
||||
type MCU_Raw CU_AvsDataContcat_User = AvsDataContact
|
||||
mkCheckUpdate CU_ADC_UserPostAddress = CheckUpdateMay UserPostAddress _avsContactPrimaryPostAddress
|
||||
mkCheckUpdate CU_ADC_UserDisplayEmail = CheckUpdateOpt UserDisplayEmail $ _avsContactPrimaryEmail . _Just . from _CI
|
||||
|
||||
data CU_AvsFirmInfo_User
|
||||
= CU_AFI_UserPostAddress
|
||||
-- CU_AFI_UserEmail -- PROBLEM: UserEmail must be unique!
|
||||
-- CU_AFI_UserDisplayEmail -- use _avsContactPrimaryEmailAddress instead
|
||||
deriving (Show, Eq)
|
||||
|
||||
instance MkCheckUpdate CU_AvsFirmInfo_User where
|
||||
type MCU_Rec CU_AvsFirmInfo_User = User
|
||||
type MCU_Raw CU_AvsFirmInfo_User = AvsFirmInfo
|
||||
mkCheckUpdate CU_AFI_UserPostAddress = CheckUpdateMay UserPostAddress _avsFirmPostAddress
|
||||
-- mkCheckUpdate CU_AFI_UserEmail = CheckUpdateOpt UserEmail $ _avsFirmEMailSuperior . _Just . from _CI -- in rare cases, firm superior email is used as fallback here; but UserEmail must be unique!
|
||||
-- mkCheckUpdate CU_AFI_UserDisplayEmail = CheckUpdateOpt UserDisplayEmail $ _avsFirmPrimaryEmail . _Just . from _CI -- Maybe im AvsInfo, aber nicht im User, daher Opt
|
||||
|
||||
|
||||
-- NOTE: Ensure that the lenses between CU_UserAvs_User and CU_AvsPersonInfo_User/CU_AvsFirmInfo_User agree!
|
||||
data CU_UserAvs_User
|
||||
= CU_UA_UserPinPassword
|
||||
-- CU_UA_UserPostAddress -- use _avsContactPrimaryPostAddress instead
|
||||
| CU_UA_UserFirstName
|
||||
| CU_UA_UserSurname
|
||||
| CU_UA_UserDisplayName
|
||||
| CU_UA_UserBirthday
|
||||
| CU_UA_UserMobile
|
||||
| CU_UA_UserMatrikelnummer
|
||||
| CU_UA_UserCompanyPersonalNumber
|
||||
| CU_UA_UserLdapPrimaryKey
|
||||
-- CU_UA_UserDisplayEmail -- use _avsContactPrimaryEmail instead
|
||||
deriving (Show, Eq)
|
||||
|
||||
instance MkCheckUpdate CU_UserAvs_User where
|
||||
type MCU_Rec CU_UserAvs_User = User
|
||||
type MCU_Raw CU_UserAvs_User = UserAvs
|
||||
mkCheckUpdate CU_UA_UserPinPassword = CheckUpdateOpt UserPinPassword $ _userAvsLastCardNo . _Just . to avsFullCardNo2pin . re _Just
|
||||
-- mkCheckUpdate CU_UA_UserPostAddress = CheckUpdateOpt UserPostAddress $ _userAvsLastFirmInfo . _Just . _avsFirmPostAddress
|
||||
mkCheckUpdate CU_UA_UserFirstName = CheckUpdateOpt UserFirstName $ _userAvsLastPersonInfo . _Just . _avsInfoFirstName
|
||||
mkCheckUpdate CU_UA_UserSurname = CheckUpdateOpt UserSurname $ _userAvsLastPersonInfo . _Just . _avsInfoLastName
|
||||
mkCheckUpdate CU_UA_UserDisplayName = CheckUpdateOpt UserDisplayName $ _userAvsLastPersonInfo . _Just . _avsInfoDisplayName
|
||||
mkCheckUpdate CU_UA_UserBirthday = CheckUpdateOpt UserBirthday $ _userAvsLastPersonInfo . _Just . _avsInfoDateOfBirth
|
||||
mkCheckUpdate CU_UA_UserMobile = CheckUpdateOpt UserMobile $ _userAvsLastPersonInfo . _Just . _avsInfoPersonMobilePhoneNo
|
||||
mkCheckUpdate CU_UA_UserMatrikelnummer = CheckUpdateOpt UserMatrikelnummer $ _userAvsLastPersonInfo . _Just . _avsInfoPersonNo . re _Just -- Maybe im User, aber nicht im AvsInfo; also: `re _Just` work like `to Just
|
||||
mkCheckUpdate CU_UA_UserCompanyPersonalNumber = CheckUpdateOpt UserCompanyPersonalNumber $ _userAvsLastPersonInfo . _Just . _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just -- Maybe im User und im AvsInfo; needs special treatment, see ldap_ups abov
|
||||
mkCheckUpdate CU_UA_UserLdapPrimaryKey = CheckUpdateOpt UserLdapPrimaryKey $ _userAvsLastPersonInfo . _Just . _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just
|
||||
-- mkCheckUpdate CU_UA_UserDisplayEmail = CheckUpdateOpt UserDisplayEmail $ _userAvsLastPersonInfo . _Just . _avsInfoPersonEMail . _Just . from _CI
|
||||
@ -15,7 +15,7 @@ module Handler.Utils.Communication
|
||||
|
||||
import Import
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Users
|
||||
import Handler.Utils.Users
|
||||
|
||||
import Jobs.Queue
|
||||
|
||||
@ -102,7 +102,7 @@ crJobsCourseCommunication jCourse Communication{..} = do
|
||||
adrReceiverMails = Set.map (Address Nothing . CI.original) rawReceiverMails
|
||||
netReceiverAddresses <- lift $ do
|
||||
netReceiverIds <- getReceiversFor $ jSender : Set.toList rawReceiverIds -- ensure supervisors get only one email
|
||||
(userAddress . entityVal) <<$>> selectList [UserId <-. netReceiverIds] []
|
||||
maybeMapM getEmailAddressFor netReceiverIds
|
||||
-- let jAllRecipientAddresses = Set.fromList netReceiverAddresses <> adrReceiverMails
|
||||
let jAllRecipientAddresses = Set.map getAddress (Set.fromList (AddressEqIgnoreName <$> netReceiverAddresses) <> Set.map AddressEqIgnoreName adrReceiverMails)
|
||||
forM_ jAllRecipientAddresses $ \raddr ->
|
||||
@ -124,7 +124,7 @@ crJobsFirmCommunication jCompanies Communication{..} = do
|
||||
adrReceiverMails = Set.map (Address Nothing . CI.original) rawReceiverMails
|
||||
netReceiverAddresses <- lift $ do
|
||||
netReceiverIds <- getReceiversFor $ jSender : Set.toList rawReceiverIds -- ensure supervisors get only one email
|
||||
(userAddress . entityVal) <<$>> selectList [UserId <-. netReceiverIds] []
|
||||
maybeMapM getEmailAddressFor netReceiverIds
|
||||
-- let jAllRecipientAddresses = Set.fromList netReceiverAddresses <> adrReceiverMails
|
||||
let jAllRecipientAddresses = Set.map getAddress (Set.fromList (AddressEqIgnoreName <$> netReceiverAddresses) <> Set.map AddressEqIgnoreName adrReceiverMails)
|
||||
forM_ jAllRecipientAddresses $ \raddr ->
|
||||
@ -145,7 +145,7 @@ commR CommunicationRoute{..} = do
|
||||
decrypt' cID = do
|
||||
uid <- decrypt cID
|
||||
whenIsJust crRecipientAuth $ guardAuthResult <=< ($ uid)
|
||||
getEntity uid
|
||||
getEntity uid
|
||||
cUser <- maybeAuth
|
||||
(chosenRecipients, suggestedRecipients) <- runDB $ (,)
|
||||
<$> (maybe id cons cUser . catMaybes <$> (mapM decrypt' =<< lookupGlobalGetParams GetRecipient))
|
||||
@ -155,7 +155,7 @@ commR CommunicationRoute{..} = do
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
mbCurrentRoute <- getCurrentRoute
|
||||
globalCC <- getsYesod $ view _appCommunicationGlobalCC
|
||||
|
||||
|
||||
let
|
||||
lookupUser :: UserId -> (UserDisplayName,UserSurname)
|
||||
lookupUser =
|
||||
@ -163,7 +163,7 @@ commR CommunicationRoute{..} = do
|
||||
usrNames Nothing = ("???","???") -- this case only happens during runFormPost when POST Data is present and no form is display
|
||||
usrNames (Just User{userDisplayName, userSurname}) = (userDisplayName, userSurname)
|
||||
in usrNames . flip Map.lookup usrMap
|
||||
|
||||
|
||||
chosenRecipients' = Map.fromList $
|
||||
[ ( (BoundedPosition $ RecipientGroup g, pos)
|
||||
, (Right recp, recp `elem` map entityKey chosenRecipients)
|
||||
@ -174,9 +174,9 @@ commR CommunicationRoute{..} = do
|
||||
[ ( (BoundedPosition RecipientCustom, pos)
|
||||
, (recp, True)
|
||||
)
|
||||
| (pos, recp) <- zip [0..]
|
||||
| (pos, recp) <- zip [0..]
|
||||
( mcons (Left <$> globalCC)
|
||||
(Right <$> Set.toList (Set.fromList (map entityKey chosenRecipients) \\ Set.fromList (concatMap (map entityKey) $ view _2 <$> suggestedRecipients)))
|
||||
(Right <$> Set.toList (Set.fromList (map entityKey chosenRecipients) \\ Set.fromList (concatMap (map entityKey . view _2) suggestedRecipients)))
|
||||
)
|
||||
]
|
||||
activeCategories = map RecipientGroup (view _1 <$> suggestedRecipients) `snoc` RecipientCustom
|
||||
@ -243,7 +243,7 @@ commR CommunicationRoute{..} = do
|
||||
postProcess = Set.fromList . map fst . filter snd . Map.elems
|
||||
|
||||
recipientsListMsg <- messageI Info MsgCommRecipientsList
|
||||
|
||||
|
||||
attachmentsMaxSize <- getsYesod $ view _appCommunicationAttachmentsMaxSize
|
||||
let attachmentField = genericFileField $ return FileField
|
||||
{ fieldIdent = Nothing
|
||||
@ -261,9 +261,9 @@ commR CommunicationRoute{..} = do
|
||||
<*> ( CommunicationContent
|
||||
<$> aopt textField (fslI MsgCommSubject & addAttr "uw-enter-as-tab" "") Nothing
|
||||
<*> (markupOutput <$> areq htmlField (fslI MsgCommBody) Nothing)
|
||||
<*> fmap fold (aopt (convertFieldM (runConduit . (.| C.foldMap Set.singleton)) yieldMany attachmentField)
|
||||
<*> fmap fold (aopt (convertFieldM (runConduit . (.| C.foldMap Set.singleton)) yieldMany attachmentField)
|
||||
(fslI MsgCommAttachments & setTooltip MsgCommAttachmentsTip) Nothing)
|
||||
)
|
||||
)
|
||||
formResult commRes $ \case
|
||||
(comm, BtnCommunicationSend) -> do
|
||||
runDBJobs . runConduit $ transPipe (mapReaderT lift) (crJobs comm) .| sinkDBJobs
|
||||
@ -272,13 +272,13 @@ commR CommunicationRoute{..} = do
|
||||
(comm, BtnCommunicationTest) -> do
|
||||
runDBJobs . runConduit $ transPipe (mapReaderT lift) (crTestJobs comm) .| sinkDBJobs
|
||||
addMessageI Info MsgCommTestSuccess
|
||||
|
||||
|
||||
let formWdgt = wrapForm commWdgt def
|
||||
{ formMethod = POST
|
||||
, formAction = SomeRoute <$> mbCurrentRoute
|
||||
, formEncoding = commEncoding
|
||||
, formSubmit = FormNoSubmit
|
||||
}
|
||||
}
|
||||
siteLayoutMsg crHeading $ do
|
||||
setTitleI crTitle
|
||||
let commTestTip = $(i18nWidgetFile "comm-test-tip")
|
||||
|
||||
@ -4,57 +4,240 @@
|
||||
|
||||
module Handler.Utils.Company where
|
||||
|
||||
|
||||
import Import
|
||||
-- import Utils.PathPiece
|
||||
|
||||
-- import Data.CaseInsensitive (CI)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import qualified Data.Char as Char
|
||||
import qualified Data.Text as Text
|
||||
|
||||
-- import qualified Data.CaseInsensitive as CI
|
||||
-- import qualified Data.Char as Char
|
||||
-- import qualified Data.Text as Text
|
||||
import Database.Persist.Postgresql
|
||||
|
||||
-- | Ensure that the given user is linked to the given company
|
||||
upsertUserCompany :: UserId -> Maybe Text -> Maybe StoredMarkup -> DB ()
|
||||
upsertUserCompany uid (Just cName) cAddr | notNull cName = do
|
||||
cid <- upsertCompany cName cAddr
|
||||
void $ upsertBy (UniqueUserCompany uid cid)
|
||||
(UserCompany uid cid False False)
|
||||
[]
|
||||
superVs <- selectList [UserCompanyCompany ==. cid, UserCompanySupervisor ==. True] []
|
||||
upsertManyWhere [ UserSupervisor super uid reroute
|
||||
| Entity{entityVal=UserCompany{userCompanyUser=super, userCompanySupervisorReroute=reroute, userCompanySupervisor=True}} <- superVs
|
||||
] [] [] []
|
||||
upsertUserCompany uid _ _ =
|
||||
deleteWhere [ UserCompanyUser ==. uid ] -- maybe also delete company supervisors?
|
||||
import Database.Esqueleto.Experimental ((:&)(..))
|
||||
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
import qualified Database.Esqueleto.PostgreSQL as E
|
||||
|
||||
-- | Does not update company address for now
|
||||
-- TODO: update company address, maybe?!
|
||||
upsertCompany :: Text -> Maybe StoredMarkup -> DB CompanyId
|
||||
upsertCompany cName cAddr =
|
||||
let cName' = CI.mk cName in
|
||||
getBy (UniqueCompanyName cName') >>= \case
|
||||
Just ent -> return $ entityKey ent
|
||||
Nothing -> getBy (UniqueCompanySynonym cName') >>= \case
|
||||
Just ent -> return . CompanyKey . companySynonymCanonical $ entityVal ent
|
||||
Nothing -> do
|
||||
let cShort = companyShorthandFromName cName
|
||||
cShort' <- findShort cName' $ CI.mk cShort
|
||||
let compy = Company cName' cShort' 0 False cAddr Nothing -- TODO: Fix this once AVS CR3 SCF-165 is implemented
|
||||
either entityKey id <$> insertBy compy
|
||||
where
|
||||
findShort :: CompanyName -> CompanyShorthand -> DB CompanyShorthand
|
||||
findShort fna fsh = aux 0
|
||||
where
|
||||
aux n = let fsh' = if n==0 then fsh else fsh <> CI.mk (tshow n) in
|
||||
checkUnique (Company fna fsh' 0 False Nothing Nothing) >>= \case
|
||||
Nothing -> return fsh'
|
||||
_other -> aux (n+1)
|
||||
import Handler.Utils.Users
|
||||
import Handler.Utils.Widgets
|
||||
|
||||
-- | Just a cheap heuristic, needs manual intervention anyway
|
||||
companyShorthandFromName :: Text -> Text
|
||||
companyShorthandFromName cName =
|
||||
let cpats = splitCamel cName
|
||||
strip = Text.filter Char.isAlphaNum . Text.take 3
|
||||
spats = strip <$> cpats
|
||||
in Text.concat spats
|
||||
-- Snippet to restrict to primary company only
|
||||
-- E.&&. E.notExists (do
|
||||
-- othr <- E.from $ E.table @UserCompany
|
||||
-- E.where_ $ othr E.^. UserCompanyPriority E.>. userCompany E.^. UserCompanyPriority
|
||||
-- E.&&. othr E.^. UserCompanyUser E.==. userCompany E.^. UserCompanyUser
|
||||
-- E.&&. othr E.^. UserCompanyCompany E.!=. E.val cid -- redundant due to > above, but likely performance improving
|
||||
-- )
|
||||
|
||||
company2msg :: CompanyId -> SomeMessage UniWorX
|
||||
company2msg = text2message . ciOriginal . unCompanyKey
|
||||
|
||||
wgtCompanies :: UserId -> DB (Maybe Widget)
|
||||
wgtCompanies = \uid -> do
|
||||
companies <- E.select $ do
|
||||
(usrComp :& comp) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @Company
|
||||
`E.on` (\(usrComp :& comp) -> 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, usrComp E.^. UserCompanyPriority)
|
||||
let (mPri, topCmp, otherCmp) = procCmp mPri companies
|
||||
resWgt =
|
||||
[whamlet|
|
||||
$forall c <- topCmp
|
||||
<p>
|
||||
^{c}
|
||||
$forall c <- otherCmp
|
||||
<p>
|
||||
^{c}
|
||||
|]
|
||||
return $ toMaybe (notNull topCmp) resWgt
|
||||
where
|
||||
procCmp _ [] = (0, [], [])
|
||||
procCmp maxPri ((E.Value cmpSh, E.Value cmpName, E.Value cmpSpr, E.Value cmpPrio) : cs) =
|
||||
let isTop = cmpPrio >= maxPri
|
||||
cmpWgt = companyWidget isTop (cmpSh, cmpName, cmpSpr)
|
||||
(accPri,accTop,accRem) = procCmp maxPri cs
|
||||
in (max cmpPrio accPri, bool accTop (cmpWgt : accTop) isTop, bool (cmpWgt : accRem) accRem isTop) -- lazy evaluation after repmin example, don't factor out the bool!
|
||||
|
||||
type AnySuperReason = Either SupervisorReason (Maybe Text)
|
||||
|
||||
|
||||
addDefaultSupervisors' :: CompanyId -> NonEmpty UserId -> DB Int64
|
||||
addDefaultSupervisors' = addDefaultSupervisors $ Just $ tshow SupervisorReasonCompanyDefault
|
||||
|
||||
-- adds the default company supervisors as supervisor to a given set of users, which themselves may belong to any company
|
||||
-- if no reason is given, SupervisorReasonCompanyDefault is used, except if reason == Just "NULL"
|
||||
addDefaultSupervisors :: Maybe Text -> CompanyId -> NonEmpty UserId -> DB Int64
|
||||
addDefaultSupervisors reason cid employees = do
|
||||
E.insertSelectWithConflictCount UniqueUserSupervisor
|
||||
(do
|
||||
(spr :& usr) <- E.from $ E.table @UserCompany `E.crossJoin` E.toValues employees
|
||||
E.where_ $ spr E.^. UserCompanyCompany E.==. E.val cid
|
||||
E.&&. spr E.^. UserCompanySupervisor
|
||||
E.distinct $ return $ UserSupervisor
|
||||
E.<# (spr E.^. UserCompanyUser)
|
||||
E.<&> usr
|
||||
E.<&> (spr E.^. UserCompanySupervisorReroute)
|
||||
E.<&> E.justVal cid
|
||||
E.<&> case reason of
|
||||
Nothing -> E.justVal $ tshow SupervisorReasonCompanyDefault
|
||||
Just "NULL" -> E.nothing
|
||||
other -> E.val other
|
||||
)
|
||||
(\old new ->
|
||||
[ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
|
||||
, UserSupervisorCompany E.=. E.justVal cid
|
||||
, UserSupervisorReason E.=. E.coalesce [new E.^. UserSupervisorReason, old E.^. UserSupervisorReason] -- keep existing reason, if no new one was given
|
||||
])
|
||||
|
||||
|
||||
-- like `Handler.Utils.addDefaultSupervisors`, but selects all employees of given companies from database, optionally filtered by being under supervision of a given individual
|
||||
-- TODO: check redundancies
|
||||
addDefaultSupervisorsFor :: (CompanyId ~ Element mono, MonoFoldable mono) => Maybe Text -> Maybe UserId -> Bool -> mono -> DB Int64
|
||||
addDefaultSupervisorsFor reason mbSuperId mutualSupervision cids = do
|
||||
E.insertSelectWithConflictCount UniqueUserSupervisor
|
||||
(do
|
||||
(spr :& usr) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @UserCompany `E.on` (\(spr :& usr) -> spr E.^. UserCompanyCompany E.==. usr E.^. UserCompanyCompany)
|
||||
E.where_ $ E.and $ guardMonoid (not mutualSupervision)
|
||||
[ E.not__ $ usr E.^. UserCompanySupervisor ]
|
||||
<> maybeEmpty mbSuperId (\sprId -> [E.exists $ do
|
||||
superv <- E.from $ E.table @UserSupervisor
|
||||
E.where_ $ superv E.^. UserSupervisorSupervisor E.==. E.val sprId
|
||||
E.&&. superv E.^. UserSupervisorUser E.==. usr E.^. UserCompanyUser
|
||||
])
|
||||
<> [ spr E.^. UserCompanySupervisor
|
||||
, spr E.^. UserCompanyCompany `E.in_` E.vals cids
|
||||
, usr E.^. UserCompanyCompany `E.in_` E.vals cids
|
||||
]
|
||||
E.distinct $ return $ UserSupervisor
|
||||
E.<# (spr E.^. UserCompanyUser)
|
||||
E.<&> (usr E.^. UserCompanyUser)
|
||||
E.<&> (spr E.^. UserCompanySupervisorReroute)
|
||||
E.<&> E.just (spr E.^. UserCompanyCompany)
|
||||
E.<&> E.val reason
|
||||
)
|
||||
(\old new ->
|
||||
[ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
|
||||
, UserSupervisorCompany E.=. new E.^. UserSupervisorCompany
|
||||
, UserSupervisorReason E.=. E.coalesce [new E.^. UserSupervisorReason, old E.^. UserSupervisorReason] -- keep existing reason, if no new one was given
|
||||
] )
|
||||
|
||||
-- like `addDefaultSupervisors`, but selects all employees of given companies from database
|
||||
-- TODO: check redundancies
|
||||
addDefaultSupervisorsAll :: (CompanyId ~ Element mono, MonoFoldable mono) => Maybe Text -> Bool -> mono -> DB Int64
|
||||
addDefaultSupervisorsAll reason mutualSupervision cids = do
|
||||
E.insertSelectWithConflictCount UniqueUserSupervisor
|
||||
(do
|
||||
(spr :& usr) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @UserCompany `E.on` (\(spr :& usr) -> spr E.^. UserCompanyCompany E.==. usr E.^. UserCompanyCompany)
|
||||
E.where_ $ E.and $ guardMonoid (not mutualSupervision)
|
||||
[ E.not__ $ usr E.^. UserCompanySupervisor ]
|
||||
<> [ spr E.^. UserCompanySupervisor
|
||||
, spr E.^. UserCompanyCompany `E.in_` E.vals cids
|
||||
, usr E.^. UserCompanyCompany `E.in_` E.vals cids
|
||||
]
|
||||
E.distinct $ return $ UserSupervisor
|
||||
E.<# (spr E.^. UserCompanyUser)
|
||||
E.<&> (usr E.^. UserCompanyUser)
|
||||
E.<&> (spr E.^. UserCompanySupervisorReroute)
|
||||
E.<&> E.just (spr E.^. UserCompanyCompany)
|
||||
E.<&> E.val reason
|
||||
)
|
||||
(\old new ->
|
||||
[ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
|
||||
, UserSupervisorCompany E.=. new E.^. UserSupervisorCompany
|
||||
, UserSupervisorReason E.=. E.coalesce [old E.^. UserSupervisorReason, new E.^. UserSupervisorReason] -- keep any existing reason
|
||||
] )
|
||||
|
||||
-- | removes user supervisorship on switch. WARNING: problems are not yet written to DB via reportProblem yet
|
||||
switchAvsUserCompany :: Bool -> Bool -> UserId -> CompanyId -> DB ([Update User], [AdminProblem])
|
||||
switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = do
|
||||
usrRec <- get404 uid
|
||||
newCompany <- get404 newCompanyId
|
||||
mbUsrComp <- getUserPrimaryCompany uid
|
||||
mbOldComp <- (get . userCompanyCompany) `traverseJoin` mbUsrComp
|
||||
mbUsrAvs <- if usrPostEmailUpds then getBy (UniqueUserAvsUser uid) else return Nothing
|
||||
let usrPostAddr :: Maybe StoredMarkup = userPostAddress usrRec
|
||||
avsPostAddr :: Maybe StoredMarkup = mbUsrAvs ^? _Just . _entityVal . _userAvsLastFirmInfo . _Just . _avsFirmPostAddress . _Just
|
||||
usrPostUp = toMaybe (usrPostEmailUpds && fromMaybe False (liftA2 isSimilarMarkup usrPostAddr avsPostAddr))
|
||||
(UserPostAddress =. Nothing) -- use company address indirectly instead
|
||||
usrPrefPost = userPrefersPostal usrRec
|
||||
usrPrefPostUp = toMaybe (Just usrPrefPost == (mbOldComp ^? _Just . _companyPrefersPostal))
|
||||
(UserPrefersPostal =. companyPrefersPostal newCompany)
|
||||
-- newCmpEmail :: UserEmail = fromMaybe "" $ companyEmail newCompany
|
||||
usrDisplayEmail :: UserEmail = userDisplayEmail usrRec
|
||||
avsEmail :: Maybe UserEmail = mbUsrAvs ^? _Just . _entityVal . _userAvsLastFirmInfo . _Just . _avsFirmPrimaryEmail . _Just . from _CI
|
||||
usrDisplayEmailUp = toMaybe (usrPostEmailUpds && avsEmail == Just usrDisplayEmail) (UserDisplayEmail =. "") -- delete DisplayEmail, if equal to AVS Firm Email
|
||||
usrUpdate = catMaybes [usrPostUp, usrPrefPostUp, usrDisplayEmailUp]
|
||||
-- [UserPostAddress =. Nothing, UserPrefersPostal =. companyPrefersPostal newCompany] -- unconditional
|
||||
|
||||
newUserComp = UserCompany uid newCompanyId False False 1 True Nothing -- default value for new company insertion, if no update can be done
|
||||
superReasonComDef = tshow SupervisorReasonCompanyDefault
|
||||
|
||||
-- update uid usrUpdate
|
||||
-- repsertSuperiorSupervisor is not called here, since the Superior is indepentent of the actual company association
|
||||
case mbUsrComp of
|
||||
Nothing -> do -- create company user
|
||||
void $ insertUnique newUserComp
|
||||
void $ addDefaultSupervisors Nothing newCompanyId $ singleton uid
|
||||
return (usrUpdate, mempty)
|
||||
Just UserCompany{userCompanyCompany=oldCompanyId, userCompanyPriority=oldPrio, userCompanySupervisor=oldSuper, userCompanySupervisorReroute=oldSuperReroute, userCompanyReason=oldAssocReason}
|
||||
| newCompanyId == oldCompanyId -> return mempty -- nothing to do
|
||||
| otherwise -> do -- switch company
|
||||
when (isNothing oldAssocReason) $ deleteBy $ UniqueUserCompany uid oldCompanyId
|
||||
void $ upsertBy (UniqueUserCompany uid newCompanyId) newUserComp{userCompanyPriority = succ oldPrio}
|
||||
[UserCompanyPriority =. succ oldPrio, UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False, UserCompanyUseCompanyAddress =. True, UserCompanyReason =. Nothing]
|
||||
-- supervised by uid
|
||||
supervisees :: [(Entity UserSupervisor, E.Value Bool)] <- E.select $ do
|
||||
usrSup <- E.from $ E.table @UserSupervisor
|
||||
E.where_ $ usrSup E.^. UserSupervisorSupervisor E.==. E.val uid
|
||||
E.&&. usrSup E.^. UserSupervisorCompany E.~=. E.val oldCompanyId
|
||||
E.&&. usrSup E.^. UserSupervisorReason E.~=. E.val superReasonComDef
|
||||
let singleSup = E.notExists $ do
|
||||
othSup <- E.from $ E.table @UserSupervisor
|
||||
E.where_ $ usrSup E.^. UserSupervisorUser E.==. othSup E.^. UserSupervisorUser
|
||||
E.&&. othSup E.^. UserSupervisorCompany E.~=. E.val oldCompanyId
|
||||
E.&&. othSup E.^. UserSupervisorReason E.~=. E.val superReasonComDef
|
||||
return (usrSup, singleSup)
|
||||
newlyUnsupervised <- guardMonoidM (notNull supervisees) $ do
|
||||
E.delete $ do
|
||||
usrSup <- E.from $ E.table @UserSupervisor
|
||||
E.where_ $ usrSup E.^. UserSupervisorId `E.in_` E.vals (fmap (entityKey . fst) supervisees)
|
||||
return $ [ AdminProblemSupervisorLeftCompany subid oldCompanyId oldSuperReroute
|
||||
| (Entity{entityVal=UserSupervisor{userSupervisorUser=subid}}, E.Value True) <- supervisees ]
|
||||
-- supervisors of uid
|
||||
let superDeftFltr = (UserSupervisorUser ==. uid) : (UserSupervisorReason ~=. superReasonComDef)
|
||||
oldSubFltr = (UserSupervisorCompany ~=. oldCompanyId) <> superDeftFltr
|
||||
oldAPs <- if keepOldCompanySupervs
|
||||
then updateWhereCount oldSubFltr [UserSupervisorReason =. Nothing]
|
||||
else deleteWhereCount oldSubFltr
|
||||
void $ addDefaultSupervisors Nothing newCompanyId $ singleton uid
|
||||
newAPs <- count $ (UserSupervisorCompany ==. Just newCompanyId) : superDeftFltr
|
||||
let isNoLongerSupervised = not keepOldCompanySupervs && oldAPs > 0 && newAPs <= 0
|
||||
problems = bcons oldSuper (AdminProblemSupervisorNewCompany uid oldCompanyId newCompanyId oldSuperReroute)
|
||||
$ bcons isNoLongerSupervised (AdminProblemNewlyUnsupervised uid (Just oldCompanyId) newCompanyId)
|
||||
newlyUnsupervised
|
||||
return (usrUpdate ,problems)
|
||||
|
||||
defaultSupervisorReasonFilter :: [Filter UserSupervisor]
|
||||
defaultSupervisorReasonFilter =
|
||||
[UserSupervisorReason ==. Nothing]
|
||||
||. [UserSupervisorReason ==. Just (tshow SupervisorReasonCompanyDefault)]
|
||||
||. [UserSupervisorReason ==. Just (tshow SupervisorReasonAvsSuperior )]
|
||||
-- ||. [UserSupervisorReason <-. Nothing : [Just $ tshow r | r <- [SupervisorReasonCompanyDefault, SupervisorReasonAvsSuperior]]] -- Does <-. work with Nothing?
|
||||
|
||||
-- | remove supervisors for given users; maybe restricted to those linked to given companies or supervisors
|
||||
deleteDefaultSupervisorsForUsers :: [CompanyId] -> [UserId] -> NonEmpty UserId -> DB Int64
|
||||
deleteDefaultSupervisorsForUsers cids sprs usrs =
|
||||
deleteWhereCount
|
||||
$ bcons (notNull cids) (UserSupervisorCompany <-. (cids <&> Just))
|
||||
$ bcons (notNull sprs) (UserSupervisorSupervisor <-. sprs)
|
||||
$ (UserSupervisorUser <-. toList usrs) : defaultSupervisorReasonFilter
|
||||
|
||||
-- | retrieve maximum company user priority fo a user
|
||||
getCompanyUserMaxPrio :: UserId -> DB Int
|
||||
getCompanyUserMaxPrio uid = do
|
||||
mbMaxPrio <- E.selectOne $ do
|
||||
usrCmp <- E.from $ E.table @UserCompany
|
||||
E.where_ $ usrCmp E.^. UserCompanyUser E.==. E.val uid
|
||||
return . E.max_ $ usrCmp E.^. UserCompanyPriority
|
||||
return $ maybe 1 (fromMaybe 1 . E.unValue) mbMaxPrio
|
||||
|
||||
@ -13,6 +13,12 @@ import UnliftIO.Concurrent as Handler.Utils.Concurrent hiding (yield)
|
||||
|
||||
|
||||
|
||||
maybeTimeoutHandler :: Maybe Int -> HandlerFor site a -> HandlerFor site (Maybe a)
|
||||
maybeTimeoutHandler Nothing = fmap Just
|
||||
maybeTimeoutHandler (Just secs) = timeoutHandler $ bool maxBound micro (micro > 0)
|
||||
where
|
||||
micro = 1000000 * secs
|
||||
|
||||
-- | Run a handler action until it finishes or if it exceeds a given number of microseconds via `registerDelay`
|
||||
timeoutHandler :: Int -> HandlerFor site a -> HandlerFor site (Maybe a)
|
||||
timeoutHandler maxWait act = do
|
||||
|
||||
@ -109,14 +109,14 @@ showCourseEventRoom uid courseEvent = E.or
|
||||
]
|
||||
|
||||
getCourseQualifications :: ( MonadHandler m
|
||||
, backend ~ SqlBackend
|
||||
)
|
||||
, backend ~ SqlBackend
|
||||
)
|
||||
=> CourseId -> ReaderT backend m [Entity Qualification]
|
||||
getCourseQualifications cid = Ex.select $ do
|
||||
getCourseQualifications cid = Ex.select $ do
|
||||
(qual :& courseQual) <-
|
||||
Ex.from $ Ex.table @Qualification
|
||||
`Ex.innerJoin` Ex.table @CourseQualification
|
||||
`Ex.on` (\(qual :& courseQual) -> qual E.^. QualificationId E.==. courseQual E.^. CourseQualificationQualification)
|
||||
`Ex.on` (\(qual :& courseQual) -> qual E.^. QualificationId E.==. courseQual E.^. CourseQualificationQualification)
|
||||
Ex.where_ $ courseQual E.^. CourseQualificationCourse E.==. E.val cid
|
||||
Ex.orderBy [E.asc $ courseQual E.^. CourseQualificationSortOrder]
|
||||
Ex.orderBy [E.asc $ courseQual E.^. CourseQualificationSortOrder, E.asc $ qual E.^. QualificationName]
|
||||
pure qual
|
||||
@ -10,7 +10,8 @@ module Handler.Utils.DateTime
|
||||
, toTimeOfDay
|
||||
, toMidnight, beforeMidnight, toMidday, toMorning
|
||||
, toFullHour, roundDownToMinutes, addHours
|
||||
, formatDiffDays, formatCalendarDiffDays
|
||||
, formatDiffDays, formatDiffHours
|
||||
, formatCalendarDiffDays
|
||||
, formatTime'
|
||||
, formatTime, formatTimeUser, formatTimeW, formatTimeMail
|
||||
, formatTimeRange, formatTimeRangeW, formatTimeRangeMail
|
||||
@ -144,8 +145,8 @@ getDateTimeFormatUser sel mUser = do
|
||||
|
||||
getDateTimeFormatUser' :: SelDateTimeFormat -> User -> DateTimeFormat
|
||||
getDateTimeFormatUser' SelFormatDateTime usr = usr & userDateTimeFormat
|
||||
getDateTimeFormatUser' SelFormatDate usr = usr & userDateFormat
|
||||
getDateTimeFormatUser' SelFormatTime usr = usr & userTimeFormat
|
||||
getDateTimeFormatUser' SelFormatDate usr = usr & userDateFormat
|
||||
getDateTimeFormatUser' SelFormatTime usr = usr & userTimeFormat
|
||||
|
||||
getDateTimeFormatter :: (MonadHandler m, HandlerSite m ~ UniWorX, YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId) => m DateTimeFormatter
|
||||
getDateTimeFormatter = do
|
||||
@ -160,7 +161,7 @@ getDateTimeFormatterUser mUser = do
|
||||
return $ mkDateTimeFormatter locale formatMap appTZ
|
||||
|
||||
getDateTimeFormatterUser' :: (MonadHandler m) => User -> m DateTimeFormatter
|
||||
getDateTimeFormatterUser' usr = do
|
||||
getDateTimeFormatterUser' usr = do
|
||||
locale <- getTimeLocale
|
||||
let formatMap = flip getDateTimeFormatUser' usr
|
||||
return $ mkDateTimeFormatter locale formatMap appTZ
|
||||
@ -263,18 +264,21 @@ formatDiffDays t
|
||||
inHours = tshow $ convertBy nominalHour
|
||||
inMinutes = tshow $ convertBy nominalMinute
|
||||
|
||||
formatDiffHours :: Integral a => a -> Text
|
||||
formatDiffHours = pack . iso8601Show . calendarTimeTime . secondsToNominalDiffTime . (* 3600) . fromIntegral
|
||||
|
||||
formatCalendarDiffDays :: CalendarDiffDays -> Text
|
||||
formatCalendarDiffDays = pack . iso8601Show
|
||||
formatCalendarDiffDays = pack . iso8601Show
|
||||
|
||||
setYear :: Integer -> Day -> Day
|
||||
setYear year date = fromGregorian year m d
|
||||
where
|
||||
(_,m,d) = toGregorian date
|
||||
|
||||
getYear :: Day -> Integer
|
||||
getYear :: Day -> Integer
|
||||
getYear date = y
|
||||
where
|
||||
(y,_,_) = toGregorian date
|
||||
where
|
||||
(y,_,_) = toGregorian date
|
||||
|
||||
dayOfWeekDiff :: DayOfWeek -> DayOfWeek -> Int
|
||||
dayOfWeekDiff a b = mod (fromEnum a - fromEnum b) 7
|
||||
@ -301,14 +305,19 @@ addLocalDays n utct = localTimeToUTCTZ appTZ newLocal
|
||||
newDay = addDays n oldDay
|
||||
newLocal = oldLocal { localDay = newDay }
|
||||
|
||||
-- This is just a Remineder
|
||||
-- addMonths :: Integer -> UTCTime -> UTCTime
|
||||
-- addMonths = addGregorianMonthsRollOver
|
||||
|
||||
|
||||
----------------------
|
||||
-- CalendarDiffDays --
|
||||
----------------------
|
||||
|
||||
fromMonths :: Integral a => a -> CalendarDiffDays
|
||||
fromMonths :: Integral a => a -> CalendarDiffDays
|
||||
fromMonths (toInteger -> m) = CalendarDiffDays { cdMonths = m, cdDays = 0 } -- above is equivalent
|
||||
|
||||
fromDays :: Integral a => a -> CalendarDiffDays
|
||||
fromDays :: Integral a => a -> CalendarDiffDays
|
||||
fromDays (toInteger -> d) = CalendarDiffDays { cdMonths = 0, cdDays = d }
|
||||
|
||||
addDiffDaysClip :: CalendarDiffDays -> UTCTime -> UTCTime
|
||||
@ -388,7 +397,7 @@ formatTimeRangeMail = formatTimeRange' formatTimeMail
|
||||
formatGregorianW :: (YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId) => Integer -> Int -> Int -> WidgetFor UniWorX ()
|
||||
formatGregorianW y m d = formatTimeW SelFormatDate $ fromGregorian y m d
|
||||
|
||||
instance Csv.ToField ZonedTime where
|
||||
instance Csv.ToField ZonedTime where
|
||||
toField = Csv.toField . iso8601Show
|
||||
|
||||
-- also see Data.Time.Clock.Instances
|
||||
|
||||
@ -77,7 +77,7 @@ import qualified Data.Text.Lazy.Builder as Builder
|
||||
-- import Control.Monad.Catch.Pure (runCatch)
|
||||
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
|
||||
|
||||
{-# ANN module ("HLint: ignore Use const" :: String) #-}
|
||||
|
||||
|
||||
@ -217,7 +217,7 @@ optionalAction'' negated minp justAct fs@FieldSettings{..} defActive csrf = do
|
||||
let actionViews = over (mapped . _fvInput) (\w -> $(widgetFile "widgets/multi-action/optional-action")) actionViews'
|
||||
|
||||
return (doRes >>= bool (pure Nothing) (Just <$> actionRes), over _fvInput (mappend $ toWidget csrf) doView : actionViews)
|
||||
|
||||
|
||||
optionalAction :: AForm Handler a
|
||||
-> FieldSettings UniWorX
|
||||
-> Maybe Bool
|
||||
@ -236,7 +236,7 @@ optionalActionA :: AForm Handler a
|
||||
-> Maybe Bool
|
||||
-> AForm Handler (Maybe a)
|
||||
optionalActionA = optionalActionA' mpopt
|
||||
|
||||
|
||||
optionalActionNegatedA :: AForm Handler a
|
||||
-> FieldSettings UniWorX
|
||||
-> Maybe Bool
|
||||
@ -594,6 +594,12 @@ degreeField = selectField $ optionsPersistKey [] [Asc StudyDegreeName, Asc Study
|
||||
degreeFieldEnt :: Field Handler (Entity StudyDegree)
|
||||
degreeFieldEnt = selectField $ optionsPersist [] [Asc StudyDegreeName, Asc StudyDegreeShorthand, Asc StudyDegreeKey] id
|
||||
|
||||
qualificationField :: Field Handler QualificationId
|
||||
qualificationField = selectField $ optionsPersistKey [] [Asc QualificationName] qualificationName
|
||||
|
||||
qualificationFieldShort :: Field Handler QualificationShorthand
|
||||
qualificationFieldShort = selectField $ (qualificationShorthand . entityVal) <<$>> optionsPersist [] [Asc QualificationName] qualificationName
|
||||
|
||||
qualificationFieldEnt :: Field Handler (Entity Qualification)
|
||||
qualificationFieldEnt = selectField $ optionsPersist [] [Asc QualificationName] qualificationName
|
||||
|
||||
@ -734,8 +740,7 @@ uploadModeForm fs prev = multiActionA actions fs (classifyUploadMode <$> prev)
|
||||
let iStart = maybe 0 (succ . fst) $ Map.lookupMax oldRess
|
||||
in pure $ Map.singleton iStart fileRes
|
||||
return (addRes', formWidget')
|
||||
miCell _ initFile _ nudge csrf =
|
||||
sFileForm nudge (Just initFile) csrf
|
||||
miCell _ initFile _ nudge = sFileForm nudge (Just initFile)
|
||||
miDelete :: MassInputDelete ListLength
|
||||
miDelete = miDeleteList
|
||||
miAddEmpty _ _ _ = Set.empty
|
||||
@ -960,9 +965,9 @@ genericFileField mkOpts = Field{..}
|
||||
$logDebugS "genericFileField.getPermittedFiles" $ "Additional: " <> tshow fieldAdditionalFiles
|
||||
$logDebugS "genericFileField.getPermittedFiles" $ "Session: " <> tshow sessionFiles'
|
||||
return $ mconcat
|
||||
[ Map.filter (views _3 $ (||) <$> not . fieldOptionForce <*> not . fieldOptionDefault) $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap
|
||||
[ Map.filter (views _3 $ (||) <$> not . fieldOptionForce <*> not . fieldOptionDefault) $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap
|
||||
, sessionFiles'
|
||||
, Map.filter (views _3 $ (&&) <$> fieldOptionForce <*> fieldOptionDefault) $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap
|
||||
, Map.filter (views _3 $ (&&) <$> fieldOptionForce <*> fieldOptionDefault) $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap
|
||||
]
|
||||
|
||||
handleUpload :: FileField FileReference -> Maybe Text -> ConduitT (File Handler) FileReference (YesodDB UniWorX) ()
|
||||
@ -996,7 +1001,7 @@ genericFileField mkOpts = Field{..}
|
||||
fieldParse :: [Text] -> [FileInfo] -> m (Either (SomeMessage (HandlerSite m)) (Maybe FileUploads))
|
||||
fieldParse vals files' = runExceptT $ do
|
||||
let files = filter (not . null . fileName) files'
|
||||
|
||||
|
||||
opts@FileField{..} <- liftHandler mkOpts
|
||||
|
||||
mIdent <- fmap getFirst . flip foldMapM vals $ \v ->
|
||||
@ -1110,7 +1115,7 @@ genericFileField mkOpts = Field{..}
|
||||
fuiChecked
|
||||
| Right sentVals' <- sentVals
|
||||
= fuiTitle `Set.member` sentVals'
|
||||
| Just (_, _, FileFieldUserOption{..}) <- Map.lookup fuiTitle $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap
|
||||
| Just (_, _, FileFieldUserOption{..}) <- Map.lookup fuiTitle $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap
|
||||
= fieldOptionDefault
|
||||
| otherwise = False
|
||||
fuiSession = fuiTitle `Map.notMember` view _FileReferenceFileReferenceTitleMap fieldAdditionalFiles
|
||||
@ -1195,7 +1200,7 @@ zipFileField :: Bool -- ^ Unpack zips?
|
||||
-> Bool -- ^ Empty files ok?
|
||||
-> Field Handler FileUploads
|
||||
zipFileField doUnpack permittedExtensions emptyOk = zipFileField' doUnpack permittedExtensions emptyOk Nothing
|
||||
|
||||
|
||||
zipFileField' :: Bool -- ^ Unpack zips?
|
||||
-> Maybe (NonNull (Set Extension)) -- ^ Restrictions on file extensions
|
||||
-> Bool -- ^ Empty files ok?
|
||||
@ -1309,16 +1314,16 @@ sheetTypeAFormReq cId fs template = wFormToAForm $ do
|
||||
|
||||
editableExams <- fmap Map.keysSet . flip mapFilterM (foldMap (\(Entity eId exam, Entity _ course, _) -> Map.singleton eId (exam, course)) examParts'') $ \(Exam{..}, Course{..}) ->
|
||||
hasWriteAccessTo $ CExamR courseTerm courseSchool courseShorthand examName EEditR
|
||||
|
||||
|
||||
return (examParts'', editableExams)
|
||||
|
||||
let
|
||||
examParts' = flip foldMap examParts'' $ \(eEnt@(Entity eId _), _, epEnt) -> guardOn @[] (eId `Set.member` editableExams) (eEnt, epEnt)
|
||||
examParts = flip sortOn examParts' $ \(Entity _ Exam{..}, Entity _ ExamPart{..}) -> (examName, examPartNumber)
|
||||
|
||||
|
||||
doExamPartPoints = fmap classifySheetType template == Just ExamPartPoints'
|
||||
|| not (null examParts)
|
||||
|
||||
|
||||
acts = Map.fromList $ catMaybes
|
||||
[ pure ( Normal', Normal <$> gradingReq )
|
||||
, pure ( Bonus' , Bonus <$> gradingReq )
|
||||
@ -1340,7 +1345,7 @@ sheetTypeAFormReq cId fs template = wFormToAForm $ do
|
||||
Informational' -> return $ i18n MsgSheetTypeInfoInformational
|
||||
NotGraded' -> return $ i18n MsgSheetTypeInfoNotGraded
|
||||
ExamPartPoints' -> return $ i18n MsgSheetTypeInfoExamPartPoints
|
||||
|
||||
|
||||
aFormToWForm . explainedMultiActionA acts opts fs $ classifySheetType <$> template
|
||||
|
||||
sheetGroupAFormReq :: FieldSettings UniWorX -> Maybe SheetGroup -> AForm Handler SheetGroup
|
||||
@ -1462,7 +1467,7 @@ jsonField fieldKind = Field{..}
|
||||
{- was only used in workflows; if needed recreate MsgYAMLFieldDecodeFailure
|
||||
yamlField :: ( ToJSON a, FromJSON a
|
||||
, MonadHandler m
|
||||
, RenderMessage (HandlerSite m) FormMessage
|
||||
, RenderMessage (HandlerSite m) FormMessage
|
||||
)
|
||||
=> Field m a
|
||||
yamlField = Field{..}
|
||||
@ -1477,7 +1482,14 @@ yamlField = Field{..}
|
||||
#{either id (decodeUtf8 . Yaml.encode) val}
|
||||
|]
|
||||
fieldEnctype = UrlEncoded
|
||||
-}
|
||||
-}
|
||||
|
||||
|
||||
boolField' :: ( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
)
|
||||
=> Field m Bool
|
||||
boolField' = boolField (Just $ SomeMessage MsgBoolIrrelevant) -- MsgBoolIrrelevant is shown if the field is optional
|
||||
|
||||
boolField :: ( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
@ -2303,7 +2315,7 @@ examModeForm mPrev = examMode
|
||||
<*> customPresetForm examRequiredEquipmentEither (Just (SomeMessage MsgExamModeFormNone, Nothing)) (Just (SomeMessage MsgExamModeFormCustom, Nothing)) (id &&& Just . examRequiredEquipmentPresetWidget) (apreq htmlField (fslI MsgExamModeFormRequiredEquipment)) (fslI MsgExamModeFormRequiredEquipment & setTooltip MsgExamModeFormRequiredEquipmentIdentificationTip) (examRequiredEquipment <$> mPrev)
|
||||
where
|
||||
examMode examSynchronicity examOnline examAids examRequiredEquipment = ExamMode{..}
|
||||
|
||||
|
||||
examAidsEither :: Iso' ExamAids (Either StoredMarkup ExamAidsPreset)
|
||||
examAidsEither = iso examAidsToEither examAidsFromEither
|
||||
where examAidsToEither (ExamAidsPreset p) = Right p
|
||||
|
||||
@ -135,7 +135,7 @@ lmsDeletionDate mbMaxAuditMonths = do
|
||||
-- | Decide whether LMS platform should delete an identifier
|
||||
lmsUserToDeleteExpr :: UTCTime -> E.SqlExpr (Entity LmsUser) -> E.SqlExpr (E.Value Bool)
|
||||
lmsUserToDeleteExpr cutoff lmslist = E.isNothing (lmslist E.^. LmsUserEnded)
|
||||
E.&&. E.isJust (lmslist E.^. LmsUserStatus)
|
||||
-- E.&&. E.isJust (lmslist E.^. LmsUserStatus)
|
||||
E.&&. E.isJust (lmslist E.^. LmsUserStatusDay)
|
||||
E.&&. lmslist E.^. LmsUserStatusDay E.<=. E.justVal cutoff
|
||||
|
||||
|
||||
@ -3,9 +3,7 @@
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
module Handler.Utils.Mail
|
||||
( addRecipientsDB
|
||||
, userAddress, userAddress'
|
||||
, userAddressFrom
|
||||
( addRecipientsDB
|
||||
, userMailT, userMailTdirect
|
||||
, addFileDB
|
||||
, addHtmlMarkdownAlternatives
|
||||
@ -16,7 +14,7 @@ import Import
|
||||
import Handler.Utils.Pandoc
|
||||
import Handler.Utils.Files
|
||||
import Handler.Utils.Widgets (nameHtml') -- TODO: how to use name widget here?
|
||||
import Handler.Utils.Users (getReceivers)
|
||||
import Handler.Utils.Users (getReceivers, getUserEmail)
|
||||
import Handler.Utils.Profile
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
@ -37,44 +35,49 @@ addRecipientsDB :: ( MonadMail m
|
||||
addRecipientsDB uFilter = runConduit $ transPipe (liftHandler . runDB) (selectSource uFilter [Asc UserDisplayName]) .| C.mapM_ addRecipient
|
||||
where
|
||||
addRecipient (Entity _ User{userEmail, userDisplayEmail, userDisplayName}) = do
|
||||
let addr = Address (Just userDisplayName) $ CI.original $ pickValidEmail userDisplayEmail userEmail
|
||||
let addr = Address (Just userDisplayName) $ CI.original $ pickValidUserEmail userDisplayEmail userEmail
|
||||
_mailTo %= flip snoc addr
|
||||
|
||||
userAddressFrom :: User -> Address
|
||||
-- -- These pure functions may no longer be used, since they ignore company emails address indirections via UserCompany es
|
||||
--
|
||||
-- userAddressFrom :: User -> Address
|
||||
-- ^ Format an e-mail address suitable for usage in a @From@-header
|
||||
--
|
||||
-- Uses `userDisplayEmail` only
|
||||
userAddressFrom User{userDisplayEmail, userDisplayName} = Address (Just userDisplayName) $ CI.original userDisplayEmail
|
||||
-- userAddressFrom User{userDisplayEmail, userDisplayName} = Address (Just userDisplayName) $ CI.original userDisplayEmail
|
||||
|
||||
userAddress :: User -> Address
|
||||
-- ^ Format an e-mail address suitable for usage as a recipient
|
||||
--
|
||||
-- Like userAddressFrom, but prefers `userDisplayEmail` (if valid) and otherwise uses `userEmail`. Unlike Uni2work, userEmail from LDAP is untrustworthy.
|
||||
userAddress User{userEmail, userDisplayEmail, userDisplayName}
|
||||
= Address (Just userDisplayName) $ CI.original $ pickValidEmail userDisplayEmail userEmail
|
||||
-- userAddress :: User -> Address
|
||||
-- -- ^ Format an e-mail address suitable for usage as a recipient
|
||||
-- --
|
||||
-- -- Like userAddressFrom, but prefers `userDisplayEmail` (if valid) and otherwise uses `userEmail`. Unlike Uni2work, userEmail from LDAP is untrustworthy.
|
||||
-- userAddress User{userEmail, userDisplayEmail, userDisplayName}
|
||||
-- = Address (Just userDisplayName) $ CI.original $ pickValidUserEmail userDisplayEmail userEmail
|
||||
|
||||
userAddress' :: UserEmail -> UserEmail -> UserDisplayName -> Address
|
||||
-- Like userAddress', but does not require a complete entity
|
||||
userAddress' userEmail userDisplayEmail userDisplayName
|
||||
= Address (Just userDisplayName) $ CI.original $ pickValidEmail userDisplayEmail userEmail
|
||||
-- userAddress' :: UserEmail -> UserEmail -> UserDisplayName -> Address
|
||||
-- -- Like userAddress', but does not require a complete entity
|
||||
-- userAddress' userEmail userDisplayEmail userDisplayName
|
||||
-- = Address (Just userDisplayName) $ CI.original $ pickValidUserEmail userDisplayEmail userEmail
|
||||
|
||||
userAddressError :: (MonadHandler m, HandlerSite m ~ UniWorX) => User -> m (Bool, Address)
|
||||
userAddressError User{userEmail, userDisplayEmail, userDisplayName}
|
||||
| Just okEmail <- pickValidEmail' userDisplayEmail userEmail = pure (True, Address (Just userDisplayName) $ CI.original okEmail)
|
||||
| otherwise = do
|
||||
|
||||
userAddressError :: (MonadHandler m, HandlerSite m ~ UniWorX, m ~ HandlerFor UniWorX) => Entity User -> m (Bool, Address)
|
||||
userAddressError usr@Entity{entityVal=User{userEmail, userDisplayEmail, userDisplayName}} =
|
||||
runDB (getUserEmail usr) >>= \case
|
||||
Just okEmail -> pure (True, Address (Just userDisplayName) $ CI.original okEmail)
|
||||
Nothing -> do
|
||||
$logErrorS "Mail" $ "Attempt to email invalid address: " <> tshow userDisplayEmail <> " / " <> tshow userEmail <> ". Sent to support instead." -- <> " with subject " <> tshow failedSubject
|
||||
(False,) <$> getsYesod (view _appMailSupport)
|
||||
|
||||
-- | Send an email to the given UserId or to all registered Supervisor with rerouteNotifications == True
|
||||
userMailT :: ( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
, m ~ HandlerFor UniWorX
|
||||
, MonadThrow m
|
||||
, MonadUnliftIO m
|
||||
) => UserId -> MailT m () -> m ()
|
||||
userMailT uid mAct = do
|
||||
(underling, receivers, undercopy) <- liftHandler . runDB $ getReceivers uid
|
||||
let undername = underling ^. _userDisplayName -- nameHtml' underling
|
||||
undermail = CI.original $ pickValidEmail (underling ^. _userDisplayEmail) (underling ^. _userEmail)
|
||||
undermail = CI.original $ pickValidUserEmail (underling ^. _userDisplayEmail) (underling ^. _userEmail)
|
||||
infoSupervised :: Hamlet.HtmlUrlI18n UniWorXSendMessage (Route UniWorX) = [ihamlet|
|
||||
<h2>_{MsgMailSupervisedNote}
|
||||
<p>
|
||||
@ -84,7 +87,7 @@ userMailT uid mAct = do
|
||||
<li>
|
||||
#{nameHtml' svr}
|
||||
|]
|
||||
forM_ receivers $ \Entity
|
||||
forM_ receivers $ \svrEnt@Entity
|
||||
{ entityKey = svr
|
||||
, entityVal = supervisor@User{ userLanguages
|
||||
, userDateTimeFormat
|
||||
@ -111,7 +114,7 @@ userMailT uid mAct = do
|
||||
$else
|
||||
_{MsgMailSupervisorNoCopy}
|
||||
|]
|
||||
(mailOk, mailtoAddr) <- userAddressError supervisor -- ensures a valid email, logs error and sends to support otherwise
|
||||
(mailOk, mailtoAddr) <- userAddressError svrEnt -- ensures a valid email, logs error and sends to support otherwise
|
||||
|
||||
mailT ctx $ do
|
||||
_mailTo .= pure mailtoAddr
|
||||
@ -126,6 +129,7 @@ userMailT uid mAct = do
|
||||
-- | like userMailT, but always sends a single mail to the given UserId, ignoring supervisors
|
||||
userMailTdirect :: ( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
, m ~ HandlerFor UniWorX
|
||||
, MonadThrow m
|
||||
, MonadUnliftIO m
|
||||
) => UserId -> MailT m a -> m a
|
||||
@ -138,6 +142,7 @@ userMailTdirect uid mAct = do
|
||||
, userCsvOptions
|
||||
} <- liftHandler . runDB $ getJust uid
|
||||
let
|
||||
usrEnt = Entity {entityKey = uid, entityVal = user}
|
||||
ctx = MailContext
|
||||
{ mcLanguages = fromMaybe def userLanguages
|
||||
, mcDateTimeFormat = \case
|
||||
@ -146,7 +151,7 @@ userMailTdirect uid mAct = do
|
||||
SelFormatTime -> userTimeFormat
|
||||
, mcCsvOptions = userCsvOptions
|
||||
}
|
||||
(mailOk, mailtoAddr) <- userAddressError user -- ensures a valid email, logs error and sends to support otherwise
|
||||
(mailOk, mailtoAddr) <- userAddressError usrEnt -- ensures a valid email, logs error and sends to support otherwise
|
||||
mailT ctx $ do
|
||||
-- failedSubject <- lookupMailHeader "Subject"
|
||||
-- unless (validEmail $ addressEmail mailtoAddr) ($logErrorS "Mail" $ "Attempt to email invalid address: " <> tshow mailtoAddr <> " with subject " <> tshow failedSubject)
|
||||
|
||||
@ -1,17 +1,18 @@
|
||||
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.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
|
||||
|
||||
module Handler.Utils.Pandoc
|
||||
( htmlField, htmlFieldSmall
|
||||
, renderMarkdownWith, parseMarkdownWith
|
||||
, htmlReaderOptions, markdownReaderOptions
|
||||
, markdownWriterOptions, htmlWriterOptions
|
||||
( module Utils.Pandoc
|
||||
, htmlField, htmlFieldSmall
|
||||
, renderMarkdownWith, parseMarkdownWith
|
||||
) where
|
||||
|
||||
import Import.NoFoundation
|
||||
import Utils.Pandoc
|
||||
import Handler.Utils.I18n
|
||||
|
||||
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.Lazy as LT
|
||||
|
||||
@ -86,20 +87,3 @@ plaintextToMarkdownWith writerOptions text =
|
||||
where
|
||||
logPandocError = $logErrorS "renderMarkdown" . tshow
|
||||
pandoc = P.Pandoc mempty [P.Plain [P.Str text]]
|
||||
|
||||
|
||||
htmlReaderOptions, markdownReaderOptions :: P.ReaderOptions
|
||||
htmlReaderOptions = markdownReaderOptions
|
||||
markdownReaderOptions = def
|
||||
{ P.readerExtensions = P.pandocExtensions
|
||||
& P.enableExtension P.Ext_hard_line_breaks
|
||||
& P.enableExtension P.Ext_autolink_bare_uris
|
||||
, P.readerTabStop = 2
|
||||
}
|
||||
|
||||
markdownWriterOptions, htmlWriterOptions :: P.WriterOptions
|
||||
markdownWriterOptions = def
|
||||
{ P.writerExtensions = P.readerExtensions markdownReaderOptions
|
||||
, P.writerTabStop = P.readerTabStop markdownReaderOptions
|
||||
}
|
||||
htmlWriterOptions = markdownWriterOptions
|
||||
|
||||
@ -1,31 +1,24 @@
|
||||
-- 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
|
||||
|
||||
-- TODO: why is this Handler.Utils.Profile instead of Utils.Profile?
|
||||
-- TODO: consider merging with Handler.Utils.Users?
|
||||
module Handler.Utils.Profile
|
||||
( validDisplayName, checkDisplayName, fixDisplayName
|
||||
, validPostAddress
|
||||
, validEmail, validEmail', pickValidEmail, pickValidEmail'
|
||||
( module Utils.Mail
|
||||
, module Utils.Postal
|
||||
, validDisplayName, checkDisplayName, fixDisplayName
|
||||
, validFraportPersonalNumber
|
||||
) where
|
||||
|
||||
import Import.NoFoundation
|
||||
|
||||
import Data.Char
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.Lazy as LT
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import qualified Data.MultiSet as MultiSet
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import qualified Text.Email.Validate as Email
|
||||
|
||||
-- | Instead of CI.mk, this still allows use of Text.isInfixOf, etc.
|
||||
stripFold :: Text -> Text
|
||||
stripFold = Text.toCaseFold . Text.strip
|
||||
import Utils.Mail
|
||||
import Utils.Postal
|
||||
|
||||
-- | remove last comma and swap order of the two parts, ie. transforming "surname, givennames" into "givennames surname".
|
||||
-- Input "givennames surname" is left unchanged, except for removing excess whitespace
|
||||
@ -67,42 +60,6 @@ validDisplayName (fmap stripFold -> mTitle) (stripFold -> fName) (stripFold -> s
|
||||
splitAdd = Text.split isAdd
|
||||
makeMultiSet = MultiSet.fromList . filter (not . Text.null) . splitAdd
|
||||
|
||||
|
||||
-- | Primitive postal address requires at least one alphabetic character, one digit and a line break
|
||||
validPostAddress :: Maybe StoredMarkup -> Bool
|
||||
validPostAddress (Just StoredMarkup {markupInput = addr})
|
||||
| Just _ <- LT.find isLetter addr
|
||||
, Just _ <- LT.find isNumber addr
|
||||
-- , Just _ <- LT.find ((LineSeparator ==) . generalCategory) addr -- THIS DID NOT WORK
|
||||
, 1 < length (LT.lines addr)
|
||||
= True
|
||||
validPostAddress _ = False
|
||||
|
||||
-- also see `Handler.Utils.Users.getEmailAddress` for Tests accepting User Type
|
||||
validEmail :: Email -> Bool -- Email = Text
|
||||
validEmail email = validRFC5322 && not invalidFraport
|
||||
where
|
||||
validRFC5322 = Email.isValid $ encodeUtf8 email
|
||||
invalidFraport = case Text.stripSuffix "@fraport.de" (foldCase email) of
|
||||
Just fralogin -> all isDigit $ drop 1 fralogin
|
||||
Nothing -> False
|
||||
|
||||
validEmail' :: UserEmail -> Bool -- UserEmail = CI Text
|
||||
validEmail' = validEmail . CI.original
|
||||
|
||||
-- | returns first argument, if it is a valid email address; returns second argument untested otherwise; convenience function
|
||||
pickValidEmail :: UserEmail -> UserEmail -> UserEmail
|
||||
pickValidEmail x y
|
||||
| validEmail' x = x
|
||||
| otherwise = y
|
||||
|
||||
-- | returns first valid email address or none if none are valid
|
||||
pickValidEmail' :: UserEmail -> UserEmail -> Maybe UserEmail
|
||||
pickValidEmail' x y
|
||||
| validEmail' x = Just x
|
||||
| validEmail' y = Just y
|
||||
| otherwise = Nothing
|
||||
|
||||
validFraportPersonalNumber :: Maybe Text -> Bool
|
||||
validFraportPersonalNumber Nothing = False
|
||||
validFraportPersonalNumber (Just t)
|
||||
|
||||
@ -19,16 +19,20 @@ import qualified Database.Esqueleto.Utils as E
|
||||
|
||||
import Handler.Utils.Widgets (statusHtml)
|
||||
|
||||
-- | Compute new valid date from old one and from validDuration in months
|
||||
-- Mainly to document which add months functions to use
|
||||
computeNewValidDate :: Integral a => a -> Day -> Day
|
||||
computeNewValidDate = addGregorianMonthsRollOver . toInteger
|
||||
|
||||
statusQualificationBlock :: Bool -> Html
|
||||
statusQualificationBlock s = statusHtml (bool Error Success s) $ iconQualificationBlock s
|
||||
|
||||
|
||||
-- needs refactoring, probbably no longer helpful
|
||||
mkQualificationBlocked :: QualificationStandardReason -> UTCTime -> QualificationUserId -> QualificationUserBlock
|
||||
mkQualificationBlocked reason qualificationUserBlockFrom qualificationUserBlockQualificationUser = QualificationUserBlock{..}
|
||||
where
|
||||
qualificationUserBlockReason = tshow reason
|
||||
qualificationUserBlockUnblock = False
|
||||
where
|
||||
qualificationUserBlockReason = tshow reason
|
||||
qualificationUserBlockUnblock = False
|
||||
qualificationUserBlockBlocker = Nothing
|
||||
|
||||
-- somewhat dangerous, if not used with latest effective block
|
||||
@ -48,13 +52,13 @@ quserToNotify cutoff quser qblock = -- either recently become invalid with no pr
|
||||
quser E.^. QualificationUserScheduleRenewal
|
||||
E.&&. (( quser E.^. QualificationUserValidUntil E.<. E.val (utctDay cutoff)
|
||||
E.&&. quser E.^. QualificationUserValidUntil E.>. E.day (quser E.^. QualificationUserLastNotified)
|
||||
E.&&. E.not_ (E.isFalse (qblock E.?. QualificationUserBlockUnblock)) -- not currently blocked
|
||||
E.&&. E.not__ (E.isFalse (qblock E.?. QualificationUserBlockUnblock)) -- not currently blocked
|
||||
) E.||. ( -- was recently blocked
|
||||
E.isFalse (qblock E.?. QualificationUserBlockUnblock)
|
||||
E.isFalse (qblock E.?. QualificationUserBlockUnblock)
|
||||
E.&&. qblock E.?. QualificationUserBlockFrom E.>. E.just (quser E.^. QualificationUserLastNotified)
|
||||
))
|
||||
|
||||
-- condition to ensure that the lastest QualificationUserBlock was picked, better to be used in join-on clauses, since inside a where-clause it might not work as intended
|
||||
-- | condition to ensure that the lastest QualificationUserBlock was picked, better to be used in join-on clauses, since inside a where-clause it might not work as intended
|
||||
isLatestBlockBefore :: E.SqlExpr (Maybe (Entity QualificationUserBlock)) -> E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Bool)
|
||||
isLatestBlockBefore qualBlock cutoff = (cutoff E.>~. qualBlock E.?. QualificationUserBlockFrom) E.&&. E.notExists (do
|
||||
newerBlock <- E.from $ E.table @QualificationUserBlock
|
||||
@ -67,10 +71,24 @@ isLatestBlockBefore qualBlock cutoff = (cutoff E.>~. qualBlock E.?. Qualificatio
|
||||
))
|
||||
)
|
||||
|
||||
-- | condition to ensure that the lastest QualificationUserBlock was picked, better to be used in join-on clauses, since inside a where-clause it might not work as intended
|
||||
-- variant for inner joins
|
||||
isLatestBlockBefore' :: E.SqlExpr (Entity QualificationUserBlock) -> E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Bool)
|
||||
isLatestBlockBefore' qualBlock cutoff = (cutoff E.>. qualBlock E.^. QualificationUserBlockFrom) E.&&. E.notExists (do
|
||||
newerBlock <- E.from $ E.table @QualificationUserBlock
|
||||
E.where_ $ newerBlock E.^. QualificationUserBlockQualificationUser E.==. qualBlock E.^. QualificationUserBlockQualificationUser
|
||||
E.&&. newerBlock E.^. QualificationUserBlockFrom E.<=. cutoff
|
||||
E.&&. newerBlock E.^. QualificationUserBlockId E.!=. qualBlock E.^. QualificationUserBlockId
|
||||
E.&&. (( newerBlock E.^. QualificationUserBlockFrom E.>. qualBlock E.^. QualificationUserBlockFrom)
|
||||
E.||. ( newerBlock E.^. QualificationUserBlockUnblock -- in case of equal timestamps, any unblock wins
|
||||
E.&&. (newerBlock E.^. QualificationUserBlockFrom E.==. qualBlock E.^. QualificationUserBlockFrom)
|
||||
))
|
||||
)
|
||||
|
||||
-- cutoff can be `E.val now` or even `Database.Esqueleto.PostgreSQL.now_`
|
||||
quserBlockAux :: Bool -> E.SqlExpr (E.Value UTCTime) -> (E.SqlExpr (E.Value QualificationUserId) -> E.SqlExpr (E.Value Bool)) -> Maybe (E.SqlExpr (Entity QualificationUserBlock) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool)
|
||||
quserBlockAux negCond cutoff checkQualUserId mbBlockCondition = bool E.notExists E.exists negCond $ do
|
||||
qualUserBlock <- E.from $ E.table @QualificationUserBlock
|
||||
quserBlockAux negCond cutoff checkQualUserId mbBlockCondition = bool E.notExists E.exists negCond $ do
|
||||
qualUserBlock <- E.from $ E.table @QualificationUserBlock
|
||||
E.where_ $ E.not_ (qualUserBlock E.^. QualificationUserBlockUnblock)
|
||||
E.&&. (qualUserBlock E.^. QualificationUserBlockFrom E.<=. cutoff)
|
||||
E.&&. checkQualUserId (qualUserBlock E.^. QualificationUserBlockQualificationUser)
|
||||
@ -83,11 +101,11 @@ quserBlockAux negCond cutoff checkQualUserId mbBlockCondition = bool E.notExists
|
||||
)
|
||||
whenIsJust mbBlockCondition (E.where_ . ($ qualUserBlock))
|
||||
|
||||
-- | Test whether a QualificationUser was blocked/unblocked at a given day; negCond: True:isBlocked False:isUnblocked
|
||||
-- | Test whether a QualificationUser was blocked/unblocked at a given day; negCond: True:isBlocked False:isUnblocked
|
||||
quserBlock :: Bool -> UTCTime -> E.SqlExpr (Entity QualificationUser) -> E.SqlExpr (E.Value Bool)
|
||||
quserBlock negCond cutoff qualUser = quserBlockAux negCond (E.val cutoff) (E.==. (qualUser E.^. QualificationUserId)) Nothing
|
||||
|
||||
-- | Variant of `isBlocked` for outer joins
|
||||
-- | Variant of `isBlocked` for outer joins
|
||||
quserBlock' :: Bool -> UTCTime -> E.SqlExpr (Maybe (Entity QualificationUser)) -> E.SqlExpr (E.Value Bool)
|
||||
quserBlock' negCond cutoff qualUser = quserBlockAux negCond (E.val cutoff) (E.=?. (qualUser E.?. QualificationUserId)) Nothing
|
||||
|
||||
@ -108,15 +126,17 @@ validQualification' cutoff qualUser =
|
||||
E.&&. quserBlock' False cutoff qualUser
|
||||
|
||||
-- selectValidQualifications :: QualificationId -> [UserId] -> UTCTime -> DB [Entity QualificationUser]
|
||||
selectValidQualifications ::
|
||||
( MonadIO m
|
||||
, BackendCompatible SqlBackend backend
|
||||
, PersistQueryRead backend
|
||||
, PersistUniqueRead backend
|
||||
) => QualificationId -> [UserId] -> UTCTime -> ReaderT backend m [Entity QualificationUser]
|
||||
selectValidQualifications qid uids cutoff =
|
||||
-- selectValidQualifications ::
|
||||
-- ( MonadIO m
|
||||
-- , BackendCompatible SqlBackend backend
|
||||
-- , PersistQueryRead backend
|
||||
-- , PersistUniqueRead backend
|
||||
-- ) => QualificationId -> [UserId] -> UTCTime -> ReaderT backend m [Entity QualificationUser]
|
||||
selectValidQualifications :: (MonadIO m, E.SqlBackendCanRead backend)
|
||||
=> QualificationId -> [UserId] -> UTCTime -> ReaderT backend m [Entity QualificationUser]
|
||||
selectValidQualifications qid uids cutoff =
|
||||
-- cutoff <- utctDay <$> liftIO getCurrentTime
|
||||
E.select $ do
|
||||
E.select $ do
|
||||
qUser <- E.from $ E.table @QualificationUser
|
||||
E.where_ $ (qUser E.^. QualificationUserQualification E.==. E.val qid)
|
||||
E.&&. qUser E.^. QualificationUserUser `E.in_` E.valList uids
|
||||
@ -138,7 +158,7 @@ upsertQualificationUser qualificationUserQualification startTime qualificationU
|
||||
let qualificationUserLastRefresh = utctDay startTime
|
||||
Entity quid _ <- upsert
|
||||
QualificationUser
|
||||
{ qualificationUserFirstHeld = qualificationUserLastRefresh
|
||||
{ qualificationUserFirstHeld = qualificationUserLastRefresh
|
||||
, qualificationUserScheduleRenewal = fromMaybe True mbScheduleRenewal
|
||||
, qualificationUserLastNotified = utctDayMidnight qualificationUserLastRefresh
|
||||
, ..
|
||||
@ -147,7 +167,7 @@ upsertQualificationUser qualificationUserQualification startTime qualificationU
|
||||
[ QualificationUserScheduleRenewal =. scheduleRenewal | Just scheduleRenewal <- [mbScheduleRenewal]
|
||||
] ++
|
||||
[ QualificationUserValidUntil =. qualificationUserValidUntil
|
||||
, QualificationUserLastRefresh =. qualificationUserLastRefresh
|
||||
, QualificationUserLastRefresh =. qualificationUserLastRefresh
|
||||
]
|
||||
)
|
||||
authUsr <- liftHandler maybeAuthId
|
||||
@ -162,8 +182,8 @@ upsertQualificationUser qualificationUserQualification startTime qualificationU
|
||||
}
|
||||
|
||||
-- | Renew an existing valid qualification, ignoring all blocks otherwise
|
||||
-- renewValidQualificationUsers :: QualificationId -> Maybe UTCTime -> [UserId] -> DB Int -- not general enough for use in YesodJobDB
|
||||
renewValidQualificationUsers ::
|
||||
-- renewValidQualificationUsers :: QualificationId -> Maybe QualificationChangeReason -> Maybe UTCTime -> [UserId] -> DB Int -- not general enough for use in YesodJobDB
|
||||
renewValidQualificationUsers ::
|
||||
( AuthId (HandlerSite m) ~ Key User
|
||||
, IsPersistBackend (YesodPersistBackend (HandlerSite m))
|
||||
, BaseBackend (YesodPersistBackend (HandlerSite m)) ~ SqlBackend
|
||||
@ -174,7 +194,7 @@ renewValidQualificationUsers ::
|
||||
, YesodAuthPersist (HandlerSite m)
|
||||
, HasAppSettings (HandlerSite m)
|
||||
, MonadHandler m
|
||||
, MonadCatch m
|
||||
, MonadCatch m
|
||||
) => QualificationId -> Maybe QualificationChangeReason -> Maybe UTCTime -> [UserId] -> ReaderT (YesodPersistBackend (HandlerSite m)) m Int
|
||||
renewValidQualificationUsers qid reason renewalTime uids =
|
||||
-- The following short code snippet suffices in principle, but would not allow audit log entries. Are these still needed?
|
||||
@ -182,15 +202,17 @@ renewValidQualificationUsers qid reason renewalTime uids =
|
||||
-- E.set qu [ QualificationUserValidUntil E.+=. E.interval (CalendarDiffDays 2 0) ] -- TODO: for Testing only
|
||||
-- E.where_ $ (qu E.^. QualificationUserQualification E.==. E.val qid )
|
||||
-- E.&&. (qu E.^. QualificationUserUser `E.in_` E.valList uids)
|
||||
get qid >>= \case
|
||||
get qid >>= \case
|
||||
Just Qualification{qualificationElearningRenews=False}
|
||||
| Just (Right (QualificationRenewELearningBy _)) <- reason -> return 0
|
||||
Just Qualification{qualificationValidDuration=Just renewalMonths} -> do
|
||||
cutoff <- maybe (liftIO getCurrentTime) return renewalTime
|
||||
quEntsAll <- selectValidQualifications qid uids cutoff
|
||||
let cutoffday = utctDay cutoff
|
||||
maxValidTo = addGregorianMonthsRollOver (toInteger $ renewalMonths `div` 2) cutoffday
|
||||
quEnts = filter (\q -> maxValidTo >= (q ^. _entityVal . _qualificationUserValidUntil)) quEntsAll
|
||||
forM_ quEnts $ \(Entity quId QualificationUser{..}) -> do
|
||||
let newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil
|
||||
forM_ quEnts $ \(Entity quId QualificationUser{..}) -> do
|
||||
let newValidTo = computeNewValidDate renewalMonths qualificationUserValidUntil
|
||||
update quId [ QualificationUserValidUntil =. newValidTo
|
||||
, QualificationUserLastRefresh =. cutoffday
|
||||
]
|
||||
@ -206,7 +228,7 @@ renewValidQualificationUsers qid reason renewalTime uids =
|
||||
_ -> return (-1) -- qualificationId not found, isNothing qualificationValidDuration, etc.
|
||||
|
||||
-- | Block or unblock some users for a given reason, but only if they are not already blocked (essential assumption that is actually used)
|
||||
qualificationUserBlocking ::
|
||||
qualificationUserBlocking ::
|
||||
( AuthId (HandlerSite m) ~ Key User
|
||||
, IsPersistBackend (YesodPersistBackend (HandlerSite m))
|
||||
, BaseBackend (YesodPersistBackend (HandlerSite m)) ~ SqlBackend
|
||||
@ -221,13 +243,13 @@ qualificationUserBlocking ::
|
||||
, Num n
|
||||
) => QualificationId -> [UserId] -> Bool -> Maybe UTCTime -> QualificationChangeReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
|
||||
qualificationUserBlocking qid uids unblock mbBlockTime (qualificationChangeReasonText -> reason) notify = do
|
||||
$logInfoS "BLOCK" $ Text.intercalate " - " [tshow qid, tshow uids, tshow unblock, tshow mbBlockTime, tshow reason, tshow notify]
|
||||
$logInfoS "BLOCK" $ Text.intercalate " - " [tshow qid, tshow unblock, tshow mbBlockTime, tshow reason, tshow notify, "#Users:" <> tshow (length uids), tshow uids] -- this message can get very long on test systems
|
||||
authUsr <- liftHandler maybeAuthId
|
||||
now <- liftIO getCurrentTime
|
||||
let blockTime = fromMaybe now mbBlockTime
|
||||
-- -- Code would work, but problematic
|
||||
let blockTime = fromMaybe now mbBlockTime
|
||||
-- -- Code would work, but problematic
|
||||
-- oks <- E.insertSelectCount . E.from $ \qualificationUser -> do
|
||||
-- E.where_ $ qualificationUser E.^. QualificationUserQualification E.==. E.val qid
|
||||
-- E.where_ $ qualificationUser E.^. QualificationUserQualification E.==. E.val qid
|
||||
-- E.&&. qualificationUser E.^. QualificationUserUser E.in_ E.valList uid
|
||||
-- E.&&. quserBlock unblock blockTime qualificationUser -- only unblock blocked qualification and vice versa
|
||||
-- return $ QualificationUserBlock
|
||||
@ -238,7 +260,7 @@ qualificationUserBlocking qid uids unblock mbBlockTime (qualificationChangeReaso
|
||||
-- E.<&> E.val authUsr
|
||||
toChange <- E.select $ do
|
||||
qualUser <- E.from $ E.table @QualificationUser
|
||||
E.where_ $ qualUser E.^. QualificationUserQualification E.==. E.val qid
|
||||
E.where_ $ qualUser E.^. QualificationUserQualification E.==. E.val qid
|
||||
E.&&. qualUser E.^. QualificationUserUser `E.in_` E.valList uids
|
||||
E.&&. quserBlock unblock blockTime qualUser -- only unblock blocked qualification and vice versa
|
||||
return (qualUser E.^. QualificationUserId, qualUser E.^. QualificationUserUser)
|
||||
@ -258,7 +280,7 @@ qualificationUserBlocking qid uids unblock mbBlockTime (qualificationChangeReaso
|
||||
}
|
||||
return $ fromIntegral $ length newBlocks
|
||||
|
||||
qualificationUserUnblockByReason ::
|
||||
qualificationUserUnblockByReason ::
|
||||
( AuthId (HandlerSite m) ~ Key User
|
||||
, IsPersistBackend (YesodPersistBackend (HandlerSite m))
|
||||
, BaseBackend (YesodPersistBackend (HandlerSite m)) ~ SqlBackend
|
||||
@ -273,11 +295,39 @@ qualificationUserUnblockByReason ::
|
||||
, Num n
|
||||
) => QualificationId -> [UserId] -> Maybe UTCTime -> QualificationChangeReason -> QualificationChangeReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
|
||||
qualificationUserUnblockByReason qid uids mbUnblockTime (qualificationChangeReasonText -> reason) undo_reason notify = do
|
||||
cutoff <- maybe (liftIO getCurrentTime) return mbUnblockTime
|
||||
cutoff <- maybe (liftIO getCurrentTime) return mbUnblockTime
|
||||
toUnblock <- E.select $ do
|
||||
quser <- E.from $ E.table @QualificationUser
|
||||
E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
|
||||
E.&&. quser E.^. QualificationUserUser `E.in_` E.valList uids
|
||||
E.&&. quserBlockAux True (E.val cutoff) (E.==. (quser E.^. QualificationUserId)) (Just (\qblock -> (qblock E.^. QualificationUserBlockReason) E.==. E.val reason))
|
||||
return $ quser E.^. QualificationUserUser
|
||||
qualificationUserBlocking qid (E.unValue <$> toUnblock) True mbUnblockTime undo_reason notify
|
||||
qualificationUserBlocking qid (E.unValue <$> toUnblock) True mbUnblockTime undo_reason notify
|
||||
|
||||
|
||||
-----------
|
||||
-- Forms --
|
||||
-----------
|
||||
|
||||
|
||||
qualificationOption :: Entity Qualification -> Option QualificationId
|
||||
qualificationOption (Entity qid Qualification{..}) =
|
||||
let qsh = ciOriginal $ unSchoolKey qualificationSchool
|
||||
in Option{ optionDisplay = ciOriginal qualificationName <> " (" <> qsh <> ")"
|
||||
, optionExternalValue = toPathPiece $ ciOriginal qualificationShorthand <> "___" <> qsh -- both a publicly known already
|
||||
, optionInternalValue = qid
|
||||
}
|
||||
|
||||
qualificationsOptionList :: [Entity Qualification] -> OptionList QualificationId
|
||||
qualificationsOptionList = mkOptionList . map qualificationOption
|
||||
|
||||
{- Should we encrypt the external value or simply rely on uniqueness? --TODO: still used in Handler.Admin.Avs
|
||||
qualOpt :: Entity Qualification -> Handler (Option QualificationId)
|
||||
qualOpt (Entity qualId qual) = do
|
||||
cQualId :: CryptoUUIDQualification <- encrypt qualId
|
||||
return $ Option
|
||||
{ optionDisplay = ciOriginal $ qualificationName qual
|
||||
, optionInternalValue = qualId
|
||||
, optionExternalValue = tshow cQualId
|
||||
}
|
||||
-}
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
-- SPDX-FileCopyrightText: 2022 Felix Hamann <felix.hamann@campus.lmu.de>,Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
|
||||
-- SPDX-FileCopyrightText: 2022-24 Felix Hamann <felix.hamann@campus.lmu.de>,Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.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
|
||||
|
||||
@ -14,7 +14,7 @@ import Handler.Utils.DateTime
|
||||
import Handler.Utils.Widgets
|
||||
import Handler.Utils.Occurrences
|
||||
import Handler.Utils.LMS (lmsUserStatusWidget)
|
||||
import Handler.Utils.Qualification (isValidQualification)
|
||||
import Handler.Utils.Qualification (isValidQualification)
|
||||
|
||||
type CourseLink = (TermId, SchoolId, CourseShorthand) -- TODO: Refactor with WithHoles !
|
||||
|
||||
@ -32,6 +32,7 @@ spacerCell = cell [whamlet| |]
|
||||
semicolonCell :: IsDBTable m a => DBCell m a
|
||||
semicolonCell = cell [whamlet|; |]
|
||||
|
||||
-- | Contribute to DBResult. BEWARE: only shown cells are executed; pagination makes tellCell useless for rowcounts; instead use dbtProj for computations on all rows regardless of pagination
|
||||
tellCell :: IsDBTable m a => a -> DBCell m a -> DBCell m a
|
||||
tellCell = flip mappend . writerCell . tell
|
||||
|
||||
@ -41,16 +42,23 @@ cellTell = flip tellCell
|
||||
indicatorCell :: IsDBTable m Any => DBCell m Any -- For dbTables that return a Bool to indicate content
|
||||
indicatorCell = writerCell . tell $ Any True
|
||||
|
||||
addIndicatorCell :: IsDBTable m Any => DBCell m Any -> DBCell m Any
|
||||
addIndicatorCell = tellCell $ Any True
|
||||
|
||||
writerCell :: IsDBTable m w => WriterT w m () -> DBCell m w
|
||||
writerCell act = mempty & cellContents %~ (<* act)
|
||||
|
||||
-- for documentation purposes
|
||||
-- for documentation purposes
|
||||
cellMaybe :: IsDBTable m b => (a -> DBCell m b) -> Maybe a -> DBCell m b
|
||||
cellMaybe = foldMap
|
||||
|
||||
maybeCell :: IsDBTable m b => Maybe a -> (a -> DBCell m b) -> DBCell m b
|
||||
maybeCell = flip foldMap
|
||||
|
||||
boolCell :: IsDBTable m b => Bool -> DBCell m b -> DBCell m b
|
||||
boolCell True c = c
|
||||
boolCell False _ = mempty
|
||||
|
||||
htmlCell :: (IsDBTable m a, ToMarkup c) => c -> DBCell m a
|
||||
htmlCell = cell . toWidget . toMarkup
|
||||
|
||||
@ -62,7 +70,7 @@ sqlCell :: (IsDBTable (YesodDB UniWorX) a) => YesodDB UniWorX Widget -> DBCell (
|
||||
sqlCell act = mempty & cellContents .~ lift act
|
||||
|
||||
-- TODO: Formulate variant of sqlCell that types for tables having actions, i.e. MForm istead of YesodDB?
|
||||
-- sqlCell' :: (IsDBTable (MForm Handler) a) => _ -> DBCell (MForm Handler) a
|
||||
-- sqlCell' :: (IsDBTable (MForm Handler) a) => _ -> DBCell (MForm Handler) a
|
||||
-- sqlCell' = flip (set' cellContents) mempty
|
||||
|
||||
-- | Highlight table cells with warning: Is not yet implemented in frontend.
|
||||
@ -79,6 +87,7 @@ ifCell decision cTrue cFalse x
|
||||
linkEmptyCell :: IsDBTable m a => Route UniWorX -> Widget -> DBCell m a
|
||||
linkEmptyCell = anchorCell
|
||||
|
||||
-- not to be confused with i18nCell
|
||||
msgCell :: (ToMessage t, IsDBTable m a) => t -> DBCell m a
|
||||
msgCell = textCell . toMessage
|
||||
|
||||
@ -157,14 +166,14 @@ modalCell content = cell $ modal (toWidget $ hasComment True) (Right $ toWidget
|
||||
|
||||
-- | Show Text if it is small, create modal otherwise
|
||||
modalCellLarge :: (IsDBTable m a, ToWidget UniWorX t, MonoFoldable t, Element t ~ Char) => t -> DBCell m a
|
||||
modalCellLarge content
|
||||
modalCellLarge content
|
||||
| length content > 32 = modalCell content
|
||||
| otherwise = stringCell content
|
||||
|
||||
markupCellLargeModal :: IsDBTable m a => StoredMarkup -> DBCell m a
|
||||
markupCellLargeModal mup
|
||||
| markupIsSmallish mup = cell $ toWidget mup
|
||||
| otherwise = modalCell mup
|
||||
| otherwise = modalCell mup
|
||||
|
||||
-----------------
|
||||
-- Datatype cells
|
||||
@ -220,44 +229,44 @@ cellHasUserLink toLink user =
|
||||
|
||||
-- | like `cellHasUserLink` but opens the user in a modal instead; link is only displayed if the user has sufficient rights
|
||||
cellHasUserModal :: (IsDBTable m c, HasEntity u User) => (CryptoUUIDUser -> Route UniWorX) -> u -> DBCell m c
|
||||
cellHasUserModal toLink user =
|
||||
cellHasUserModal toLink user =
|
||||
let userEntity = user ^. hasEntityUser
|
||||
uid = userEntity ^. _entityKey
|
||||
nWdgt = nameWidget (userEntity ^. _entityVal . _userDisplayName) (userEntity ^. _entityVal . _userSurname)
|
||||
lWdgt = do
|
||||
lWdgt = do
|
||||
uuid <- liftHandler $ encrypt uid
|
||||
modalAccess nWdgt nWdgt False $ toLink uuid
|
||||
modalAccess nWdgt nWdgt False $ toLink uuid
|
||||
in cell lWdgt
|
||||
|
||||
-- | like `cellHasUserModal` but but always display link without prior access rights checks
|
||||
cellHasUserModalAdmin :: (IsDBTable m c, HasEntity u User) => (CryptoUUIDUser -> Route UniWorX) -> u -> DBCell m c
|
||||
cellHasUserModalAdmin toLink user =
|
||||
cellHasUserModalAdmin toLink user =
|
||||
let userEntity = user ^. hasEntityUser
|
||||
uid = userEntity ^. _entityKey
|
||||
nWdgt = nameWidget (userEntity ^. _entityVal . _userDisplayName) (userEntity ^. _entityVal . _userSurname)
|
||||
lWdgt = do
|
||||
lWdgt = do
|
||||
uuid <- liftHandler $ encrypt uid
|
||||
modal nWdgt $ Left $ SomeRoute $ toLink uuid
|
||||
modal nWdgt $ Left $ SomeRoute $ toLink uuid
|
||||
in cell lWdgt
|
||||
|
||||
-- | like `cellHasUserModal` but with fixed route and showing an edit icon instead; link is only displayed if the user has sufficient rights
|
||||
cellEditUserModal :: (IsDBTable m c, HasEntity u User) => u -> DBCell m c
|
||||
cellEditUserModal user =
|
||||
cellEditUserModal user =
|
||||
let userEntity = user ^. hasEntityUser
|
||||
uid = userEntity ^. _entityKey
|
||||
nWdgt = toWidget $ icon IconUserEdit
|
||||
lWdgt = do
|
||||
nWdgt = toWidget $ icon IconUserEdit
|
||||
lWdgt = do
|
||||
uuid <- liftHandler $ encrypt uid
|
||||
modalAccess mempty nWdgt True $ ForProfileR uuid
|
||||
in cell lWdgt
|
||||
|
||||
-- | like `cellEditUserModal` but always displays the link without prior access rights checks
|
||||
cellEditUserModalAdmin :: (IsDBTable m c, HasEntity u User) => u -> DBCell m c
|
||||
cellEditUserModalAdmin user =
|
||||
cellEditUserModalAdmin user =
|
||||
let userEntity = user ^. hasEntityUser
|
||||
uid = userEntity ^. _entityKey
|
||||
nWdgt = toWidget $ icon IconUserEdit
|
||||
lWdgt = do
|
||||
nWdgt = toWidget $ icon IconUserEdit
|
||||
lWdgt = do
|
||||
uuid <- liftHandler $ encrypt uid
|
||||
modal nWdgt (Left $ SomeRoute $ ForProfileR uuid)
|
||||
in cell lWdgt
|
||||
@ -266,23 +275,23 @@ cellHasMatrikelnummer :: (IsDBTable m a, HasUser u) => u -> DBCell m a
|
||||
cellHasMatrikelnummer = maybe mempty textCell . view _userMatrikelnummer
|
||||
|
||||
cellHasMatrikelnummerLinked :: (IsDBTable m a, HasEntity u User) => Bool -> u -> DBCell m a
|
||||
cellHasMatrikelnummerLinked isAdmin usr
|
||||
| Just matNr <- usrEntity ^. _userMatrikelnummer = cell $ do
|
||||
cellHasMatrikelnummerLinked isAdmin usr
|
||||
| Just matNr <- usrEntity ^. _userMatrikelnummer = cell $ do
|
||||
uuid <- liftHandler $ encrypt $ usrEntity ^. _entityKey
|
||||
if isAdmin
|
||||
then modal (text2widget matNr) (Left $ SomeRoute $ AdminAvsUserR uuid)
|
||||
else modalAccess mempty (text2widget matNr) False (AdminAvsUserR uuid)
|
||||
| otherwise = mempty
|
||||
where
|
||||
where
|
||||
usrEntity = usr ^. hasEntityUser
|
||||
|
||||
cellHasMatrikelnummerLinkedAdmin :: (IsDBTable m a, HasEntity u User) => u -> DBCell m a
|
||||
cellHasMatrikelnummerLinkedAdmin usr
|
||||
| Just matNr <- usrEntity ^. _userMatrikelnummer = cell $ do
|
||||
cellHasMatrikelnummerLinkedAdmin usr
|
||||
| Just matNr <- usrEntity ^. _userMatrikelnummer = cell $ do
|
||||
uuid <- liftHandler $ encrypt $ usrEntity ^. _entityKey
|
||||
modal (text2widget matNr) (Left $ SomeRoute $ AdminAvsUserR uuid)
|
||||
modal (text2widget matNr) (Left $ SomeRoute $ AdminAvsUserR uuid)
|
||||
| otherwise = mempty
|
||||
where
|
||||
where
|
||||
usrEntity = usr ^. hasEntityUser
|
||||
|
||||
|
||||
@ -355,15 +364,39 @@ courseCell Course{..} = anchorCell link name `mappend` desc
|
||||
^{modal "Beschreibung" (Right $ toWidget descr)}
|
||||
|]
|
||||
|
||||
-- also see Handler.Utils.Widgets.companyWidget
|
||||
companyCell :: IsDBTable m a => CompanyShorthand -> CompanyName -> Bool -> DBCell m a
|
||||
companyCell cid cname isSupervisor = anchorCell link name
|
||||
companyCell csh cname isSupervisor = anchorCell curl name
|
||||
where
|
||||
link = FirmUsersR cid
|
||||
curl = FirmUsersR csh
|
||||
corg = ciOriginal cname
|
||||
name
|
||||
name
|
||||
| isSupervisor = text2markup (corg <> " ") <> icon IconSupervisor
|
||||
| otherwise = text2markup corg
|
||||
|
||||
companyIdCell :: IsDBTable m a => CompanyId -> DBCell m a
|
||||
companyIdCell cid = companyCell csh csh False
|
||||
where
|
||||
csh = unCompanyKey cid
|
||||
|
||||
-- | Uses DB Lookup to link to a qualification by id only, use sparingly!
|
||||
qualificationIdCell :: (IsDBTable m c) => QualificationId -> DBCell m c
|
||||
qualificationIdCell qid = anchorCellM' qual link name
|
||||
where
|
||||
qual = liftHandler $ runDBRead $ get qid
|
||||
link (Just Qualification{..}) = QualificationR qualificationSchool qualificationShorthand
|
||||
link Nothing = HelpR
|
||||
name Nothing = text2widget "Error: unknown QID"
|
||||
name (Just Qualification{..}) = citext2widget qualificationName
|
||||
|
||||
qualificationIdShortCell :: (IsDBTable m c) => QualificationId -> DBCell m c
|
||||
qualificationIdShortCell qid = anchorCellM' qual link name
|
||||
where
|
||||
qual = liftHandler $ runDBRead $ get qid
|
||||
link (Just Qualification{..}) = QualificationR qualificationSchool qualificationShorthand
|
||||
link Nothing = HelpR
|
||||
name Nothing = text2widget "Error: unknown QID"
|
||||
name (Just Qualification{..}) = citext2widget qualificationShorthand
|
||||
|
||||
qualificationCell :: (IsDBTable m c, HasQualification a) => a -> DBCell m c
|
||||
qualificationCell (view hasQualification -> Qualification{..}) = anchorCell link name
|
||||
@ -387,7 +420,7 @@ qualificationDescrCell (view hasQualification -> q@Qualification{..}) = qualific
|
||||
qualificationValidIconCell :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Day -> Maybe b -> a -> DBCell m c
|
||||
qualificationValidIconCell d qb qu = do
|
||||
blockIcon $ isValidQualification d qu qb
|
||||
where
|
||||
where
|
||||
blockIcon = cell . toWidget . iconQualificationBlock
|
||||
|
||||
qualificationValidUntilCell :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Day -> Maybe b -> a -> DBCell m c
|
||||
@ -396,11 +429,11 @@ qualificationValidUntilCell = qualificationValidUntilCell' (Just LmsUserAllR)
|
||||
qualificationValidUntilCell' :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Maybe (CryptoUUIDUser -> Route UniWorX) -> Day -> Maybe b -> a -> DBCell m c
|
||||
qualificationValidUntilCell' mbToLink d qb qu = cell $ case mbToLink of
|
||||
Nothing -> headWgt <> dateWgt
|
||||
Just toLink -> do
|
||||
Just toLink -> do
|
||||
uuid <- liftHandler $ encrypt $ qu ^. hasQualificationUser . _qualificationUserUser
|
||||
let modalWgt = modalAccess dateWgt dateWgt False $ toLink uuid
|
||||
headWgt <> modalWgt
|
||||
where
|
||||
where
|
||||
dateWgt = formatTimeW SelFormatDate (qu ^. hasQualificationUser . _qualificationUserValidUntil)
|
||||
iconWgt = toWidget $ iconQualificationBlock $ isValidQualification d qu qb
|
||||
headWgt = iconWgt <> [whamlet| |]
|
||||
@ -410,18 +443,18 @@ qualificationValidReasonCell = qualificationValidReasonCell' (Just LmsUserAllR)
|
||||
|
||||
qualificationValidReasonCell' :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Maybe (CryptoUUIDUser -> Route UniWorX) -> Bool -> Day -> Maybe b -> a -> DBCell m c
|
||||
qualificationValidReasonCell' mbToLink showReason d qb qu = ic <> foldMap blc qb
|
||||
where
|
||||
where
|
||||
ic = cell . toWidget . iconQualificationBlock $ isValidQualification d qu qb
|
||||
blc (view hasQualificationUserBlock -> QualificationUserBlock{..})
|
||||
| showReason = spacerCell <> dc qualificationUserBlockFrom <> spacerCell <> modalCellLarge qualificationUserBlockReason
|
||||
| showReason = spacerCell <> dc qualificationUserBlockFrom <> spacerCell <> modalCellLarge qualificationUserBlockReason
|
||||
| qualificationUserBlockUnblock = mempty
|
||||
| otherwise = spacerCell <> dateCell qualificationUserBlockFrom
|
||||
dc tstamp
|
||||
dc tstamp
|
||||
| Just toLink <- mbToLink = cell $ do
|
||||
uuid <- liftHandler $ encrypt uid
|
||||
let dWgt = formatTimeW SelFormatDate tstamp
|
||||
modalAccess dWgt dWgt False $ toLink uuid
|
||||
-- anchorCellM (toLink <$> encrypt uid)
|
||||
-- anchorCellM (toLink <$> encrypt uid)
|
||||
| otherwise = dateCell tstamp
|
||||
uid = qu ^. hasQualificationUser . _qualificationUserUser
|
||||
|
||||
@ -432,15 +465,15 @@ qualificationValidReasonCell'' mbToLink showReason d qb qu extValid = ic <> icEr
|
||||
icErr = cell . toWidget . isBad $ quValid /= extValid
|
||||
ic = cell . toWidget $ iconQualificationBlock quValid
|
||||
blc (view hasQualificationUserBlock -> QualificationUserBlock{..})
|
||||
| showReason = spacerCell <> dc qualificationUserBlockFrom <> spacerCell <> modalCellLarge qualificationUserBlockReason
|
||||
| showReason = spacerCell <> dc qualificationUserBlockFrom <> spacerCell <> modalCellLarge qualificationUserBlockReason
|
||||
| qualificationUserBlockUnblock = mempty
|
||||
| otherwise = spacerCell <> dateCell qualificationUserBlockFrom
|
||||
dc tstamp
|
||||
dc tstamp
|
||||
| Just toLink <- mbToLink = cell $ do
|
||||
uuid <- liftHandler $ encrypt uid
|
||||
let dWgt = formatTimeW SelFormatDate tstamp
|
||||
modalAccess dWgt dWgt False $ toLink uuid
|
||||
-- anchorCellM (toLink <$> encrypt uid)
|
||||
-- anchorCellM (toLink <$> encrypt uid)
|
||||
| otherwise = dateCell tstamp
|
||||
uid = qu ^. hasQualificationUser . _qualificationUserUser
|
||||
|
||||
@ -490,7 +523,7 @@ lmsStatusCell extendedInfo mkLink = wgtCell . lmsUserStatusWidget extendedInfo m
|
||||
|
||||
lmsStateCell :: IsDBTable m a => LmsState -> DBCell m a
|
||||
lmsStateCell LmsFailed = iconBoolCell False
|
||||
lmsStateCell LmsOpen = iconSpacerCell
|
||||
lmsStateCell LmsOpen = iconSpacerCell
|
||||
lmsStateCell LmsPassed = iconBoolCell True
|
||||
|
||||
avsPersonNoCell :: (IsDBTable m c, HasUserAvs a) => a -> DBCell m c
|
||||
@ -509,7 +542,7 @@ avsPersonNoLinkedCellAdmin a = cell $ do
|
||||
modal nWgt (Left $ SomeRoute $ AdminAvsUserR uuid)
|
||||
|
||||
avsPersonCardCell :: (IsDBTable m c) => Set AvsDataPersonCard -> DBCell m c
|
||||
avsPersonCardCell cards = wgtCell
|
||||
avsPersonCardCell cards = wgtCell
|
||||
[whamlet|
|
||||
$newline never
|
||||
<ul .list--iconless .list--inline .list--comma-separated>
|
||||
@ -517,6 +550,6 @@ avsPersonCardCell cards = wgtCell
|
||||
<li>
|
||||
_{c}
|
||||
|]
|
||||
where
|
||||
where
|
||||
validCards = Set.filter avsDataValid cards
|
||||
validColors = Set.toDescList $ Set.map avsDataCardColor validCards
|
||||
@ -8,6 +8,8 @@ module Handler.Utils.Table.Columns where
|
||||
|
||||
import Import hiding (link)
|
||||
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import qualified Database.Esqueleto.Legacy as E
|
||||
import qualified Database.Esqueleto.Utils as E hiding ((->.))
|
||||
import Database.Esqueleto.Utils (mkExactFilter, mkExactFilterWith, mkContainsFilter, mkContainsFilterWith, mkContainsFilterWithComma, mkContainsFilterWithCommaPlus, anyFilter)
|
||||
@ -21,6 +23,8 @@ import Handler.Utils.Form
|
||||
import Handler.Utils.Widgets
|
||||
import Handler.Utils.DateTime
|
||||
import Handler.Utils.StudyFeatures
|
||||
import Handler.Utils.Avs (queryAvsCardNos)
|
||||
import Handler.Utils.Concurrent
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
@ -413,12 +417,16 @@ fltrUserNameUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map F
|
||||
fltrUserNameUI = fltrUserNameLinkUI
|
||||
|
||||
fltrUserNameLinkUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
|
||||
fltrUserNameLinkUI = fltrUserNameLinkHdrUI MsgTableCourseMembers
|
||||
fltrUserNameLinkUI = fltrUserNameLinkHdrUI MsgTableCourseMembers
|
||||
|
||||
fltrUserNameLinkHdrUI :: (RenderMessage UniWorX msg) => msg -> Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
|
||||
fltrUserNameLinkHdrUI msg mPrev =
|
||||
fltrUserNameLinkHdrUI msg mPrev =
|
||||
prismAForm (singletonFilter "user-name") mPrev $ aopt textField (fslI msg)
|
||||
|
||||
fltrUserDisplayNameHdrUI :: (RenderMessage UniWorX msg) => msg -> Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
|
||||
fltrUserDisplayNameHdrUI msg mPrev =
|
||||
prismAForm (singletonFilter "user-display-name") mPrev $ aopt textField (fslI msg)
|
||||
|
||||
fltrUserNameEmailUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
|
||||
fltrUserNameEmailUI = fltrUserNameEmailHdrUI MsgTableCourseMembers
|
||||
|
||||
@ -466,6 +474,8 @@ fltrUserMatriclenrUI mPrev =
|
||||
|
||||
----------------
|
||||
-- User E-Mail
|
||||
----------------
|
||||
|
||||
colUserEmail :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c)
|
||||
colUserEmail = sortable (Just "user-email") (i18nCell MsgTableEmail) cellHasEMail
|
||||
|
||||
@ -680,7 +690,7 @@ fltrRelevantStudyFeaturesTerms queryTermUser = singletonMap "features-terms" . F
|
||||
|
||||
fltrRelevantStudyFeaturesTermsUI :: DBFilterUI
|
||||
fltrRelevantStudyFeaturesTermsUI = fltrStudyTermsUI
|
||||
|
||||
|
||||
fltrRelevantStudyFeaturesDegree :: OpticFilterColumn' t (Set Text) (E.SqlExpr (E.Value TermId), E.SqlExpr (E.Value UserId))
|
||||
fltrRelevantStudyFeaturesDegree queryTermUser = singletonMap "features-degree" . FilterColumn $ \t criterias ->
|
||||
E.subSelectOr . E.from $ \(term `E.InnerJoin` studyFeatures) -> do
|
||||
@ -699,7 +709,7 @@ fltrRelevantStudyFeaturesDegree queryTermUser = singletonMap "features-degree" .
|
||||
fltrRelevantStudyFeaturesDegreeUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
|
||||
fltrRelevantStudyFeaturesDegreeUI mPrev =
|
||||
prismAForm (singletonFilter "features-degree") mPrev $ aopt textField (fslI MsgTableDegreeName)
|
||||
|
||||
|
||||
fltrRelevantStudyFeaturesSemester :: OpticFilterColumn' t (Set Text) (E.SqlExpr (E.Value TermId), E.SqlExpr (E.Value UserId))
|
||||
fltrRelevantStudyFeaturesSemester queryTermUser = singletonMap "features-semester" . FilterColumn $ \t criterias ->
|
||||
E.subSelectOr . E.from $ \(term `E.InnerJoin` studyFeatures) -> do
|
||||
@ -715,6 +725,19 @@ fltrRelevantStudyFeaturesSemesterUI :: DBFilterUI
|
||||
fltrRelevantStudyFeaturesSemesterUI = fltrFeaturesSemesterUI
|
||||
|
||||
|
||||
--------------------
|
||||
-- Qualifications
|
||||
--------------------
|
||||
|
||||
fltrQualification :: OpticFilterColumn t QualificationShorthand
|
||||
fltrQualification queryQual = singletonMap "qualification" . FilterColumn $ mkExactFilter (view queryQual)
|
||||
|
||||
fltrQualificationUI :: DBFilterUI
|
||||
fltrQualificationUI = fltrQualificationHdrUI MsgTableQualification
|
||||
|
||||
fltrQualificationHdrUI :: (RenderMessage UniWorX msg) => msg -> DBFilterUI
|
||||
fltrQualificationHdrUI msg mPrev = prismAForm (singletonFilter "qualification" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift qualificationFieldShort) (fslI msg)
|
||||
|
||||
|
||||
---------------
|
||||
-- Companies --
|
||||
@ -722,13 +745,13 @@ fltrRelevantStudyFeaturesSemesterUI = fltrFeaturesSemesterUI
|
||||
|
||||
{-
|
||||
-- colUserCompany :: (HandlerSite (DBCell m) ~ UniWorX, IsDBTable m c, HasEntity a User) => Colonnade Sortable a (DBCell m c)
|
||||
colUserCompany = sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \heu -> do
|
||||
colUserCompany = sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \heu -> do
|
||||
let uid = heu ^. hasEntity . _entityKey
|
||||
companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
|
||||
E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
|
||||
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
|
||||
return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor)
|
||||
let companies = intersperse (text2markup ", ") $
|
||||
let companies = intersperse (text2markup ", ") $
|
||||
(\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies'
|
||||
icnSuper = text2markup " " <> icon IconSupervisor
|
||||
cell $ toWgt $ mconcat companies
|
||||
@ -737,13 +760,13 @@ colUserCompany = sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \
|
||||
-- PROBLEM: how to type sqlCell compatible with dbTable that as actions, i.e. MForm instead of YesodDB?
|
||||
colUserCompany :: (IsDBTable (YesodDB UniWorX) c, HasEntity a User) => Colonnade Sortable a (DBCell (YesodDB UniWorX) c)
|
||||
colUserCompany = sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \heu ->
|
||||
let uid = heu ^. hasEntity . _entityKey in
|
||||
sqlCell $ do
|
||||
let uid = heu ^. hasEntity . _entityKey in
|
||||
sqlCell $ do
|
||||
companies' <- E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
|
||||
E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
|
||||
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
|
||||
return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor)
|
||||
let companies = intersperse (text2markup ", ") $
|
||||
let companies = intersperse (text2markup ", ") $
|
||||
(\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies'
|
||||
icnSuper = text2markup " " <> icon IconSupervisor
|
||||
pure $ toWgt $ mconcat companies
|
||||
@ -784,12 +807,12 @@ fltrCompanyNameNr query = ("company-name-number", FilterColumn $ \needle (setFol
|
||||
let numCrits = setMapMaybe readMay criterias
|
||||
fltrCName = mkContainsFilterWith CI.mk (query >>> (E.^. CompanyName)) needle criterias
|
||||
fltrCShort = mkContainsFilterWith CI.mk (query >>> (E.^. CompanyShorthand)) needle criterias
|
||||
fltrCno = mkExactFilter (query >>> (E.^. CompanyAvsId)) needle numCrits
|
||||
fltrCno = mkExactFilter (query >>> (E.^. CompanyAvsId)) needle numCrits
|
||||
in if null numCrits
|
||||
then fltrCName E.||. fltrCShort
|
||||
else fltrCName E.||. fltrCShort E.||. fltrCno
|
||||
else fltrCName E.||. fltrCShort E.||. fltrCno
|
||||
)
|
||||
where
|
||||
where
|
||||
setFoldMap :: (Text -> Set.Set Text) -> Set.Set Text -> Set.Set Text
|
||||
setFoldMap = foldMap
|
||||
|
||||
@ -801,6 +824,41 @@ fltrCompanyNameNrHdrUI msg mPrev =
|
||||
prismAForm (singletonFilter "company-name-number") mPrev $ aopt textField (fslI msg & setTooltip MsgTableFilterCommaNameNr)
|
||||
|
||||
|
||||
---------
|
||||
-- AVS --
|
||||
---------
|
||||
|
||||
|
||||
fltrAVSCardNos :: (IsFilterColumnHandler t ([Text] -> Handler (a -> E.SqlExpr (E.Value Bool))), IsString k)
|
||||
=> (a -> E.SqlExpr (Entity User)) -> Map k (FilterColumn t fs)
|
||||
fltrAVSCardNos queryUser = Map.singleton "avs-card" fch
|
||||
where
|
||||
fch = FilterColumnHandler $ \case
|
||||
[] -> return (const E.true)
|
||||
cs -> do
|
||||
let crds = mapMaybe parseAvsCardNo $ foldMap anySeparatedText cs
|
||||
toutsecs <- getsYesod $ preview $ _appAvsConf . _Just . _avsTimeout
|
||||
maybeTimeoutHandler toutsecs (try $ queryAvsCardNos crds) >>= \case
|
||||
Nothing -> addMessageI Error MsgAvsCommunicationTimeout
|
||||
>> return (const E.false)
|
||||
(Just (Left err)) -> addMessage Error (someExc2Html err)
|
||||
>> return (const E.false)
|
||||
(Just (Right (null -> True))) -> return (const E.false)
|
||||
(Just (Right apids)) -> return $
|
||||
\(queryUser -> user) ->
|
||||
E.exists $ E.from $ \usrAvs ->
|
||||
E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId
|
||||
E.&&. usrAvs E.^. UserAvsPersonId `E.in_` E.vals apids
|
||||
someExc2Html :: SomeException -> Html
|
||||
someExc2Html (SomeException e) = text2Html $ tshow e
|
||||
|
||||
fltrAVSCardNosUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
|
||||
fltrAVSCardNosUI mPrev =
|
||||
prismAForm (singletonFilter "avs-card" ) mPrev $
|
||||
aopt textField (fslI MsgAvsCardNo & setTooltip (SomeMessages [SomeMessage MsgTableFilterComma, SomeMessage MsgAvsQueryNeeded]))
|
||||
|
||||
|
||||
|
||||
----------------------------
|
||||
-- Colonnade manipulation --
|
||||
----------------------------
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
-- SPDX-FileCopyrightText: 2022-23 Felix Hamann <felix.hamann@campus.lmu.de>,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-FileCopyrightText: 2022-24 Felix Hamann <felix.hamann@campus.lmu.de>,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
|
||||
|
||||
@ -22,7 +22,7 @@ module Handler.Utils.Table.Pagination
|
||||
, SortColumn(..), SortDirection(..)
|
||||
, SortingSetting(..)
|
||||
, pattern SortAscBy, pattern SortDescBy
|
||||
, FilterColumn(..), IsFilterColumn, IsFilterProjected
|
||||
, FilterColumn(..), IsFilterColumn, IsFilterColumnHandler, IsFilterProjected
|
||||
, mkFilterProjectedPost
|
||||
, DBTProjFilterPost(..)
|
||||
, DBRow(..), _dbrOutput, _dbrCount
|
||||
@ -84,7 +84,7 @@ import Data.Ratio ((%))
|
||||
import qualified Data.Foldable as Foldable
|
||||
|
||||
import qualified Yesod.Form.Functions as Yesod
|
||||
|
||||
|
||||
import qualified Database.Esqueleto.Legacy as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
import qualified Database.Esqueleto.Internal.Internal as E (SqlSelect,unsafeSqlValue)
|
||||
@ -170,7 +170,7 @@ dbFilterKey ident = toPathPiece . WithIdent ident
|
||||
|
||||
|
||||
data SomeExprValue = forall a. PersistField a => SomeExprValue { getSomeExprValue :: E.SqlExpr (E.Value a) }
|
||||
|
||||
|
||||
data SortColumn t r' = forall a. PersistField a => SortColumn { getSortColumn :: t -> E.SqlExpr (E.Value a) }
|
||||
| forall a. PersistField a => SortColumnNullsInv { getSortColumn :: t -> E.SqlExpr (E.Value a) }
|
||||
| forall a. PersistField a => SortColumnNeverNull { getSortColumn :: t -> E.SqlExpr (E.Value a) }
|
||||
@ -262,12 +262,18 @@ instance Monoid (DBTProjFilterPost r') where
|
||||
|
||||
|
||||
data FilterColumn t fs = forall a. IsFilterColumn t a => FilterColumn a
|
||||
| forall a. IsFilterColumnHandler t a => FilterColumnHandler a
|
||||
| forall a. IsFilterProjected fs a => FilterProjected a
|
||||
|
||||
|
||||
filterColumn :: FilterColumn t fs -> Maybe ([Text] -> t -> E.SqlExpr (E.Value Bool))
|
||||
filterColumn (FilterColumn f) = Just $ filterColumn' f
|
||||
filterColumn _ = Nothing
|
||||
|
||||
filterColumnHandler :: FilterColumn t fs -> Maybe ([Text] -> Handler (t -> E.SqlExpr (E.Value Bool)))
|
||||
filterColumnHandler (FilterColumnHandler f) = Just $ filterColumnHandler' f
|
||||
filterColumnHandler _ = Nothing
|
||||
|
||||
filterProjected :: FilterColumn t fs -> [Text] -> (fs -> fs)
|
||||
filterProjected (FilterProjected f) = filterProjected' f
|
||||
filterProjected _ = const id
|
||||
@ -286,7 +292,13 @@ instance IsFilterColumn t cont => IsFilterColumn t (t -> cont) where
|
||||
|
||||
instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterColumn t cont, MonoPointed l, Monoid l) => IsFilterColumn t (l -> cont) where
|
||||
filterColumn' cont is' = filterColumn' (cont $ is' ^. mono' _PathPiece) is'
|
||||
|
||||
|
||||
class IsFilterColumnHandler t a where
|
||||
filterColumnHandler' :: a -> [Text] -> Handler (t -> E.SqlExpr (E.Value Bool))
|
||||
|
||||
instance IsFilterColumnHandler t ([Text] -> Handler (t -> E.SqlExpr (E.Value Bool))) where
|
||||
filterColumnHandler' fin args = fin args
|
||||
|
||||
class IsFilterProjected fs a where
|
||||
filterProjected' :: a -> [Text] -> (fs -> fs)
|
||||
|
||||
@ -470,7 +482,7 @@ data DBCsvMode
|
||||
| DBCsvAbort
|
||||
|
||||
makePrisms ''DBCsvMode
|
||||
|
||||
|
||||
data DBCsvDiff r' csv k'
|
||||
= DBCsvDiffNew
|
||||
{ dbCsvNewKey :: Maybe k'
|
||||
@ -507,7 +519,7 @@ makeLenses_ ''DBCsvException
|
||||
|
||||
instance (Typeable k', Show k') => Exception (DBCsvException k')
|
||||
|
||||
|
||||
|
||||
data DBTProjCtx fs r = DBTProjCtx
|
||||
{ dbtProjFilter :: fs
|
||||
, dbtProjRow :: DBRow r
|
||||
@ -601,7 +613,7 @@ data DBStyle r = DBStyle
|
||||
}
|
||||
|
||||
data DBSTemplateMode r = DBSTDefault { dbstmNumber :: Int64 -> Bool, dbstmShowNumber :: Int64 -> Bool }
|
||||
| DBSTCourse
|
||||
| DBSTCourse
|
||||
(Lens' r (Entity Course)) -- course
|
||||
(Traversal' r (Entity User)) -- lecturers
|
||||
(Lens' r Bool) -- isRegistered
|
||||
@ -654,7 +666,7 @@ multiFilter key = prism' fromInner fromOuter
|
||||
-- prism' :: (Maybe [v] -> (Map k [v])) -> ((Map k [v]) -> Maybe (Maybe [v])) -> Prism' (Map k [v]) (Maybe [v])
|
||||
fromInner = maybe Map.empty (Map.singleton key)
|
||||
fromOuter = Just . Map.lookup key
|
||||
|
||||
|
||||
data DBTCsvEncode r' k' csv = forall exportData filename sheetName.
|
||||
( ToNamedRecord csv, CsvColumnsExplained csv
|
||||
, DBTableKey k'
|
||||
@ -738,7 +750,7 @@ dbtProjId :: forall fs r r'.
|
||||
( fs ~ (), DBRow r ~ r' )
|
||||
=> ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r'
|
||||
dbtProjId = dbtProjId'
|
||||
|
||||
|
||||
dbtProjSimple' :: forall fs r r' r''.
|
||||
DBRow r'' ~ r'
|
||||
=> (r -> DB r'')
|
||||
@ -1047,7 +1059,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
||||
doSorting <- or2M
|
||||
(getsYesod . views _appBotMitigations $ Set.notMember SettingBotMitigationOnlyLoggedInTableSorting)
|
||||
(is _Just <$> maybeAuthId)
|
||||
|
||||
|
||||
let
|
||||
sortingOptions = mkOptionList
|
||||
[ Option t' (SortingSetting t d) t'
|
||||
@ -1100,7 +1112,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
||||
<|> piInput
|
||||
|
||||
psShortcircuit <- (== Just dbtIdent') <$> lookupCustomHeader HeaderDBTableShortcircuit
|
||||
|
||||
|
||||
let
|
||||
-- adjustPI = over _piSorting $ guardOnM doSorting -- probably not neccessary; not displaying the links should be enough for now
|
||||
((errs, PaginationSettings{..}), paginationInput@PaginationInput{..})
|
||||
@ -1198,7 +1210,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
||||
sortSql :: _ -> [E.SqlExpr E.OrderBy]
|
||||
sortSql t = concatMap (\(f, d) -> f d t) $ mapMaybe (\(c, d) -> (, d) <$> sqlSortDirection c) psSorting'
|
||||
|
||||
filterSql :: Map FilterKey (Maybe (_ -> E.SqlExpr (E.Value Bool)))
|
||||
filterSql :: Map FilterKey (Maybe (_ -> E.SqlExpr (E.Value Bool))) -- could there be any reason not to remove Nothing values from the map already here?
|
||||
filterSql = map (\(fc, args) -> ($ args) <$> filterColumn fc) $ psFilter'
|
||||
|
||||
-- selectPagesize = primarySortSql
|
||||
@ -1206,6 +1218,10 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
||||
|
||||
-- psLimit' = bool PagesizeAll psLimit selectPagesize
|
||||
|
||||
filterHandler <- case csvMode of
|
||||
FormSuccess DBCsvImport{} -> return mempty -- don't execute Handler actions for unneeded filters upon csv _import_
|
||||
_other -> liftHandler $ forM psFilter' $ \(fc,args) -> mapM ($ args) $ filterColumnHandler fc
|
||||
|
||||
rows' <- E.select . E.from $ \t -> do
|
||||
res <- dbtSQLQuery t
|
||||
E.orderBy $ sortSql t
|
||||
@ -1221,9 +1237,11 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
||||
-> do
|
||||
E.limit l
|
||||
E.offset $ psPage * l
|
||||
Just ps -> E.where_ $ dbtRowKey t `E.sqlIn` ps
|
||||
Just ps -> E.where_ $ dbtRowKey t `E.sqlIn` ps -- Note that multiple where_ are indeed concatenated
|
||||
_other -> return ()
|
||||
Map.foldr (\fc expr -> maybe (return ()) (E.where_ . ($ t)) fc >> expr) (return ()) filterSql
|
||||
let filterAppT = Map.foldr (\fc expr -> maybe expr ((: expr) . ($ t)) fc) []
|
||||
sqlFilters = filterAppT filterHandler <> filterAppT filterSql -- Note that <> on the maps won't work as intended, since keys are present in both
|
||||
unless (null sqlFilters) $ E.where_ $ E.and sqlFilters
|
||||
return (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64), dbtRowKey t, res)
|
||||
|
||||
let mapMaybeM' f = mapMaybeM $ \(k, v) -> (,) <$> pure k <*> f v
|
||||
@ -1261,7 +1279,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
||||
exData <- hoistMaybe dbtCsvExampleData
|
||||
hdr <- lift $ dbtCsvHeader Nothing
|
||||
exportUrl <- toTextUrl (currentRoute, [(toPathPiece GetCsvExampleData, "")])
|
||||
return $(widgetFile "table/csv-example")
|
||||
return $(widgetFile "table/csv-example")
|
||||
|
||||
formResult csvMode $ \case
|
||||
DBCsvAbort{} -> do
|
||||
@ -1452,7 +1470,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
||||
guardM doAltRep
|
||||
|
||||
cts <- reqAccept <$> getRequest
|
||||
|
||||
|
||||
altRep <- hoistMaybe <=< asum $ do
|
||||
mRep <- hoistMaybe . selectRep' extraReps' =<< cts
|
||||
return . return $ mRep <&> \case
|
||||
@ -1502,7 +1520,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
||||
-> State.modify $ (:) (n, beforeSize, cellSize)
|
||||
| otherwise -> return ()
|
||||
let rowspanAcc'' = rowspanAcc'
|
||||
& traverse . _1 %~ pred
|
||||
& traverse . _1 %~ pred
|
||||
whenIsJust (flattenAnnotated v) $ go rowspanAcc''
|
||||
|
||||
compCellSize :: forall h' c. [(Int, Int, Int)] -> [Sized (Maybe Int) h' c] -> Sized (Maybe Int) h' c -> (Int, Maybe Int)
|
||||
@ -1616,7 +1634,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
||||
addMessageI Success . MsgCsvImportSuccessful $ length acts'
|
||||
E.transactionSave
|
||||
redirect finalDest
|
||||
|
||||
|
||||
_other -> return ((FormMissing, mempty), mempty)
|
||||
formResult csvImportConfirmRes $ \case
|
||||
(_, BtnCsvImportAbort) -> do
|
||||
@ -1643,7 +1661,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
||||
|
||||
setParam :: Text -> Maybe Text -> QueryText -> QueryText
|
||||
setParam key = setParams key . maybeToList
|
||||
|
||||
|
||||
|
||||
dbTableWidget :: Monoid x
|
||||
=> PSValidator (HandlerFor UniWorX) x
|
||||
@ -1671,7 +1689,7 @@ widgetColonnade :: Colonnade h r (DBCell (HandlerFor UniWorX) x)
|
||||
-> Colonnade h r (DBCell (HandlerFor UniWorX) x)
|
||||
widgetColonnade = id
|
||||
|
||||
-- | force the column list type for tables that cotain forms, especially those constructed with dbSelect, avoids explicit type signatures
|
||||
-- | force the column list type for tables that contain forms, especially those constructed with dbSelect, avoids explicit type signatures
|
||||
formColonnade :: Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) (FormResult a))
|
||||
-> Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) (FormResult a))
|
||||
formColonnade = id
|
||||
@ -1766,7 +1784,7 @@ anchorCellCM cache routeM widget = anchorCellCM' cache routeM id (const widget)
|
||||
|
||||
anchorCellM' :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a) => WidgetFor UniWorX x -> (x -> url) -> (x -> wgt) -> DBCell m a
|
||||
anchorCellM' xM x2route x2widget = linkEitherCellM' xM x2route (x2widget, x2widget)
|
||||
|
||||
|
||||
anchorCellCM' :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a, Binary cache) => cache -> WidgetFor UniWorX x -> (x -> url) -> (x -> wgt) -> DBCell m a
|
||||
anchorCellCM' cache xM x2route x2widget = linkEitherCellCM' cache xM x2route (x2widget, x2widget)
|
||||
|
||||
@ -1837,7 +1855,7 @@ maybeLinkEitherCellCM' mCache xM x2route (x2widgetAuth,x2widgetUnauth) = cell $
|
||||
|
||||
listCell :: (IsDBTable m a, MonoFoldable mono) => mono -> (Element mono -> DBCell m a) -> DBCell m a
|
||||
listCell = listCell' . return
|
||||
|
||||
|
||||
listCell' :: (IsDBTable m a, MonoFoldable mono) => WriterT a m mono -> (Element mono -> DBCell m a) -> DBCell m a
|
||||
listCell' mkXS mkCell = ilistCell' (otoList <$> mkXS) $ const mkCell
|
||||
|
||||
@ -1908,7 +1926,7 @@ dbSelect :: forall x h r i a. (Headedness h, Monoid' x)
|
||||
-> Colonnade h (DBRow r) (DBCell (MForm (HandlerFor UniWorX)) x)
|
||||
-- dbSelect resLens selLens genIndex = Colonnade.singleton (headednessPure $ i18nCell MsgSelectColumn) $ formCell resLens genIndex genForm
|
||||
dbSelect resLens selLens genIndex = Colonnade.singleton (headednessPure $ mempty & cellAttrs <>~ pure ("uw-hide-columns--no-hide","")) $ formCell resLens genIndex genForm
|
||||
where
|
||||
where
|
||||
genForm _ mkUnique = do
|
||||
(selResult, selWidget) <- mreq checkBoxField (fsUniq mkUnique "select") (Just False)
|
||||
return (set selLens <$> selResult, [whamlet|^{fvWidget selWidget}|])
|
||||
@ -1918,7 +1936,7 @@ dbSelectIf :: forall x h r i a. (Headedness h, Monoid' x)
|
||||
=> Lens' x (FormResult (DBFormResult i a (DBRow r)))
|
||||
-> Setter' a Bool
|
||||
-> (DBRow r -> MForm (HandlerFor UniWorX) i)
|
||||
-> (DBRow r -> Bool)
|
||||
-> (DBRow r -> Bool)
|
||||
-> Colonnade h (DBRow r) (DBCell (MForm (HandlerFor UniWorX)) x)
|
||||
dbSelectIf resLens selLens genIndex condition = Colonnade.singleton (headednessPure $ mempty & cellAttrs <>~ [("uw-hide-columns--no-hide", mempty)] ) fCell
|
||||
where
|
||||
@ -1927,9 +1945,9 @@ dbSelectIf resLens selLens genIndex condition = Colonnade.singleton (headednessP
|
||||
(selResult, selWidget) <- mreq checkBoxField ((bool inputDisabled id $ condition row) $ fsUniq mkUnique "select") (Just False) -- produces disabled field, but still checked by master checkbox from header
|
||||
--(selResult, selWidget) <- mreq (bool noField checkBoxField $ condition row) (fsUniq mkUnique "select") (Just False) -- omits field entirely, but also removes master checkbox from header
|
||||
{- Similar to previous: omits field entirely, but also removes master checkbox from header
|
||||
(selResult, selWidget) <- if condition row
|
||||
(selResult, selWidget) <- if condition row
|
||||
then mreq checkBoxField (fsUniq mkUnique "select") (Just False)
|
||||
else return (FormMissing, FieldView "" Nothing "" mempty Nothing False)
|
||||
else return (FormMissing, FieldView "" Nothing "" mempty Nothing False)
|
||||
-}
|
||||
return (set selLens <$> selResult, [whamlet|^{fvWidget selWidget}|])
|
||||
|
||||
|
||||
@ -12,12 +12,16 @@ module Handler.Utils.Users
|
||||
, NameMatchQuality(..)
|
||||
, matchesName
|
||||
, GuessUserInfo(..)
|
||||
, guessUser
|
||||
, guessUser, guessUserByEmail
|
||||
, UserAssimilateException(..), UserAssimilateExceptionReason(..)
|
||||
, assimilateUser
|
||||
, userPrefersEmail, userPrefersLetter
|
||||
, getEmailAddress
|
||||
, getPostalAddress, getPostalPreferenceAndAddress
|
||||
, getUserPrimaryCompany, getUserPrimaryCompanyAddress
|
||||
, getUserEmail
|
||||
, getEmailAddress, getJustEmailAddress
|
||||
, getUserEmailAutomatic
|
||||
, getEmailAddressFor, getJustEmailAddressFor
|
||||
, getPostalAddress, getPostalAddress'
|
||||
, getPostalPreferenceAndAddress, getPostalPreferenceAndAddress'
|
||||
, abbrvName
|
||||
, getReceivers, getReceiversFor
|
||||
, getSupervisees
|
||||
@ -53,6 +57,12 @@ import Handler.Utils.Profile
|
||||
|
||||
import Jobs.Types(Job, JobChildren)
|
||||
|
||||
data ExceptionUserHandling
|
||||
= ExceptionUserHasNoEmail
|
||||
deriving (Eq, Ord, Read, Show, Generic) -- Enum, Bounded,
|
||||
instance Exception ExceptionUserHandling
|
||||
|
||||
|
||||
abbrvName :: User -> Text
|
||||
abbrvName User{userDisplayName, userFirstName, userSurname} =
|
||||
if | (lastDisplayName : tsrif) <- reverse nameParts
|
||||
@ -65,36 +75,115 @@ abbrvName User{userDisplayName, userFirstName, userSurname} =
|
||||
assemble = Text.intercalate "."
|
||||
|
||||
|
||||
-- deprecated, used getPostalPreferenceAndAddress
|
||||
userPrefersLetter :: User -> Bool
|
||||
userPrefersLetter = fst . getPostalPreferenceAndAddress
|
||||
-- Note: Entity can be recovered, since CompanyShort is also the key
|
||||
getUserPrimaryCompany :: UserId -> DB (Maybe UserCompany)
|
||||
getUserPrimaryCompany uid = entityVal <<$>>
|
||||
selectFirst [UserCompanyUser ==. uid]
|
||||
[Desc UserCompanyPriority, Desc UserCompanySupervisorReroute, Desc UserCompanySupervisor, Asc UserCompanyCompany]
|
||||
|
||||
-- deprecated, used getPostalPreferenceAndAddress
|
||||
userPrefersEmail :: User -> Bool
|
||||
userPrefersEmail = not . userPrefersLetter
|
||||
getUserPrimaryCompanyAddress :: UserId -> (Company -> Maybe a) -> DB (Maybe a)
|
||||
getUserPrimaryCompanyAddress uid prj = runMaybeT $ do
|
||||
UserCompany{userCompanyCompany=cid, userCompanyUseCompanyAddress=True} <- MaybeT $ getUserPrimaryCompany uid -- return Nothing if company address is not to be used
|
||||
company <- MaybeT $ get cid
|
||||
-- hoistMaybe $ prj company
|
||||
MaybeT $ pure $ prj company
|
||||
|
||||
-- | result (True, Nothing) indicates that neither userEmail nor userPostAddress is known
|
||||
getPostalPreferenceAndAddress :: User -> (Bool, Maybe [Text])
|
||||
getPostalPreferenceAndAddress usr@User{userPrefersPostal} =
|
||||
((userPrefersPostal && postPossible) || not emailPossible, pa)
|
||||
-- (((userPrefersPostal || isNothing userPinPassword) && postPossible) || not emailPossible, pa) -- ignore email/post preference if no pinPassword is set
|
||||
where
|
||||
pa = getPostalAddress usr
|
||||
postPossible = isJust pa
|
||||
emailPossible = isJust $ getEmailAddress usr
|
||||
|
||||
getEmailAddress :: User -> Maybe UserEmail
|
||||
getEmailAddress User{userDisplayEmail, userEmail} = pickValidEmail' userDisplayEmail userEmail
|
||||
|
||||
getPostalAddress :: User -> Maybe [Text]
|
||||
getPostalAddress User{..}
|
||||
| Just pa <- userPostAddress
|
||||
= Just $ userDisplayName : html2textlines pa
|
||||
| Just abt <- userCompanyDepartment
|
||||
= Just $ if | "BVD" `isPrefixOf` abt -> [userDisplayName, abt, "Bodenverkehrsdienste"]
|
||||
| otherwise -> [userDisplayName, abt, "Hausbriefkasten" ]
|
||||
-- | result (True, Nothing, Nothing) indicates that neither userEmail nor userPostAddress is known
|
||||
getPostalPreferenceAndAddress :: Entity User -> DB (Bool, Maybe [Text], Maybe UserEmail)
|
||||
getPostalPreferenceAndAddress usr = do
|
||||
pa <- getPostalAddress usr
|
||||
em <- getUserEmail usr
|
||||
let usrPrefPost = usr ^. _entityVal . _userPrefersPostal
|
||||
finalPref = (usrPrefPost && isJust pa) || isNothing em
|
||||
-- finalPref = isJust pa && (usrPrefPost || isNothing em)
|
||||
return (finalPref, pa, em)
|
||||
|
||||
-- | result (True, Nothing, Nothing) indicates that neither userEmail nor userPostAddress is known
|
||||
-- primed variant returns storedMarkup without prefixed userDisplayName
|
||||
getPostalPreferenceAndAddress' :: Entity User -> DB (Bool, (Maybe StoredMarkup, Bool), (Maybe UserEmail, Bool))
|
||||
getPostalPreferenceAndAddress' usr = do
|
||||
pa <- getPostalAddress' usr
|
||||
em <- getUserEmailAutomatic usr
|
||||
let usrPrefPost = usr ^. _entityVal . _userPrefersPostal
|
||||
finalPref = (usrPrefPost && isJust (fst pa)) || isNothing (fst em)
|
||||
-- finalPref = isJust (fst pa) && (usrPrefPost || isNothing (fst em))
|
||||
return (finalPref, pa, em)
|
||||
|
||||
getEmailAddressFor :: UserId -> DB (Maybe Address)
|
||||
getEmailAddressFor = maybeM (return Nothing) getEmailAddress . getEntity
|
||||
|
||||
getJustEmailAddressFor :: UserId -> DB Address
|
||||
getJustEmailAddressFor = maybeThrowM ExceptionUserHasNoEmail . getEmailAddressFor
|
||||
|
||||
getJustEmailAddress :: Entity User -> DB Address
|
||||
getJustEmailAddress = maybeThrowM ExceptionUserHasNoEmail . getEmailAddress
|
||||
|
||||
getEmailAddress :: Entity User -> DB (Maybe Address)
|
||||
getEmailAddress usr@Entity{entityVal=User{userDisplayName}} = toAddress <<$>> getUserEmail usr
|
||||
where toAddress = Address (Just userDisplayName) . CI.original
|
||||
|
||||
getUserEmail :: Entity User -> DB (Maybe UserEmail)
|
||||
getUserEmail Entity{entityKey=uid, entityVal=User{userDisplayEmail, userEmail}}
|
||||
| validEmail' userDisplayEmail
|
||||
= return $ Just userDisplayEmail
|
||||
| otherwise
|
||||
= Nothing
|
||||
= do
|
||||
compEmailMb <- getUserPrimaryCompanyAddress uid companyEmail
|
||||
return $ pickValidEmail' $ mcons compEmailMb [userEmail]
|
||||
|
||||
-- like `getUserEmail`, but also checks whether the Email will be update automatically
|
||||
getUserEmailAutomatic :: Entity User -> DB (Maybe UserEmail, Bool)
|
||||
getUserEmailAutomatic Entity{entityKey=uid, entityVal=User{userDisplayEmail, userEmail}}
|
||||
| validEmail' userDisplayEmail
|
||||
= do
|
||||
muavs <- getBy $ UniqueUserAvsUser uid
|
||||
let auto = userDisplayEmail == muavs ^. _Just . _userAvsLastFirmInfo . _Just . _avsFirmPrimaryEmail . _Just . from _CI -- Recall: _Just on Nothing yields mempty here
|
||||
|| userDisplayEmail == muavs ^. _Just . _userAvsLastPersonInfo . _Just . _avsInfoPersonEMail . _Just . from _CI
|
||||
return (Just userDisplayEmail, auto)
|
||||
| otherwise
|
||||
= getUserPrimaryCompanyAddress uid companyEmail >>= \case
|
||||
Just compEmail | validEmail' compEmail -> return (Just compEmail, True )
|
||||
Nothing | validEmail' userEmail -> return (Just userEmail, False)
|
||||
_ -> return (Nothing , False)
|
||||
|
||||
-- address is prefixed with userDisplayName
|
||||
getPostalAddress :: Entity User -> DB (Maybe [Text])
|
||||
getPostalAddress Entity{entityKey=uid, entityVal=User{..}}
|
||||
| (Just upo) <- userPostAddress, validPostAddress userPostAddress
|
||||
= prefixMarkupName upo
|
||||
| otherwise
|
||||
= do
|
||||
getUserPrimaryCompanyAddress uid companyPostAddress >>= \case
|
||||
(Just pa)
|
||||
-> prefixMarkupName pa
|
||||
Nothing
|
||||
| Just abt <- userCompanyDepartment
|
||||
-> return $ Just $ if | "BVD" `isPrefixOf` abt -> [userDisplayName, abt, "Bodenverkehrsdienste"]
|
||||
| otherwise -> [userDisplayName, abt, "Hausbriefkasten" ]
|
||||
| otherwise -> return Nothing
|
||||
where
|
||||
prefixMarkupName = return . Just . (userDisplayName :) . html2textlines
|
||||
|
||||
-- primed variant returns storedMarkup without prefixed userDisplayName and whether updates are automatic
|
||||
getPostalAddress' :: Entity User -> DB (Maybe StoredMarkup, Bool)
|
||||
getPostalAddress' Entity{entityKey=uid, entityVal=User{..}}
|
||||
| validPostAddress userPostAddress
|
||||
= do
|
||||
muavs <- getBy $ UniqueUserAvsUser uid
|
||||
let auto = userPostAddress == muavs ^? _Just . _userAvsLastFirmInfo . _Just . _avsFirmPostAddress . _Just -- Recall: using _Just with ^. on Nothing yields mempty
|
||||
return (userPostAddress, auto)
|
||||
| otherwise
|
||||
= do
|
||||
getUserPrimaryCompanyAddress uid companyPostAddress >>= \case
|
||||
res@(Just _)
|
||||
-> return (res, True)
|
||||
Nothing
|
||||
| Just abt <- userCompanyDepartment
|
||||
-> return $ (,True) $ Just $ plaintextToStoredMarkup $ textUnlines $
|
||||
if | "BVD" `isPrefixOf` abt -> [userDisplayName, abt, "Bodenverkehrsdienste"]
|
||||
| otherwise -> [userDisplayName, abt, "Hausbriefkasten" ]
|
||||
| otherwise -> return (Nothing, True)
|
||||
|
||||
-- | Consider using Handler.Utils.Avs.updateReceivers instead
|
||||
-- Return Entity User and all Supervisors with rerouteNotifications as well as
|
||||
@ -123,15 +212,26 @@ getReceiversFor uids = (E.unValue <<$>>) $ E.select $ E.distinct $ do
|
||||
|
||||
-- | return underlings for currently logged in user
|
||||
getSupervisees :: DB (Set UserId)
|
||||
getSupervisees = do
|
||||
getSupervisees = do
|
||||
uid <- requireAuthId
|
||||
svs <- userSupervisorUser . entityVal <<$>> selectList [UserSupervisorSupervisor ==. uid] [Asc UserSupervisorUser]
|
||||
return $ Set.insert uid $ Set.fromAscList svs
|
||||
return $ Set.insert uid $ Set.fromAscList svs
|
||||
|
||||
|
||||
computeUserAuthenticationDigest :: Maybe Text -> Digest SHA3_256
|
||||
computeUserAuthenticationDigest = hashlazy . JSON.encode
|
||||
|
||||
-- guessUserByCompanyPersonalNumber :: Text -> Text -> DB (Maybe UserId)
|
||||
-- guessUserByCompanyPersonalNumber surname ipn = getKeyByFilter [UserCompanyPersonalNumber ==. Just ipn, UserSurname ==. surname]
|
||||
|
||||
guessUserByEmail :: UserEmail -> DB (Maybe UserId)
|
||||
guessUserByEmail eml = firstJustM $
|
||||
[ getKeyBy $ UniqueEmail eml
|
||||
, getKeyBy $ UniqueAuthentication eml -- aka UserIdent
|
||||
, getKeyByFilter [UserDisplayEmail ==. eml]
|
||||
] <> maybeEmpty (getFraportLogin (CI.original eml)) (\lgi ->
|
||||
[ getKeyBy $ UniqueLdapPrimaryKey $ Just lgi
|
||||
])
|
||||
|
||||
data GuessUserInfo
|
||||
= GuessUserMatrikelnummer
|
||||
@ -266,7 +366,7 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria)
|
||||
, Just True == matchesMatriculation x || didUpsert
|
||||
-> return $ Just $ Left $ NonEmpty.fromList xs
|
||||
| not didUpsert
|
||||
, userMatrs <- (Set.toList . Set.fromList . catMaybes) $ getTermMatr <$> criteria
|
||||
, userMatrs <- ((Set.toList . Set.fromList) (mapMaybe getTermMatr criteria))
|
||||
-> mapM doUpsert userMatrs >>= maybe (go True) (return . Just) . convertUpsertResults . catMaybes
|
||||
| otherwise
|
||||
-> return Nothing
|
||||
@ -299,10 +399,10 @@ assimilateUser :: UserId -- ^ @newUserId@
|
||||
-- Fatal errors are thrown, non-fatal warnings are returned
|
||||
assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
||||
-- retrieve user entities first, to ensure they both exist
|
||||
(oldUserEnt, newUserEnt) <- do
|
||||
(oldUserEnt, newUserEnt) <- do
|
||||
oldUser <- getEntity oldUserId
|
||||
newUser <- getEntity newUserId
|
||||
case (oldUser, newUser) of
|
||||
case (oldUser, newUser) of
|
||||
(Just old, Just new) -> return (old,new)
|
||||
_ -> tellError UserAssimilateCouldNotDetermineUserIdents
|
||||
let oldUser = oldUserEnt ^. _entityVal
|
||||
@ -805,7 +905,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
||||
|
||||
-- Qualifications and ongoing LMS
|
||||
-- LmsUser: insertSelectWithConflict impossible due to 2 simultaneous uniqueness constraints; UniqueLmsIdent requires proper update, prohibits insert and then delete
|
||||
-- updateWhere [ LmsUserUser ==. oldUserId ] [ LmsUserUser =. newUserId ] -- might fail due to UniqueLmsQualficationUuser
|
||||
-- updateWhere [ LmsUserUser ==. oldUserId ] [ LmsUserUser =. newUserId ] -- might fail due to UniqueLmsQualificationUuser
|
||||
oldLms <- selectList [ LmsUserUser ==. oldUserId ] [ Asc LmsUserQualification ]
|
||||
newLms <- selectList [ LmsUserUser ==. newUserId ] [ Asc LmsUserQualification ]
|
||||
let projQ = lmsUserQualification . entityVal
|
||||
@ -822,13 +922,13 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
||||
EL.on ( newQual E.?. QualificationUserQualification E.?=. oldQual E.^. QualificationUserQualification
|
||||
E.&&. newQual E.?. QualificationUserUser E.?=. E.val newUserId
|
||||
)
|
||||
E.where_ $ oldQual E.^. QualificationUserUser E.==. E.val oldUserId
|
||||
E.where_ $ oldQual E.^. QualificationUserUser E.==. E.val oldUserId
|
||||
return (oldQual, newQual)
|
||||
forM_ usrQualis $ \case
|
||||
forM_ usrQualis $ \case
|
||||
(Entity oldQKey _, Nothing) -> update oldQKey [ QualificationUserUser =. newUserId ] -- update must succeed if there is not RHS in the join
|
||||
(Entity oldQKey oldQUsr, Just (Entity newQKey newQUsr)) -> do
|
||||
updateWhere [ QualificationUserBlockQualificationUser ==. oldQKey ] [ QualificationUserBlockQualificationUser =. newQKey ]
|
||||
update newQKey
|
||||
update newQKey
|
||||
[ QualificationUserValidUntil =. (max `on` view _qualificationUserValidUntil ) oldQUsr newQUsr
|
||||
, QualificationUserLastRefresh =. (max `on` view _qualificationUserLastRefresh ) oldQUsr newQUsr
|
||||
, QualificationUserFirstHeld =. (min `on` view _qualificationUserFirstHeld ) oldQUsr newQUsr
|
||||
@ -836,7 +936,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
||||
, QualificationUserLastNotified =. (max `on` view _qualificationUserLastNotified ) oldQUsr newQUsr
|
||||
]
|
||||
delete oldQKey
|
||||
-- deleteWhere [ QualificationUserUser ==. oldUserId ] -- no longer needed
|
||||
-- deleteWhere [ QualificationUserUser ==. oldUserId ] -- no longer needed
|
||||
|
||||
-- PrintJobs
|
||||
updateWhere [ PrintJobRecipient ==. Just oldUserId ] [ PrintJobRecipient =. Just newUserId ]
|
||||
@ -850,9 +950,15 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
||||
return $ UserSupervisor
|
||||
E.<# E.val newUserId
|
||||
E.<&> (userSupervisor E.^. UserSupervisorUser)
|
||||
E.<&> (userSupervisor E.^. UserSupervisorRerouteNotifications)
|
||||
E.<&> (userSupervisor E.^. UserSupervisorRerouteNotifications)
|
||||
E.<&> (userSupervisor E.^. UserSupervisorCompany)
|
||||
E.<&> (userSupervisor E.^. UserSupervisorReason)
|
||||
)
|
||||
(\current excluded -> [ UserSupervisorRerouteNotifications E.=. (current E.^. UserSupervisorRerouteNotifications E.||. excluded E.^. UserSupervisorRerouteNotifications) ] )
|
||||
(\current excluded ->
|
||||
[ UserSupervisorRerouteNotifications E.=. (current E.^. UserSupervisorRerouteNotifications E.||. excluded E.^. UserSupervisorRerouteNotifications)
|
||||
, UserSupervisorCompany E.=. E.coalesce [current E.^. UserSupervisorCompany, excluded E.^. UserSupervisorCompany]
|
||||
, UserSupervisorReason E.=. E.coalesce [current E.^. UserSupervisorReason , excluded E.^. UserSupervisorReason]
|
||||
] )
|
||||
deleteWhere [ UserSupervisorSupervisor ==. oldUserId]
|
||||
|
||||
E.insertSelectWithConflict
|
||||
@ -863,8 +969,14 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
||||
E.<# (userSupervisor E.^. UserSupervisorSupervisor)
|
||||
E.<&> E.val newUserId
|
||||
E.<&> (userSupervisor E.^. UserSupervisorRerouteNotifications)
|
||||
E.<&> (userSupervisor E.^. UserSupervisorCompany)
|
||||
E.<&> (userSupervisor E.^. UserSupervisorReason)
|
||||
)
|
||||
(\current excluded -> [ UserSupervisorRerouteNotifications E.=. (current E.^. UserSupervisorRerouteNotifications E.||. excluded E.^. UserSupervisorRerouteNotifications) ] )
|
||||
(\current excluded ->
|
||||
[ UserSupervisorRerouteNotifications E.=. (current E.^. UserSupervisorRerouteNotifications E.||. excluded E.^. UserSupervisorRerouteNotifications)
|
||||
, UserSupervisorCompany E.=. E.coalesce [current E.^. UserSupervisorCompany, excluded E.^. UserSupervisorCompany]
|
||||
, UserSupervisorReason E.=. E.coalesce [current E.^. UserSupervisorReason , excluded E.^. UserSupervisorReason]
|
||||
] )
|
||||
deleteWhere [ UserSupervisorUser ==. oldUserId]
|
||||
|
||||
-- Companies, in conflict, keep the newUser-Company as is
|
||||
@ -877,20 +989,28 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
||||
E.<&> (userCompany E.^. UserCompanyCompany)
|
||||
E.<&> (userCompany E.^. UserCompanySupervisor)
|
||||
E.<&> (userCompany E.^. UserCompanySupervisorReroute)
|
||||
E.<&> (userCompany E.^. UserCompanyPriority)
|
||||
E.<&> (userCompany E.^. UserCompanyUseCompanyAddress)
|
||||
E.<&> (userCompany E.^. UserCompanyReason)
|
||||
)
|
||||
(\current excluded ->
|
||||
[ UserCompanySupervisor E.=. E.greatest (current E.^. UserCompanySupervisor) (excluded E.^. UserCompanySupervisor) -- t > f
|
||||
, UserCompanyPriority E.=. E.greatest (current E.^. UserCompanyPriority) (excluded E.^. UserCompanyPriority)
|
||||
, UserCompanyUseCompanyAddress E.=. E.greatest (current E.^. UserCompanyUseCompanyAddress) (excluded E.^. UserCompanyUseCompanyAddress)
|
||||
, UserCompanyReason E.=. E.coalesce [current E.^. UserCompanyReason ,excluded E.^. UserCompanyReason]
|
||||
]
|
||||
)
|
||||
(\current _excluded -> [ UserCompanySupervisor E.=. (current E.^. UserCompanySupervisor)] )
|
||||
deleteWhere [ UserCompanyUser ==. oldUserId]
|
||||
|
||||
mbOldAvsId <- getBy $ UniqueUserAvsUser oldUserId
|
||||
mbNewAvsId <- getBy $ UniqueUserAvsUser newUserId
|
||||
case (mbOldAvsId,mbNewAvsId) of
|
||||
(Nothing, _)
|
||||
mbNewAvsId <- getBy $ UniqueUserAvsUser newUserId
|
||||
case (mbOldAvsId,mbNewAvsId) of
|
||||
(Nothing, _)
|
||||
-> return ()
|
||||
(Just Entity{entityVal=UserAvs{userAvsPersonId=oldAvsId}}, Just _)
|
||||
-> deleteWhere [UserAvsCardPersonId ==. oldAvsId] >> deleteBy (UniqueUserAvsUser oldUserId)
|
||||
(Just Entity{entityVal=oldUserAvs}, Nothing)
|
||||
-> -- deleteBy $ UniqueUserAvsUser oldUserId -- maybe we need this due to double uniqueness?!
|
||||
void $ upsertBy (UniqueUserAvsId (oldUserAvs ^. _userAvsPersonId)) oldUserAvs{userAvsUser=newUserId} [UserAvsUser =. newUserId]
|
||||
(Just Entity{entityVal=UserAvs{userAvsPersonId=oldAvsId}}, Just _)
|
||||
-> deleteBy (UniqueUserAvsId oldAvsId)
|
||||
(Just Entity{entityVal=oldUserAvs}, Nothing)
|
||||
-> void $ upsertBySafe (UniqueUserAvsId (oldUserAvs ^. _userAvsPersonId)) oldUserAvs{userAvsUser=newUserId} (_userAvsUser .~ newUserId)
|
||||
|
||||
-- merge some optional / incomplete user fields
|
||||
let mergeBy :: forall a . PersistField a => (a -> a -> Bool) -> EntityField User a -> Maybe (Update User)
|
||||
@ -898,7 +1018,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
||||
oldV = oldUserEnt ^. ufl
|
||||
newV = newUserEnt ^. ufl
|
||||
in toMaybe (cmp oldV newV) (uf =. oldV)
|
||||
|
||||
|
||||
mergeMaybe :: forall b . PersistField b => EntityField User (Maybe b) -> Maybe (Update User)
|
||||
mergeMaybe = mergeBy (\oldV newV -> isNothing newV && isJust oldV)
|
||||
|
||||
@ -917,14 +1037,14 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
||||
(UserPostLastUpdate =. oldUser ^. _userPostLastUpdate)
|
||||
, toMaybe ((isJust (newUser ^. _userPostAddress) || isJust (oldUser ^. _userPostAddress))
|
||||
&& (newUser ^. _userPrefersPostal || oldUser ^. _userPrefersPostal))
|
||||
(UserPrefersPostal =. True)
|
||||
(UserPrefersPostal =. True)
|
||||
, mergeMaybe UserPinPassword
|
||||
, mergeMaybe UserLanguages
|
||||
, mergeMaybe UserSex
|
||||
, mergeMaybe UserBirthday
|
||||
, mergeMaybe UserTelephone
|
||||
, mergeMaybe UserMobile
|
||||
]
|
||||
]
|
||||
|
||||
delete oldUserId
|
||||
let oldUsrIdent = oldUser ^. _userIdent
|
||||
|
||||
@ -14,6 +14,7 @@ import Handler.Utils.DateTime
|
||||
|
||||
import qualified Data.Char as Char
|
||||
import qualified Data.HashMap.Strict as Aeson -- ON UPDATE replace with: import qualified Data.Aeson.KeyMap as Aeson
|
||||
import Data.Scientific
|
||||
|
||||
---------
|
||||
-- Simple utilities for consistent display
|
||||
@ -37,7 +38,8 @@ visibleUTCTime dtf t = do
|
||||
-- | Simple link to a known route
|
||||
simpleLink :: HasRoute UniWorX url => Widget -> url -> Widget
|
||||
simpleLink lbl url = do
|
||||
isAuth <- hasReadAccessTo $ urlRoute url
|
||||
let route = urlRoute url
|
||||
isAuth <- liftHandler . $cachedHereBinary route $ hasReadAccessTo route
|
||||
if | isAuth -> do
|
||||
tUrl <- toTextUrl url
|
||||
[whamlet|
|
||||
@ -59,11 +61,18 @@ nameWidget displayName surname = toWidget $ nameHtml displayName surname
|
||||
userWidget :: HasUser c => c -> Widget
|
||||
userWidget x = nameWidget (x ^. _userDisplayName) (x ^._userSurname)
|
||||
|
||||
userIdWidget :: UserId -> Widget
|
||||
userIdWidget uid = maybeM (msg2widget MsgUserUnknown) userWidget (liftHandler $ runDBRead $ get uid)
|
||||
|
||||
linkUserWidget :: HasRoute UniWorX url => (CryptoUUIDUser -> url) -> Entity User -> Widget
|
||||
linkUserWidget lnk (Entity uid usr) = do
|
||||
linkUserWidget lnk (Entity uid usr) = do
|
||||
uuid <- encrypt uid
|
||||
simpleLink (userWidget usr) (lnk uuid)
|
||||
|
||||
-- | like linkUserWidget, but on Id only. Requires DB access, use with caution
|
||||
linkUserIdWidget :: HasRoute UniWorX url => (CryptoUUIDUser -> url) -> UserId -> Widget
|
||||
linkUserIdWidget lnk uid = maybeM (msg2widget MsgUserUnknown) (linkUserWidget lnk . Entity uid) (liftHandler $ runDBRead $ get uid)
|
||||
|
||||
userEmailWidget :: HasUser c => c -> Widget
|
||||
userEmailWidget x = nameEmailWidget (x ^. _userDisplayEmail) (x ^. _userDisplayName) (x ^. _userSurname)
|
||||
|
||||
@ -84,18 +93,36 @@ nameHtml :: Text -> Text -> Html
|
||||
nameHtml displayName surname
|
||||
| null surname = toHtml displayName
|
||||
| otherwise = case reverse $ T.splitOn surname displayName of
|
||||
[_notContained] -> [shamlet|$newline never
|
||||
[_notContained]
|
||||
| (suffix:prefixes) <- reverse $ T.splitOn (T.toTitle surname) (T.toTitle displayName), notNull prefixes ->
|
||||
let prefix = T.intercalate surname $ reverse prefixes
|
||||
in [shamlet|$newline never
|
||||
#{prefix} #
|
||||
<b .surname>#{surname}
|
||||
\ #{suffix}
|
||||
|]
|
||||
| (suffix:prefixes) <- reverse $ T.splitOn (fullyNormalize surname) (fullyNormalize displayName), notNull prefixes ->
|
||||
let prefix = T.intercalate surname $ reverse prefixes
|
||||
in [shamlet|$newline never
|
||||
#{prefix} #
|
||||
<b .surname>#{surname}
|
||||
\ #{suffix}
|
||||
|]
|
||||
| otherwise -> [shamlet|$newline never
|
||||
#{displayName} (
|
||||
<b .surname>#{surname}
|
||||
)|]
|
||||
(suffix:prefixes) ->
|
||||
let prefix = T.intercalate surname $ reverse prefixes
|
||||
in [shamlet|$newline never
|
||||
#{prefix}
|
||||
#{prefix} #
|
||||
<b .surname>#{surname}
|
||||
#{suffix}
|
||||
\ #{suffix}
|
||||
|]
|
||||
[] -> error "Data.Text.splitOn returned empty list in violation of specification."
|
||||
where
|
||||
fullyNormalize :: Text -> Text
|
||||
fullyNormalize = T.toTitle . T.unwords . map text2asciiAlphaNum . T.words
|
||||
|
||||
nameHtml' :: HasUser u => u -> Html
|
||||
nameHtml' u = nameHtml (u ^. _userDisplayName) (u ^. _userSurname)
|
||||
@ -126,11 +153,43 @@ editedByW fmt tm usr = do
|
||||
-- | like `modal`, but only conditionally displays the modal link only after checking access rights. WARNING: this might be too slow for large dbTable. Use `modalAccessCheckOnClick` instead
|
||||
modalAccess :: Widget -> Widget -> Bool -> Route UniWorX -> Widget
|
||||
modalAccess wdgtNo wdgtYes writeAccess route = do
|
||||
authOk <- liftHandler $ bool hasReadAccessTo hasWriteAccessTo writeAccess route
|
||||
authOk <- liftHandler . $cachedHereBinary (route, writeAccess) $ bool hasReadAccessTo hasWriteAccessTo writeAccess route
|
||||
if authOk
|
||||
then modal wdgtYes (Left $ SomeRoute route)
|
||||
else wdgtNo
|
||||
|
||||
-- also see Handler.Utils.Table.Cells.companyCell
|
||||
companyWidget :: Bool -> (CompanyShorthand, CompanyName, Bool) -> Widget
|
||||
companyWidget isPrimary (csh, cname, isSupervisor)
|
||||
| isPrimary, isSupervisor = simpleLink (toWgt $ name <> iconSupervisor) curl
|
||||
| isPrimary = simpleLink (toWgt name ) curl
|
||||
| isSupervisor = toWgt name <> simpleLink (toWgt iconSupervisor) curl
|
||||
| otherwise = toWgt name
|
||||
where
|
||||
curl = FirmUsersR csh
|
||||
corg = ciOriginal cname
|
||||
name
|
||||
| isSupervisor = text2markup (corg <> " ")
|
||||
| otherwise = text2markup corg
|
||||
|
||||
|
||||
---------------------
|
||||
-- Status Tooltips --
|
||||
---------------------
|
||||
|
||||
-- | generate a generic colored icon to display success or failure to user
|
||||
mkErrorFlag :: Handler (Maybe Bool -> Widget)
|
||||
mkErrorFlag = do
|
||||
-- we abuse messageTooltip for colored icons here
|
||||
msgSuccessTooltip <- messageI Success MsgMessageSuccess
|
||||
msgWarningTooltip <- messageI Warning MsgMessageWarning
|
||||
msgErrorTooltip <- messageI Error MsgMessageError
|
||||
let flagError Nothing = messageTooltip msgWarningTooltip
|
||||
flagError (Just False) = messageTooltip msgErrorTooltip
|
||||
flagError (Just True) = messageTooltip msgSuccessTooltip
|
||||
return flagError
|
||||
|
||||
|
||||
----------
|
||||
-- HEAT --
|
||||
----------
|
||||
@ -248,13 +307,15 @@ roomReferenceWidget RoomReferenceLink{..} = $(widgetFile "widgets/room-reference
|
||||
-- Data.Aeson.Encode.Pretty.encodePretty did not render in Html properly, hence jsonWidget
|
||||
jsonWidget :: ToJSON a => a -> Widget
|
||||
jsonWidget x = jsonWidgetAux $ toJSON x
|
||||
where
|
||||
where
|
||||
jsonWidgetAux :: Value -> Widget
|
||||
jsonWidgetAux Null = [whamlet|Null|]
|
||||
jsonWidgetAux (Bool b) = toWidget $ boolSymbol b
|
||||
jsonWidgetAux (String s) = [whamlet|#{s}|]
|
||||
jsonWidgetAux (Number n) = [whamlet|#{show n}|]
|
||||
jsonWidgetAux (Array l)
|
||||
jsonWidgetAux (Number n)
|
||||
| isInteger n = [whamlet|#{formatScientific Fixed (Just 0) n}|]
|
||||
| otherwise = [whamlet|#{formatScientific Generic Nothing n}|]
|
||||
jsonWidgetAux (Array l)
|
||||
| 1 >= length l = foldMap jsonWidgetAux l -- empty arrays don't show
|
||||
| otherwise =
|
||||
[whamlet|
|
||||
@ -271,4 +332,3 @@ jsonWidget x = jsonWidgetAux $ toJSON x
|
||||
<dt .deflist__dt>#{k}
|
||||
<dd .deflist__dd>^{jsonWidgetAux v}
|
||||
|]
|
||||
|
||||
47
src/Handler/Utils/avs_callgraph.md
Normal file
47
src/Handler/Utils/avs_callgraph.md
Normal file
@ -0,0 +1,47 @@
|
||||
# Demo
|
||||
## Mermaid Flowcharts
|
||||
|
||||
```mermaid
|
||||
flowchart LR;
|
||||
gau([guessAvsUser])
|
||||
%% uau([XupsertAvsUser])
|
||||
uaubi[upsertAvsUserById]
|
||||
uaubis[upsertAvsUserByIds]
|
||||
uaubc[upsertAvsUserByCard]
|
||||
ldap[[ldapLookupAndUpsert]]
|
||||
lau[lookupAvsUser]
|
||||
laus[lookupAvsUsers - DEPRECATED?]
|
||||
gla[guessLicenceAddress - DEPRECATED]
|
||||
ur([?updateReceivers])
|
||||
caubi[createAvsUserById]
|
||||
ucomp[upsertAvsCompany]
|
||||
|
||||
aqc{{AvsQueryContact}}
|
||||
aqp{{AvsQueryPerson}}
|
||||
aqs{{AvsQueryStatus}}
|
||||
|
||||
|
||||
uaubc-->uaubi
|
||||
uaubc-->aqp
|
||||
|
||||
gau-->uaubi
|
||||
gau-->uaubc
|
||||
gau-->ldap
|
||||
|
||||
%% uau-..->uaubi
|
||||
%% uau-..->uaubc
|
||||
|
||||
uaubi-->uaubis
|
||||
uaubi-->caubi-->uaubis
|
||||
uaubis-->aqc
|
||||
caubi-->aqs
|
||||
caubi-->aqc
|
||||
|
||||
caubi-->ucomp
|
||||
uaubis-->ucomp
|
||||
|
||||
lau-->laus
|
||||
laus-->aqs
|
||||
|
||||
ur-->uaubi
|
||||
```
|
||||
@ -110,7 +110,7 @@ determineCrontab = execWriterT $ do
|
||||
sheetJobs (Entity nSheet Sheet{..}) = do
|
||||
for_ (max <$> sheetVisibleFrom <*> sheetActiveFrom) $ \aFrom -> do
|
||||
tellPrewarmJobs (JobCtlPrewarmSheetFile nSheet SheetExercise) aFrom
|
||||
|
||||
|
||||
when (isn't _JobsOffload appJobMode) $ do
|
||||
tell $ HashMap.singleton
|
||||
(JobCtlQueue $ JobQueueNotification NotificationSheetActive{..})
|
||||
@ -181,7 +181,7 @@ determineCrontab = execWriterT $ do
|
||||
|
||||
runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ sheetJobs
|
||||
|
||||
|
||||
|
||||
when (isn't _JobsOffload appJobMode) $ do
|
||||
case appJobFlushInterval of
|
||||
Just interval | maybe True (> 0) appJobMaxFlush -> tell $ HashMap.singleton
|
||||
@ -395,28 +395,41 @@ determineCrontab = execWriterT $ do
|
||||
whenIsJust appJobLmsQualificationsEnqueueHour $ \hour -> tell $ HashMap.singleton
|
||||
(JobCtlQueue JobLmsQualificationsEnqueue)
|
||||
Cron
|
||||
{ cronInitial = CronAsap -- time after scheduling
|
||||
{ cronInitial = CronAsap -- time after scheduling
|
||||
, cronRepeat = CronRepeatScheduled $ cronCalendarAny { cronDayOfWeek = CronMatchSome . impureNonNull . Set.fromList $ [1..5]
|
||||
, cronHour = cronMatchOne hour -- cronHour = CronMatchSome (impureNonNull $ Set.fromList [3,15] )
|
||||
, cronHour = cronMatchOne hour -- cronHour = CronMatchSome (impureNonNull $ Set.fromList [3,15] )
|
||||
, cronMinute = cronMatchOne 2
|
||||
, cronSecond = cronMatchOne 27
|
||||
}
|
||||
, cronRateLimit = 600 -- minimal time between two executions, before the second job is skipped
|
||||
, cronNotAfter = Right CronNotScheduled -- maximal delay of an execution, before it is skipped entirely
|
||||
}
|
||||
}
|
||||
|
||||
whenIsJust appJobLmsQualificationsDequeueHour $ \hour -> tell $ HashMap.singleton
|
||||
(JobCtlQueue JobLmsQualificationsDequeue)
|
||||
Cron
|
||||
{ cronInitial = CronAsap -- time after scheduling
|
||||
{ cronInitial = CronAsap -- time after scheduling
|
||||
, cronRepeat = CronRepeatScheduled $ cronCalendarAny { cronDayOfWeek = CronMatchSome . impureNonNull . Set.fromList $ [1..5]
|
||||
, cronHour = cronMatchOne hour -- cronHour = CronMatchSome (impureNonNull $ Set.fromList [3,15] )
|
||||
, cronHour = cronMatchOne hour -- cronHour = CronMatchSome (impureNonNull $ Set.fromList [3,15] )
|
||||
, cronMinute = cronMatchOne 7
|
||||
, cronSecond = cronMatchOne 27
|
||||
}
|
||||
, cronRateLimit = 600 -- minimal time between two executions, before the second job is skipped
|
||||
, cronNotAfter = Right CronNotScheduled -- maximal delay of an execution, before it is skipped entirely
|
||||
}
|
||||
}
|
||||
|
||||
when (notNull (avsLicenceSynchTimes appAvsLicenceSynchConf)) $ tell $ HashMap.singleton
|
||||
(JobCtlQueue JobSynchroniseAvsLicences)
|
||||
Cron
|
||||
{ cronInitial = CronAsap
|
||||
, cronRateLimit = 10 -- minimal time between two executions, before the second job is skipped
|
||||
, cronNotAfter = Right CronNotScheduled -- maximal delay of an execution, before it is skipped entirely
|
||||
, cronRepeat = CronRepeatScheduled $ cronCalendarAny { cronDayOfWeek = CronMatchSome . impureNonNull . Set.fromList $ [1..5] --weekdays only
|
||||
, cronHour = CronMatchSome . impureNonNull . Set.fromList $ avsLicenceSynchTimes appAvsLicenceSynchConf
|
||||
, cronMinute = cronMatchOne 1
|
||||
, cronSecond = cronMatchOne 3
|
||||
}
|
||||
}
|
||||
|
||||
let
|
||||
correctorNotifications :: Map (UserId, SheetId) (Max UTCTime) -> WriterT (Crontab JobCtl) (ReaderT SqlReadBackend (HandlerFor UniWorX)) ()
|
||||
@ -454,7 +467,7 @@ determineCrontab = execWriterT $ do
|
||||
ExamPart{examPartExam} <- MaybeT . $cachedHereBinary epId $ get epId
|
||||
Exam{..} <- MaybeT . $cachedHereBinary examPartExam $ get examPartExam
|
||||
return examFinished
|
||||
notifyTime <- hoistMaybe . nBot $ maybe NTop (max `on` NTop) examFinishedTime submissionRatingTime
|
||||
notifyTime <- hoistMaybe . nBot $ maybe NTop (max `on` NTop) examFinishedTime submissionRatingTime
|
||||
tell $ HashMap.singleton
|
||||
(JobCtlQueue . JobQueueNotification $ NotificationSubmissionRated subId)
|
||||
Cron
|
||||
|
||||
@ -9,6 +9,7 @@ module Jobs.Handler.ChangeUserDisplayEmail
|
||||
import Import
|
||||
|
||||
import Handler.Utils.Mail
|
||||
import Handler.Utils.Users
|
||||
import qualified Data.HashSet as HashSet
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
@ -24,10 +25,13 @@ dispatchJobChangeUserDisplayEmail jUser jDisplayEmail = JobHandlerException $ do
|
||||
setDisplayEmailUrl = SomeRoute (SetDisplayEmailR, [(toPathPiece GetBearer, toPathPiece jwt)])
|
||||
setDisplayEmailUrl' <- toTextUrl setDisplayEmailUrl
|
||||
|
||||
user@User{..} <- runDB $ getJust jUser
|
||||
(Entity{entityVal=User{..}}, userAddress) <- runDB $ do
|
||||
usrEnt <- getJustEntity jUser -- error aborts job
|
||||
usrAdr <- getJustEmailAddress usrEnt
|
||||
return (usrEnt, usrAdr)
|
||||
|
||||
userMailT jUser $ do
|
||||
_mailTo .= pure (userAddress user & _addressEmail .~ CI.original jDisplayEmail)
|
||||
_mailTo .= pure (userAddress & _addressEmail .~ CI.original jDisplayEmail)
|
||||
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
|
||||
setSubjectI MsgMailSubjectChangeUserDisplayEmail
|
||||
addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/changeUserDisplayEmail.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX))
|
||||
|
||||
@ -8,6 +8,7 @@ module Jobs.Handler.Invitation
|
||||
|
||||
import Import
|
||||
import Handler.Utils.Mail
|
||||
import Handler.Utils.Users
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import Text.Hamlet
|
||||
@ -20,12 +21,15 @@ dispatchJobInvitation :: Maybe UserId
|
||||
-> Html
|
||||
-> JobHandler UniWorX
|
||||
dispatchJobInvitation jInviter jInvitee jInvitationUrl jInvitationSubject jInvitationExplanation = JobHandlerException $ do
|
||||
mInviter <- join <$> traverse (runDB . get) jInviter
|
||||
(mInviter, mInviterAddress) <- ifNothingM jInviter (Nothing,Nothing) $ \uid -> runDB $ do
|
||||
usrEnt <- getEntity uid
|
||||
usrAdr <- join <$> traverse getEmailAddress usrEnt
|
||||
return (usrEnt ^? _Just . _entityVal, usrAdr)
|
||||
|
||||
mailT def $ do
|
||||
_mailTo .= [Address Nothing $ CI.original jInvitee]
|
||||
whenIsJust mInviter $ \jInviter' ->
|
||||
replaceMailHeader "Reply-To" . Just . renderAddress $ userAddressFrom jInviter'
|
||||
whenIsJust mInviterAddress $ \jInviterAddress ->
|
||||
replaceMailHeader "Reply-To" . Just $ renderAddress jInviterAddress
|
||||
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
|
||||
replaceMailHeader "Subject" $ Just jInvitationSubject
|
||||
addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/invitation.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX))
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
-- SPDX-FileCopyrightText: 2022-24 Steffen Jost <s.jost@fraport.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
||||
-- SPDX-FileCopyrightText: 2022-24 Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
@ -46,12 +46,15 @@ fetchRefreshQualifications qidJob = do
|
||||
qids <- E.select $ do
|
||||
q <- E.from $ E.table @Qualification
|
||||
E.where_ $ E.isJust (q E.^. QualificationRefreshWithin)
|
||||
E.||. E.isJust (q E.^. QualificationRefreshReminder)
|
||||
E.||. q E.^. QualificationExpiryNotification
|
||||
pure $ q E.^. QualificationId
|
||||
forM_ qids $ \(E.unValue -> qid) ->
|
||||
queueDBJob $ qidJob qid
|
||||
|
||||
|
||||
-- | enlist expiring qualification holders to e-learning
|
||||
-- Second reminders sent for users with validQualifications and open LMS only
|
||||
-- NOTE: getting rid of QualificationId parameter and using a DB-join fails, since addGregorianDurationClip cannot be performed within DB
|
||||
dispatchJobLmsEnqueue :: QualificationId -> JobHandler UniWorX
|
||||
dispatchJobLmsEnqueue qid = JobHandlerAtomic act
|
||||
@ -60,64 +63,68 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act
|
||||
act = do
|
||||
quali <- getJust qid -- may throw an error, aborting the job
|
||||
let qshort = CI.original $ qualificationShorthand quali
|
||||
$logInfoS "LMS" $ "Notifying about exipiring qualification " <> qshort
|
||||
$logInfoS "LMS" $ "Notifying about expiring qualification " <> qshort
|
||||
now <- liftIO getCurrentTime
|
||||
case qualificationRefreshWithin quali of
|
||||
Nothing -> return () -- TODO: no renewal period, no reminders currently
|
||||
(Just renewalPeriod) -> do
|
||||
let nowaday = utctDay now
|
||||
renewalDate = addGregorianDurationClip renewalPeriod nowaday
|
||||
sendReminders remindPeriod = do
|
||||
let remindDate = addGregorianDurationClip remindPeriod nowaday
|
||||
reminders <- E.select $ do -- TODO: refactor to remove some redundancies with later query
|
||||
(luser :& quser) <- E.from $ E.table @LmsUser `E.innerJoin` E.table @QualificationUser
|
||||
`E.on` (\(luser :& quser) -> luser E.^. LmsUserQualification E.==. quser E.^. QualificationUserQualification
|
||||
E.&&. luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser
|
||||
)
|
||||
E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
|
||||
E.&&. quser E.^. QualificationUserScheduleRenewal
|
||||
E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val remindDate
|
||||
E.&&. validQualification now quser
|
||||
E.&&. E.isNothing (luser E.^. LmsUserEnded)
|
||||
E.&&. E.isNothing (luser E.^. LmsUserStatus)
|
||||
E.&&. E.isJust (luser E.^. LmsUserNotified)
|
||||
-- E.&&. ((day_ (luser E.^. LmsUserNotified) E.+. E.interval remindPeriod) E.<. quser E.^. QualificationUserValidUntil) -- not sure whether may throw runtime errors, so we check in Haskell-Land instead
|
||||
return (luser, quser E.^. QualificationUserValidUntil)
|
||||
forM_ reminders $ \case
|
||||
(Entity _ LmsUser{lmsUserUser=luser, lmsUserNotified=Just lnotified}, E.Value quValidUntil)
|
||||
| addGregorianDurationClip remindPeriod (utctDay lnotified) < quValidUntil ->
|
||||
queueDBJob JobUserNotification
|
||||
{ jRecipient = luser
|
||||
, jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = True }
|
||||
}
|
||||
_ -> return ()
|
||||
-- send second reminders first, before enqueing even more
|
||||
ifMaybeM (qualificationRefreshReminder quali) () sendReminders
|
||||
|
||||
renewalUsers <- E.select $ do
|
||||
quser <- E.from $ E.table @QualificationUser
|
||||
E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
|
||||
E.&&. quser E.^. QualificationUserScheduleRenewal
|
||||
E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate
|
||||
E.&&. (quser `qualificationValid` now)
|
||||
E.&&. E.notExists (do
|
||||
luser <- E.from $ E.table @LmsUser
|
||||
E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid
|
||||
E.&&. luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser
|
||||
E.&&. E.isNothing (luser E.^. LmsUserEnded)
|
||||
)
|
||||
pure quser
|
||||
let usr_job :: Entity QualificationUser -> Job
|
||||
usr_job quser =
|
||||
let uid = quser ^. _entityVal . _qualificationUserUser
|
||||
uex = quser ^. _entityVal . _qualificationUserValidUntil
|
||||
in if qualificationElearningStart quali
|
||||
then JobLmsEnqueueUser { jQualification = qid, jUser = uid }
|
||||
else JobUserNotification { jRecipient = uid, jNotification =
|
||||
NotificationQualificationExpiry { nQualification = qid, nExpiry = uex }
|
||||
}
|
||||
forM_ renewalUsers (queueDBJob . usr_job)
|
||||
logInterface "LMS" (qshort <> "-enq") True (Just $ length renewalUsers) ""
|
||||
let nowaday = utctDay now
|
||||
-- send second reminders first, before enqueing even more, but only for users with currently open LMS and still valid Qualificiations
|
||||
whenIsJust (qualificationRefreshReminder quali) $ \remindPeriod -> do
|
||||
let remindDate = addGregorianDurationClip remindPeriod nowaday
|
||||
reminders <- E.select $ do
|
||||
(luser :& quser) <- E.from $ E.table @LmsUser `E.innerJoin` E.table @QualificationUser
|
||||
`E.on` (\(luser :& quser) -> luser E.^. LmsUserQualification E.==. quser E.^. QualificationUserQualification
|
||||
E.&&. luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser
|
||||
)
|
||||
E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
|
||||
E.&&. quser E.^. QualificationUserScheduleRenewal
|
||||
E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val remindDate
|
||||
E.&&. validQualification now quser
|
||||
E.&&. E.isNothing (luser E.^. LmsUserEnded)
|
||||
E.&&. E.isNothing (luser E.^. LmsUserStatus)
|
||||
E.&&. E.isJust (luser E.^. LmsUserNotified)
|
||||
-- E.&&. ((day_ (luser E.^. LmsUserNotified) E.+. E.interval remindPeriod) E.<. quser E.^. QualificationUserValidUntil) -- not sure whether this may throw runtime errors, so we check in Haskell-Land instead
|
||||
return (luser, quser E.^. QualificationUserValidUntil)
|
||||
forM_ reminders $ \case
|
||||
(Entity _ LmsUser{lmsUserUser=luser, lmsUserNotified=Just lnotified}, E.Value quValidUntil)
|
||||
| addGregorianDurationClip remindPeriod (utctDay lnotified) < quValidUntil ->
|
||||
queueDBJob JobUserNotification
|
||||
{ jRecipient = luser
|
||||
, jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = True }
|
||||
}
|
||||
_ -> return ()
|
||||
-- send initial reminders
|
||||
whenIsJust (qualificationRefreshWithin quali) $ \renewalPeriod -> do -- no refreshWithin, no first reminders
|
||||
let renewalDate = addGregorianDurationClip renewalPeriod nowaday
|
||||
renewalUsers <- E.select $ do
|
||||
quser <- E.from $ E.table @QualificationUser
|
||||
E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
|
||||
E.&&. quser E.^. QualificationUserScheduleRenewal
|
||||
E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate
|
||||
E.&&. (quser `qualificationValid` now)
|
||||
E.&&. E.notExists (do
|
||||
luser <- E.from $ E.table @LmsUser
|
||||
E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid
|
||||
E.&&. luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser
|
||||
E.&&. E.isNothing (luser E.^. LmsUserEnded)
|
||||
)
|
||||
pure quser
|
||||
let usr_job :: Entity QualificationUser -> Maybe Job
|
||||
usr_job quser =
|
||||
let uid = quser ^. _entityVal . _qualificationUserUser
|
||||
uex = quser ^. _entityVal . _qualificationUserValidUntil
|
||||
unf = quser ^. _entityVal . _qualificationUserLastNotified
|
||||
nfy_cutoff = addGregorianDurationClip renewalPeriod $ utctDay unf
|
||||
do_notify = uex > nfy_cutoff || (uex == nfy_cutoff && utctDayTime now >= utctDayTime unf)
|
||||
in if
|
||||
| qualificationElearningStart quali -- repetition avoided since LmsUser does not exist
|
||||
-> Just $ JobLmsEnqueueUser { jQualification = qid, jUser = uid }
|
||||
| do_notify -- repetition avoided by QualificationUserLastNotified
|
||||
-> Just $ JobUserNotification
|
||||
{ jRecipient = uid
|
||||
, jNotification = NotificationQualificationExpiry { nQualification = qid, nExpiry = uex }
|
||||
}
|
||||
| otherwise -> Nothing
|
||||
forM_ renewalUsers (flip whenIsJust queueDBJob . usr_job)
|
||||
logInterface "LMS" (qshort <> "-enq") True (Just $ length renewalUsers) ""
|
||||
|
||||
dispatchJobLmsEnqueueUser :: QualificationId -> UserId -> JobHandler UniWorX
|
||||
dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
|
||||
@ -129,8 +136,7 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
|
||||
qprefix = fst <$> Text.uncons (Text.toLower qshort)
|
||||
identsInUseVs <- E.select $ do
|
||||
lui <- E.from $
|
||||
|
||||
( (E.^. LmsUserIdent) <$> E.from (E.table @LmsUser ) ) -- no filter by Qid, since LmsIdents must be unique across all
|
||||
( (E.^. LmsUserIdent) <$> E.from (E.table @LmsUser ) ) -- no filter by qid, since LmsIdents must be unique across all
|
||||
`E.union_`
|
||||
( (E.^. LmsReportIdent) <$> E.from (E.table @LmsReport ) ) -- V2
|
||||
E.orderBy [E.asc lui]
|
||||
@ -153,20 +159,20 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
|
||||
, lmsUserEnded = Nothing
|
||||
, lmsUserResetTries = False
|
||||
, lmsUserLocked = True -- initially display locked, since it is not yet available until the first feedback
|
||||
}
|
||||
}
|
||||
-- startLmsUser :: YesodJobDB UniWorX (Maybe (Entity LmsUser))
|
||||
startLmsUser = do
|
||||
lpw <- randomLMSpw
|
||||
lpw <- randomLMSpw
|
||||
maybeM (pure Nothing) (E.insertUniqueEntity . mkLmsUser lpw) (randomLMSIdentBut qprefix identsInUse)
|
||||
-- runMaybeT $ do
|
||||
-- lid <- MaybeT $ randomLMSIdentBu qprefix identsInUse
|
||||
-- MaybeT $ E.insertUniqueEntity $ mkLmsUser lpw lid
|
||||
getBy uniqLmsUse >>= \case
|
||||
Just Entity{entityVal=LmsUser{..}}
|
||||
| isNothing lmsUserEnded, isNothing lmsUserStatus || lmsUserStatus == Just LmsSuccess -> do
|
||||
Just Entity{entityVal=LmsUser{..}}
|
||||
| isNothing lmsUserEnded, isNothing lmsUserStatus || lmsUserStatus == Just LmsSuccess -> do
|
||||
uuid :: CryptoUUIDUser <- encrypt uid
|
||||
$logErrorS "LMS" $ "Generating fresh LmsIdent failed for uuid " <> tshow uuid <> " and qid " <> tshow qid <> " due to LMS still existing!"
|
||||
other -> do
|
||||
other -> do
|
||||
when (isJust other) $ deleteBy uniqLmsUse
|
||||
untilJustMaxM maxLmsUserIdentRetries startLmsUser >>= \case
|
||||
Nothing -> do
|
||||
@ -204,6 +210,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
|
||||
-- E.&&. E.isNothing (luser E.^. LmsUserEnded)
|
||||
E.&&. E.not__ (validQualification now quser)
|
||||
pure (luser E.?. LmsUserId, quser E.^. QualificationUserUser)
|
||||
-- TODO: why do we block expired users again? to notify?
|
||||
nrBlocked <- qualificationUserBlocking qid (E.unValue . snd <$> expiredUsers) False (Just now) (Right QualificationBlockExpired) True -- essential that blocks occur only once
|
||||
let expiredLearners = [ luid | (E.Value (Just luid), _) <- expiredUsers ]
|
||||
-- let expiredLearners = catMaybes (E.unValue . fst <$> expiredUsers)
|
||||
@ -212,7 +219,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
|
||||
E.where_ $ E.isNothing (luser E.^. LmsUserStatus)
|
||||
E.&&. luser E.^. LmsUserQualification E.==. E.val qid
|
||||
E.&&. (luser E.^. LmsUserId) `E.in_` E.valList expiredLearners
|
||||
let dequeueInfo = "Blocked qualification holders " <> tshow nrBlocked <> " out of expired lms users " <> tshow nrExpired <> " for qualification " <> qshort
|
||||
let dequeueInfo = "Blocked qualification holders " <> tshow nrBlocked <> " out of expired lms users " <> tshow nrExpired <> " for qualification " <> qshort
|
||||
$logInfoS "LMS" dequeueInfo
|
||||
|
||||
when (quali ^. _qualificationExpiryNotification) $ do -- notifies expired and previously lms-failed drivers
|
||||
@ -266,7 +273,7 @@ dispatchJobLmsReports :: QualificationId -> JobHandler UniWorX
|
||||
dispatchJobLmsReports qid = JobHandlerAtomic act
|
||||
where
|
||||
-- act :: YesodJobDB UniWorX ()
|
||||
act = whenM (exists [LmsReportQualification ==. qid]) $ do -- executing twice must be prohibited due to assertion that ALL learners are always sent (D fails otherwise)
|
||||
act = whenM (exists [LmsReportQualification ==. qid]) $ do -- executing twice must be prohibited due to assertion that ALL learners are always sent (E fails otherwise)
|
||||
now <- liftIO getCurrentTime
|
||||
-- DEBUG 2rows; remove later
|
||||
totalrows <- count [LmsReportQualification ==. qid]
|
||||
@ -313,10 +320,13 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
|
||||
E.&&. lreport E.^. LmsReportLock E.==. E.true
|
||||
)
|
||||
-- B) notify all newly reported users that lms is available
|
||||
let luserFltrNew luser = E.isNothing (luser E.^. LmsUserReceived) -- not seen before, just starting
|
||||
E.||. E.isNothing (luser E.^. LmsUserNotified) -- a previous notification has failed
|
||||
let luserFltrNew luser = E.isNothing (luser E.^. LmsUserReceived) -- not seen before, just starting OR (
|
||||
E.||. E.isNothing (luser E.^. LmsUserNotified) -- a previous notification has failed AND
|
||||
-- E.&&. E.not__ (luser E.^. LmsUserLocked) -- user is not to be locked)
|
||||
repFltr _ lreport = lreport E.^. LmsReportResult E.==. E.val LmsOpen -- LMS is open now
|
||||
E.&&. E.not__ (lreport E.^. LmsReportLock) -- never notify currently locked users
|
||||
notifyNewLearner (E.Value uid) = queueDBJob JobUserNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = False } }
|
||||
in luserQry luserFltrNew (const $ const E.true) >>= mapM_ notifyNewLearner
|
||||
in luserQry luserFltrNew repFltr >>= mapM_ notifyNewLearner
|
||||
-- C) block qualifications for failed learners by calling qualificationUserBlocking [uids] (includes audit), notified during expiry
|
||||
let lrFltrBlock luser lreport = E.isNothing (luser E.^. LmsUserStatus) E.&&. lreport E.^. LmsReportResult E.==. E.val LmsFailed
|
||||
procBlock (Entity luid luser, Entity _ lreport) = do
|
||||
@ -337,7 +347,7 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
|
||||
-- ok_unblock <- qualificationUserUnblockByReason qid [lmsUserUser luser] repTime (Right QualificationBlockFailedELearning) reason_undo False -- affects audit log
|
||||
-- when (ok_unblock > 0) ($logWarnS "LMS" [st|LMS Result: workaround triggered, unblocking #{tshow ok_unblock} e-learners for #{tshow qid} having success reported after initially failed e-learning|])
|
||||
-- END LMS WORKAROUND 2
|
||||
ok_renew <- renewValidQualificationUsers qid reason repDay [lmsUserUser luser]-- only valid qualifications are truly renewed; transcribes to audit log
|
||||
ok_renew <- renewValidQualificationUsers qid reason repDay [lmsUserUser luser] -- only valid qualifications are truly renewed and only if validDuration is set and elearningRenews is true; transcribes to audit log
|
||||
update luid [LmsUserStatus =. Just LmsSuccess, LmsUserStatusDay =. repDay]
|
||||
return $ Sum ok_renew
|
||||
in lrepQry lrFltrSuccess
|
||||
@ -393,9 +403,9 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
|
||||
E.orderBy [E.desc $ lrl E.^. LmsReportLogTimestamp]
|
||||
return $ lreport E.^. LmsReportResult E.==. lrl E.^. LmsReportLogResult
|
||||
E.&&. lreport E.^. LmsReportLock E.==. lrl E.^. LmsReportLogLock
|
||||
E.&&. E.not_ (lrl E.^. LmsReportLogMissing)
|
||||
E.&&. E.not__ (lrl E.^. LmsReportLogMissing)
|
||||
E.where_ $ lreport E.^. LmsReportQualification E.==. E.val qid
|
||||
E.&&. E.not_ (E.isTrue samelog)
|
||||
E.&&. E.not__ (E.isTrue samelog)
|
||||
return (LmsReportLog
|
||||
E.<# (lreport E.^. LmsReportQualification)
|
||||
E.<&> (lreport E.^. LmsReportIdent )
|
||||
@ -406,7 +416,7 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
|
||||
E.<&> E.false)
|
||||
E.insertSelect $ do
|
||||
lrl <- E.from $ E.table @LmsReportLog
|
||||
E.where_ $ E.not_ (lrl E.^. LmsReportLogMissing)
|
||||
E.where_ $ E.not__ (lrl E.^. LmsReportLogMissing)
|
||||
E.&&. lrl E.^. LmsReportLogQualification E.==. E.val qid
|
||||
E.&&. E.notExists (do
|
||||
lreport <- E.from $ E.table @LmsReport
|
||||
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user