diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 08d1f7694..514846b63 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -8,6 +8,7 @@ default: image: name: fpco/stack-build:lts-16.31 cache: &global_cache + key: default paths: - .npm - node_modules @@ -249,7 +250,11 @@ yesod:test:yesod:dev: yesod:test:hlint: stage: lint - cache: {} + cache: &hlint_cache + key: hlint + paths: + - .stack + - .stack-work needs: - job: npm install # transitive @@ -283,7 +288,7 @@ yesod:test:hlint: yesod:test:hlint:dev: stage: lint - cache: {} + cache: *hlint_cache needs: - job: npm install # transitive diff --git a/.hlint.yaml b/.hlint.yaml index 5414d2724..f6a6cd81c 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -18,3 +18,179 @@ - -XQuasiQuotes - -XTemplateHaskell - -j + + - fixity: "infix 4 `isInfixOf`" + - fixity: "infix 4 `hasInfix`" + - fixity: "infixl 6 `strConcat`" + - fixity: "infix 4 `ciEq`" + - fixity: "infix 4 `maybeEq`" + - fixity: "infixl 8 ->." + - fixity: "infixl 8 #>>." + - fixity: "infixl 6 `diffDays`" + - fixity: "infixr 3 `predDNFAnd`" + - fixity: "infixr 2 `predDNFOr`" + - fixity: "infixl 6 |-" + - fixity: "infixr 5 <|" + - fixity: "infixr 5 `cons`" + - fixity: "infixl 5 |>" + - fixity: "infixl 5 `snoc`" + - fixity: "infixl 8 ^.." + - fixity: "infixl 8 ^?" + - fixity: "infixl 8 ^?!" + - fixity: "infixl 8 ^@.." + - fixity: "infixl 8 ^@?" + - fixity: "infixl 8 ^@?!" + - fixity: "infixl 8 ^." + - fixity: "infixl 8 ^@." + - fixity: "infixr 9 <.>" + - fixity: "infixr 9 <." + - fixity: "infixr 9 .>" + - fixity: "infixl 8 ^#" + - fixity: "infixr 4 %%@~" + - fixity: "infixr 4 <%@~" + - fixity: "infixr 4 <<%@~" + - fixity: "infixr 4 %%~" + - fixity: "infixr 4 <+~" + - fixity: "infixr 4 <*~" + - fixity: "infixr 4 <-~" + - fixity: "infixr 4 ~" + - fixity: "infixr 4 <%~" + - fixity: "infixr 4 <<%~" + - fixity: "infixr 4 <<.~" + - fixity: "infixr 4 <~" + - fixity: "infix 4 %%@=" + - fixity: "infix 4 <%@=" + - fixity: "infix 4 <<%@=" + - fixity: "infix 4 %%=" + - fixity: "infix 4 <+=" + - fixity: "infix 4 <*=" + - fixity: "infix 4 <-=" + - fixity: "infix 4 =" + - fixity: "infix 4 <%=" + - fixity: "infix 4 <<%=" + - fixity: "infix 4 <<.=" + - fixity: "infix 4 <=" + - fixity: "infixr 2 <<~" + - fixity: "infixl 1 ??" + - fixity: "infixl 1 &~" + - fixity: "infixr 9 ..." + - fixity: "infixr 8 #" + - fixity: "infixr 4 %@~" + - fixity: "infixr 4 .@~" + - fixity: "infixr 4 .~" + - fixity: "infixr 4 +~" + - fixity: "infixr 4 *~" + - fixity: "infixr 4 -~" + - fixity: "infixr 4 //~" + - fixity: "infixr 4 ^~" + - fixity: "infixr 4 ^^~" + - fixity: "infixr 4 **~" + - fixity: "infixr 4 &&~" + - fixity: "infixr 4 <>~" + - fixity: "infixr 4 ||~" + - fixity: "infixr 4 %~" + - fixity: "infixr 4 <.~" + - fixity: "infixr 4 ?~" + - fixity: "infixr 4 =" + - fixity: "infix 4 ||=" + - fixity: "infix 4 %=" + - fixity: "infix 4 <.=" + - fixity: "infix 4 ?=" + - fixity: "infix 4 " + - fixity: "infixr 4 .|.~" + - fixity: "infixr 4 .&.~" + - fixity: "infixr 4 <.|.~" + - fixity: "infixr 4 <.&.~" + - fixity: "infixr 4 <<.|.~" + - fixity: "infixr 4 <<.&.~" + - fixity: "infix 4 .|.=" + - fixity: "infix 4 .&.=" + - fixity: "infix 4 <.|.=" + - fixity: "infix 4 <.&.=" + - fixity: "infix 4 <<.|.=" + - fixity: "infix 4 <<.&.=" + - fixity: "infixr 4 ~" + - fixity: "infixr 4 <~" + - fixity: "infixr 4 <<~" + - fixity: "infixr 4 <.>~" + - fixity: "infixr 4 <<.>~" + - fixity: "infixr 4 <<<.>~" + - fixity: "infix 4 =" + - fixity: "infix 4 <=" + - fixity: "infix 4 <<=" + - fixity: "infix 4 <.>=" + - fixity: "infix 4 <<.>=" + - fixity: "infix 4 <<<.>=" + + - suggest: { lhs: maybeT (return ()), rhs: maybeT_ } + - suggest: { lhs: fromMaybe (return ()), rhs: maybeVoid } + - suggest: { lhs: maybe (return ()) void, rhs: maybeVoid } + + - warn: { lhs: length xs >= n, rhs: minLength n xs, note: IncreasesLaziness } + - warn: { lhs: n <= length xs, rhs: minLength n xs, note: IncreasesLaziness } + - warn: { lhs: length xs > n, rhs: minLength (n + 1) xs, note: IncreasesLaziness } + - warn: { lhs: n < length xs, rhs: minLength (n + 1) xs, note: IncreasesLaziness } + - warn: { lhs: length xs <= n, rhs: maxLength n xs, note: IncreasesLaziness } + - warn: { lhs: n >= length xs, rhs: maxLength n xs, note: IncreasesLaziness } + - warn: { lhs: length xs < n, rhs: maxLength (n - 1) xs, note: IncreasesLaziness } + - warn: { lhs: n > length xs, rhs: maxLength (n - 1) xs, note: IncreasesLaziness } diff --git a/CHANGELOG.md b/CHANGELOG.md index 2cd185be7..aacb10dfa 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,188 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +## [25.8.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.8.0...v25.8.1) (2021-04-09) + +## [25.8.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.7.0...v25.8.0) (2021-04-08) + + +### Features + +* additional general purpose caching tier (memcachedLocal) ([939ab37](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/939ab37588bb71b14b8a9f3ab58d7440f598faf9)) + + +### Bug Fixes + +* typo ([f155a4b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f155a4bf08d169309c05e3efbb47a246f3010816)) + +## [25.7.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.6.1...v25.7.0) (2021-03-30) + + +### Features + +* **course-users-table:** json export ([6f291b2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/6f291b2e6893554193732b059758794fe2b7fa51)) + +## [25.6.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.6.0...v25.6.1) (2021-03-30) + + +### Bug Fixes + +* **admin-tokens:** avoid option none ([af3ec98](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/af3ec98de512f72220d363b9dd0c06532ae1a960)) +* add missing do ([55319c8](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/55319c8c5060a0d8763abb56c27d30e852c51f52)) +* buttons know about ALL actions from other buttons ([11664dc](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/11664dcd82c13eef1c395e2e590c4fb0c587aa65)) +* check space of occurrences after ignoring ([fabf56c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/fabf56c1640c94f806d43aaca264100cbc39b840)) +* correct rebase-sourced error ([02589e4](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/02589e4d00de233d847d6be71e44f9fc451fbfe9)) +* correctly apply suggestion ([67d6fd7](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/67d6fd7d438a31b50e6f4e6e921873ee11b32e9c)) +* correctly handle original minimizeRooms-flag ([d5bd504](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d5bd5042ad920b26df847845cc437c3f0616575c)) +* correctly report NoUsers for ExamRoomRandom ([16cbc78](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/16cbc78878615a8d123de5d8fda11136685a824c)) +* oops ([f6cbf99](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f6cbf99245ffdd19a2d6c9acc7c0b9a7f8df45ca)) +* sort occurrences in the right order ([732df50](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/732df5053033c3533f52850cc6220dd06a7e3500)) +* use extraUsers instead of extraCapacity for unrestricted pseudo-capacity ([2be9d76](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/2be9d76af2b3e9fd52284c639a4c3f6dc1c51779)) + +## [25.6.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.5.3...v25.6.0) (2021-03-29) + + +### Features + +* **frontend:** password visibilty toggle ([f0e4547](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f0e45477fa85a1d82750597cdaf122e41e9c7764)) + +## [25.5.3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.5.2...v25.5.3) (2021-03-24) + +## [25.5.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.5.1...v25.5.2) (2021-03-24) + +## [25.5.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.5.0...v25.5.1) (2021-03-23) + + +### Bug Fixes + +* remove cached-db-runner ([ff82700](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ff8270042f74d8019e121aebf8636472e1e4d79e)) + +## [25.5.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.4.0...v25.5.0) (2021-03-23) + + +### Features + +* **course-participants:** csv export first name/surname separately ([1036926](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/1036926470792bf3409ba3a224886d48b7e1d314)) + +## [25.4.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.3.0...v25.4.0) (2021-03-19) + + +### Features + +* **submissions:** also warn correctors about multiple submissions ([8795edd](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/8795edd1fa452d012704146481c8318d206634a5)) +* **submissions:** warn about multiple submissions for same user ([c19a00d](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/c19a00dcefb2dcae017026edb6e1c7cb6ce16841)) + + +### Bug Fixes + +* **auth:** wrong caching for external-exam-staff ([9d1f1c6](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/9d1f1c691085ec65ad0f19cc51602a59ee133fc4)) +* **submissions:** improve submission process ([7219131](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/72191315b6daed78cd0f31b02627e1d27db620f3)), closes [#675](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/675) + +## [25.3.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.2.0...v25.3.0) (2021-03-18) + + +### Features + +* **exams:** exam finish button ([78d0f25](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/78d0f2522db759c2ee465e040939c92b2f9a1891)) + + +### Bug Fixes + +* **submissions:** take care when to display corrections ([a6390ec](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a6390eccbd164ee5e821d3ecb0fab794a417425a)) + +## [25.2.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.1.2...v25.2.0) (2021-03-18) + + +### Features + +* **csv-export:** .xlsx ([5c51394](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/5c513946c15ed215f6958be1c7a435f03314f115)) +* **submissions:** improve behaviour of sheet-type-exam-part ([91a5166](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/91a51664c32bd17e4c2d1cd496bf05338146291d)), closes [#676](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/676) + + +### Bug Fixes + +* **csv-export:** mime confusion ([8bdaae0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/8bdaae0881fe98c4c5f69f1332ac2ffb0ca83081)) + +## [25.1.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.1.1...v25.1.2) (2021-03-17) + +## [25.1.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.1.0...v25.1.1) (2021-03-16) + + +### Bug Fixes + +* weight random token impersonation towards active users ([a314f64](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a314f64a70d9e7e427383c8d656d9bdceed5f9f3)) + +## [25.1.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.0.5...v25.1.0) (2021-03-16) + + +### Features + +* admins can efficiently generate many tokens for random users ([600bbe5](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/600bbe5d7e9051e4a4eac540b01ff358666ebc9c)) + + +### Bug Fixes + +* typo ([f931c67](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f931c67a9ecf37bd9a6c9814ee61de7cb054dcc5)) +* **test:** isNullResultJustified reported false positives ([292f5cf](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/292f5cf91b56953189ee72e42b822d66761ff3bb)) +* check if number of relevant user is >0 to prevent crash ([317b95b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/317b95be317ea038ad9fa398fc0c0c456b53495d)) +* correctly calculate maximum user name length ([cd07a56](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/cd07a56a9fd3ee99b74e5304581574671e3689a0)) +* handle rare cases where a mappingDescription with start>end would be produced ([c99d96e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/c99d96ecb8a43400eb10dfe192bf751cb00a9d25)) +* make sure to report NoUsers, regardless of rule ([9c928b0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/9c928b0375c1aab0c46768101849ce8daeae9b81)) +* **test:** fixed compiler errors (oops) ([bc42f30](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/bc42f3072fd37ee6f37c70a0b3999d9ac793b240)) +* ensure termination for non-{'A'..'Z']-names ([873d5a0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/873d5a02adae8f33db349bd9de3c7bd49331d27f)) +* examAutoOccurence no longer user >100% of a room ([eaf245b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/eaf245beaaa1f739d6b857712f1e4ea5b53e7c82)) +* increase size of test instances again (oops) ([4e76fe7](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/4e76fe7e504515845d468fc3251a38c90aaaaf66)) +* make sure it compiles again + add 2-letter name ([d60f935](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d60f93561f5ee84d460645a945db35ac6b55e97d)) +* make sure line-break algorithm respects available lines ([e487cef](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/e487ceff5858671eb0bcbd813e9de0d3b4c74f75)) +* make sure unfortunate combination doesn't only produce 0-9 ranges for matrikelnummer ([8e4cb09](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/8e4cb0917db1098f5b19be0dfad4c6fafb900c49)) +* mappingDescription doesn't overlap for the first n rooms/with small names/matrikelnummer ([fc35fd2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/fc35fd26c1eb699d6eb8aa1b9febb48641c26d05)) +* shown ranges "include" special mappings ([7e1b75c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/7e1b75c2e167c75ebc3a05f881ad7fb07c29af55)) +* spelling plugin had a suggestion; actually Hello World commit :p ([7b0fd61](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/7b0fd61f7f8bf1e995209bec7b44231b5ba011a6)) +* user with a pre-assigned room count towards the capacity limit ([4fc0535](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/4fc05351fa8048752f2ec3260dcaac64f962c9a3)) + +## [25.0.5](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.0.4...v25.0.5) (2021-03-13) + + +### Bug Fixes + +* **authorisation:** inverted logic for empty ([65814c0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/65814c005e2637bb5f6347bf1f35133654538e7a)) + +## [25.0.4](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.0.3...v25.0.4) (2021-03-12) + + +### Bug Fixes + +* tests ([4803026](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/4803026a2c091128a7370c12f0c06de9bd7b9180)) + +## [25.0.3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.0.2...v25.0.3) (2021-03-12) + + +### Bug Fixes + +* invalidate nav caches ([e88b6d6](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/e88b6d6bab3ea4577af3cd9465e66aa7e48177a2)) + +## [25.0.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.0.1...v25.0.2) (2021-03-12) + +## [25.0.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.0.0...v25.0.1) (2021-03-11) + + +### Bug Fixes + +* **auth-caching:** submission-group ([896bd41](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/896bd41e3b415283cce16cb84a8219b8d4c1702c)) + +## [25.0.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v24.9.2...v25.0.0) (2021-03-08) + + +### ⚠ BREAKING CHANGES + +* **auth:** additional authorisation caching + +### Features + +* **auth:** user independent authorisation caching ([63f0d3c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/63f0d3c37ad4a02a5cbdf76398d4a9c74a0a0b59)) +* **messages:** implement custom parser for message files ([bb877eb](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/bb877eb81396211a801496061ea603b39753829b)) +* **messages:** mkMessageAddition ([ea33d84](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ea33d844cc4acb2503fc4780c7895299eb9d5ef5)) + ## [24.9.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v24.9.1...v24.9.2) (2021-03-01) ## [24.9.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v24.9.0...v24.9.1) (2021-03-01) diff --git a/config/settings.yml b/config/settings.yml index ea6d0dd97..024a72945 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -157,6 +157,10 @@ memcached: limit: "_env:MEMCACHED_LIMIT:1024" timeout: "_env:MEMCACHED_TIMEOUT:20" expiration: "_env:MEMCACHED_EXPIRATION:300" +memcache-auth: true +memcached-local: + maximum-ghost: 512 + maximum-weight: 104857600 # 100MiB upload-cache: host: "_env:UPLOAD_S3_HOST:" @@ -269,8 +273,6 @@ fallback-personalised-sheet-files-keys-expire: 2419200 download-token-expire: 604801 -memcache-auth: true - file-source-arc: maximum-ghost: 512 maximum-weight: 1073741824 # 1GiB diff --git a/frontend/src/app.sass b/frontend/src/app.sass index 0156fee16..2de117489 100644 --- a/frontend/src/app.sass +++ b/frontend/src/app.sass @@ -403,6 +403,9 @@ input[type="button"].btn-info:not(.btn-link):hover, font-weight: 600 color: var(--color-fontsec) +.table__td--tooltip + width: 2em + .table__td font-size: 16px color: var(--color-font) @@ -588,13 +591,35 @@ section padding-bottom: 30px border-bottom: 1px solid #d3d3d3 - + section + & + section, & + .two-column-sections margin-top: 20px &:last-child border-bottom: none padding-bottom: 0px +.two-column-sections + padding-bottom: 30px + border-bottom: 1px solid #d3d3d3 + + & + section, & + .two-column-sections + margin-top: 20px + + &:last-child + border-bottom: none + padding-bottom: 0px + + @media (min-width: 768px) + display: flex + justify-content: space-between + + & > section + padding: 0 + border: none + + margin: 0 auto + width: calc(50% - 7px) + .headline-one margin-bottom: 10px @@ -946,7 +971,7 @@ th, td right: 5px top: 5px -.occurrence--not-registered, .no-bonus, .allocation-course--excluded, .allocation-course--inactive +.occurrence--not-registered, .no-bonus, .allocation-course--excluded, .allocation-course--inactive, .occurrence--ignored text-decoration: line-through .result diff --git a/frontend/src/utils/inputs/inputs.js b/frontend/src/utils/inputs/inputs.js index 9b438bf6e..a072c2196 100644 --- a/frontend/src/utils/inputs/inputs.js +++ b/frontend/src/utils/inputs/inputs.js @@ -1,6 +1,7 @@ import { Checkbox } from './checkbox'; import { FileInput } from './file-input'; import { FileMaxSize } from './file-max-size'; +import { Password } from './password'; import './inputs.sass'; import './radio-group.sass'; @@ -9,4 +10,5 @@ export const InputUtils = [ Checkbox, FileInput, FileMaxSize, + Password, ]; diff --git a/frontend/src/utils/inputs/inputs.sass b/frontend/src/utils/inputs/inputs.sass index a1633f934..a8c49a716 100644 --- a/frontend/src/utils/inputs/inputs.sass +++ b/frontend/src/utils/inputs/inputs.sass @@ -273,3 +273,30 @@ option .form--vertical__cell vertical-align: top + +// PASSWORD INPUT + +.password-input__wrapper + display: grid + grid-template-areas: 'input toggle' + width: 100% + max-width: 600px + grid-template-rows: auto + grid-template-columns: 1fr auto + + .password-input__input + grid-area: input + + .password-input__toggle + grid-area: toggle + + display: flex + justify-content: center + align-content: center + flex-direction: column + padding: 7px + + cursor: pointer + color: var(--color-fontsec) + &:hover + color: var(--color-font) diff --git a/frontend/src/utils/inputs/password.js b/frontend/src/utils/inputs/password.js new file mode 100644 index 000000000..2bb750802 --- /dev/null +++ b/frontend/src/utils/inputs/password.js @@ -0,0 +1,77 @@ +import { Utility } from '../../core/utility'; + +const PASSWORD_INITIALIZED_CLASS = 'password-input--initialized'; + +@Utility({ + selector: 'input[type="password"]:not([uw-no-password])', +}) +export class Password { + _element; + _iconEl; + _toggleContainerEl; + + constructor(element) { + if (!element) + throw new Error('Password utility cannot be setup without an element!'); + + if (element.classList.contains(PASSWORD_INITIALIZED_CLASS)) + return false; + + this._element = element; + + this._element.classList.add('password-input__input'); + + const siblingEl = this._element.nextSibling; + const parentEl = this._element.parentElement; + + const wrapperEl = document.createElement('div'); + wrapperEl.classList.add('password-input__wrapper'); + wrapperEl.appendChild(this._element); + + this._toggleContainerEl = document.createElement('div'); + this._toggleContainerEl.classList.add('password-input__toggle'); + wrapperEl.appendChild(this._toggleContainerEl); + + this._iconEl = document.createElement('i'); + this._iconEl.classList.add('fas', 'fa-fw'); + this._toggleContainerEl.appendChild(this._iconEl); + + parentEl.insertBefore(wrapperEl, siblingEl); + + this._element.classList.add(PASSWORD_INITIALIZED_CLASS); + } + + start() { + this.updateVisibleIcon(this.isVisible()); + + this._toggleContainerEl.addEventListener('mouseover', () => { + this.updateVisibleIcon(!this.isVisible()); + }); + this._toggleContainerEl.addEventListener('mouseout', () => { + this.updateVisibleIcon(this.isVisible()); + }); + this._toggleContainerEl.addEventListener('click', (event) => { + event.preventDefault(); + event.stopPropagation(); + this.setVisible(!this.isVisible()); + }); + } + + isVisible() { + return this._element.type !== 'password'; + } + + setVisible(visible) { + this._element.type = visible ? 'text' : 'password'; + this.updateVisibleIcon(visible); + } + + updateVisibleIcon(visible) { + function visibleClass(visible) { + return 'fa-' + (visible ? 'eye' : 'eye-slash'); + } + + this._iconEl.classList.remove(visibleClass(!visible)); + this._iconEl.classList.add(visibleClass(!!visible)); + } +} diff --git a/messages/uniworx/misc/de-de-formal.msg b/messages/uniworx/misc/de-de-formal.msg index a6194893a..23f75ff2d 100644 --- a/messages/uniworx/misc/de-de-formal.msg +++ b/messages/uniworx/misc/de-de-formal.msg @@ -6,19 +6,13 @@ AcceptApplicationsSecondaryRandom: Zufällig AcceptApplicationsSecondaryTime: Nach Zeitpunkt der Bewerbung #headings -HeadingLegal: Rechtliche Informationen -SubmissionNew: Abgabe anlegen -ParticipantsList: Kursteilnehmerlisten -ParticipantsIntersect: Überschneidung von Kursteilnehmer:innen -HeadingProfileData: Persönliche Daten -HeadingSchoolList: Institute CorrectorsChange: Korrektoren ändern -MaterialList: Material HeadingDataProt: Datenschutzerklärung HeadingTermsUse: Nutzungsbedingungen HeadingCopyright: Urheberrecht HeadingImprint: Impressum -CourseNew: Neuen Kurs anlegen +HeadingTermsHeading: Semesterübersicht +HeadingTermEditHeading: Semester editieren/anlegen EmailInvitationWarning: Diese Adresse konnte keinem Uni2work-Benutzer zugeordnet werden. Es wird eine Einladung per E-Mail versandt. @@ -37,42 +31,18 @@ GenericAvg: Avg GenericMax: Max GenericAll: Insgesamt -AchievedOf achieved@Points possible@Points: #{achieved} von #{possible} - SummerTerm year@Integer: Sommersemester #{year} WinterTerm year@Integer: Wintersemester #{year}/#{succ year} SummerTermShort year@Integer: SoSe #{year} WinterTermShort year@Integer: WiSe #{year}/#{mod (succ year) 100} Page num@Int64: #{num} -TermsHeading: Semesterübersicht TermCurrent: Aktuelles Semester -TermEditHeading: Semester editieren/anlegen TermEditTid tid@TermId: Semester #{tid} editieren -TermEdited tid@TermId: Semester #{tid} erfolgreich editiert. -TermNewTitle: Semester editieren/anlegen. -InvalidInput: Eingaben bitte korrigieren. -Term: Semester -TermPlaceholder: W/S + vierstellige Jahreszahl - -TermStartDay: Erster Tag -TermStartDayTooltip: Üblicherweise immer 1. April oder 1. Oktober -TermEndDay: Letzter Tag -TermEndDayTooltip: Üblicherweise immer 30. September oder 31. März -TermHolidays: Feiertage -TermHolidayPlaceholder: Feiertag -TermHolidayMissing: Feiertag wird benötigt -TermLectureStart: Beginn Vorlesungen -TermLectureEnd: Ende Vorlesungen -TermLectureEndTooltip: Meistens dauer das Sommersemester 14 Wochen und das Wintersemester 15 Wochen. -TermActive: Aktiv - SchoolListHeading: Übersicht über verwaltete Institute SchoolHeading school@SchoolName: Übersicht #{school} -LectureStart: Beginn Vorlesungen - CourseNoCapacity: In diesem Kurs sind keine Plätze mehr frei. TutorialNoCapacity: In dieser Übung sind keine Plätze mehr frei. ExamOccurrenceNoCapacity: Zu diesem Termin/Raum sind keine Plätze mehr frei. @@ -104,20 +74,16 @@ SheetArchiveFileTypeDirectoryHint: hinweis SheetArchiveFileTypeDirectorySolution: loesung SheetArchiveFileTypeDirectoryMarking: korrektur -Deadline: Abgabe -Done: Eingereicht - SubmissionsCourse tid@TermId ssh@SchoolId csh@CourseShorthand: Alle Abgaben Kurs #{tid}-#{ssh}-#{csh} SubmissionsSheet sheetName@SheetName: Abgaben für #{sheetName} SubmissionEditHead tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{tid}-#{ssh}-#{csh} #{sheetName}: Abgabe editieren/anlegen CorrectionHead tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName cid@CryptoFileNameSubmission: #{tid}-#{ssh}-#{csh} #{sheetName}: Korrektur CosubmittorTip: Einladungen per E-Mail erhalten genau jene Adressen, für die nicht gesichert werden kann, dass sie mit der dahinter stehenden Person schon einmal für diesen Kurs abgegeben haben. Wenn eine angegebene Adresse einer Person zugeordnet werden kann, mit der Sie in diesem Kurs schon einmal zusammen abgegeben haben, wird der Name der Person angezeigt und die Abgabe erfolgt sofort auch im Namen jener Person. -SubmissionGroupName: Gruppenname - CorrectionsTitle: Zugewiesene Korrekturen CorrectorsHead sheetName@SheetName: Korrektoren für #{sheetName} +<<<<<<< Updated upstream MaterialName: Name MaterialType: Art MaterialTypePlaceholder: Folien, Code, Beispiel, ... @@ -193,6 +159,7 @@ UnauthorizedParticipantSelf: Sie sind kein Teilnehmer dieser Veranstaltung. UnauthorizedApplicant: Angegebener Benutzer hat sich nicht für diese Veranstaltung beworben. UnauthorizedApplicantSelf: Sie sind kein Bewerber für diese Veranstaltung. UnauthorizedCourseTime: Dieser Kurs ist momentan nicht freigegeben. +UnauthorizedCorrectionExamTime: Sichtbarkeitseinstellungen der relevanten Prüfung verhindern momentan die Freigabe. UnauthorizedCourseRegistrationTime: Dieses Kurs erlaubt momentan keine Anmeldungen. UnauthorizedAllocationRegisterTime: Diese Zentralanmeldung erlaubt momentan keine Bewerbungen. UnauthorizedSheetTime: Dieses Übungsblatt ist momentan nicht freigegeben. @@ -213,43 +180,18 @@ MaterialFree: Kursmaterialien ohne Anmeldung zugänglich UnauthorizedWrite: Sie haben hierfür keine Schreibberechtigung UnauthorizedSystemMessageTime: Diese Systemnachricht ist noch nicht oder nicht mehr einsehbar. UnauthorizedSystemMessageAuth: Diese Systemnachricht ist nur für angemeldete Benutzer einsehbar. +======= +>>>>>>> Stashed changes UnsupportedAuthPredicate authTagT@Text shownRoute@Text: „#{authTagT}“ wurde auf eine Route angewandt, die dies nicht unterstützt: „#{shownRoute}“ -UnauthorizedDisabledTag authTag@AuthTag: Authorisierungsprädikat "#{toPathPiece authTag}" ist für Ihre Sitzung nicht aktiv -UnknownAuthPredicate tag@String: Authorisierungsprädikat "#{tag}" ist dem System nicht bekannt -UnauthorizedRedirect: Die angeforderte Seite existiert nicht oder Sie haben keine Berechtigung, die angeforderte Seite zu sehen. -UnauthorizedSelf: Aktueller Nutzer ist nicht angegebener Benutzer. -UnauthorizedTutorialTutor: Sie sind nicht Tutor für dieses Tutorium. -UnauthorizedTutorialTutorControl: Tutoren dürfen dieses Tutorium nicht editieren. -UnauthorizedCourseTutor: Sie sind nicht Tutor für diesen Kurs. -UnauthorizedTutor: Sie sind nicht Tutor. -UnauthorizedTutorialRegisterGroup: Sie sind bereits in einem Tutorium mit derselben Registrierungs-Gruppe. -UnauthorizedLDAP: Angegebener Nutzer meldet sich nicht mit Campus-Kennung an. -UnauthorizedPWHash: Angegebener Nutzer meldet sich nicht mit Uni2work-Kennung an. -UnauthorizedExternalExamListNotEmpty: Liste von externen Prüfungen ist nicht leer -UnauthorizedExternalExamLecturer: Sie sind nicht als Prüfer für diese externe Prüfung eingetragen -UnauthorizedSubmissionSubmissionGroup: Sie sind nicht Mitglied in einer der registrierten Abgabegruppen, die an dieser Abgabe beteiligt sind -UnauthorizedSheetSubmissionGroup: Sie sind nicht Mitglied in einer registrierten Abgabegruppe - -UnauthorizedPasswordResetToken: Dieses Authorisierungs-Token kann nicht mehr zum Passwort ändern benutzt werden - -UnauthorizedAllocatedCourseRegister: Direkte Anmeldungen zum Kurs sind aufgrund einer Zentralanmeldung aktuell nicht gestattet -UnauthorizedAllocatedCourseDeregister: Abmeldungen vom Kurs sind aufgrund einer Zentralanmeldung aktuell nicht gestattet -UnauthorizedAllocatedCourseDelete: Kurse, die an einer Zentralanmeldung teilnehmen, dürfen nicht gelöscht werden -UnauthorizedWorkflowInitiate: Sie dürfen keinen neuen laufenden Workflow initiieren -UnauthorizedWorkflowWrite: Sie dürfen aktuell keinen Zustandsübergang im Workflow auslösen -UnauthorizedWorkflowRead: Der Workflow enthält aktuell keine Zustände oder Daten die Sie einsehen dürfen -UnauthorizedWorkflowInstancesNotEmpty: Es gibt Workflow Instanzen für die Sie einen neuen laufenden Workflow initiieren dürfen -UnauthorizedWorkflowWorkflowsNotEmpty: Es gibt laufende Workflows, die Sie einsehen dürfen -UnauthorizedWorkflowFiles: Sie dürfen die angegebenen Workflow-Dateien nicht im angegebenen historischen Zustand herunterladen -UnauthorizedNotAuthenticatedInDifferentApproot: Sie konnten im Kontext einer separierten Domain (z.B. zum sicheren Download von Dateien) nicht authentifiziert werden. Vermutlich haben Sie kein oder ein abgelaufenes Token verwendet. Sie können versuchen auf die gewünschte Resource mit einem neu generierten Download-Link zuzugreifen. -UnauthorizedCsrfDisabled: Ihre Anfrage hätte wmgl. Änderungen am Server-Zustand ausgelöst. Da die sog. CSRF-Protection für Ihre Anfrage deaktiviert ist, musste sie daher abgelehnt werden. -UnauthorizedStudent: Sie sind kein Student WorkflowRoleUserMismatch: Sie sind nicht einer der vom Workflow geforderten Benutzer WorkflowRoleAlreadyInitiated: Dieser Workflow wurde bereits initiiert WorkflowRoleNoSuchWorkflowWorkflow: Der angegebene Workflow konnte nicht gefunden werden WorkflowRoleNoPayload: Dieser Workflow enthält keine Daten +UnauthorizedCsrfDisabled: Ihre Anfrage hätte wmgl. Änderungen am Server-Zustand ausgelöst. Da die sog. CSRF-Protection für Ihre Anfrage deaktiviert ist, musste sie daher abgelehnt werden. +UnauthorizedDisabledTag authTag@AuthTag: Authorisierungsprädikat "#{toPathPiece authTag}" ist für Ihre Sitzung nicht aktiv + EMail: E-Mail EMailUnknown email@UserEmail: E-Mail #{email} gehört zu keinem bekannten Benutzer. @@ -262,40 +204,22 @@ CorByProportionExcludingTutorial proportion@Rational: #{rationalToFixed3 proport DeleteRow: Entfernen Users: Benutzer -NewsHeading: Aktuelles LoginHeading: Authentifizierung LoginTitle: Authentifizierung ProfileHeading: Benutzereinstellungen - -InfoHeading: Informationen VersionHeading: Versionsgeschichte LegalHeading: Rechtliche Informationen SystemMessageHeading: Uni2work Statusmeldung SystemMessageListHeading: Uni2work Statusmeldungen -NotificationSettingsHeading displayName@Text: Benachrichtigungs-Einstellungen für #{displayName} -TokensResetSuccess: Authorisierungs-Tokens invalidiert - -NewsOpenAllocations: Offene Zentralanmeldungen -NewsUpcomingSheets: Anstehende Übungsblätter -NewsUpcomingExams: Bevorstehende Prüfungen - -NewsHideHiddenSystemMessages: Versteckte Nachrichten nicht mehr anzeigen -NewsShowHiddenSystemMessages: Versteckte Nachrichten anzeigen - -NumCourses num@Int64: #{num} #{pluralDE num "Kurs" "Kurse"} CloseAlert: Schliessen Name: Name -LdapSynced: LDAP-Synchronisiert -LdapSyncedBefore: Letzte LDAP-Synchronisation vor Plugin: Plugin Settings: Individuelle Benutzereinstellungen -SettingsUpdate: Einstellungen erfolgreich gespeichert -NotificationSettingsUpdate: Benachrichtigungs-Einstellungen erfolgreich gespeichert Never: Nie PreviouslyUploadedInfo: Bereits hochgeladene Dateien @@ -336,13 +260,8 @@ AssignSubmissionsAssignableSheets: Korrekturen verteilen für: AchievedBonusPoints: Erreichte Bonuspunkte AchievedNormalPoints: Erreichte Punkte PassedResult: Ergebnis -Passed: Bestanden -NotPassed: Nicht bestanden RatingPointsDone: Abgabe zählt als korrigiert, gdw. Punktezahl gesetzt ist -VisibleFrom: Veröffentlicht -AccessibleSince: Verfügbar seit - RatingNegative: Bewertungspunkte dürfen nicht negativ sein RatingExceedsMax: Bewertung übersteigt die erlaubte Maximalpunktzahl RatingNotExpected: Keine Bewertungen erlaubt @@ -355,39 +274,18 @@ SubmissionSinkExceptionRatingWithoutUpdate: Bewertung gefunden, es ist hier aber SubmissionSinkExceptionForeignRating smid@CryptoFileNameSubmission: Fremde Bewertung für Abgabe #{toPathPiece smid} enthalten. Bewertungen müssen sich immer auf die gleiche Abgabe beziehen! SubmissionSinkExceptionInvalidFileTitleExtension file@FilePath: Dateiname „#{file}“ (wmgl. innerhalb eines ZIP-Archivs) hat keine der für dieses Übungsblatt zulässigen Dateiendungen. -NoUpcomingSheetDeadlines: Keine anstehenden Übungsblätter -NoUpcomingExams difftime@Text: In den nächsten #{difftime} gibt es keine Prüfungen oder ablaufende Prüfungsanmeldungen in Ihren Kursen - -AdminHeading: Administration AdminUserHeading: Benutzeradministration -AdminUserRightsHeading: Benutzerrechte -AdminUserAuthHeading: Benutzer-Authentifizierung -AdminUserHeadingFor: Benutzerprofil für AdminFor: Administrator -UserListTitle: Komprehensive Benutzerliste -AccessRightsSaved: Berechtigungen erfolgreich verändert -AccessRightsNotChanged: Berechtigungen wurden nicht verändert -UserSystemFunctions: Systemweite Rollen -UserSystemFunctionsSaved: Systemweite Rollen gespeichert -UserSystemFunctionsNotChanged: Es wurden keine systemweiten Rollen angepasst -UserAssimilateUser: Benutzer -AssimilateUserNotFound: E-Mail Adresse konnte keinem Benutzer zugeordnet werden -AssimilateUserHaveError: Beim Assimilieren ist ein Fehler aufgetreten -AssimilateUserHaveWarnings: Beim Assimilieren wurden Warnungen ausgegeben -AssimilateUserSuccess: Benutzer erfolgreich assimiliert Date: Datum FormFieldRequiredTip: Gekennzeichnete Pflichtfelder sind immer auszufüllen -FormAllocationNotifications: Benachrichtigungen für neue Zentralanmeldungskurse -FormAllocationNotificationsTip: Wollen Sie eine Benachrichtigung per E-Mail erhalten wenn ein neuer Kurs zur Zentralanmeldung eingetragen wird? „Ja“ und „Nein“ überschreiben die entsprechende systemweite Einstellung unter "Benachrichtigungen" AllocNotifyNewCourseDefault: Systemweite Einstellung AllocNotifyNewCourseForceOff: Nein AllocNotifyNewCourseForceOn: Ja LastEdits: Letzte Änderungen -LastEditByUser: Ihre letzte Bearbeitung NoEditByUser: Nicht von Ihnen bearbeitet LDAPLoginTitle: Campus-Login @@ -413,10 +311,6 @@ CorrectorMissing: Abwesend CorrectorExcused: Entschuldigt CorrectorStateTip: Abwesende Korrektoren bekommen bei späteren Übungsblättern mehr Korrekturen zum Ausgleich zugewiesen. Entschuldigte Korrektoren müssen nicht nacharbeiten. -DayIsAHoliday tid@TermId name@Text date@Text: "#{name}" (#{date}) ist ein Feiertag -DayIsOutOfLecture tid@TermId name@Text date@Text: "#{name}" (#{date}) ist außerhalb der Vorlesungszeit des #{tid} -DayIsOutOfTerm tid@TermId name@Text date@Text: "#{name}" (#{date}) liegt nicht im Semester #{tid} - AutoUnzip: ZIPs automatisch entpacken AutoUnzipInfo: Entpackt hochgeladene ZIP-Dateien (*.zip) automatisch und fügt den Inhalt dem Stamm-Verzeichnis hinzu. @@ -447,91 +341,9 @@ GermanGermany: Deutsch (Deutschland) English: Englisch EnglishEurope: Englisch (Europa) -MailSubjectSubmissionRated csh@CourseShorthand: Ihre #{csh}-Abgabe wurde korrigiert -MailSubmissionRatedIntro courseName@Text termDesc@Text: Ihre Abgabe im Kurs #{courseName} (#{termDesc}) wurde korrigiert. - -MailSubjectSubmissionEdited csh@CourseShorthand shn@SheetName: Ihre Abgabe für #{shn} im Kurs #{csh} wurde verändert -MailSubmissionEditedIntro coursen@CourseName shn@SheetName termDesc@Text displayName@Text: #{displayName} hat Ihre Abgabe für #{shn} im Kurs #{coursen} (#{termDesc}) verändert. - -MailSubjectSubmissionUserCreated csh@CourseShorthand shn@SheetName: Sie wurden als Mitabgebender zu einer Abgabe für #{shn} im Kurs #{csh} hinzugefügt -MailSubjectSubmissionUserCreatedOther displayName@Text csh@CourseShorthand shn@SheetName: Es wurde ein Mitabgebender zu einer Abgabe für #{shn} im Kurs #{csh} hinzugefügt - -MailSubmissionUserCreatedIntro coursen@CourseName shn@SheetName termDesc@Text: Sie wurden als Mitabgebender zu einer Abgabe für #{shn} im Kurs #{coursen} (#{termDesc}) hinzugefügt. -MailSubmissionUserCreatedOtherIntro displayName@UserDisplayName coursen@CourseName shn@SheetName termDesc@Text: #{displayName} wurde als Mitabgebender zu einer Abgabe für #{shn} im Kurs #{coursen} (#{termDesc}) hinzugefügt. - -MailSubjectSubmissionUserDeleted csh@CourseShorthand shn@SheetName: Sie wurden als Mitabgebender von Ihrer Abgabe für #{shn} im Kurs #{csh} entfernt -MailSubjectSubmissionUserDeletedOther displayName@Text csh@CourseShorthand shn@SheetName: Es wurde ein Mitabgebender von einer Abgabe für #{shn} im Kurs #{csh} entfernt - -MailSubmissionUserDeletedIntro coursen@CourseName shn@SheetName termDesc@Text: Sie wurden als Mitabgebender von Ihrer Abgabe für #{shn} im Kurs #{coursen} (#{termDesc}) entfernt. -MailSubmissionUserDeletedOtherIntro displayName@UserDisplayName coursen@CourseName shn@SheetName termDesc@Text: #{displayName} wurde als Mitabgebender von einer Abgabe für #{shn} im Kurs #{coursen} (#{termDesc}) entfernt. - -MailSubjectSheetActive csh@CourseShorthand sheetName@SheetName: #{sheetName} in #{csh} wurde herausgegeben -MailSheetActiveIntro courseName@Text termDesc@Text sheetName@SheetName: Sie können nun #{sheetName} im Kurs #{courseName} (#{termDesc}) herunterladen. - -MailSubjectSheetHint csh@CourseShorthand sheetName@SheetName: Hinweise für #{sheetName} in #{csh} wurden herausgegeben -MailSheetHintIntro courseName@Text termDesc@Text sheetName@SheetName: Sie können nun die Hinweise für #{sheetName} im Kurs #{courseName} (#{termDesc}) herunterladen. - -MailSubjectSheetSolution csh@CourseShorthand sheetName@SheetName: Lösungen für #{sheetName} in #{csh} wurden herausgegeben -MailSheetSolutionIntro courseName@Text termDesc@Text sheetName@SheetName: Sie können nun die Lösungen für #{sheetName} im Kurs #{courseName} (#{termDesc}) herunterladen. - -MailSubjectCourseRegistered csh@CourseShorthand: Sie wurden zu #{csh} angemeldet -MailSubjectCourseRegisteredOther displayName@Text csh@CourseShorthand: #{displayName} wurde zu #{csh} angemeldet -MailCourseRegisteredIntro courseName@Text termDesc@Text: Sie wurden im Kurs #{courseName} (#{termDesc}) angemeldet. -MailCourseRegisteredIntroOther displayName@Text courseName@Text termDesc@Text: #{displayName} wurde im Kurs #{courseName} (#{termDesc}) angemeldet. - -MailSubjectExamResult csh@CourseShorthand examn@ExamName: Ergebnisse für #{examn} in #{csh} wurden herausgegeben -MailExamResultIntro courseName@Text termDesc@Text examn@ExamName: Sie können nun Ihr Ergebnis für #{examn} im Kurs #{courseName} (#{termDesc}) einsehen. - -MailSubjectExamOfficeExamResults coursen@CourseName examn@ExamName: Ergebnisse für #{examn} in #{coursen} sind fertiggestellt -MailExamOfficeExamResultsIntro courseName@Text termDesc@Text examn@ExamName: Ein Kursverwalter hat die Prüfungsleistungen für #{examn} im Kurs #{courseName} (#{termDesc}) freigegeben. - -MailSubjectExamOfficeExamResultsChanged coursen@CourseName examn@ExamName: Ergebnisse für #{examn} in #{coursen} wurden verändert -MailExamOfficeExamResultsChangedIntro courseName@Text termDesc@Text examn@ExamName: Ein Kursverwalter hat Prüfungsleistungen für #{examn} im Kurs #{courseName} (#{termDesc}) verändert. - -MailSubjectExamOfficeExternalExamResults coursen@CourseName examn@ExamName: Ergebnisse für #{examn} in #{coursen} -MailExamOfficeExternalExamResultsIntro coursen@CourseName termDesc@Text examn@ExamName: Ein Kursverwalter hat Prüfungsleistungen für #{examn} im Kurs #{coursen} (#{termDesc}) erstellt oder angepasst. - -MailSubjectExamRegistrationActive csh@CourseShorthand examn@ExamName: Anmeldung für #{examn} in #{csh} ist möglich -MailExamRegistrationActiveIntro courseName@Text termDesc@Text examn@ExamName: Sie können sich nun für #{examn} im Kurs #{courseName} (#{termDesc}) anmelden. - -MailSubjectExamRegistrationSoonInactive csh@CourseShorthand examn@ExamName: Anmeldung für #{examn} in #{csh} ist nur noch kurze Zeit möglich -MailExamRegistrationSoonInactiveIntro courseName@Text termDesc@Text examn@ExamName: Sie können sich bald nicht mehr für #{examn} im Kurs #{courseName} (#{termDesc}) anmelden. - -MailSubjectExamDeregistrationSoonInactive csh@CourseShorthand examn@ExamName: Abmeldung für #{examn} in #{csh} ist nur noch kurze Zeit möglich -MailExamDeregistrationSoonInactiveIntro courseName@Text termDesc@Text examn@ExamName: Sie können sich bald nicht mehr von #{examn} im Kurs #{courseName} (#{termDesc}) abmelden. - -MailSubjectSubmissionsUnassigned csh@CourseShorthand sheetName@SheetName: Abgaben zu #{sheetName} in #{csh} konnten nicht verteilt werden -MailSubmissionsUnassignedIntro n@Int courseName@Text termDesc@Text sheetName@SheetName: #{n} Abgaben zu #{sheetName} im Kurs #{courseName} (#{termDesc}) konnten nicht automatisiert verteilt werden. - -MailSubjectSheetSoonInactive csh@CourseShorthand sheetName@SheetName: #{sheetName} in #{csh} kann nur noch kurze Zeit abgegeben werden -MailSheetSoonInactiveIntro courseName@Text termDesc@Text sheetName@SheetName: Abgabefrist für #{sheetName} im Kurs #{courseName} (#{termDesc}) endet in Kürze. -MailSubjectSheetInactive csh@CourseShorthand sheetName@SheetName: Abgabezeitraum für #{sheetName} in #{csh} abgelaufen -MailSheetInactiveIntro courseName@Text termDesc@Text sheetName@SheetName n@Int num@Int64: Die Abgabefrist für #{sheetName} im Kurs #{courseName} (#{termDesc}) ist beendet. Es gab #{noneOneMoreDE n "Keine Abgaben" "Nur eine Abgabe von " (toMessage n <> " Abgaben von ")}#{noneOneMoreDE num "" "einem Teilnehmer" (toMessage num <> " Teilnehmern")}. -MailSheetInactiveIntroNoUserSubmission courseName@Text termDesc@Text sheetName@SheetName n@Int num@Int64: Die Abgabefrist für #{sheetName} im Kurs #{courseName} (#{termDesc}) ist beendet.#{noneOneMoreDE n "" "Es gab bereits eine Abgabe von " (("Es gab bereits " <> toMessage n) <> " Abgaben von ")}#{noneOneMoreDE num "" "einem Teilnehmer" (toMessage num <> " Teilnehmern")}. -MailSheetInactivePseudonymsCount n@Int: Die Anzahl von Abgaben betrifft nur jene, die bereits direkt in Uni2work abgegeben haben. Es #{pluralDE n (("wurde " <> tshow n) <> " Pseudonym") (("wurden " <> tshow n) <> " Pseudonyme")} generiert. -MailSheetInactiveParticipantsCount n@Int: Es #{pluralDE n "ist aktuell" "sind aktuell"} #{n} Teilnehmer zum Kurs angemeldet. - -MailSubjectCorrectionsAssigned csh@CourseShorthand sheetName@SheetName: Ihnen wurden Korrekturen zu #{sheetName} in #{csh} zugeteilt -MailCorrectionsAssignedIntro courseName@Text termDesc@Text sheetName@SheetName n@Int: #{n} #{pluralDE n "Abgabe wurde" "Abgaben wurden"} Ihnen zur Korrektur für #{sheetName} im Kurs #{courseName} (#{termDesc}) zugeteilt. - -MailSubjectUserRightsUpdate name@Text: Berechtigungen für #{name} aktualisiert -MailUserRightsIntro name@Text email@UserEmail: #{name} <#{email}> hat folgende Uni2work Berechtigungen: -MailNoLecturerRights: Sie haben derzeit keine Dozenten-Rechte. -MailLecturerRights n@Int: Als Dozent dürfen Sie Veranstaltungen innerhalb #{pluralDE n "Ihres Instituts" "Ihrer Institute"} anlegen. - -MailSubjectUserSystemFunctionsUpdate name@Text: Berechtigungen für #{name} aktualisiert -MailUserSystemFunctionsIntro name@Text email@UserEmail: #{name} <#{email}> hat folgende Uni2work nicht-institutsbezogene Berechtigungen: -MailUserSystemFunctionsNoFunctions: Keine - -MailSubjectUserAuthModeUpdate: Ihr Uni2work-Login -UserAuthModePWHashChangedToLDAP: Sie können sich nun mit Ihrer Campus-Kennung in Uni2work einloggen -UserAuthModeLDAPChangedToPWHash: Sie können sich nun mit einer Uni2work-internen Kennung in Uni2work einloggen NewPasswordLinkTip: Das Passwort Ihrer Uni2work-internen Kennung können Sie auf der folgenden Seite setzen: NewPasswordLink: Neues Passwort setzen -AuthPWHashTip: Sie müssen nun das mit "Uni2work-Login" beschriftete Login-Formular verwenden. Stellen Sie bitte sicher, dass Sie ein Passwort gesetzt haben, bevor Sie versuchen sich anzumelden. -PasswordResetEmailIncoming: Einen Link um ihr Passwort zu setzen bzw. zu ändern bekommen Sie, aus Sicherheitsgründen, in einer separaten E-Mail. -MailEditNotifications: Benachrichtigungen ein-/ausschalten MailSubjectSupport: Supportanfrage MailSubjectSupportCustom customSubject@Text: [Support] #{customSubject} @@ -569,60 +381,8 @@ PseudonymAutocorrections: Korrekturvorschläge: CorrGrade: Korrekturen eintragen -UserAccountDeleted name@Text: Konto für #{name} wurde gelöscht! -UserSubmissionsDeleted n@Int: #{tshow n} Abgaben wurden unwiderruflich gelöscht. -UserGroupSubmissionsKept n@Int: #{tshow n} Gruppenabgaben verbleiben in der Datenbank, aber die Zuordnung zum Benutzer wurde gelöscht. Gruppenabgaben können dadurch zu Einzelabgaben werden, die dann mit dem letzten Benutzer gelöscht werden. -UserSubmissionGroupsDeleted count@Int64: #{tshow count} benannte Abgabengruppen wurden gelöscht, da sie ohne den Nutzer leer wären. UserAccountDeleteWarning: Achtung, dies löscht den kompletten Benutzer unwiderruflich und mit allen assoziierten Daten aus der Datenbank. Prüfungsdaten müssen jedoch langfristig gespeichert bleiben! -HelpTitle : Hilfe -HelpSendLastError: Letzte Fehlermeldung anhängen -HelpError: Letzte Fehlermeldung -HelpErrorYamlFilename mailId@MailObjectId: fehlermeldung-#{toPathPiece mailId}.yaml -HelpErrorOrRequestRequired: Bitte geben Sie entweder eine Supportanfrage bzw. einen Verbesserungsvorschlag an oder hängen Sie die letzte Fehlermeldung an - -InfoLecturerTitle: Hinweise für Veranstalter - -SystemMessageNewsOnly: Nur auf "Aktuelles" -SystemMessageRecordChanged: Signifikante Änderung -SystemMessageRecordChangedTip: Soll der "zuletzt geändert"-Zeitstempel gesetzt werden? Nachrichten werden auf "Aktuelles" danach sortiert und bei signifikanten Änderungen erneut als Benachrichtigung unten rechts angezeigt. -SystemMessageUnhide: "Verstecken" ignorieren -SystemMessageUnhideTip: Soll die Nachricht für Benutzer, die sie aktiv versteckt haben, erneut angezeigt werden? -SystemMessageCreated: Erstellt -SystemMessageLastChanged: Zuletzt geändert -SystemMessageLastChangedAt time@Text: Zuletzt geändert: #{time} -SystemMessageLastUnhide: Zuletzt un-versteckt -SystemMessageFrom: Sichtbar ab -SystemMessageTo: Sichtbar bis -SystemMessageAuthenticatedOnly: Nur angemeldet -SystemMessageSeverity: Schwere -SystemMessagePriority: Priorität -SystemMessagePriorityNegative: Priorität darf nicht negativ sein -SystemMessageId: Id -SystemMessageSummaryContent: Zusammenfassung / Inhalt -SystemMessageSummary: Zusammenfassung -SystemMessageContent: Inhalt -SystemMessageLanguage: Sprache - -SystemMessageDelete: Löschen -SystemMessageActivate: Sichtbar schalten -SystemMessageDeactivate: Unsichtbar schalten -SystemMessageTimestamp: Zeitpunkt - -SystemMessagesDeleted: System-Nachrichten gelöscht: -SystemMessagesActivated: Aktivierungszeitpunkt folgender System-Nachrichten gesetzt: -SystemMessagesDeactivated: Deaktivierungszeitpunkt folgender System-Nachrichten gesetzt: -SystemMessageEmptySelection: Keine System-Nachrichten ausgewählt -SystemMessageAdded sysMsgId@CryptoUUIDSystemMessage: System-Nachricht hinzugefügt: #{toPathPiece sysMsgId} -SystemMessageEdit: Statusmeldung anpassen -SystemMessageEditTranslations: Übersetzungen anpassen -SystemMessageAddTranslation: Übersetzung hinzufügen - -SystemMessageEditSuccess: Statusmeldung angepasst. -SystemMessageAddTranslationSuccess: Übersetzung hinzugefügt. -SystemMessageEditTranslationSuccess: Übersetzung angepasst. -SystemMessageDeleteTranslationSuccess: Übersetzung entfernt. - MessageError: Fehler MessageWarning: Warnung MessageInfo: Information @@ -649,8 +409,6 @@ EncodedSecretBoxCouldNotOpenSecretBox: Konnte libsodium-secretbox nicht öffnen EncodedSecretBoxCouldNotDecodePlaintext aesonErr@String: Konnte Klartext nicht JSON-dekodieren: #{aesonErr} ErrMsgHeading: Fehlermeldung entschlüsseln -TitleMetrics: Metriken - DBTIRowsMissing n@Int: #{pluralDE n "Eine Zeile ist" "Einige Zeilen sind"} aus der Datenbank verschwunden, seit das Formular für Sie generiert wurde NavigationFavourites: Favoriten @@ -659,6 +417,7 @@ CommBody: Nachricht CommDuplicateRecipients n@Int: #{n} #{pluralDE n "doppelter" "doppelte"} Empfänger ignoriert CommUndisclosedRecipients: Verborgene Empfänger CommAllRecipients: alle-empfaenger +CommAllRecipientsSheet: Empfänger MultiSelectFieldTip: Mehrfach-Auswahl ist möglich (Umschalt bzw. Strg) MultiEmailFieldTip: Es sind mehrere, Komma-separierte, E-Mail-Adressen möglich @@ -675,29 +434,14 @@ WeekDay: Wochentag MassInputTip: Es können mehrere Werte angegeben werden. Werte müssen mit + zur Liste hinzugefügt werden und können mit - wieder entfernt werden. Alle Änderungen müssen noch durch Drücken des Formular-Knopfes bestätigt werden. -HealthReport: Instanz-Zustand -InstanceIdentification: Instanz-Identifikation - -InstanceId: Instanz-Nummer ClusterId: Cluster-Nummer -HealthMatchingClusterConfig: Cluster-geteilte Konfiguration ist aktuell -HealthHTTPReachable: Cluster kann an der erwarteten URL über HTTP erreicht werden -HealthLDAPAdmins: Anteil der Administratoren, die im LDAP-Verzeichnis gefunden werden können -HealthSMTPConnect: SMTP-Server kann erreicht werden -HealthWidgetMemcached: Memcached-Server liefert Widgets korrekt aus -HealthActiveJobExecutors: Anteil der job-workers, die neue Befehle annehmen - - CourseParticipants n@Int: Derzeit #{n} angemeldete Kursteilnehmer CourseParticipant: Teilnehmer:in CourseParticipantsRegisteredWithoutField n@Int: #{n} Teilnehmer #{pluralDE n "wurde ohne assoziiertes Studienfach" "wurden ohne assoziierte Studienfächer"} angemeldet, da #{pluralDE n "kein eindeutiges Hauptfach bestimmt werden konnte" "keine eindeutigen Hauptfächer bestimmt werden konnten"} ExamRegistrationRegisteredWithoutField n@Int: #{n} Teilnehmer #{pluralDE n "wurde" "wurden"} sowohl zur Prüfung, als auch #{pluralDE n "ohne assoziiertes Studienfach" "ohne assoziierte Studienfächer"} zum Kurs angemeldet, da #{pluralDE n "kein eindeutiges Hauptfach bestimmt werden konnte" "keine eindeutigen Hauptfächer bestimmt werden konnten"} ExamRegistrationParticipantsRegistered n@Int: #{n} Teilnehmer #{pluralDE n "wurde" "wurden"} zur Prüfung angemeldet -NewsExamOccurrenceRoomIsUnset: — -NewsExamOccurrenceRoomIsHidden: Raum wird nur Teilnehmern angezeigt - ExamOpenBook: Open Book ExamClosedBook: Closed Book @@ -718,8 +462,6 @@ ExamRequiredEquipmentMicrophoneInternet: Mikrophon ExamPassed: Bestanden ExamNotPassed: Nicht bestanden -NewsExamRegistered: Zur Prüfung angemeldet -NewsExamNotRegistered: Nicht zur Prüfung angemeldet ExamRegistrationTime: Angemeldet seit VersionHistory: Versionsgeschichte @@ -749,15 +491,16 @@ CsvDeleteMissing: Fehlende Einträge entfernen TableProportion c@Text of'@Text prop@Rational: #{c}/#{of'} (#{rationalToFixed2 (100 * prop)}%) TableProportionNoRatio c@Text of'@Text: #{c}/#{of'} +<<<<<<< Updated upstream ParticipantsCsvName tid@TermId ssh@SchoolId: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-kursteilnehmer +ParticipantsCsvSheetName tid@TermId ssh@SchoolId: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)} Kursteilnehmer +======= +>>>>>>> Stashed changes CsvColumnUserField: Studienfach, mit dem der Teilnehmer seine Kursanmeldung assoziiert hat CsvColumnUserDegree: Abschluss, den der Teilnehmer im assoziierten Studienfach anstrebt CsvColumnUserSemester: Fachsemester des Teilnehmers im assoziierten Studienfach -Action: Aktion -ActionNoUsersSelected: Keine Benutzer ausgewählt - ExamUserCsvCourseRegister: Benutzer zum Kurs und zur Prüfung anmelden ExamUserCsvRegister: Kursteilnehmer zur Prüfung anmelden ExamUserCsvAssignOccurrence: Teilnehmern einen anderen Termin/Raum zuweisen @@ -783,62 +526,11 @@ ExternalExamUserCsvDeregister: Hinterlegte Prüfungsleistung löschen TableHeadingCsvImport: CSV-Import TableHeadingCsvExport: CSV-Export -AuthLDAPLookupFailed: Nutzer konnte aufgrund eines LDAP-Fehlers nicht nachgeschlagen werden -AuthLDAPInvalidLookup: Bestehender Nutzer konnte nicht eindeutig einem LDAP-Eintrag zugeordnet werden -AuthLDAPAlreadyConfigured: Nutzer meldet sich bereits per Campus-Kennung in Uni2work an -AuthLDAPConfigured: Nutzer meldet sich nun per Campus-Kennung in Uni2work an - -AuthPWHashAlreadyConfigured: Nutzer meldet sich bereits per Uni2work-Kennung an -AuthPWHashConfigured: Nutzer meldet sich nun per Uni2work-Kennung an - -PasswordResetQueued: Link zum Passwort-Zurücksetzen versandt ResetPassword: Uni2work-Passwort ändern bzw. setzen -AuthLDAP: Campus -AuthPWHash pwHash@Text: Uni2work -CurrentPassword: Aktuelles Passwort -NewPassword: Neues Passwort -NewPasswordRepeat: Wiederholung -CurrentPasswordInvalid: Aktuelles Passwort ist inkorrekt -PasswordRepeatInvalid: Wiederholung stimmt nicht mit neuem Passwort überein -UserPasswordHeadingFor: Passwort ändern für -PasswordChangedSuccess: Passwort erfolgreich geändert - -FunctionaryInviteFunction: Funktion -FunctionaryInviteSchool: Institut -FunctionaryInviteField: Einzuladende E-Mail-Adressen -FunctionaryInviteHeading: Institut-Funktionäre hinzufügen - -FunctionariesInvited n@Int: #{n} #{pluralDE n "Funktionär" "Funktionäre"} per E-Mail eingeladen -FunctionariesAdded n@Int: #{n} #{pluralDE n "Funktionär" "Funktionäre"} eingetragen - -MailSubjectSchoolFunctionInvitation school@SchoolName renderedFunction@Text: #{renderedFunction}-Einladung für „#{school}“ -MailSchoolFunctionInviteHeading school@SchoolName renderedFunction@Text: #{renderedFunction}-Einladung für „#{school}“ -SchoolFunctionInviteExplanation renderedFunction@Text: Sie wurden eingeladen, als #{renderedFunction} für ein Institut zu wirken. Sie erhalten, nachdem Sie die Einladung annehmen, erweiterte Rechte innerhalb des Instituts. -SchoolFunctionInvitationAccepted school@SchoolName renderedFunction@Text: #{renderedFunction}-Einladung zum Dozent für „#{school}“ angenommen - AllocationApplication: Bewerbung AllocationProcess: Platzvergabe -SchoolShort: Kürzel -SchoolName: Name -SchoolLdapOrganisations: Assoziierte LDAP-Fragmente -SchoolLdapOrganisationsTip: Beim Login via LDAP werden dem Nutzer alle Institute zugeordnet deren assoziierte LDAP-Fragmente im Eintrag des Nutzer gefunden werden -SchoolLdapOrganisationMissing: LDAP-Fragment wird benötigt -SchoolExamMinimumRegisterBeforeStart: Minimale Tage zwischen Anmeldebeginn und Termin für Prüfungen -SchoolExamMinimumRegisterBeforeStartTip: Wenn angegeben werden Dozenten gezwungen Anmeldezeitraum und Prüfungstermin stets zusammen einzustellen. -SchoolExamMinimumRegisterDuration: Minimale Anmeldedauer für Prüfungen -SchoolExamMinimumRegisterDurationTip: Wenn angegeben werden Dozenten daran gehindert Anmeldefristen von weniger als der minimalen Dauer für ihre Prüfungen einzustellen. -SchoolExamRequireModeForRegistration: Prüfungsmodus erforderlich für Anmeldung -SchoolExamRequireModeForRegistrationTip: Sollen Dozenten gezwungen werden Prüfungsmodus und Anmeldefrist stets zusammen einzustellen? -SchoolExamDiscouragedModes: Prüfungsmodi mit Warnung - -SchoolUpdated ssh@SchoolId: #{ssh} erfolgreich angepasst -SchoolTitle ssh@SchoolId: Institut „#{ssh}“ -TitleSchoolNew: Neues Institut anlegen -SchoolCreated ssh@SchoolId: #{ssh} erfolgreich angelegt -SchoolExists ssh@SchoolId: Institut „#{ssh}“ existiert bereits - SchoolAdmin: Admin SchoolLecturer: Dozent SchoolEvaluation: Kursumfragenverwaltung @@ -847,55 +539,8 @@ SchoolAllocation: Zentralanmeldungs-Administration UserLdapSync: LDAP-Synchronisieren AllUsersLdapSync: Alle LDAP-Synchronisieren -SynchroniseLdapUserQueued n@Int: LDAP-Synchronisation von #{n} #{pluralDE n "Benutzer" "Benutzern"} angestoßen -SynchroniseLdapAllUsersQueued: LDAP-Synchronisation von allen Benutzern angestoßen UserHijack: Sitzung übernehmen -MailAllocationSchoolAndName allocationSchool@SchoolId allocation@AllocationName: #{allocationSchool}: „#{allocation}“ - -MailSubjectAllocationStaffRegister allocationSchool@SchoolId allocation@AllocationName: Sie können nun Kurse für die Zentralameldung #{allocationSchool}: „#{allocation}“ registrieren -MailSubjectAllocationStaffRegisterMultiple n@Int: Sie können nun Kurse für #{n} Zentralameldungen registrieren -MailAllocationStaffRegisterIntroMultiple n@Int: Sie können nun Kurse für die folgenden #{n} Zentralameldungen registrieren: -MailAllocationStaffRegisterNewCourse: Sie können auf der unten aufgeführten Seite neue Kurse in Uni2work anlegen. Hierbei haben Sie die Möglichkeit anzugeben, dass der Kurs an einer Zentralanmeldung teilnimmt. -MailAllocationStaffRegisterDeadline n@Int deadline@Text: Bitte beachten Sie, dass alle Kurse, die an #{pluralDE n "dieser Zentralanmeldung" "diesen Zentralanmeldungen"} teilnehmen, bis #{deadline} eingetragen sein müssen. -MailAllocationStaffRegisterDeadlineMultiple: Bitte beachten Sie, dass alle Kurse, die an einer dieser Zentralanmeldungen teilnehmen, bis Ende der jeweiligen Regstrierungsphase (siehe unten) eingetragen sein müssen. -MailAllocationStaffRegisterDeadlineSingle deadline@Text: Registrierungsphase endet #{deadline} -MailAllocationStaffRegisterDeadlineSingleNothing: Aktuell kein Ende der Registrierungsphase festgelegt - -MailSubjectAllocationRegister allocationSchool@SchoolId allocation@AllocationName: Es kann sich nun für Kurse der Zentralameldung #{allocationSchool}: „#{allocation}“ beworben werden -MailSubjectAllocationRegisterMultiple n@Int: Es kann sich nun für Kurse für #{n} Zentralanmeldungen beworben werden -MailAllocationRegisterIntroMultiple n@Int: Es kann sich nun für Kurse für die folgenden #{n} Zentralanmeldungen beworben werden: -MailAllocationRegister n@Int: Es kann sich nun, auf #{pluralDE n "der unten aufgeführten Seite" "den unten aufgeführten Seiten"}, für alle Kurse der #{pluralDE n "Zentralanmeldung" "Zentralanmeldungen"} jeweils einzeln beworben werden. -MailAllocationRegisterDeadline deadline@Text: Bitte beachten Sie, dass alle Bewerbungen bis #{deadline} eingegangen sein müssen. -MailAllocationRegisterDeadlineMultiple: Bitte beachten Sie, dass alle Bewerbungen bis Ende der jeweiligen Bewerbungsphase (siehe unten) eingegangen sein müssen. -MailAllocationRegisterDeadlineSingle deadline@Text: Bewerbungsphase endet #{deadline} -MailAllocationRegisterDeadlineSingleNothing: Aktuell kein Ende der Bewerbungsphase festgelegt - - -MailSubjectAllocationAllocation allocationSchool@SchoolId allocation@AllocationName: Sie können nun Bewerbungen für ihre Kurse in der Zentralanmeldung #{allocationSchool}: „#{allocation}“ bewerten -MailSubjectAllocationAllocationMultiple n@Int: Sie können nun Bewerbungen für ihre Kurse in #{n} Zentralanmeldungen bewerten -MailAllocationAllocationIntroMultiple n@Int: Sie können nun Bewerbungen für ihre Kurse in #{n} Zentralanmeldungen bewerten: -MailAllocationAllocation n@Int: Sie können nun auf den unten aufgeführten Seiten Bewerbungen, die im Rahmen der #{pluralDE n "Zentralanmeldung" "Zentralanmeldungen"} an ihre Kurse gestellt wurden, bewerten. Die Bewertungen werden bei der Vergabe der Plätze berücksichtigt. -MailAllocationApplicationsMayChange deadline@Text: Bitte beachten Sie, dass Studierende noch bis #{deadline} Bewerbungen stellen, verändern und zurückziehen können. Bewerbungen, die sich nach ihrer Bewertung noch verändern, müssen neu bewertet werden. -MailAllocationApplicationsRegisterDeadline deadline@Text: Bewerbungsphase endet #{deadline} -MailAllocationApplicationsRegisterDeadlineNothing: Aktuell kein Ende der Bewerbungsphase festgelegt -MailAllocationApplicationsMayChangeMultiple: Bitte beachten Sie, dass Studierende noch bis Ende der Bewerbungsphase (siehe unten) der jeweiligen Zentralanmeldung Bewerbungen stellen, verändern und zurückziehen können. Bewerbungen, die sich nach ihrer Bewertung noch verändern, müssen neu bewertet werden. -MailAllocationAllocationDeadline deadline@Text: Bitte beachten Sie, dass alle Bewertungen bis #{deadline} erfolgt sein müssen. -MailAllocationApplicationsAllocationDeadline deadline@Text: Bewertungsphase endet #{deadline} -MailAllocationApplicationsAllocationDeadlineNothing: Aktuell keine Ende der Bewertungsphase festgelegt -MailAllocationAllocationDeadlineMultiple: Bitte beachten Sie, dass alle Bewertungen bis Ende der Bewertungsphase (siehe unten) erfolgt sein müssen. - -MailSubjectAllocationUnratedApplications allocationSchool@SchoolId allocation@AllocationName: Es stehen noch Bewertungen zu Bewerbungen für ihre Kurse in der Zentralanmeldung #{allocationSchool}: „#{allocation}“ aus -MailSubjectAllocationUnratedApplicationsMultiple n@Int: Es stehen noch Bewertungen zu Bewerbungen für ihre Kurse in #{n} Zentralanmeldungen aus -MailAllocationUnratedApplicationsIntroMultiple n@Int: Es stehen noch Bewertungen zu Bewerbungen für ihre Kurse in #{n} Zentralanmeldungen aus: -MailAllocationUnratedApplications n@Int: Für die unten aufgeführten Kurse liegen Bewerbungen vor, die im Rahmen der #{pluralDE n "Zentralanmeldung" "Zentralanmeldungen"} an den jeweiligen Kurs gestellt wurden, die entweder noch nicht bewertet wurden oder die nach der Bewertung noch verändert wurden und deswegen neu bewertet werden müssen. -MailAllocationUnratedApplicationsCount i@Natural: #{i} #{pluralDE i "Bewerbung" "Bewerbungen"} - -MailSubjectAllocationNewCourse allocation@AllocationName: Es wurde ein zusätzlicher Kurs zur Zentralanmeldung „#{allocation}” eingetragen -MailAllocationNewCourseTip: Es wurde der folgende Kurs zur Zentralanmeldung eingetragen: -MailAllocationNewCourseEditApplicationsHere: Sie können Ihre Bewerbung(en) hier anpassen: -MailAllocationNewCourseApplyHere: Sie können sich hier bewerben: - UserMatriculationNotFound matriculation@Text: Es existiert kein Uni2work-Benutzer mit Matrikelnummer „#{matriculation}“ UserMatriculationAmbiguous matriculation@Text: Matrikelnummer „#{matriculation}“ ist nicht eindeutig @@ -906,13 +551,11 @@ LdapIdentificationOrEmail: Campus-Kennung / E-Mail-Adresse AuthKindLDAP: Campus-Kennung AuthKindPWHash: Uni2work-Kennung -UserDisplayEmailChanged: Öffentliche E-Mail-Adresse erfolgreich gesetzt -TitleChangeUserDisplayEmail: Öffentliche E-Mail-Adresse setzen - MailSubjectChangeUserDisplayEmail: Diese E-Mail-Adresse in Uni2work veröffentlichen MailIntroChangeUserDisplayEmail displayEmail@UserEmail: Der oben genannte Benutzer möchte „#{displayEmail}“ als öffentliche Adresse, assoziiert mit sich selbst, angeben. Wenn Sie diese Aktion nicht selbst ausgelöst haben, ignorieren Sie diese Mitteilung bitte! MailTitleChangeUserDisplayEmail displayName@Text: #{displayName} möchte diese E-Mail-Adresse in Uni2work veröffentlichen +<<<<<<< Updated upstream LecturerInfoTooltipNew: Neues Feature LecturerInfoTooltipProblem: Feature mit bekannten Problemen LecturerInfoTooltipPlanned: Geplantes Feature @@ -931,12 +574,15 @@ AllocationResultsTip: Die folgenden Informationen entsprechen dem aktuellen Stan AllocationResultsStudentTip: Unten aufgeführt sind alle Plätze, die Sie im Rahmen der genannten Zentralanmeldung erhalten haben und von denen Sie seit dem weder abgemeldet wurden, noch sich selbst abgemeldet haben. Plätze, über die Sie ggf. bereits informiert wurden, können also erneut aufgeführt sein. AllocationResultStudentRegistrationTip: Sie sind zu oben genanntem Kurs in Uni2work angemeldet. AllocationResultsStudentRegistrationTip: Sie sind zu den oben genannten Kursen in Uni2work angemeldet. +AllocationResultsStudentConsultFaq n@Int: Falls Sie Fragen oder Anmerkungen haben, beachten Sie bitte auch die Informationen auf #{pluralDE n "der" "den"} folgenden #{pluralDE n "Seite" "Seiten"}: FavouriteVisited: Kürzlich besucht FavouriteParticipant: Ihre Kurse FavouriteManual: Favoriten FavouriteCurrent: Aktueller Kurs +======= +>>>>>>> Stashed changes FavouritesUnavailableTip: Das Schnellzugriffsmenü für diesen Kurs ist aktuell nicht verfügbar. @@ -955,30 +601,6 @@ ShortSexFemale: w ShortSexNotApplicable: k.A. MenuLanguage: Sprache -LanguageChanged: Sprache erfolgreich geändert - -RFC1766: RFC1766-Sprachcode - -TermShort: Kürzel -TermCourseCount: Kurse -TermStart: Semesteranfang -TermEnd: Semesterende -TermStartMustMatchName: Jahreszahl im Namenskürzel stimmt nicht mit Semesterbeginn überein. -TermEndMustBeAfterStart: Semester darf nicht enden, bevor es beginnt. -TermLectureEndMustBeAfterStart: Vorlesungszeit muss vor ihrem Ende anfgangen. -TermStartMustBeBeforeLectureStart: Semester muss vor der Vorlesungszeit beginnen. -TermEndMustBeAfterLectureEnd: Vorlesungszeit muss vor dem Semester enden. -AdminPageEmpty: Diese Seite soll eine Übersichtsseite für Administratoren werden. Aktuell finden sich hier nur Links zu wichtigen Administrator-Funktionalitäten. -HaveCorrectorAccess sheetName@SheetName: Sie haben Korrektor-Zugang zu #{original sheetName}. -FavouritesPlaceholder: Anzahl Favoriten -FavouritesNotNatural: Anzahl der Favoriten muss eine natürliche Zahl sein! -FavouritesSemestersPlaceholder: Anzahl Semester -FavouritesSemestersNotNatural: Anzahl der Favoriten-Semester muss eine natürliche Zahl sein! - -ProfileTitle: Benutzereinstellungen - -GlossaryTitle: Begriffsverzeichnis - Applicant: Bewerber Administrator: Administrator @@ -993,27 +615,12 @@ CommTutorial: Tutorium-Mitteilung Clone: Klonen Deficit: Defizit -MetricNoSamples: Keine Messwerte -MetricName: Name -MetricValue: Wert - TitleExamAutoOccurrence tid@TermId ssh@SchoolId csh@CourseShorthand examn@ExamName: #{tid} - #{ssh} - #{csh} #{examn}: Automatische Raum-/Terminverteilung ExamGradingPass: Bestanden/Nicht Bestanden ExamGradingGrades: Numerische Noten ExamGradingMixed: Gemischt -InfoLecturerCourses: Veranstaltungen -InfoLecturerExercises: Übungsbetrieb -InfoLecturerTutorials: Tutorien -InfoLecturerExams: Prüfungen -InfoLecturerAllocations: Zentralanmeldungen - -ParticipantsIntersectCourseOption tid@TermId ssh@SchoolId coursen@CourseName: #{tid} - #{ssh} - #{coursen} -ParticipantsIntersectCourses: Kurse - -FaqTitle: Häufig gestellte Fragen - CourseParticipantStateIsActiveFilter: Ansicht CourseParticipantActive: Teilnehmer CourseParticipantInactive: Abgemeldet @@ -1057,7 +664,6 @@ InvalidCredentialsADAccountLockedOut: Benutzereintrag wurde durch Eindringlingse ExamCloseModeSeparate: Separat ExamCloseModeOnFinished: Mit Veröffentlichung ExamCloseModeOnFinishedHidden: Mit Veröffentlichung (versteckt) -ExamCloseMode: Prüfungs-Abschluss UrlFieldCouldNotParseAbsolute: Konnte nicht als absolute URL interpretiert werden diff --git a/messages/uniworx/misc/en-eu.msg b/messages/uniworx/misc/en-eu.msg index 9a4db4142..b997c327a 100644 --- a/messages/uniworx/misc/en-eu.msg +++ b/messages/uniworx/misc/en-eu.msg @@ -6,19 +6,13 @@ AcceptApplicationsSecondaryRandom: Randomly AcceptApplicationsSecondaryTime: By time of application #headings -HeadingLegal: Legal -SubmissionNew: Create submission -ParticipantsList: Lists of course participants -ParticipantsIntersect: Common course participants -HeadingProfileData: Personal information -HeadingSchoolList: Departments CorrectorsChange: Adjust correctors -MaterialList: Material HeadingDataProt: Data protection HeadingTermsUse: Terms of use HeadingCopyright: Copyright HeadingImprint: Imprint -CourseNew: Create new course +HeadingTermsHeading: Semesters +HeadingTermEditHeading: Edit semester #general warnings EmailInvitationWarning: This address could not be matched to any Uni2work user. An invitation will be sent via email. @@ -45,36 +39,12 @@ SummerTermShort year: Summer #{year} WinterTermShort year: Winter #{year}/#{mod (succ year) 100} Page num: #{num} -TermsHeading: Semesters TermCurrent: Current semester -TermEditHeading: Edit semester TermEditTid tid: Edit semester #{tid} -TermEdited tid: Successfully edited semester #{tid} -TermNewTitle: Edit/create semester -InvalidInput: Invalid input -Term: Semester -TermPlaceholder: (W|S) - -TermStartDay: Starting day -TermStartDayTooltip: Usually 1st of April or 1st of October -TermEndDay: Last day -TermEndDayTooltip: Usually 30th of September or 31st of March -TermHolidays: Legal holidays -TermHolidayPlaceholder: Legal holiday -TermHolidayMissing: Holiday is required -TermLectureStart: Lectures start -TermLectureEnd: Lectures end -TermLectureEndTooltip: Summer semesters are usually 14 weeks; winter semesters 15 -TermActive: Active - -AchievedOf achieved possible: #{achieved} of #{possible} - SchoolListHeading: Department SchoolHeading school: #{school} -LectureStart: Lectures start - CourseNoCapacity: Course has reached maximum capacity TutorialNoCapacity: Tutorial has reached maximum capacity ExamOccurrenceNoCapacity: Occurrence/Room has reached maximum capacity @@ -107,20 +77,16 @@ SheetArchiveFileTypeDirectoryHint: hint SheetArchiveFileTypeDirectorySolution: solution SheetArchiveFileTypeDirectoryMarking: marking -Deadline: Deadline -Done: Submitted - SubmissionsCourse tid ssh csh: All submissions for Course #{tid}-#{ssh}-#{csh} SubmissionsSheet sheetName: Submissions for #{sheetName} SubmissionEditHead tid ssh csh sheetName: #{tid}-#{ssh}-#{csh} #{sheetName}: Edit/Create submission CorrectionHead tid ssh csh sheetName cid: #{tid}-#{ssh}-#{csh} #{sheetName}: Marking CosubmittorTip: Invitations are sent via email to exactly those addresses for which it cannot be determined, that you have already submitted for this course with the associated person, at least once. If one of the specified addresses can be matched to a person with whom you have submitted at least once for this course already, the name of that person will be shown and the submission will immediately be made in their name as well. -SubmissionGroupName: Group name - CorrectionsTitle: Assigned corrections CorrectorsHead sheetName: Correctors for #{sheetName} +<<<<<<< Updated upstream MaterialName: Name MaterialType: Type MaterialTypePlaceholder: Slides, Code, Example, ... @@ -195,6 +161,7 @@ UnauthorizedParticipantSelf: You are no participant of this course. UnauthorizedApplicant: The specified user is no applicant for this course. UnauthorizedApplicantSelf: You are no applicant for this course. UnauthorizedCourseTime: This course is not currently available. +UnauthorizedCorrectionExamTime: Visibility restrictions of the relevant exam are restricting access. UnauthorizedCourseRegistrationTime: This course does not currently allow enrollment. UnauthorizedAllocationRegisterTime: This central allocation does not currently allow applications. UnauthorizedSheetTime: This sheet is not currently available. @@ -215,43 +182,18 @@ MaterialFree: Course material is publicly available. UnauthorizedWrite: You do not have the write permission necessary to perform this action UnauthorizedSystemMessageTime: This system-message is not currently available. UnauthorizedSystemMessageAuth: This system-message is only available to logged in users. +======= +>>>>>>> Stashed changes UnsupportedAuthPredicate authTagT shownRoute: “#{authTagT}” was applied to a route which does not support it: “#{shownRoute}” -UnauthorizedDisabledTag authTag: Auth predicate “#{toPathPiece authTag}” is disabled for your session -UnknownAuthPredicate tag: Auth predicate “#{tag}” is unknown -UnauthorizedRedirect: The requested view does not exist or you haven't the required permissions to access it. -UnauthorizedSelf: You are not the specified user. -UnauthorizedTutorialTutor: You are no tutor for this tutorial. -UnauthorizedTutorialTutorControl: Tutors may not edit this tutorial. -UnauthorizedCourseTutor: You are no tutor for this course. -UnauthorizedTutor: You are no tutor. -UnauthorizedTutorialRegisterGroup: You are already registered for a tutorial with the same registration group. -UnauthorizedLDAP: Specified user does not log in with their campus account. -UnauthorizedPWHash: Specified user does not log in with an Uni2work-account. -UnauthorizedExternalExamListNotEmpty: List of external exams is not empty -UnauthorizedExternalExamLecturer: You are not an associated person for this external exam -UnauthorizedSubmissionSubmissionGroup: You are not member in any of the submission groups for this submission -UnauthorizedSheetSubmissionGroup: You are not member in any submission group - -UnauthorizedPasswordResetToken: This authorisation-token may no longer be used to change passwords - -UnauthorizedAllocatedCourseRegister: Direct enrollment to this course is currently not allowed due to participation in a central allocation -UnauthorizedAllocatedCourseDeregister: Deregistration from this course is currently not allowed due to participation in a central allocation -UnauthorizedAllocatedCourseDelete: Courses that participate in a central allocation may not be deleted -UnauthorizedWorkflowInitiate: You currently may not initiate a new running workflow -UnauthorizedWorkflowWrite: You are currently not allowed to initiate any state transition within the workflow -UnauthorizedWorkflowRead: The workflow currently contains no states or data you are permitted to view -UnauthorizedWorkflowInstancesNotEmpty: There are workflow instances for which you are allowed to initiate a new running workflow -UnauthorizedWorkflowWorkflowsNotEmpty: There are running workflows, which you may view -UnauthorizedWorkflowFiles: You are not allowed to download the given workflow files in the given historical state -UnauthorizedNotAuthenticatedInDifferentApproot: You could not be authenticated in the context of a separate domain (e.g. for secure downloading of files). You probably used no or an expired token. You can try to access the resource with a newly generated download link. -UnauthorizedCsrfDisabled: Your request might have triggered a state change on the server. Since CSRF-protection was disabled for your request, it had to be rejected. -UnauthorizedStudent: You are not a student. WorkflowRoleUserMismatch: You aren't any of the users authorized by the workflow WorkflowRoleAlreadyInitiated: This workflow was already initiated WorkflowRoleNoSuchWorkflowWorkflow: The given workflow could not be found WorkflowRoleNoPayload: This workflow does not contain any data +UnauthorizedCsrfDisabled: Your request might have triggered a state change on the server. Since CSRF-protection was disabled for your request, it had to be rejected. +UnauthorizedDisabledTag authTag: Auth predicate “#{toPathPiece authTag}” is disabled for your session + EMail: Email EMailUnknown email: Email #{email} does not belong to any known user. @@ -264,40 +206,22 @@ CorByProportionExcludingTutorial proportion: #{rationalToFixed3 proportion} part DeleteRow: Delete Users: Users -NewsHeading: News LoginHeading: Authentication LoginTitle: Authentication ProfileHeading: Settings - -InfoHeading: Information VersionHeading: Version history LegalHeading: Legal SystemMessageHeading: Uni2work system message SystemMessageListHeading: Uni2work system message -NotificationSettingsHeading displayName: Notification settings for #{displayName} -TokensResetSuccess: Successfully invalidated all authorisation tokens - -NewsOpenAllocations: Active central allocations -NewsUpcomingSheets: Upcoming exercise sheets -NewsUpcomingExams: Upcoming exams - -NewsHideHiddenSystemMessages: Don't show hidden news items -NewsShowHiddenSystemMessages: Show hidden news items - -NumCourses num: #{num} #{pluralEN num "course" "courses"} CloseAlert: Close Name: Name -LdapSynced: LDAP-synchronised -LdapSyncedBefore: Last LDAP-synchronisation before Plugin: Plugin Settings: Settings -SettingsUpdate: Successfully updated settings -NotificationSettingsUpdate: Successfully updated notification settings Never: Never PreviouslyUploadedInfo: Previously uploaded files @@ -338,13 +262,8 @@ AssignSubmissionsAssignableSheets: Distribute corrections for: AchievedBonusPoints: Bonus points achieved AchievedNormalPoints: Points achieved PassedResult: Result -Passed: Passed -NotPassed: Failed RatingPointsDone: Correction counts as marked iff “Points” is set -VisibleFrom: Published -AccessibleSince: Accessible since - RatingNegative: Marking points may not be negative RatingExceedsMax: Marking points exceed maximum RatingNotExpected: No marking points expected for this sheet @@ -357,39 +276,18 @@ SubmissionSinkExceptionRatingWithoutUpdate: Marking file found without permissio SubmissionSinkExceptionForeignRating smid: Foreign marking file for submission #{toPathPiece smid} found. SubmissionSinkExceptionInvalidFileTitleExtension file: Filename “#{show file}” (may be packed within a zip-archive) does not have any of the file extensions allowed for this sheet. -NoUpcomingSheetDeadlines: No upcoming sheets -NoUpcomingExams difftime: No exams for your courses occur or allow registration in the next #{difftime} - -AdminHeading: Administration AdminUserHeading: User administration -AdminUserRightsHeading: User permissions -AdminUserAuthHeading: User authentication -AdminUserHeadingFor: Profile of AdminFor: Administrator -UserListTitle: Comprehensive list of users -AccessRightsSaved: Successfully updated permissions -AccessRightsNotChanged: Permissions left unchanged -UserSystemFunctions: System wide roles -UserSystemFunctionsSaved: Successfully saved system wide roles -UserSystemFunctionsNotChanged: No system wide roles were changed -UserAssimilateUser: User -AssimilateUserNotFound: Email could not be resolved to an user -AssimilateUserHaveError: An error occurred during assimilation -AssimilateUserHaveWarnings: Warnings were ermitted during assimilation -AssimilateUserSuccess: Successfully assimilated user Date: Date FormFieldRequiredTip: Required fields -FormAllocationNotifications: Notifications for new central allocation courses -FormAllocationNotificationsTip: Do you want to receive a notification if a new course is added to the central allocation? “Yes” and “No” override the system wide setting under “Notifications” AllocNotifyNewCourseDefault: System wide setting AllocNotifyNewCourseForceOff: No AllocNotifyNewCourseForceOn: Yes LastEdits: Latest edits -LastEditByUser: Your last edit NoEditByUser: Not edited by you LDAPLoginTitle: Campus login @@ -415,10 +313,6 @@ CorrectorMissing: Missing CorrectorExcused: Excused CorrectorStateTip: Missing correctors are assigned additional corrections during later sheets. Excused correctors are not assigned any additional deficit. -DayIsAHoliday tid name date: “#{name}” (#{date}) is a legal holiday -DayIsOutOfLecture tid name date: “#{name}” (#{date}) is not within lecture period of #{tid} -DayIsOutOfTerm tid name date: “#{name}” (#{date}) is not within #{tid} - AutoUnzip: Automatically unpack ZIPs AutoUnzipInfo: Automatically unpacks ZIP-files (*.zip) and adds their content to the root directory. @@ -449,94 +343,9 @@ GermanGermany: German (Germany) English: English EnglishEurope: English (Europe) -MailSubjectSubmissionRated csh: Your #{csh}-submission was marked -MailSubmissionRatedIntro courseName termDesc: Your submission for #{courseName} (#{termDesc}) was marked. - -MailSubjectSubmissionEdited csh shn: Your submisson for #{shn} in #{csh} was edited -MailSubmissionEditedIntro coursen shn termDesc displayName: #{displayName} edited your submission for #{shn} in #{coursen} (#{termDesc}). - - -MailSubjectSubmissionUserCreated csh shn: You were added to a submission for #{shn} in #{csh} -MailSubjectSubmissionUserCreatedOther displayName csh shn: An user was added to a submission for #{shn} in #{csh} - - -MailSubmissionUserCreatedIntro coursen shn termDesc: You were added to a submission for #{shn} in #{coursen} (#{termDesc}). -MailSubmissionUserCreatedOtherIntro displayName coursen shn termDesc: #{displayName} was added as to a submission for #{shn} in #{coursen} (#{termDesc}). - - -MailSubjectSubmissionUserDeleted csh shn: You were removed from your submission for #{shn} in #{csh} -MailSubjectSubmissionUserDeletedOther displayName csh shn: An user was removed from your submission for #{shn} in #{csh} - -MailSubmissionUserDeletedIntro coursen shn termDesc: You were removed from your submission for #{shn} in #{coursen} (#{termDesc}). -MailSubmissionUserDeletedOtherIntro displayName coursen shn termDesc: #{displayName} was removed from your submission for #{shn} in #{coursen} (#{termDesc}). - -MailSubjectSheetActive csh sheetName: #{sheetName} in #{csh} was released -MailSheetActiveIntro courseName termDesc sheetName: You may now download #{sheetName} for #{courseName} (#{termDesc}). - -MailSubjectSheetHint csh sheetName: Hints for #{sheetName} in #{csh} have been released -MailSheetHintIntro courseName termDesc sheetName: You may now download the hints for #{sheetName} in #{courseName} (#{termDesc}). - -MailSubjectSheetSolution csh sheetName: Solutions for #{sheetName} in #{csh} have been released -MailSheetSolutionIntro courseName termDesc sheetName: You may now download the solutions for #{sheetName} in #{courseName} (#{termDesc}). - -MailSubjectCourseRegistered csh: You were enrolled for #{csh} -MailSubjectCourseRegisteredOther displayName csh: #{displayName} was enrolled for #{csh} -MailCourseRegisteredIntro courseName termDesc: You were enrolled for the course “#{courseName}” (#{termDesc}) -MailCourseRegisteredIntroOther displayName courseName termDesc: #{displayName} was enrolled for the course “#{courseName}” (#{termDesc}). - -MailSubjectExamResult csh examn: Results for #{examn} in #{csh} are now available -MailExamResultIntro courseName termDesc examn: You may now view your result for #{examn} of the course #{courseName} (#{termDesc}). - -MailSubjectExamOfficeExamResults coursen examn: Results for #{examn} of #{coursen} are now available -MailExamOfficeExamResultsIntro courseName termDesc examn: A course administrator has made the results for #{examn} of the course #{courseName} (#{termDesc}) available. - -MailSubjectExamOfficeExamResultsChanged coursen examn: Results for #{examn} of #{coursen} were changed -MailExamOfficeExamResultsChangedIntro courseName termDesc examn: A course administrator has changed exam results for #{examn} of the course #{courseName} (#{termDesc}). - -MailSubjectExamOfficeExternalExamResults coursen@CourseName examn@ExamName: Results for #{examn} in #{coursen} -MailExamOfficeExternalExamResultsIntro coursen@CourseName termDesc@Text examn@ExamName: A course administrator has changed or initially made available the results for #{examn} of the course {coursen} (#{termDesc}). - -MailSubjectExamRegistrationActive csh examn: Registration is now allowed for #{examn} of #{csh} -MailExamRegistrationActiveIntro courseName termDesc examn: You may now register for #{examn} of the course #{courseName} (#{termDesc}). - -MailSubjectExamRegistrationSoonInactive csh examn: The registration period for #{examn} of #{csh} ends shortly -MailExamRegistrationSoonInactiveIntro courseName termDesc examn: Soon you will no longer be allowed to register for #{examn} of #{courseName} (#{termDesc}). - -MailSubjectExamDeregistrationSoonInactive csh examn: Deregistration for #{examn} in #{csh} ends shortly -MailExamDeregistrationSoonInactiveIntro courseName termDesc examn: Soon you will no longer be allowed to deregister from #{examn} of #{courseName} (#{termDesc}). - -MailSubjectSubmissionsUnassigned csh sheetName: Corrections for #{sheetName} of #{csh} could not be distributed -MailSubmissionsUnassignedIntro n courseName termDesc sheetName: #{n} corrections for #{sheetName} of the course #{courseName} (#{termDesc}) could not be automatically distributed. - -MailSubjectSheetSoonInactive csh sheetName: The submission period for #{sheetName} of #{csh} ends shortly -MailSheetSoonInactiveIntro courseName termDesc sheetName: Soon you will no longer be allowed to submit for #{sheetName} of the course #{courseName} (#{termDesc}). -MailSubjectSheetInactive csh sheetName: The submission period for #{sheetName} of #{csh} has ended -MailSheetInactiveIntro courseName termDesc sheetName n num: The submission period for #{sheetName} of the course #{courseName} (#{termDesc}) has ended. #{noneOneMoreEN num "" "One participant" (toMessage num <> " participants")}#{noneOneMoreEN n "" "" (" made " <> toMessage num)}#{noneOneMoreEN n "There were no submissions" " made one submission" " submissions"}. -MailSheetInactiveIntroNoUserSubmission courseName termDesc sheetName n num: The submission period for #{sheetName} of the course #{courseName} (#{termDesc}) has ended. #{noneOneMoreEN num "" "One participant already" (toMessage num <> " participants already")}#{noneOneMoreEN n "" "" (" made " <> toMessage num)}#{noneOneMoreEN n "" " made one submission" " submissions"}. -MailSheetInactivePseudonymsCount n: The number of submissions above accounts only for the submissions already made directly in Uni2work. #{n} #{pluralEN n "pseudonym was" "pseudonyms were"} generated. -MailSheetInactiveParticipantsCount n: There #{pluralEN n "is" "are"} currently #{n} #{pluralEN n "participant" "participants"} registered for the course. - -MailSubjectCorrectionsAssigned csh sheetName: You were assigned corrections for #{sheetName} of #{csh} -MailCorrectionsAssignedIntro courseName termDesc sheetName n: You were assigned #{n} #{pluralEN n "correction" "corrections"} for #{sheetName} of #{courseName} (#{termDesc}). - -MailSubjectUserRightsUpdate name: Permissions for #{name} changed -MailUserRightsIntro name email: #{name} <#{email}> now has the following permissions: -MailNoLecturerRights: You don't currently have lecturer permissions for any department. -MailLecturerRights n: As a lecturer you may create new courses within your #{pluralEN n "department" "departments"}. - -MailSubjectUserSystemFunctionsUpdate name: Permissions for #{name} changed -MailUserSystemFunctionsIntro name email: #{name} <#{email}> now has the following, not school restricted, permissions: -MailUserSystemFunctionsNoFunctions: None - -MailSubjectUserAuthModeUpdate: Your Uni2work login -UserAuthModePWHashChangedToLDAP: You can now log in to Uni2work using your Campus-account -UserAuthModeLDAPChangedToPWHash: You can now log in to Uni2work using your Uni2work-internal account NewPasswordLinkTip: You can set the password for your Uni2work-internal account on the following page: NewPasswordLink: Set password -AuthPWHashTip: You now need to use the login form labeled "Uni2work login". Please ensure that you have already set a password when you try to log in. -PasswordResetEmailIncoming: For security reasons you will receive a link to the page on which you can set and later change your password in a separate email. -MailEditNotifications: Enable/Disable notifications MailSubjectSupport: Support request MailSubjectSupportCustom customSubject: [Support] #{customSubject} @@ -574,60 +383,8 @@ PseudonymAutocorrections: Suggestions: CorrGrade: Mark submissions -UserAccountDeleted name: User account for #{name} was deleted! -UserSubmissionsDeleted n: #{tshow n} #{pluralEN n "submission was" "submissions were"} permanently deleted. -UserGroupSubmissionsKept n: #{tshow n} #{pluralEN n "group submission was" "group submissions were"} kept. They are no longer associated with the deleted user. Group submissions can thus become as if made by a single user. Such submissions are deleted together with their last user. -UserSubmissionGroupsDeleted count: #{tshow count} #{pluralEN count "submission group was" "submission groups were"} deleted since #{pluralEN count "it" "they"} would have become empty. UserAccountDeleteWarning: Caution, this permanently deletes users and all of their associated data. Exam results must be stored long term! -HelpTitle: Support -HelpSendLastError: Attach last error message -HelpError: Last error message -HelpErrorYamlFilename mailId: error-#{toPathPiece mailId}.yaml -HelpErrorOrRequestRequired: Please attach either the last error message or submit a support request or a suggestion - -InfoLecturerTitle: Information for lecturers - -SystemMessageNewsOnly: Only on "News" -SystemMessageRecordChanged: Signifcant change -SystemMessageRecordChangedTip: Should the "last changed"-timestamp be adjusted? News are sorted by "last changed" on "News". After a significant change news items are displayed once again as a popup in the bottom right. -SystemMessageUnhide: Ignore previously hidden -SystemMessageUnhideTip: Should the news item be display again for users that have actively hidden it? -SystemMessageCreated: Created -SystemMessageLastChanged: Last changed -SystemMessageLastChangedAt time: Last changed: #{time} -SystemMessageLastUnhide: Last unhidden -SystemMessageFrom: Visible from -SystemMessageTo: Visible to -SystemMessageAuthenticatedOnly: Only logged in users -SystemMessageSeverity: Severity -SystemMessagePriority: Priority -SystemMessagePriorityNegative: Priority may not be negative -SystemMessageId: Id -SystemMessageSummaryContent: Summary / Content -SystemMessageSummary: Summary -SystemMessageContent: Content -SystemMessageLanguage: Language - -SystemMessageDelete: Delete -SystemMessageActivate: Set to be visible -SystemMessageDeactivate: Set to be invisible -SystemMessageTimestamp: Timestamp - -SystemMessagesDeleted: System messages deleted: -SystemMessagesActivated: System messages set to become visible at: -SystemMessagesDeactivated: System messages set to become invisable at: -SystemMessageEmptySelection: No system messages selected -SystemMessageAdded sysMsgId: System message added: #{toPathPiece sysMsgId} -SystemMessageEdit: Edit system message -SystemMessageEditTranslations: Edit translations -SystemMessageAddTranslation: Add translation - -SystemMessageEditSuccess: Successfully edited system message. -SystemMessageAddTranslationSuccess: Successfully added translation. -SystemMessageEditTranslationSuccess: Successfully edited translation. -SystemMessageDeleteTranslationSuccess: Successfully deleted translation. - MessageError: Error MessageWarning: Warning MessageInfo: Information @@ -654,8 +411,6 @@ EncodedSecretBoxCouldNotOpenSecretBox: Could not open libsodium-secretbox (Encry EncodedSecretBoxCouldNotDecodePlaintext aesonErr: Could not decode json cleartext: #{aesonErr} ErrMsgHeading: Decrypt error message -TitleMetrics: Metrics - DBTIRowsMissing n: #{pluralDE n "A line" "A number of lines"} vanished from the database since the form you submitted was generated for you NavigationFavourites: Favourites @@ -664,6 +419,7 @@ CommBody: Message CommDuplicateRecipients n: #{n} duplicate #{pluralEN n "recipient" "recipients"} ignored CommUndisclosedRecipients: Undisclosed recipients CommAllRecipients: all-recipients +CommAllRecipientsSheet: Recipients MultiSelectFieldTip: Multiple selections are possible (Shift or Ctrl) MultiEmailFieldTip: Multiple emails addresses may be specified (comma-separated) @@ -680,28 +436,14 @@ WeekDay: Day of the week MassInputTip: You may specify multiple values. Values must be added to the list by clicking + and can be removed again by clicking -. All changes must be confirmed by clicking the form submit button. -HealthReport: Health report -InstanceIdentification: Instance identification - -InstanceId: Instance id ClusterId: Cluster id -HealthMatchingClusterConfig: Cluster config matches -HealthHTTPReachable: Cluster can be reached under the expected URL via HTTP -HealthLDAPAdmins: Proportion of administrators that were found in the LDAP directory -HealthSMTPConnect: SMTP server is reachable -HealthWidgetMemcached: Memcached server is serving widgets correctly -HealthActiveJobExecutors: Proportion of job workers accepting new jobs - CourseParticipants n: Currently #{n} course #{pluralEN n "participant" "participants"} CourseParticipant: Participant CourseParticipantsRegisteredWithoutField n: #{n} #{pluralEN n "participant was" "participants were"} registered without #{pluralEN n "an associated field of study" "associated fields of study"}, because #{pluralEN n "it" "they"} could not be determined uniquely. ExamRegistrationRegisteredWithoutField n: Registered #{n} #{pluralEN n "participant" "participants"} for the exam as well as for the course. The #{pluralEN n "participant was" "participants were"} enrolled without #{pluralEN n "an associated field of study" "associated fields of study"} since #{pluralEN n "it" "they"} could not be determined uniquely. ExamRegistrationParticipantsRegistered n: #{n} #{pluralEN n "participant was" "participants were"} registered for the exam -NewsExamOccurrenceRoomIsUnset: — -NewsExamOccurrenceRoomIsHidden: Room is only displayed to participants registered for this occurrence/room - ExamOpenBook: Open book ExamClosedBook: Closed book @@ -722,8 +464,6 @@ ExamRequiredEquipmentMicrophoneInternet: Microphone ExamPassed: Passed ExamNotPassed: Failed -NewsExamRegistered: Registered for the exam -NewsExamNotRegistered: Not registered for the exam ExamRegistrationTime: Registered since VersionHistory: Version history @@ -753,15 +493,16 @@ CsvDeleteMissing: Delete missing entries TableProportion c of' prop: #{c}/#{of'} (#{rationalToFixed2 (100 * prop)}%) TableProportionNoRatio c of': #{c}/#{of'} +<<<<<<< Updated upstream ParticipantsCsvName tid ssh: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-participants +ParticipantsCsvSheetName tid ssh: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)} Participants +======= +>>>>>>> Stashed changes CsvColumnUserField: Field of study the participant specified when enrolling for the course CsvColumnUserDegree: Degree the participant pursues in their associated field of study CsvColumnUserSemester: Semester the participant is in wrt. to their associated field of study -Action: Action -ActionNoUsersSelected: No users selected - ExamUserCsvCourseRegister: Register users for the exam and enroll them in the course ExamUserCsvRegister: Register users for the exam ExamUserCsvAssignOccurrence: Assign occurrences/rooms to participants @@ -787,62 +528,11 @@ ExternalExamUserCsvDeregister: Delete stored exam achievement TableHeadingCsvImport: CSV import TableHeadingCsvExport: CSV export -AuthLDAPLookupFailed: User could not be looked up due to a LDAP error -AuthLDAPInvalidLookup: Existing user could not be uniquely matched with a LDAP entry -AuthLDAPAlreadyConfigured: User already logs in using their campus account -AuthLDAPConfigured: User now logs in using their campus account - -AuthPWHashAlreadyConfigured: User already logs in using their Uni2work account -AuthPWHashConfigured: User now logs in using their Uni2work account - -PasswordResetQueued: Sent link to reset password ResetPassword: Reselt Uni2work password -AuthLDAP: Campus -AuthPWHash pwHash: Uni2work -CurrentPassword: Current password -NewPassword: New password -NewPasswordRepeat: New password (again) -CurrentPasswordInvalid: Current password is incorrect -PasswordRepeatInvalid: New passwords do not match -UserPasswordHeadingFor: Change password for -PasswordChangedSuccess: Successfully changed password - -FunctionaryInviteFunction: Function -FunctionaryInviteSchool: Department -FunctionaryInviteField: Email addresses to invite -FunctionaryInviteHeading: Add department functionaries - -FunctionariesInvited n: Invited #{n} #{pluralEN n "functionary" "functionaries"} via email -FunctionariesAdded n: Added #{n} #{pluralEN n "functionary" "functionaries"} - -MailSubjectSchoolFunctionInvitation school renderedFunction: Invitation to be #{renderedFunction} for “#{school}” -MailSchoolFunctionInviteHeading school renderedFunction: Invitation to be #{renderedFunction} for “#{school}” -SchoolFunctionInviteExplanation renderedFunction: You were invited to act as #{renderedFunction} for a department. By accepting the invitation you are granted elevated rights within the department. -SchoolFunctionInvitationAccepted school renderedFunction: Successfully accepted invitation to be #{renderedFunction} for “#{school}” - AllocationApplication: Application AllocationProcess: Allocation process -SchoolShort: Shorthand -SchoolName: Name -SchoolLdapOrganisations: Associated LDAP fragments -SchoolLdapOrganisationsTip: When logging in users are associated with any departments whose associated LDAP fragments are found in the users LDAP entry -SchoolLdapOrganisationMissing: LDAP-fragment is required -SchoolExamMinimumRegisterBeforeStart: Minimum number of days between start of registration period and start of exams -SchoolExamMinimumRegisterBeforeStartTip: If specified course administrators will be forced to specify the start of the registration period and the start of the exam at the same time. -SchoolExamMinimumRegisterDuration: Minimum duration of registration period for exams -SchoolExamMinimumRegisterDurationTip: If specified course administrators will be prevented from setting a registration period of less than the specified number of days. -SchoolExamRequireModeForRegistration: Exam design required for registration -SchoolExamRequireModeForRegistrationTip: Should course administrators be forced to fully specify their exam design when setting a registration period? -SchoolExamDiscouragedModes: Exam designs to warn against - -SchoolUpdated ssh: Successfully edited #{ssh} -SchoolTitle ssh: Department „#{ssh}“ -TitleSchoolNew: Neues Institut anlegen -SchoolCreated ssh: Successfully created #{ssh} -SchoolExists ssh: A department named „#{ssh}“ already exists - SchoolAdmin: Admin SchoolLecturer: Lecturer SchoolEvaluation: Course evaluation @@ -851,55 +541,8 @@ SchoolAllocation: Administration of central allocations UserLdapSync: Synchronise with LDAP AllUsersLdapSync: Synchronise all with LDAP -SynchroniseLdapUserQueued n: Triggered LDAP synchronisation of #{n} #{pluralEN n "user" "users"}. -SynchroniseLdapAllUsersQueued: Triggered LDAP synchronisation of all users UserHijack: Hijack session -MailAllocationSchoolAndName allocationSchool allocation: #{allocationSchool}: “#{allocation}” - -MailSubjectAllocationStaffRegister allocationSchool allocation: You can now register courses for the central allocation #{allocationSchool}: “#{allocation}” -MailSubjectAllocationStaffRegisterMultiple n: You can now register courses for #{n} central allocations -MailAllocationStaffRegisterIntroMultiple n: You can now register courses for the following #{n} central allocations: -MailAllocationStaffRegisterNewCourse: You can create new courses in Uni2work on the site listed below. While doing so you can specify that the course should participate in a central allocation. -MailAllocationStaffRegisterDeadline n deadline: Please consider that all courses, that are to participate in #{pluralEN n "this central allocation" "these central allocations"}, must be registered before #{deadline}. -MailAllocationStaffRegisterDeadlineMultiple: Please consider that alle courses, that are to participate in these central allocations, must be registered before the ends of their respective course registration periods (see below). -MailAllocationStaffRegisterDeadlineSingle deadline: Course Registration period ends on #{deadline} -MailAllocationStaffRegisterDeadlineSingleNothing: Currently no end of course registration period configured - -MailSubjectAllocationRegister allocationSchool allocation: Applications can now be made for courses of the central allocation #{allocationSchool}: “#{allocation}” -MailSubjectAllocationRegisterMultiple n: Applications can now be made for courses of #{n} central allocations -MailAllocationRegisterIntroMultiple n: Applications can now be made for courses of the following #{n} central allocations: -MailAllocationRegister n: Applications can now be made for each of the courses participating in the central #{pluralEN n "allocation" "allocations"} on the #{pluralEN n "page" "pages"} listed below. -MailAllocationRegisterDeadline deadline: Please consider that all applications have to be made before #{deadline}. -MailAllocationRegisterDeadlineMultiple: Please consider that all applications for courses participating in central allocations have to be made before the ends of their respective application periods (see below). -MailAllocationRegisterDeadlineSingle deadline: Application periods ends on #{deadline} -MailAllocationRegisterDeadlineSingleNothing: Currently no end of application period configured - - -MailSubjectAllocationAllocation allocationSchool allocation: You can now rate applications for your courses that participate in the central allocation #{allocationSchool}: “#{allocation}” -MailSubjectAllocationAllocationMultiple n: You can now rate applications for your courses that participate in #{n} central allocations -MailAllocationAllocationIntroMultiple n: You can now rate applications for your courses that participate in #{n} central allocations: -MailAllocationAllocation n: You can now rate applications made in the context of the central #{pluralEN n "allocation" "allocations"} for your courses on the pages listed below. Ratings made will have an effect on the allocation. -MailAllocationApplicationsMayChange deadline: Please consider that applicants may change or delete their applications until #{deadline}. If an application was rated before it was changed it needs to be rated again. -MailAllocationApplicationsRegisterDeadline deadline: Application period ends on #{deadline} -MailAllocationApplicationsRegisterDeadlineNothing: Currently no end of application period configured -MailAllocationApplicationsMayChangeMultiple: Please consider that applicants may change or delete their applications until the end of the respective central allocation's application period. If an application was rated before it was changed it needs to be rated again. -MailAllocationAllocationDeadline deadline: Please consider that all ratings have to be made before #{deadline}. -MailAllocationApplicationsAllocationDeadline deadline: Rating period ends on #{deadline} -MailAllocationApplicationsAllocationDeadlineNothing: Currently no end of rating period configured -MailAllocationAllocationDeadlineMultiple: Please consider that all ratings have to be made before the end of the respective rating period (see below). - -MailSubjectAllocationUnratedApplications allocationSchool allocation: There are unrated applications for you courses participating in the central allocation #{allocationSchool}: “#{allocation}” -MailSubjectAllocationUnratedApplicationsMultiple n: There are unrated applications for your courses participating in #{n} central allocations -MailAllocationUnratedApplicationsIntroMultiple n: There are unrated applications for your courses participating in #{n} central allocations: -MailAllocationUnratedApplications n: For there courses listed below, there exist applications made in the context of #{pluralEN n "the central allocation" "one of the central allocations"} which have either not yet been rated or which have changed since they were rated. -MailAllocationUnratedApplicationsCount i: #{i} #{pluralDE i "application" "applications"} - -MailSubjectAllocationNewCourse allocation: A new course was added to the central allocation “#{allocation}” -MailAllocationNewCourseTip: The following course was added to the central allocation: -MailAllocationNewCourseEditApplicationsHere: You can modify your application here: -MailAllocationNewCourseApplyHere: You can apply here: - UserMatriculationNotFound matriculation: There is no uni2work-user with matriculation “#{matriculation}” UserMatriculationAmbiguous matriculation: Matriculation “#{matriculation}” isn't unique @@ -910,13 +553,11 @@ LdapIdentificationOrEmail: Campus account/email address AuthKindLDAP: Campus account AuthKindPWHash: Uni2work account -UserDisplayEmailChanged: Successfully set display email -TitleChangeUserDisplayEmail: Set display email - MailSubjectChangeUserDisplayEmail: Publishing this email address in Uni2work MailIntroChangeUserDisplayEmail displayEmail: The user mentioned above wants to publish “#{displayEmail}” as their own email address. If you have not caused this email to be sent, please ignore it! MailTitleChangeUserDisplayEmail displayName: #{displayName} wants to publish this email address as their own in Uni2work +<<<<<<< Updated upstream LecturerInfoTooltipNew: New feature LecturerInfoTooltipProblem: Feature with known issues LecturerInfoTooltipPlanned: Planned feature @@ -935,16 +576,17 @@ AllocationResultsTip: The following information reflect the current state of the AllocationResultsStudentTip: Listed below are placements in courses which you have received due to the mentioned central allocation and for which you have not left the respective course or have been deregistered. Thus placements you have been informed of already may be listed again. AllocationResultStudentRegistrationTip: You were enrolled in the course mentioned above in Uni2work. AllocationResultsStudentRegistrationTip: You were enrolled in the courses mentioned above in Uni2work. +AllocationResultsStudentConsultFaq n@Int: If you have questions or remarks, please also take into account the information on the following #{pluralEN n "page" "pages"}: FavouriteVisited: Visited FavouriteParticipant: Your courses FavouriteManual: Favourites FavouriteCurrent: Current course +======= +>>>>>>> Stashed changes FavouritesUnavailableTip: Quick Actions for this course are currently not available. - - UserSimplifiedFeaturesOfStudyCsv: Simplified features of study UserSimplifiedFeaturesOfStudyCsvTip: Should field of study, degree, and semester be exported in separate columns for ease of processing? If so only the field of study associated by the user with their course registration will be exported. @@ -959,30 +601,6 @@ ShortSexFemale: f ShortSexNotApplicable: N/A MenuLanguage: Language -LanguageChanged: Language changed successfully - -RFC1766: RFC1766 language code - -TermShort: Shorthand -TermCourseCount: Courses -TermStart: Semester start -TermEnd: Semester end -TermStartMustMatchName: Shorthand number does not match semester start. -TermEndMustBeAfterStart: Semester end may not be before semester start. -TermLectureEndMustBeAfterStart: Lecture start may not be after lecture end. -TermStartMustBeBeforeLectureStart: Semester start must be before lecture start. -TermEndMustBeAfterLectureEnd: Lecture end must be before semester end. -AdminPageEmpty: This page shall provide an overview for administrators in the future. For now there are only links to important administrator-functions. -HaveCorrectorAccess sheetName: You have corrector access to #{original sheetName}. -FavouritesPlaceholder: Number of favourites -FavouritesNotNatural: Number of favourites must be a natural number! -FavouritesSemestersPlaceholder: Number of semesters -FavouritesSemestersNotNatural: Maximum number of semesters in favourites bar must be a natural number! - -ProfileTitle: Settings - -GlossaryTitle: Glossary - Applicant: Applicant Administrator: Administrator @@ -997,27 +615,12 @@ CommTutorial: Tutorial message Clone: Cloning Deficit: Deficit -MetricNoSamples: No samples -MetricName: Name -MetricValue: Value - TitleExamAutoOccurrence tid ssh csh examn: #{tid} - #{ssh} - #{csh} #{examn}: Automatic occurrence/room distribution ExamGradingPass: Passed/Failed ExamGradingGrades: Numeric grades ExamGradingMixed: Mixed -InfoLecturerCourses: Courses -InfoLecturerExercises: Course Exercises -InfoLecturerTutorials: Tutorials -InfoLecturerExams: Exams -InfoLecturerAllocations: Central allocations - -ParticipantsIntersectCourseOption tid@TermId ssh@SchoolId coursen@CourseName: #{tid} - #{ssh} - #{coursen} -ParticipantsIntersectCourses: Courses - -FaqTitle: Frequently asked questions - CourseParticipantStateIsActiveFilter: View CourseParticipantActive: Participant CourseParticipantInactive: Deregistered @@ -1061,7 +664,6 @@ InvalidCredentialsADAccountLockedOut: Account disabled by intruder detection ExamCloseModeSeparate: Seperately ExamCloseModeOnFinished: With publication of achievements ExamCloseModeOnFinishedHidden: With publication of achievements (hidden) -ExamCloseMode: Exam closure UrlFieldCouldNotParseAbsolute: Could not parse as an absolute URL diff --git a/messages/uniworx/uniworx_new/categories/admin/de-de-formal.msg b/messages/uniworx/uniworx_new/categories/admin/de-de-formal.msg index 2640ec799..35fc90912 100644 --- a/messages/uniworx/uniworx_new/categories/admin/de-de-formal.msg +++ b/messages/uniworx/uniworx_new/categories/admin/de-de-formal.msg @@ -73,3 +73,6 @@ StudyFeatureNameInference: Studiengangschlüssel-Inferenz StudyFeatureParentInference: Unterstudiengang-Inferenz StudyFeatureInferenceNoNameConflicts: Keine Konflikte beobachtet StudyFeatureInferenceNameConflictsHeading: Studiengangseinträge mit beobachteten Konflikten + +AdminHeading: Administration +AdminPageEmpty: Diese Seite soll eine Übersichtsseite für Administratoren werden. Aktuell finden sich hier nur Links zu wichtigen Administrator-Funktionalitäten. diff --git a/messages/uniworx/uniworx_new/categories/admin/en-eu.msg b/messages/uniworx/uniworx_new/categories/admin/en-eu.msg index 81f920df7..d1ec42096 100644 --- a/messages/uniworx/uniworx_new/categories/admin/en-eu.msg +++ b/messages/uniworx/uniworx_new/categories/admin/en-eu.msg @@ -73,3 +73,6 @@ StudyFeatureNameInference: Infer field of study mapping StudyFeatureParentInference: Infer field of study parent relation StudyFeatureInferenceNoNameConflicts: No observed conflicts StudyFeatureInferenceNameConflictsHeading: Fields of study with observed conflicts + +AdminHeading: Administration +AdminPageEmpty: This page shall provide an overview for administrators in the future. For now there are only links to important administrator-functions. diff --git a/messages/uniworx/uniworx_new/categories/authorization/de-de-formal.msg b/messages/uniworx/uniworx_new/categories/authorization/de-de-formal.msg new file mode 100644 index 000000000..43ab8581a --- /dev/null +++ b/messages/uniworx/uniworx_new/categories/authorization/de-de-formal.msg @@ -0,0 +1,89 @@ +UnauthorizedNotAuthenticatedInDifferentApproot: Sie konnten im Kontext einer separierten Domain (z.B. zum sicheren Download von Dateien) nicht authentifiziert werden. Vermutlich haben Sie kein oder ein abgelaufenes Token verwendet. Sie können versuchen auf die gewünschte Resource mit einem neu generierten Download-Link zuzugreifen. +Unauthorized: Sie haben hierfür keine explizite Berechtigung. +UnauthorizedAnd l@Text r@Text: (#{l} UND #{r}) +UnauthorizedOr l@Text r@Text: (#{l} ODER #{r}) +UnauthorizedNot r@Text: #{r} +UnauthorizedI18nMismatch: Es wurden unterschiedliche Authorisierungs-Ergebnisse für verschiedene Sprachen berechnet +UnauthorizedNoToken: Ihrer Anfrage war kein Authorisierungs-Token beigefügt. +UnauthorizedTokenExpired: Ihr Authorisierungs-Token ist abgelaufen. +UnauthorizedTokenNotStarted: Ihr Authorisierungs-Token ist noch nicht gültig. +UnauthorizedTokenInvalid: Ihr Authorisierungs-Token konnte nicht verarbeitet werden. +UnauthorizedTokenInvalidRoute: Ihr Authorisierungs-Token ist auf dieser Unterseite nicht gültig. +UnauthorizedTokenInvalidNoAuthority: Ihr Authorisierungs-Token nennt keine Nutzer:innen, auf deren Rechten es basiert. +UnauthorizedTokenInvalidAuthority: Ihr Authorisierungs-Token basiert auf den Rechten eines Nutzers/einer Nutzerin, der nicht mehr existiert. +UnauthorizedTokenInvalidAuthorityGroup: Ihr Authorisierungs-Token basiert auf den Rechten einer Gruppe von Nutzer:innen, die nicht mehr existiert. +UnauthorizedTokenInvalidAuthorityValue: Ihr Authorisierungs-Token basiert auf Rechten, deren Spezifikation nicht interpretiert werden konnte. +UnauthorizedTokenInvalidImpersonation: Ihr Authorisierungs-Token enthält die Anweisung sich als ein Nutzer:in auszugeben, dies ist jedoch nicht allen Benutzer:innen, auf deren Rechten ihr Authorisierungs-Token basiert, erlaubt. +UnauthorizedToken404: Authorisierungs-Tokens können nicht auf Fehlerseiten ausgewertet werden. +UnauthorizedSiteAdmin: Sie sind nicht System-weiter Administrator:in. +UnauthorizedSchoolAdmin: Sie sind nicht als Administrator:in für dieses Institut eingetragen. +UnauthorizedAdminEscalation: Sie sind nicht Administrator:in für alle Institute, für die dieser Nutzer/diese Nutzerin Administrator:in oder Veranstalter:in ist. +UnauthorizedExamOffice: Sie sind nicht mit Prüfungsverwaltung beauftragt. +UnauthorizedExamExamOffice: Es existieren keine Prüfungsergebnisse für Nutzer:innen, für die Sie mit der Prüfungsverwaltung beauftragt sind. +UnauthorizedSchoolExamOffice: Sie sind nicht mit Prüfungsverwaltung für dieses Institut beauftragt. +UnauthorizedSystemExamOffice: Sie sind nicht mit systemweiter Prüfungsverwaltung beauftragt. +UnauthorizedExternalExamExamOffice: Es existieren keine Prüfungsergebnisse für Nutzer:innen, für die Sie mit der Prüfungsverwaltung beauftragt sind. +UnauthorizedEvaluation: Sie sind nicht mit der Kursumfragenverwaltung beauftragt. +UnauthorizedAllocationAdmin: Sie sind nicht mit der Administration von Zentralanmeldungen beauftragt. +UnauthorizedSchoolLecturer: Sie sind nicht als Veranstalter:in für dieses Institut eingetragen. +UnauthorizedLecturer: Sie sind nicht als Veranstalter:in für diese Veranstaltung eingetragen. +UnauthorizedAllocationLecturer: Sie sind nicht als Veranstalter:in für eine Veranstaltung dieser Zentralanmeldung eingetragen. +UnauthorizedCorrector: Sie sind nicht als Korrektor:in für diese Veranstaltung eingetragen. +UnauthorizedSheetCorrector: Sie sind nicht als Korrektor:in für dieses Übungsblatt eingetragen. +UnauthorizedExamCorrector: Sie sind nicht als Korrektor:in für diese Prüfung eingetragen. +UnauthorizedCorrectorAny: Sie sind nicht als Korrektor:in für eine Veranstaltung eingetragen. +UnauthorizedRegistered: Sie sind nicht als Teilnehmer:in für diese Veranstaltung registriert. +UnauthorizedRegisteredExam: Sie sind nicht als Teilnehmer:in für diese Prüfung registriert. +UnauthorizedRegisteredAnyExam: Sie sind nicht als Teilnehmer:in für eine Prüfung registriert. +UnauthorizedAllocationRegistered: Sie sind nicht als Teilnehmer:in für diese Zentralanmeldung registriert. +UnauthorizedExamResult: Sie haben keine Ergebnisse in dieser Prüfung. +UnauthorizedExamOccurrenceRegistration: Anmeldung zur Prüfung erfolgt nicht inkl. Raum/Termin. +UnauthorizedExternalExamResult: Sie haben keine Ergebnisse in dieser Prüfung. +UnauthorizedParticipant: Angegebener Benutzer/Angegebene Benutzerin ist nicht als Teilnehmer:in dieser Veranstaltung registriert. +UnauthorizedParticipantSelf: Sie sind nicht Teilnehmer:in dieser Veranstaltung. +UnauthorizedApplicant: Angegebener Benutzer/Angegebene Benutzerin hat sich nicht für diese Veranstaltung beworben. +UnauthorizedApplicantSelf: Sie sind nicht Bewerber:in für diese Veranstaltung. +UnauthorizedCourseTime: Dieser Kurs ist momentan nicht freigegeben. +UnauthorizedCourseRegistrationTime: Dieser Kurs erlaubt momentan keine Anmeldungen. +UnauthorizedAllocationRegisterTime: Diese Zentralanmeldung erlaubt momentan keine Bewerbungen. +UnauthorizedSheetTime: Dieses Übungsblatt ist momentan nicht freigegeben. +UnauthorizedApplicationTime: Diese Bewerbung ist momentan nicht freigegeben. +UnauthorizedMaterialTime: Dieses Material ist momentan nicht freigegeben. +UnauthorizedTutorialTime: Dieses Tutorium erlaubt momentan keine Anmeldungen. +UnauthorizedCourseNewsTime: Diese Nachricht ist momentan nicht freigegeben. +UnauthorizedExamTime: Diese Prüfung ist momentan nicht freigegeben. +UnauthorizedSubmissionOwner: Sie sind an dieser Abgabe nicht beteiligt. +UnauthorizedSubmissionPersonalisedSheetFiles: Ihnen wurden keine personalisierten Übungsblatt-Dateien zugeteilt und die Abgabe ist ohne diese nicht gestattet. +UnauthorizedSubmissionRated: Diese Abgabe ist noch nicht korrigiert. +UnauthorizedSubmissionCorrector: Sie sind nicht Korrektor:in für diese Abgabe. +UnauthorizedUserSubmission: Nutzer:innen dürfen für dieses Übungsblatt keine Abgaben erstellen. +UnauthorizedCorrectorSubmission: Korrektor:innen dürfen für dieses Übungsblatt keine Abgaben erstellen. +DeprecatedRoute: Diese Ansicht ist obsolet und könnte in Zukunft entfallen. +UnfreeMaterials: Die Materialien für diese Veranstaltung sind nicht allgemein freigegeben. +UnauthorizedWrite: Sie haben hierfür keine Schreibberechtigung +UnauthorizedSystemMessageTime: Diese Systemnachricht ist noch nicht oder nicht mehr einsehbar. +UnauthorizedSystemMessageAuth: Diese Systemnachricht ist nur für angemeldete Benutzer:innen einsehbar. +UnknownAuthPredicate tag@String: Authorisierungsprädikat "#{tag}" ist dem System nicht bekannt +UnauthorizedSelf: Aktueller Nutzer/Aktuelle Nutzerin ist nicht angegebener Benutzer/angegebene Benutzerin. +UnauthorizedTutorialTutor: Sie sind nicht Tutor:in für dieses Tutorium. +UnauthorizedTutorialTutorControl: Tutor:innen dürfen dieses Tutorium nicht editieren. +UnauthorizedCourseTutor: Sie sind nicht Tutor:in für diesen Kurs. +UnauthorizedTutor: Sie sind nicht Tutor:in. +UnauthorizedTutorialRegisterGroup: Sie sind bereits in einem Tutorium mit derselben Registrierungs-Gruppe. +UnauthorizedLDAP: Angegebener Nutzer/Angegebene Nutzerin meldet sich nicht mit Campus-Kennung an. +UnauthorizedPWHash: Angegebener Nutzer/Angegebene Nutzerin meldet sich nicht mit Uni2work-Kennung an. +UnauthorizedExternalExamListNotEmpty: Liste von externen Prüfungen ist nicht leer +UnauthorizedExternalExamLecturer: Sie sind nicht als Prüfer:in für diese externe Prüfung eingetragen +UnauthorizedSubmissionSubmissionGroup: Sie sind nicht Mitglied in einer der registrierten Abgabegruppen, die an dieser Abgabe beteiligt sind +UnauthorizedSheetSubmissionGroup: Sie sind nicht Mitglied in einer registrierten Abgabegruppe + +UnauthorizedAllocatedCourseRegister: Direkte Anmeldungen zum Kurs sind aufgrund einer Zentralanmeldung aktuell nicht gestattet +UnauthorizedAllocatedCourseDeregister: Abmeldungen vom Kurs sind aufgrund einer Zentralanmeldung aktuell nicht gestattet +UnauthorizedAllocatedCourseDelete: Kurse, die an einer Zentralanmeldung teilnehmen, dürfen nicht gelöscht werden +UnauthorizedWorkflowInitiate: Sie dürfen keinen neuen laufenden Workflow initiieren +UnauthorizedWorkflowWrite: Sie dürfen aktuell keinen Zustandsübergang im Workflow auslösen +UnauthorizedWorkflowRead: Der Workflow enthält aktuell keine Zustände oder Daten die Sie einsehen dürfen +UnauthorizedWorkflowInstancesNotEmpty: Es gibt Workflow Instanzen für die Sie einen neuen laufenden Workflow initiieren dürfen +UnauthorizedWorkflowWorkflowsNotEmpty: Es gibt laufende Workflows, die Sie einsehen dürfen +UnauthorizedWorkflowFiles: Sie dürfen die angegebenen Workflow-Dateien nicht im angegebenen historischen Zustand herunterladen +UnauthorizedStudent: Sie sind nicht Student:in diff --git a/messages/uniworx/uniworx_new/categories/authorization/en-eu.msg b/messages/uniworx/uniworx_new/categories/authorization/en-eu.msg new file mode 100644 index 000000000..c364aa416 --- /dev/null +++ b/messages/uniworx/uniworx_new/categories/authorization/en-eu.msg @@ -0,0 +1,89 @@ +UnauthorizedNotAuthenticatedInDifferentApproot: You could not be authenticated in the context of a separate domain (e.g. for secure downloading of files). You probably used no or an expired token. You can try to access the resource with a newly generated download link. +Unauthorized: You do not have explicit authorisation. +UnauthorizedAnd l r: (#{l} AND #{r}) +UnauthorizedOr l r: (#{l} OR #{r}) +UnauthorizedNot r: (NOT #{r}) +UnauthorizedI18nMismatch: Different authentication results were calculated for different languages +UnauthorizedNoToken: No authorisation-token was provided with your request. +UnauthorizedTokenExpired: Your authorisation-token is expired. +UnauthorizedTokenNotStarted: Your authorisation-token is not yet valid. +UnauthorizedTokenInvalid: Your authorisation-token could not be processed. +UnauthorizedTokenInvalidRoute: Your authorisation-token is not valid for this page. +UnauthorizedTokenInvalidNoAuthority: Your authorisation-token does not list any users on whose rights it is based. +UnauthorizedTokenInvalidAuthority: Your authorisation-token is based in an user's rights who does not exist anymore. +UnauthorizedTokenInvalidAuthorityGroup: Your authorisation-token is based in an user groups rights which does not exist anymore. +UnauthorizedTokenInvalidAuthorityValue: The specification of the rights in which your authorisation-token is based, could not be interpreted. +UnauthorizedTokenInvalidImpersonation: Your authorisation-token contains an instruction to impersonate an user. Not all users on whose rights your token is based however are permitted to do so. +UnauthorizedToken404: Authorisation-tokens cannot be processed on error pages. +UnauthorizedSiteAdmin: You are no system-wide administrator. +UnauthorizedSchoolAdmin: You are no administrator for this department. +UnauthorizedAdminEscalation: You aren't an administrator for all departments for which this user is an administrator. +UnauthorizedExamOffice: You are not part of an exam office. +UnauthorizedEvaluation: You are not charged with course evaluation. +UnauthorizedAllocationAdmin: You are not charged with the administration of central allocations. +UnauthorizedExamExamOffice: You are not part of the appropriate exam office for any of the participants of this exam. +UnauthorizedSchoolExamOffice: You are not part of an exam office for this school. +UnauthorizedSystemExamOffice: You are not charged with system wide exam administration +UnauthorizedExternalExamExamOffice: You are not part of the appropriate exam office for any of the participants of this exam. +UnauthorizedSchoolLecturer: You are no lecturer for this department. +UnauthorizedLecturer: You are no administrator for this course. +UnauthorizedAllocationLecturer: You are no administrator for any of the courses of this central allocation. +UnauthorizedCorrector: You are no sheet corrector for this course. +UnauthorizedSheetCorrector: You are no corrector for this sheet. +UnauthorizedExamCorrector: You are no corrector for this exam. +UnauthorizedCorrectorAny: You are no corrector for any course. +UnauthorizedRegistered: You are no participant in this course. +UnauthorizedRegisteredExam: You are not registered for this exam. +UnauthorizedRegisteredAnyExam: You are not registered for an exam. +UnauthorizedAllocationRegistered: You are no participant in this central allocation. +UnauthorizedExamResult: You have no results in this exam. +UnauthorizedExamOccurrenceRegistration: Registration for exam is not done including occurrence/room. +UnauthorizedExternalExamResult: You have no results in this exam. +UnauthorizedParticipant: The specified user is no participant of this course. +UnauthorizedParticipantSelf: You are no participant of this course. +UnauthorizedApplicant: The specified user is no applicant for this course. +UnauthorizedApplicantSelf: You are no applicant for this course. +UnauthorizedCourseTime: This course is not currently available. +UnauthorizedCourseRegistrationTime: This course does not currently allow enrollment. +UnauthorizedAllocationRegisterTime: This central allocation does not currently allow applications. +UnauthorizedSheetTime: This sheet is not currently available. +UnauthorizedApplicationTime: This allocation is not currently available. +UnauthorizedMaterialTime: This course material is not currently available. +UnauthorizedTutorialTime: This tutorial does not currently allow registration. +UnauthorizedCourseNewsTime: This news item is not currently available. +UnauthorizedExamTime: This exam is not currently available. +UnauthorizedSubmissionOwner: You are no submittor for this submission. +UnauthorizedSubmissionPersonalisedSheetFiles: You were not assigned any personalised exercise sheet files and submission is not permitted without them. +UnauthorizedSubmissionRated: This submission is not yet marked. +UnauthorizedSubmissionCorrector: You are no corrector for this submission. +UnauthorizedUserSubmission: Users may not directly submit for this exercise sheet. +UnauthorizedCorrectorSubmission: Correctors may not create submissions for this exercise sheet. +DeprecatedRoute: This view is deprecated and will be removed. +UnfreeMaterials: Course material are not publicly accessable. +UnauthorizedWrite: You do not have the write permission necessary to perform this action +UnauthorizedSystemMessageTime: This system-message is not currently available. +UnauthorizedSystemMessageAuth: This system-message is only available to logged in users. +UnknownAuthPredicate tag: Auth predicate “#{tag}” is unknown +UnauthorizedSelf: You are not the specified user. +UnauthorizedTutorialTutor: You are no tutor for this tutorial. +UnauthorizedTutorialTutorControl: Tutors may not edit this tutorial. +UnauthorizedCourseTutor: You are no tutor for this course. +UnauthorizedTutor: You are no tutor. +UnauthorizedTutorialRegisterGroup: You are already registered for a tutorial with the same registration group. +UnauthorizedLDAP: Specified user does not log in with their campus account. +UnauthorizedPWHash: Specified user does not log in with an Uni2work-account. +UnauthorizedExternalExamListNotEmpty: List of external exams is not empty +UnauthorizedExternalExamLecturer: You are not an associated person for this external exam +UnauthorizedSubmissionSubmissionGroup: You are not member in any of the submission groups for this submission +UnauthorizedSheetSubmissionGroup: You are not member in any submission group + +UnauthorizedAllocatedCourseRegister: Direct enrollment to this course is currently not allowed due to participation in a central allocation +UnauthorizedAllocatedCourseDeregister: Deregistration from this course is currently not allowed due to participation in a central allocation +UnauthorizedAllocatedCourseDelete: Courses that participate in a central allocation may not be deleted +UnauthorizedWorkflowInitiate: You currently may not initiate a new running workflow +UnauthorizedWorkflowWrite: You are currently not allowed to initiate any state transition within the workflow +UnauthorizedWorkflowRead: The workflow currently contains no states or data you are permitted to view +UnauthorizedWorkflowInstancesNotEmpty: There are workflow instances for which you are allowed to initiate a new running workflow +UnauthorizedWorkflowWorkflowsNotEmpty: There are running workflows, which you may view +UnauthorizedWorkflowFiles: You are not allowed to download the given workflow files in the given historical state +UnauthorizedStudent: You are not a student. diff --git a/messages/uniworx/uniworx_new/categories/allocation/de-de-formal.msg b/messages/uniworx/uniworx_new/categories/courses/allocation/de-de-formal.msg similarity index 100% rename from messages/uniworx/uniworx_new/categories/allocation/de-de-formal.msg rename to messages/uniworx/uniworx_new/categories/courses/allocation/de-de-formal.msg diff --git a/messages/uniworx/uniworx_new/categories/allocation/en-eu.msg b/messages/uniworx/uniworx_new/categories/courses/allocation/en-eu.msg similarity index 100% rename from messages/uniworx/uniworx_new/categories/allocation/en-eu.msg rename to messages/uniworx/uniworx_new/categories/courses/allocation/en-eu.msg diff --git a/messages/uniworx/uniworx_new/categories/courses/application/de-de-formal.msg b/messages/uniworx/uniworx_new/categories/courses/courses/application/de-de-formal.msg similarity index 100% rename from messages/uniworx/uniworx_new/categories/courses/application/de-de-formal.msg rename to messages/uniworx/uniworx_new/categories/courses/courses/application/de-de-formal.msg diff --git a/messages/uniworx/uniworx_new/categories/courses/application/en-eu.msg b/messages/uniworx/uniworx_new/categories/courses/courses/application/en-eu.msg similarity index 100% rename from messages/uniworx/uniworx_new/categories/courses/application/en-eu.msg rename to messages/uniworx/uniworx_new/categories/courses/courses/application/en-eu.msg diff --git a/messages/uniworx/uniworx_new/categories/courses/de-de-formal.msg b/messages/uniworx/uniworx_new/categories/courses/courses/de-de-formal.msg similarity index 100% rename from messages/uniworx/uniworx_new/categories/courses/de-de-formal.msg rename to messages/uniworx/uniworx_new/categories/courses/courses/de-de-formal.msg diff --git a/messages/uniworx/uniworx_new/categories/courses/en-eu.msg b/messages/uniworx/uniworx_new/categories/courses/courses/en-eu.msg similarity index 100% rename from messages/uniworx/uniworx_new/categories/courses/en-eu.msg rename to messages/uniworx/uniworx_new/categories/courses/courses/en-eu.msg diff --git a/messages/uniworx/uniworx_new/categories/courses/event/de-de-formal.msg b/messages/uniworx/uniworx_new/categories/courses/courses/event/de-de-formal.msg similarity index 100% rename from messages/uniworx/uniworx_new/categories/courses/event/de-de-formal.msg rename to messages/uniworx/uniworx_new/categories/courses/courses/event/de-de-formal.msg diff --git a/messages/uniworx/uniworx_new/categories/courses/event/en-eu.msg b/messages/uniworx/uniworx_new/categories/courses/courses/event/en-eu.msg similarity index 100% rename from messages/uniworx/uniworx_new/categories/courses/event/en-eu.msg rename to messages/uniworx/uniworx_new/categories/courses/courses/event/en-eu.msg diff --git a/messages/uniworx/uniworx_new/categories/courses/news/de-de-formal.msg b/messages/uniworx/uniworx_new/categories/courses/courses/news/de-de-formal.msg similarity index 100% rename from messages/uniworx/uniworx_new/categories/courses/news/de-de-formal.msg rename to messages/uniworx/uniworx_new/categories/courses/courses/news/de-de-formal.msg diff --git a/messages/uniworx/uniworx_new/categories/courses/news/en-eu.msg b/messages/uniworx/uniworx_new/categories/courses/courses/news/en-eu.msg similarity index 100% rename from messages/uniworx/uniworx_new/categories/courses/news/en-eu.msg rename to messages/uniworx/uniworx_new/categories/courses/courses/news/en-eu.msg diff --git a/messages/uniworx/uniworx_new/categories/exam/exam/de-de-formal.msg b/messages/uniworx/uniworx_new/categories/courses/exam/exam/de-de-formal.msg similarity index 100% rename from messages/uniworx/uniworx_new/categories/exam/exam/de-de-formal.msg rename to messages/uniworx/uniworx_new/categories/courses/exam/exam/de-de-formal.msg index b374cc4d6..c84b3dfe6 100644 --- a/messages/uniworx/uniworx_new/categories/exam/exam/de-de-formal.msg +++ b/messages/uniworx/uniworx_new/categories/courses/exam/exam/de-de-formal.msg @@ -43,8 +43,8 @@ ExamTimeTip: Nur zur Information der Studierenden, die tatsächliche Zeitangabe ExamVisibleFrom: Sichtbar ab ExamVisibleFromTip: Ohne Datum nie sichtbar und keine Anmeldung möglich ExamRegisterFrom: Anmeldung ab -ExamRegisterFromTip: Zeitpunkt ab dem sich Kursteilnehmer:innen selbständig zur Prüfung anmelden können; ohne Datum ist keine Anmeldung möglich ExamRegisterTo: Anmeldung bis +ExamRegisterFromTip: Zeitpunkt ab dem sich Kursteilnehmer:innen selbständig zur Prüfung anmelden können; ohne Datum ist keine Anmeldung möglich ExamDeregisterUntil: Abmeldung bis ExamPublishOccurrenceAssignments: Termin- bzw. Raumzuteilung den Teilnehmer:innen mitteilen um ExamPublishOccurrenceAssignmentsTip: Ab diesem Zeitpunkt können Teilnehmer:innen einsehen zu welcher Teilprüfung bzw. welchen Raum sie angemeldet sind diff --git a/messages/uniworx/uniworx_new/categories/exam/exam/en-eu.msg b/messages/uniworx/uniworx_new/categories/courses/exam/exam/en-eu.msg similarity index 100% rename from messages/uniworx/uniworx_new/categories/exam/exam/en-eu.msg rename to messages/uniworx/uniworx_new/categories/courses/exam/exam/en-eu.msg index e29929904..2b5a73e97 100644 --- a/messages/uniworx/uniworx_new/categories/exam/exam/en-eu.msg +++ b/messages/uniworx/uniworx_new/categories/courses/exam/exam/en-eu.msg @@ -43,8 +43,8 @@ ExamTimeTip: Only for informational purposes. The actual times are set for each ExamVisibleFrom: Visible from ExamVisibleFromTip: If left empty the exam is never visible and course participants may not register. ExamRegisterFrom: Register from -ExamRegisterFromTip: Start of the period in which course participants may register themselves for the exam. If left empty participants are never allowed to register. ExamRegisterTo: Register to +ExamRegisterFromTip: Start of the period in which course participants may register themselves for the exam. If left empty participants are never allowed to register. ExamDeregisterUntil: Deregister until ExamPublishOccurrenceAssignments: Publish occurrence/room-assignments ExamPublishOccurrenceAssignmentsTip: At this time participants can find out to which occurrence/room they are assigned diff --git a/messages/uniworx/uniworx_new/categories/exam/exam_office/de-de-formal.msg b/messages/uniworx/uniworx_new/categories/courses/exam/exam_office/de-de-formal.msg similarity index 100% rename from messages/uniworx/uniworx_new/categories/exam/exam_office/de-de-formal.msg rename to messages/uniworx/uniworx_new/categories/courses/exam/exam_office/de-de-formal.msg diff --git a/messages/uniworx/uniworx_new/categories/exam/exam_office/en-eu.msg b/messages/uniworx/uniworx_new/categories/courses/exam/exam_office/en-eu.msg similarity index 100% rename from messages/uniworx/uniworx_new/categories/exam/exam_office/en-eu.msg rename to messages/uniworx/uniworx_new/categories/courses/exam/exam_office/en-eu.msg diff --git a/messages/uniworx/uniworx_new/categories/exam/external_exam/de-de-formal.msg b/messages/uniworx/uniworx_new/categories/courses/exam/external_exam/de-de-formal.msg similarity index 100% rename from messages/uniworx/uniworx_new/categories/exam/external_exam/de-de-formal.msg rename to messages/uniworx/uniworx_new/categories/courses/exam/external_exam/de-de-formal.msg diff --git a/messages/uniworx/uniworx_new/categories/exam/external_exam/en-eu.msg b/messages/uniworx/uniworx_new/categories/courses/exam/external_exam/en-eu.msg similarity index 100% rename from messages/uniworx/uniworx_new/categories/exam/external_exam/en-eu.msg rename to messages/uniworx/uniworx_new/categories/courses/exam/external_exam/en-eu.msg diff --git a/messages/uniworx/uniworx_new/categories/courses/material/de-de-formal.msg b/messages/uniworx/uniworx_new/categories/courses/material/de-de-formal.msg new file mode 100644 index 000000000..f60733335 --- /dev/null +++ b/messages/uniworx/uniworx_new/categories/courses/material/de-de-formal.msg @@ -0,0 +1,32 @@ +MaterialList: Material +MaterialName: Name +MaterialType: Art +MaterialTypePlaceholder: Folien, Code, Beispiel, ... +MaterialTypeSlides: Folien +MaterialTypeCode: Code +MaterialTypeExample: Beispiel +MaterialDescription: Beschreibung +MaterialVisibleFrom: Sichtbar für Teilnehmer:innen ab +MaterialVisibleFromTip: Ohne Datum nie sichtbar für Teilnehmer:innen; leer lassen ist nur sinnvoll für unfertige Materialien oder zur ausschließlichen Verteilung an Korrektor:innen +MaterialVisibleFromEditWarning: Das Datum der Veröffentlichung liegt in der Vergangenheit und sollte nicht mehr verändert werden, da dies die Benutzer:innen verwirren könnte. +MaterialInvisible: Dieses Material ist für Teilnehmer:innen momentan unsichtbar! +MaterialFiles: Dateien +MaterialHeading materialName@MaterialName: #{materialName} +MaterialListHeading: Materialien +MaterialNewHeading: Neues Material veröffentlichen +MaterialNewTitle: Neues Material +MaterialEditHeading materialName@MaterialName: Material "#{materialName}" editieren +MaterialEditTitle materialName@MaterialName: Material "#{materialName}" editieren +MaterialSaveOk tid@TermId ssh@SchoolId csh@CourseShorthand materialName@MaterialName: Material "#{materialName}" erfolgreich gespeichert in Kurs #{tid}-#{ssh}-#{csh} +MaterialNameDup tid@TermId ssh@SchoolId csh@CourseShorthand materialName@MaterialName: Es gibt bereits Material mit Namen "#{materialName}" in diesem Kurs #{tid}-#{ssh}-#{csh} +MaterialDeleteCaption: Wollen Sie das unten aufgeführte Material wirklich löschen? +MaterialDelHasFiles count@Int64: inklusive #{count} #{pluralDE count "Datei" "Dateien"} +MaterialIsVisible: Achtung, dieses Material wurde bereits veröffentlicht. +MaterialDeleted materialName@MaterialName: Material "#{materialName}" gelöscht +MaterialArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand materialName@MaterialName: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase materialName} +MaterialVideo materialName@MaterialName: #{materialName} - Video +MaterialVideoUnsupported: Ihr Browser scheint keine eingebetten Videos zu unterstützen +MaterialVideoDownload: Herunterladen +MaterialFree: Kursmaterialien ohne Anmeldung zugänglich +AccessibleSince: Verfügbar seit +VisibleFrom: Veröffentlicht diff --git a/messages/uniworx/uniworx_new/categories/courses/material/en-eu.msg b/messages/uniworx/uniworx_new/categories/courses/material/en-eu.msg new file mode 100644 index 000000000..8c2b0c202 --- /dev/null +++ b/messages/uniworx/uniworx_new/categories/courses/material/en-eu.msg @@ -0,0 +1,32 @@ +MaterialList: Material +MaterialName: Name +MaterialType: Type +MaterialTypePlaceholder: Slides, Code, Example, ... +MaterialTypeSlides: Slides +MaterialTypeCode: Code +MaterialTypeExample: Example +MaterialDescription: Description +MaterialVisibleFrom: Visible to participants from +MaterialVisibleFromTip: Never visible to participants if left empty; leaving the date empty is only sensible for unfinished course material or when course material should be provided only to sheet correctors +MaterialVisibleFromEditWarning: This course material has already been published and should not be edited. Doing so might confuse the participants. +MaterialInvisible: This course material is currently invisible to participants! +MaterialFiles: Files +MaterialHeading materialName: #{materialName} +MaterialListHeading: Course materials +MaterialNewHeading: Publish new course material +MaterialNewTitle: New course material +MaterialEditHeading materialName: Edit course material “#{materialName}” +MaterialEditTitle materialName: Edit course material “#{materialName}” +MaterialSaveOk tid ssh csh materialName: Successfully saved “#{materialName}” for course #{tid}-#{ssh}-#{csh} +MaterialNameDup tid ssh csh materialName: Course material with the name “#{materialName}” already exists for course #{tid}-#{ssh}-#{csh} +MaterialDeleteCaption: Do you really want to delete the course material mentioned below? +MaterialDelHasFiles count: including #{count} #{pluralEN count "file" "files"} +MaterialIsVisible: Caution, this course material has already been published. +MaterialDeleted materialName: Successfully deleted course material “#{materialName}” +MaterialArchiveName tid ssh csh materialName: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase materialName} +MaterialVideo materialName: #{materialName} - Video +MaterialVideoUnsupported: Your browser does not seem to support embedded video +MaterialVideoDownload: Download +MaterialFree: Course material is publicly available. +AccessibleSince: Accessible since +VisibleFrom: Published diff --git a/messages/uniworx/uniworx_new/categories/courses/participants/de-de-formal.msg b/messages/uniworx/uniworx_new/categories/courses/participants/de-de-formal.msg new file mode 100644 index 000000000..dd0fca730 --- /dev/null +++ b/messages/uniworx/uniworx_new/categories/courses/participants/de-de-formal.msg @@ -0,0 +1,5 @@ +ParticipantsList: Kursteilnehmerlisten +ParticipantsIntersect: Überschneidung von Kursteilnehmer:innen +ParticipantsCsvName tid@TermId ssh@SchoolId: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-kursteilnehmer:innen +ParticipantsIntersectCourseOption tid@TermId ssh@SchoolId coursen@CourseName: #{tid} - #{ssh} - #{coursen} +ParticipantsIntersectCourses: Kurse diff --git a/messages/uniworx/uniworx_new/categories/courses/participants/en-eu.msg b/messages/uniworx/uniworx_new/categories/courses/participants/en-eu.msg new file mode 100644 index 000000000..36249ce41 --- /dev/null +++ b/messages/uniworx/uniworx_new/categories/courses/participants/en-eu.msg @@ -0,0 +1,5 @@ +ParticipantsList: Lists of course participants +ParticipantsIntersect: Common course participants +ParticipantsCsvName tid ssh: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-participants +ParticipantsIntersectCourseOption tid@TermId ssh@SchoolId coursen@CourseName: #{tid} - #{ssh} - #{coursen} +ParticipantsIntersectCourses: Courses diff --git a/messages/uniworx/uniworx_new/categories/sheet/de-de-formal.msg b/messages/uniworx/uniworx_new/categories/courses/sheet/de-de-formal.msg similarity index 99% rename from messages/uniworx/uniworx_new/categories/sheet/de-de-formal.msg rename to messages/uniworx/uniworx_new/categories/courses/sheet/de-de-formal.msg index 8a688020c..aafeba7dc 100644 --- a/messages/uniworx/uniworx_new/categories/sheet/de-de-formal.msg +++ b/messages/uniworx/uniworx_new/categories/courses/sheet/de-de-formal.msg @@ -128,3 +128,5 @@ SheetTypeInfoInformational: Blätter ohne Anrechnung werden nirgends angerechnet SheetTypeInfoExamPartPoints: Bei diesem Übungsblatt erreichte Punkte werden direkt auf die Punktezahl eines Prüfungsteils angerechnet. Wenn die Anzahl von über Übungsblättern erreichbaren Punkten nicht der Maximalpunktzahl des Prüfungsteils entspricht, werden die Übungsblattpunkte anhand der angegebenen Gewichtung skaliert. GroupSizeNotNatural: „Gruppengröße“ muss eine natürliche Zahl sein SheetGroupMaxGroupsize: Maximale Gruppengröße + +HaveCorrectorAccess sheetName@SheetName: Sie haben Korrektor:in-Zugang zu #{original sheetName}. diff --git a/messages/uniworx/uniworx_new/categories/sheet/en-eu.msg b/messages/uniworx/uniworx_new/categories/courses/sheet/en-eu.msg similarity index 99% rename from messages/uniworx/uniworx_new/categories/sheet/en-eu.msg rename to messages/uniworx/uniworx_new/categories/courses/sheet/en-eu.msg index c6b4307a3..419668a7c 100644 --- a/messages/uniworx/uniworx_new/categories/sheet/en-eu.msg +++ b/messages/uniworx/uniworx_new/categories/courses/sheet/en-eu.msg @@ -128,3 +128,5 @@ SheetTypeInfoExamPartPoints: Points achieved in this exercise sheet will be dire SheetTypeInfoInformational: Sheets marked "informational" do not counted anywhere. They are marked only as feedback for participants. GroupSizeNotNatural: “Maximum group size” needs to be a natural number SheetGroupMaxGroupsize: Maximum group size + +HaveCorrectorAccess sheetName: You have corrector access to #{original sheetName}. diff --git a/messages/uniworx/uniworx_new/categories/submission/de-de-formal.msg b/messages/uniworx/uniworx_new/categories/courses/submission/de-de-formal.msg similarity index 100% rename from messages/uniworx/uniworx_new/categories/submission/de-de-formal.msg rename to messages/uniworx/uniworx_new/categories/courses/submission/de-de-formal.msg diff --git a/messages/uniworx/uniworx_new/categories/submission/en-eu.msg b/messages/uniworx/uniworx_new/categories/courses/submission/en-eu.msg similarity index 100% rename from messages/uniworx/uniworx_new/categories/submission/en-eu.msg rename to messages/uniworx/uniworx_new/categories/courses/submission/en-eu.msg diff --git a/messages/uniworx/uniworx_new/categories/tutorial/de-de-formal.msg b/messages/uniworx/uniworx_new/categories/courses/tutorial/de-de-formal.msg similarity index 100% rename from messages/uniworx/uniworx_new/categories/tutorial/de-de-formal.msg rename to messages/uniworx/uniworx_new/categories/courses/tutorial/de-de-formal.msg diff --git a/messages/uniworx/uniworx_new/categories/tutorial/en-eu.msg b/messages/uniworx/uniworx_new/categories/courses/tutorial/en-eu.msg similarity index 100% rename from messages/uniworx/uniworx_new/categories/tutorial/en-eu.msg rename to messages/uniworx/uniworx_new/categories/courses/tutorial/en-eu.msg diff --git a/messages/uniworx/uniworx_new/categories/health/de-de-formal.msg b/messages/uniworx/uniworx_new/categories/health/de-de-formal.msg new file mode 100644 index 000000000..a4a31a673 --- /dev/null +++ b/messages/uniworx/uniworx_new/categories/health/de-de-formal.msg @@ -0,0 +1,9 @@ +HealthReport: Instanz-Zustand +HealthMatchingClusterConfig: Cluster-geteilte Konfiguration ist aktuell +HealthHTTPReachable: Cluster kann an der erwarteten URL über HTTP erreicht werden +HealthLDAPAdmins: Anteil der Administrator:innen, die im LDAP-Verzeichnis gefunden werden können +HealthSMTPConnect: SMTP-Server kann erreicht werden +HealthWidgetMemcached: Memcached-Server liefert Widgets korrekt aus +HealthActiveJobExecutors: Anteil der job-workers, die neue Befehle annehmen +InstanceIdentification: Instanz-Identifikation +InstanceId: Instanz-Nummer diff --git a/messages/uniworx/uniworx_new/categories/health/en-eu.msg b/messages/uniworx/uniworx_new/categories/health/en-eu.msg new file mode 100644 index 000000000..18cd82b0d --- /dev/null +++ b/messages/uniworx/uniworx_new/categories/health/en-eu.msg @@ -0,0 +1,9 @@ +HealthReport: Health report +HealthMatchingClusterConfig: Cluster config matches +HealthHTTPReachable: Cluster can be reached under the expected URL via HTTP +HealthLDAPAdmins: Proportion of administrators that were found in the LDAP directory +HealthSMTPConnect: SMTP server is reachable +HealthWidgetMemcached: Memcached server is serving widgets correctly +HealthActiveJobExecutors: Proportion of job workers accepting new jobs +InstanceIdentification: Instance identification +InstanceId: Instance id diff --git a/messages/uniworx/uniworx_new/categories/help/de-de-formal.msg b/messages/uniworx/uniworx_new/categories/help/de-de-formal.msg index 718d8c4ea..0ecb7c430 100644 --- a/messages/uniworx/uniworx_new/categories/help/de-de-formal.msg +++ b/messages/uniworx/uniworx_new/categories/help/de-de-formal.msg @@ -10,3 +10,9 @@ HelpSubject: Betreff HelpRequest: Supportanfrage/Verbesserungsvorschlag HelpSent: Ihre Supportanfrage wurde weitergeleitet. AdditionalFaqs: Weitere häufig gestellte Fragen +HelpName: Name +HelpTitle : Hilfe +HelpSendLastError: Letzte Fehlermeldung anhängen +HelpError: Letzte Fehlermeldung +HelpErrorYamlFilename mailId@MailObjectId: fehlermeldung-#{toPathPiece mailId}.yaml +HelpErrorOrRequestRequired: Bitte geben Sie entweder eine Supportanfrage bzw. einen Verbesserungsvorschlag an oder hängen Sie die letzte Fehlermeldung an diff --git a/messages/uniworx/uniworx_new/categories/help/en-eu.msg b/messages/uniworx/uniworx_new/categories/help/en-eu.msg index 1694c79e5..519df67a0 100644 --- a/messages/uniworx/uniworx_new/categories/help/en-eu.msg +++ b/messages/uniworx/uniworx_new/categories/help/en-eu.msg @@ -10,3 +10,9 @@ HelpSubject: Subject HelpRequest: Support request / Suggestion HelpSent: Your support request has been sent. AdditionalFaqs: More frequently asked questions +HelpName: Name +HelpTitle: Support +HelpSendLastError: Attach last error message +HelpError: Last error message +HelpErrorYamlFilename mailId: error-#{toPathPiece mailId}.yaml +HelpErrorOrRequestRequired: Please attach either the last error message or submit a support request or a suggestion diff --git a/messages/uniworx/uniworx_new/categories/info/de-de-formal.msg b/messages/uniworx/uniworx_new/categories/info/de-de-formal.msg new file mode 100644 index 000000000..3bd6539c5 --- /dev/null +++ b/messages/uniworx/uniworx_new/categories/info/de-de-formal.msg @@ -0,0 +1,14 @@ +HeadingLegal: Rechtliche Informationen +InfoHeading: Informationen +InfoLecturerTitle: Hinweise für Veranstalter:innen +InfoLecturerCourses: Veranstaltungen +InfoLecturerExercises: Übungsbetrieb +InfoLecturerTutorials: Tutorien +InfoLecturerExams: Prüfungen +InfoLecturerAllocations: Zentralanmeldungen +LecturerInfoTooltipNew: Neues Feature +LecturerInfoTooltipProblem: Feature mit bekannten Problemen +LecturerInfoTooltipPlanned: Geplantes Feature +LecturerInfoTooltipNewU2W: Unterschied zu UniWorX +GlossaryTitle: Begriffsverzeichnis +FaqTitle: Häufig gestellte Fragen diff --git a/messages/uniworx/uniworx_new/categories/info/en-eu.msg b/messages/uniworx/uniworx_new/categories/info/en-eu.msg new file mode 100644 index 000000000..ee8c27dc8 --- /dev/null +++ b/messages/uniworx/uniworx_new/categories/info/en-eu.msg @@ -0,0 +1,14 @@ +HeadingLegal: Legal +InfoHeading: Information +InfoLecturerTitle: Information for lecturers +InfoLecturerCourses: Courses +InfoLecturerExercises: Course Exercises +InfoLecturerTutorials: Tutorials +InfoLecturerExams: Exams +InfoLecturerAllocations: Central allocations +LecturerInfoTooltipNew: New feature +LecturerInfoTooltipProblem: Feature with known issues +LecturerInfoTooltipPlanned: Planned feature +LecturerInfoTooltipNewU2W: Unlike UniWorX +GlossaryTitle: Glossary +FaqTitle: Frequently asked questions diff --git a/messages/uniworx/uniworx_new/categories/metrics/de-de-formal.msg b/messages/uniworx/uniworx_new/categories/metrics/de-de-formal.msg new file mode 100644 index 000000000..b60f5fad6 --- /dev/null +++ b/messages/uniworx/uniworx_new/categories/metrics/de-de-formal.msg @@ -0,0 +1,4 @@ +TitleMetrics: Metriken +MetricNoSamples: Keine Messwerte +MetricName: Name +MetricValue: Wert diff --git a/messages/uniworx/uniworx_new/categories/metrics/en-eu.msg b/messages/uniworx/uniworx_new/categories/metrics/en-eu.msg new file mode 100644 index 000000000..08ae106f4 --- /dev/null +++ b/messages/uniworx/uniworx_new/categories/metrics/en-eu.msg @@ -0,0 +1,4 @@ +TitleMetrics: Metrics +MetricNoSamples: No samples +MetricName: Name +MetricValue: Value diff --git a/messages/uniworx/uniworx_new/categories/news/de-de-formal.msg b/messages/uniworx/uniworx_new/categories/news/de-de-formal.msg new file mode 100644 index 000000000..5cf6fadc3 --- /dev/null +++ b/messages/uniworx/uniworx_new/categories/news/de-de-formal.msg @@ -0,0 +1,16 @@ +NewsHeading: Aktuelles +SystemMessageLastChangedAt time@Text: Zuletzt geändert: #{time} +NewsOpenAllocations: Offene Zentralanmeldungen +NewsUpcomingSheets: Anstehende Übungsblätter +NewsUpcomingExams: Bevorstehende Prüfungen +NewsHideHiddenSystemMessages: Versteckte Nachrichten nicht mehr anzeigen +NewsShowHiddenSystemMessages: Versteckte Nachrichten anzeigen +NewsExamOccurrenceRoomIsUnset: — +NewsExamOccurrenceRoomIsHidden: Raum wird nur Teilnehmer:innen angezeigt +NewsExamRegistered: Zur Prüfung angemeldet +NewsExamNotRegistered: Nicht zur Prüfung angemeldet +Deadline: Abgabe +Done: Eingereicht +SubmissionNew: Abgabe anlegen +NoUpcomingSheetDeadlines: Keine anstehenden Übungsblätter +NoUpcomingExams difftime@Text: In den nächsten #{difftime} gibt es keine Prüfungen oder ablaufende Prüfungsanmeldungen in Ihren Kursen diff --git a/messages/uniworx/uniworx_new/categories/news/en-eu.msg b/messages/uniworx/uniworx_new/categories/news/en-eu.msg new file mode 100644 index 000000000..553604ab1 --- /dev/null +++ b/messages/uniworx/uniworx_new/categories/news/en-eu.msg @@ -0,0 +1,16 @@ +NewsHeading: News +SystemMessageLastChangedAt time: Last changed: #{time} +NewsOpenAllocations: Active central allocations +NewsUpcomingSheets: Upcoming exercise sheets +NewsUpcomingExams: Upcoming exams +NewsHideHiddenSystemMessages: Don't show hidden news items +NewsShowHiddenSystemMessages: Show hidden news items +NewsExamOccurrenceRoomIsUnset: — +NewsExamOccurrenceRoomIsHidden: Room is only displayed to participants registered for this occurrence/room +NewsExamRegistered: Registered for the exam +NewsExamNotRegistered: Not registered for the exam +Deadline: Deadline +Done: Submitted +SubmissionNew: Create submission +NoUpcomingSheetDeadlines: No upcoming sheets +NoUpcomingExams difftime: No exams for your courses occur or allow registration in the next #{difftime} diff --git a/messages/uniworx/uniworx_new/categories/school/de-de-formal.msg b/messages/uniworx/uniworx_new/categories/school/de-de-formal.msg new file mode 100644 index 000000000..67e234587 --- /dev/null +++ b/messages/uniworx/uniworx_new/categories/school/de-de-formal.msg @@ -0,0 +1,19 @@ +HeadingSchoolList: Institute +SchoolShort: Kürzel +SchoolName: Name +SchoolLdapOrganisations: Assoziierte LDAP-Fragmente +SchoolLdapOrganisationsTip: Beim Login via LDAP werden dem Nutzer/der Nutzerin alle Institute zugeordnet deren assoziierte LDAP-Fragmente im Eintrag des Nutzer/der Nutzerin gefunden werden +SchoolLdapOrganisationMissing: LDAP-Fragment wird benötigt +SchoolExamMinimumRegisterBeforeStart: Minimale Tage zwischen Anmeldebeginn und Termin für Prüfungen +SchoolExamMinimumRegisterBeforeStartTip: Wenn angegeben werden Dozierende gezwungen Anmeldezeitraum und Prüfungstermin stets zusammen einzustellen. +SchoolExamMinimumRegisterDuration: Minimale Anmeldedauer für Prüfungen +SchoolExamMinimumRegisterDurationTip: Wenn angegeben werden Dozierende daran gehindert Anmeldefristen von weniger als der minimalen Dauer für ihre Prüfungen einzustellen. +SchoolExamRequireModeForRegistration: Prüfungsmodus erforderlich für Anmeldung +SchoolExamRequireModeForRegistrationTip: Sollen Dozierende gezwungen werden Prüfungsmodus und Anmeldefrist stets zusammen einzustellen? +SchoolExamDiscouragedModes: Prüfungsmodi mit Warnung +ExamCloseMode: Prüfungs-Abschluss +SchoolUpdated ssh@SchoolId: #{ssh} erfolgreich angepasst +SchoolTitle ssh@SchoolId: Institut „#{ssh}“ +TitleSchoolNew: Neues Institut anlegen +SchoolCreated ssh@SchoolId: #{ssh} erfolgreich angelegt +SchoolExists ssh@SchoolId: Institut „#{ssh}“ existiert bereits diff --git a/messages/uniworx/uniworx_new/categories/school/en-eu.msg b/messages/uniworx/uniworx_new/categories/school/en-eu.msg new file mode 100644 index 000000000..c9f280e6d --- /dev/null +++ b/messages/uniworx/uniworx_new/categories/school/en-eu.msg @@ -0,0 +1,19 @@ +HeadingSchoolList: Departments +SchoolShort: Shorthand +SchoolName: Name +SchoolLdapOrganisations: Associated LDAP fragments +SchoolLdapOrganisationsTip: When logging in users are associated with any departments whose associated LDAP fragments are found in the users LDAP entry +SchoolLdapOrganisationMissing: LDAP-fragment is required +SchoolExamMinimumRegisterBeforeStart: Minimum number of days between start of registration period and start of exams +SchoolExamMinimumRegisterBeforeStartTip: If specified course administrators will be forced to specify the start of the registration period and the start of the exam at the same time. +SchoolExamMinimumRegisterDuration: Minimum duration of registration period for exams +SchoolExamMinimumRegisterDurationTip: If specified course administrators will be prevented from setting a registration period of less than the specified number of days. +SchoolExamRequireModeForRegistration: Exam design required for registration +SchoolExamRequireModeForRegistrationTip: Should course administrators be forced to fully specify their exam design when setting a registration period? +SchoolExamDiscouragedModes: Exam designs to warn against +ExamCloseMode: Exam closure +SchoolUpdated ssh: Successfully edited #{ssh} +SchoolTitle ssh: Department „#{ssh}“ +TitleSchoolNew: Neues Institut anlegen +SchoolCreated ssh: Successfully created #{ssh} +SchoolExists ssh: A department named „#{ssh}“ already exists diff --git a/messages/uniworx/uniworx_new/categories/send/send_notifications/de-de-formal.msg b/messages/uniworx/uniworx_new/categories/send/send_notifications/de-de-formal.msg new file mode 100644 index 000000000..cd12b3c7f --- /dev/null +++ b/messages/uniworx/uniworx_new/categories/send/send_notifications/de-de-formal.msg @@ -0,0 +1,143 @@ +#allocation.hs + templates in scope +MailSubjectAllocationStaffRegister allocationSchool@SchoolId allocation@AllocationName: Sie können nun Kurse für die Zentralameldung #{allocationSchool}: „#{allocation}“ registrieren +MailSubjectAllocationStaffRegisterMultiple n@Int: Sie können nun Kurse für #{n} Zentralameldungen registrieren +MailSubjectAllocationRegister allocationSchool@SchoolId allocation@AllocationName: Es kann sich nun für Kurse der Zentralameldung #{allocationSchool}: „#{allocation}“ beworben werden +MailSubjectAllocationRegisterMultiple n@Int: Es kann sich nun für Kurse für #{n} Zentralanmeldungen beworben werden +MailSubjectAllocationAllocation allocationSchool@SchoolId allocation@AllocationName: Sie können nun Bewerbungen für ihre Kurse in der Zentralanmeldung #{allocationSchool}: „#{allocation}“ bewerten +MailSubjectAllocationAllocationMultiple n@Int: Sie können nun Bewerbungen für ihre Kurse in #{n} Zentralanmeldungen bewerten +MailSubjectAllocationUnratedApplications allocationSchool@SchoolId allocation@AllocationName: Es stehen noch Bewertungen zu Bewerbungen für ihre Kurse in der Zentralanmeldung #{allocationSchool}: „#{allocation}“ aus +MailSubjectAllocationUnratedApplicationsMultiple n@Int: Es stehen noch Bewertungen zu Bewerbungen für ihre Kurse in #{n} Zentralanmeldungen aus +MailSubjectAllocationNewCourse allocation@AllocationName: Es wurde ein zusätzlicher Kurs zur Zentralanmeldung „#{allocation}” eingetragen +MailSubjectAllocationResults allocation@AllocationName: Plätze für Zentralanmeldung „#{allocation}“ wurden verteilt +AllocationResultLecturer csh@CourseShorthand count@Int64 count2@Int64: #{count} Teilnehmer:innen (von insgesamt #{count2}) für #{csh} +AllocationResultLecturerAll csh@CourseShorthand count@Int64: #{count} Teilnehmer:innen für #{csh} +AllocationResultLecturerNone csh@CourseShorthand: Keine Teilnehmer:innen für #{csh} +MailAllocationStaffRegisterIntroMultiple n@Int: Sie können nun Kurse für die folgenden #{n} Zentralameldungen registrieren: +MailAllocationStaffRegisterNewCourse: Sie können auf der unten aufgeführten Seite neue Kurse in Uni2work anlegen. Hierbei haben Sie die Möglichkeit anzugeben, dass der Kurs an einer Zentralanmeldung teilnimmt. +MailAllocationStaffRegisterDeadline n@Int deadline@Text: Bitte beachten Sie, dass alle Kurse, die an #{pluralDE n "dieser Zentralanmeldung" "diesen Zentralanmeldungen"} teilnehmen, bis #{deadline} eingetragen sein müssen. +MailAllocationStaffRegisterDeadlineMultiple: Bitte beachten Sie, dass alle Kurse, die an einer dieser Zentralanmeldungen teilnehmen, bis Ende der jeweiligen Regstrierungsphase (siehe unten) eingetragen sein müssen. +MailAllocationStaffRegisterDeadlineSingle deadline@Text: Registrierungsphase endet #{deadline} +MailAllocationStaffRegisterDeadlineSingleNothing: Aktuell kein Ende der Registrierungsphase festgelegt +MailAllocationSchoolAndName allocationSchool@SchoolId allocation@AllocationName: #{allocationSchool}: „#{allocation}“ +CourseNew: Neuen Kurs anlegen +MailAllocationRegisterIntroMultiple n@Int: Es kann sich nun für Kurse für die folgenden #{n} Zentralanmeldungen beworben werden: +MailAllocationRegister n@Int: Es kann sich nun, auf #{pluralDE n "der unten aufgeführten Seite" "den unten aufgeführten Seiten"}, für alle Kurse der #{pluralDE n "Zentralanmeldung" "Zentralanmeldungen"} jeweils einzeln beworben werden. +MailAllocationRegisterDeadline deadline@Text: Bitte beachten Sie, dass alle Bewerbungen bis #{deadline} eingegangen sein müssen. +MailAllocationRegisterDeadlineMultiple: Bitte beachten Sie, dass alle Bewerbungen bis Ende der jeweiligen Bewerbungsphase (siehe unten) eingegangen sein müssen. +MailAllocationRegisterDeadlineSingle deadline@Text: Bewerbungsphase endet #{deadline} +MailAllocationRegisterDeadlineSingleNothing: Aktuell kein Ende der Bewerbungsphase festgelegt +MailAllocationAllocationIntroMultiple n@Int: Sie können nun Bewerbungen für ihre Kurse in #{n} Zentralanmeldungen bewerten: +MailAllocationAllocation n@Int: Sie können nun auf den unten aufgeführten Seiten Bewerbungen, die im Rahmen der #{pluralDE n "Zentralanmeldung" "Zentralanmeldungen"} an ihre Kurse gestellt wurden, bewerten. Die Bewertungen werden bei der Vergabe der Plätze berücksichtigt. +MailAllocationApplicationsMayChange deadline@Text: Bitte beachten Sie, dass Studierende noch bis #{deadline} Bewerbungen stellen, verändern und zurückziehen können. Bewerbungen, die sich nach ihrer Bewertung noch verändern, müssen neu bewertet werden. +MailAllocationApplicationsRegisterDeadline deadline@Text: Bewerbungsphase endet #{deadline} +MailAllocationApplicationsRegisterDeadlineNothing: Aktuell kein Ende der Bewerbungsphase festgelegt +MailAllocationApplicationsMayChangeMultiple: Bitte beachten Sie, dass Studierende noch bis Ende der Bewerbungsphase (siehe unten) der jeweiligen Zentralanmeldung Bewerbungen stellen, verändern und zurückziehen können. Bewerbungen, die sich nach ihrer Bewertung noch verändern, müssen neu bewertet werden. +MailAllocationAllocationDeadline deadline@Text: Bitte beachten Sie, dass alle Bewertungen bis #{deadline} erfolgt sein müssen. +MailAllocationApplicationsAllocationDeadline deadline@Text: Bewertungsphase endet #{deadline} +MailAllocationApplicationsAllocationDeadlineNothing: Aktuell keine Ende der Bewertungsphase festgelegt +MailAllocationAllocationDeadlineMultiple: Bitte beachten Sie, dass alle Bewertungen bis Ende der Bewertungsphase (siehe unten) erfolgt sein müssen. +MailAllocationUnratedApplicationsIntroMultiple n@Int: Es stehen noch Bewertungen zu Bewerbungen für ihre Kurse in #{n} Zentralanmeldungen aus: +MailAllocationUnratedApplications n@Int: Für die unten aufgeführten Kurse liegen Bewerbungen vor, die im Rahmen der #{pluralDE n "Zentralanmeldung" "Zentralanmeldungen"} an den jeweiligen Kurs gestellt wurden, die entweder noch nicht bewertet wurden oder die nach der Bewertung noch verändert wurden und deswegen neu bewertet werden müssen. +MailAllocationUnratedApplicationsCount i@Natural: #{i} #{pluralDE i "Bewerbung" "Bewerbungen"} +AllocationResultsLecturer: Im Rahmen der oben genannten Zentralanmeldung wurden Plätze zugewiesen, wie folgt: +AllocationResultsLecturerSubstituteCoursesWarning: Bitte konfigurieren Sie so bald wie möglich einen Zeitrahmen in dem Sie bereit sind etwaige Nachrücker in den folgenden Kursen zu akzeptieren: +AllocationResultsStudent: Sie haben Plätze erhalten in: +AllocationNoResultsStudent: Sie haben leider keine Plätze erhalten. +AllocationResultStudent csh@CourseShorthand: Sie haben einen Platz in #{csh} erhalten. +AllocationResultsTip: Die folgenden Informationen entsprechen dem aktuellen Stand der Zentralanmeldung und können sich, z.B. durch die Verteilung von Plätzen an Nachrücker, noch ändern. Über zukünftige Änderungen, die Sie betreffen, werden Sie gesondert informiert. +AllocationResultsStudentTip: Unten aufgeführt sind alle Plätze, die Sie im Rahmen der genannten Zentralanmeldung erhalten haben und von denen Sie seit dem weder abgemeldet wurden, noch sich selbst abgemeldet haben. Plätze, über die Sie ggf. bereits informiert wurden, können also erneut aufgeführt sein. +AllocationResultStudentRegistrationTip: Sie sind zu oben genanntem Kurs in Uni2work angemeldet. +AllocationResultsStudentRegistrationTip: Sie sind zu den oben genannten Kursen in Uni2work angemeldet. +MailAllocationNewCourseTip: Es wurde der folgende Kurs zur Zentralanmeldung eingetragen: +MailAllocationNewCourseEditApplicationsHere: Sie können Ihre Bewerbung(en) hier anpassen: +MailAllocationNewCourseApplyHere: Sie können sich hier bewerben: + +#correctionsAssigned.hs + templates +MailSubjectCorrectionsAssigned csh@CourseShorthand sheetName@SheetName: Ihnen wurden Korrekturen zu #{sheetName} in #{csh} zugeteilt +MailCorrectionsAssignedIntro courseName@Text termDesc@Text sheetName@SheetName n@Int: #{n} #{pluralDE n "Abgabe wurde" "Abgaben wurden"} Ihnen zur Korrektur für #{sheetName} im Kurs #{courseName} (#{termDesc}) zugeteilt. +MailCorrectionsTitle: Zugewiesene Korrekturen + +#correctionsNotDistributed.hs + templates +MailSubjectSubmissionsUnassigned csh@CourseShorthand sheetName@SheetName: Abgaben zu #{sheetName} in #{csh} konnten nicht verteilt werden +MailSubmissionsUnassignedIntro n@Int courseName@Text termDesc@Text sheetName@SheetName: #{n} Abgaben zu #{sheetName} im Kurs #{courseName} (#{termDesc}) konnten nicht automatisiert verteilt werden. + +#courseRegistered.hs + templates +MailSubjectCourseRegistered csh@CourseShorthand: Sie wurden zu #{csh} angemeldet +MailSubjectCourseRegisteredOther displayName@Text csh@CourseShorthand: #{displayName} wurde zu #{csh} angemeldet +MailCourseRegisteredIntro courseName@Text termDesc@Text: Sie wurden im Kurs #{courseName} (#{termDesc}) angemeldet. +MailCourseRegisteredIntroOther displayName@Text courseName@Text termDesc@Text: #{displayName} wurde im Kurs #{courseName} (#{termDesc}) angemeldet. + +#ExamActive.hs + templates +MailSubjectExamRegistrationActive csh@CourseShorthand examn@ExamName: Anmeldung für #{examn} in #{csh} ist möglich +MailExamRegistrationActiveIntro courseName@Text termDesc@Text examn@ExamName: Sie können sich nun für #{examn} im Kurs #{courseName} (#{termDesc}) anmelden. +MailSubjectExamRegistrationSoonInactive csh@CourseShorthand examn@ExamName: Anmeldung für #{examn} in #{csh} ist nur noch kurze Zeit möglich +MailExamRegistrationSoonInactiveIntro courseName@Text termDesc@Text examn@ExamName: Sie können sich bald nicht mehr für #{examn} im Kurs #{courseName} (#{termDesc}) anmelden. +MailSubjectExamDeregistrationSoonInactive csh@CourseShorthand examn@ExamName: Abmeldung für #{examn} in #{csh} ist nur noch kurze Zeit möglich +MailExamDeregistrationSoonInactiveIntro courseName@Text termDesc@Text examn@ExamName: Sie können sich bald nicht mehr von #{examn} im Kurs #{courseName} (#{termDesc}) abmelden. + +#examOffice.hs + templates +MailSubjectExamOfficeExamResults coursen@CourseName examn@ExamName: Ergebnisse für #{examn} in #{coursen} sind fertiggestellt +MailExamOfficeExamResultsIntro courseName@Text termDesc@Text examn@ExamName: Ein Kursverwalter/Eine Kursverwalterin hat die Prüfungsleistungen für #{examn} im Kurs #{courseName} (#{termDesc}) freigegeben. +MailSubjectExamOfficeExamResultsChanged coursen@CourseName examn@ExamName: Ergebnisse für #{examn} in #{coursen} wurden verändert +MailExamOfficeExamResultsChangedIntro courseName@Text termDesc@Text examn@ExamName: Ein Kursverwalter/Eine Kursverwalterin hat Prüfungsleistungen für #{examn} im Kurs #{courseName} (#{termDesc}) verändert. +MailSubjectExamOfficeExternalExamResults coursen@CourseName examn@ExamName: Ergebnisse für #{examn} in #{coursen} +MailExamOfficeExternalExamResultsIntro coursen@CourseName termDesc@Text examn@ExamName: Ein Kursverwalter/Eine Kursverwalterin hat Prüfungsleistungen für #{examn} im Kurs #{coursen} (#{termDesc}) erstellt oder angepasst. + +#examResult.hs + templates +MailSubjectExamResult csh@CourseShorthand examn@ExamName: Ergebnisse für #{examn} in #{csh} wurden herausgegeben +MailExamResultIntro courseName@Text termDesc@Text examn@ExamName: Sie können nun Ihr Ergebnis für #{examn} im Kurs #{courseName} (#{termDesc}) einsehen. + +#sheetActive.hs + templates +MailSubjectSheetActive csh@CourseShorthand sheetName@SheetName: #{sheetName} in #{csh} wurde herausgegeben +MailSheetActiveIntro courseName@Text termDesc@Text sheetName@SheetName: Sie können nun #{sheetName} im Kurs #{courseName} (#{termDesc}) herunterladen. +MailSubjectSheetHint csh@CourseShorthand sheetName@SheetName: Hinweise für #{sheetName} in #{csh} wurden herausgegeben +MailSheetHintIntro courseName@Text termDesc@Text sheetName@SheetName: Sie können nun die Hinweise für #{sheetName} im Kurs #{courseName} (#{termDesc}) herunterladen. +MailSubjectSheetSolution csh@CourseShorthand sheetName@SheetName: Lösungen für #{sheetName} in #{csh} wurden herausgegeben +MailSheetSolutionIntro courseName@Text termDesc@Text sheetName@SheetName: Sie können nun die Lösungen für #{sheetName} im Kurs #{courseName} (#{termDesc}) herunterladen. + +#sheetInactive.hs + templates +MailSubjectSheetSoonInactive csh@CourseShorthand sheetName@SheetName: #{sheetName} in #{csh} kann nur noch kurze Zeit abgegeben werden +MailSheetSoonInactiveIntro courseName@Text termDesc@Text sheetName@SheetName: Abgabefrist für #{sheetName} im Kurs #{courseName} (#{termDesc}) endet in Kürze. +MailSubjectSheetInactive csh@CourseShorthand sheetName@SheetName: Abgabezeitraum für #{sheetName} in #{csh} abgelaufen +MailSheetInactiveIntro courseName@Text termDesc@Text sheetName@SheetName n@Int num@Int64: Die Abgabefrist für #{sheetName} im Kurs #{courseName} (#{termDesc}) ist beendet. Es gab #{noneOneMoreDE n "Keine Abgaben" "Nur eine Abgabe von " (toMessage n <> " Abgaben von ")}#{noneOneMoreDE num "" "einem Teilnehmer/einer Teilnehmerin" (toMessage num <> " Teilnehmer:innen")}. +MailSheetInactiveIntroNoUserSubmission courseName@Text termDesc@Text sheetName@SheetName n@Int num@Int64: Die Abgabefrist für #{sheetName} im Kurs #{courseName} (#{termDesc}) ist beendet.#{noneOneMoreDE n "" "Es gab bereits eine Abgabe von " (("Es gab bereits " <> toMessage n) <> " Abgaben von ")}#{noneOneMoreDE num "" "einem Teilnehmer/einer Teilnehmerin" (toMessage num <> " Teilnehmer:innen")}. +MailSheetInactivePseudonymsCount n@Int: Die Anzahl von Abgaben betrifft nur jene, die bereits direkt in Uni2work abgegeben haben. Es #{pluralDE n (("wurde " <> tshow n) <> " Pseudonym") (("wurden " <> tshow n) <> " Pseudonyme")} generiert. +MailSheetInactiveParticipantsCount n@Int: Es #{pluralDE n "ist aktuell" "sind aktuell"} #{n} Teilnehmer zum Kurs angemeldet. + +#submissionEdited.hs +templates +MailSubjectSubmissionEdited csh@CourseShorthand shn@SheetName: Ihre Abgabe für #{shn} im Kurs #{csh} wurde verändert +MailSubmissionEditedIntro coursen@CourseName shn@SheetName termDesc@Text displayName@Text: #{displayName} hat Ihre Abgabe für #{shn} im Kurs #{coursen} (#{termDesc}) verändert. +MailSubjectSubmissionUserCreated csh@CourseShorthand shn@SheetName: Sie wurden als Mitabgebende:r zu einer Abgabe für #{shn} im Kurs #{csh} hinzugefügt +MailSubjectSubmissionUserCreatedOther displayName@Text csh@CourseShorthand shn@SheetName: Es wurde ein Mitabgebender/eine Mitabgebende zu einer Abgabe für #{shn} im Kurs #{csh} hinzugefügt +MailSubmissionUserCreatedIntro coursen@CourseName shn@SheetName termDesc@Text: Sie wurden als Mitabgebende:r zu einer Abgabe für #{shn} im Kurs #{coursen} (#{termDesc}) hinzugefügt. +MailSubmissionUserCreatedOtherIntro displayName@UserDisplayName coursen@CourseName shn@SheetName termDesc@Text: #{displayName} wurde als Mitabgebender zu einer Abgabe für #{shn} im Kurs #{coursen} (#{termDesc}) hinzugefügt. +MailSubjectSubmissionUserDeleted csh@CourseShorthand shn@SheetName: Sie wurden als Mitabgebende:r von Ihrer Abgabe für #{shn} im Kurs #{csh} entfernt +MailSubjectSubmissionUserDeletedOther displayName@Text csh@CourseShorthand shn@SheetName: Es wurde ein Mitabgebender/eine Mitabgebende von einer Abgabe für #{shn} im Kurs #{csh} entfernt +MailSubmissionUserDeletedIntro coursen@CourseName shn@SheetName termDesc@Text: Sie wurden als Mitabgebende:r von Ihrer Abgabe für #{shn} im Kurs #{coursen} (#{termDesc}) entfernt. +MailSubmissionUserDeletedOtherIntro displayName@UserDisplayName coursen@CourseName shn@SheetName termDesc@Text: #{displayName} wurde als Mitabgebende:r von einer Abgabe für #{shn} im Kurs #{coursen} (#{termDesc}) entfernt. + +#submissionRated.hs + templates +MailSubjectSubmissionRated csh@CourseShorthand: Ihre #{csh}-Abgabe wurde korrigiert +MailSubmissionRatedIntro courseName@Text termDesc@Text: Ihre Abgabe im Kurs #{courseName} (#{termDesc}) wurde korrigiert. +AchievedOf achieved@Points possible@Points: #{achieved} von #{possible} +Passed: Bestanden +NotPassed: Nicht bestanden + +#userAuthModeUpdate.hs + templates +MailSubjectUserAuthModeUpdate: Ihr Uni2work-Login +UserAuthModePWHashChangedToLDAP: Sie können sich nun mit Ihrer Campus-Kennung in Uni2work einloggen +UserAuthModeLDAPChangedToPWHash: Sie können sich nun mit einer Uni2work-internen Kennung in Uni2work einloggen +AuthPWHashTip: Sie müssen nun das mit "Uni2work-Login" beschriftete Login-Formular verwenden. Stellen Sie bitte sicher, dass Sie ein Passwort gesetzt haben, bevor Sie versuchen sich anzumelden. +PasswordResetEmailIncoming: Einen Link um ihr Passwort zu setzen bzw. zu ändern bekommen Sie, aus Sicherheitsgründen, in einer separaten E-Mail. + +#userRightsUpdate.hs + templates +MailSubjectUserRightsUpdate name@Text: Berechtigungen für #{name} aktualisiert +MailSubjectUserSystemFunctionsUpdate name@Text: Berechtigungen für #{name} aktualisiert +MailUserRightsIntro name@Text email@UserEmail: #{name} <#{email}> hat folgende Uni2work Berechtigungen: +MailNoLecturerRights: Sie haben derzeit keine Dozent:innen-Rechte. +MailLecturerRights n@Int: Als Dozent:in dürfen Sie Veranstaltungen innerhalb #{pluralDE n "Ihres Instituts" "Ihrer Institute"} anlegen. +MailUserSystemFunctionsIntro name@Text email@UserEmail: #{name} <#{email}> hat folgende Uni2work nicht-institutsbezogene Berechtigungen: +MailUserSystemFunctionsNoFunctions: Keine + +#utils.hs + templates +MailEditNotifications: Benachrichtigungen ein-/ausschalten diff --git a/messages/uniworx/uniworx_new/categories/send/send_notifications/en-eu.msg b/messages/uniworx/uniworx_new/categories/send/send_notifications/en-eu.msg new file mode 100644 index 000000000..5293887c4 --- /dev/null +++ b/messages/uniworx/uniworx_new/categories/send/send_notifications/en-eu.msg @@ -0,0 +1,143 @@ +#allocation.hs + templates in scope +MailSubjectAllocationStaffRegister allocationSchool allocation: You can now register courses for the central allocation #{allocationSchool}: “#{allocation}” +MailSubjectAllocationStaffRegisterMultiple n: You can now register courses for #{n} central allocations +MailSubjectAllocationRegister allocationSchool allocation: Applications can now be made for courses of the central allocation #{allocationSchool}: “#{allocation}” +MailSubjectAllocationRegisterMultiple n: Applications can now be made for courses of #{n} central allocations +MailSubjectAllocationAllocation allocationSchool allocation: You can now rate applications for your courses that participate in the central allocation #{allocationSchool}: “#{allocation}” +MailSubjectAllocationAllocationMultiple n: You can now rate applications for your courses that participate in #{n} central allocations +MailSubjectAllocationUnratedApplications allocationSchool allocation: There are unrated applications for you courses participating in the central allocation #{allocationSchool}: “#{allocation}” +MailSubjectAllocationUnratedApplicationsMultiple n: There are unrated applications for your courses participating in #{n} central allocations +MailSubjectAllocationNewCourse allocation: A new course was added to the central allocation “#{allocation}” +AllocationResultLecturer csh count count2: #{count} #{pluralEN count "participant" "participants"} (of #{count2}) for #{csh} +AllocationResultLecturerAll csh count: #{count} #{pluralEN count "participant" "participants"} for #{csh} +AllocationResultLecturerNone csh: No participants for #{csh} +MailAllocationStaffRegisterIntroMultiple n: You can now register courses for the following #{n} central allocations: +MailAllocationStaffRegisterNewCourse: You can create new courses in Uni2work on the site listed below. While doing so you can specify that the course should participate in a central allocation. +MailAllocationStaffRegisterDeadline n deadline: Please consider that all courses, that are to participate in #{pluralEN n "this central allocation" "these central allocations"}, must be registered before #{deadline}. +MailAllocationStaffRegisterDeadlineMultiple: Please consider that alle courses, that are to participate in these central allocations, must be registered before the ends of their respective course registration periods (see below). +MailAllocationStaffRegisterDeadlineSingle deadline: Course Registration period ends on #{deadline} +MailAllocationStaffRegisterDeadlineSingleNothing: Currently no end of course registration period configured +MailAllocationSchoolAndName allocationSchool allocation: #{allocationSchool}: “#{allocation}” +CourseNew: Create new course +MailAllocationRegisterIntroMultiple n: Applications can now be made for courses of the following #{n} central allocations: +MailAllocationRegister n: Applications can now be made for each of the courses participating in the central #{pluralEN n "allocation" "allocations"} on the #{pluralEN n "page" "pages"} listed below. +MailAllocationRegisterDeadline deadline: Please consider that all applications have to be made before #{deadline}. +MailAllocationRegisterDeadlineMultiple: Please consider that all applications for courses participating in central allocations have to be made before the ends of their respective application periods (see below). +MailAllocationRegisterDeadlineSingle deadline: Application periods ends on #{deadline} +MailAllocationRegisterDeadlineSingleNothing: Currently no end of application period configured +MailAllocationAllocationIntroMultiple n: You can now rate applications for your courses that participate in #{n} central allocations: +MailAllocationAllocation n: You can now rate applications made in the context of the central #{pluralEN n "allocation" "allocations"} for your courses on the pages listed below. Ratings made will have an effect on the allocation. +MailAllocationApplicationsMayChange deadline: Please consider that applicants may change or delete their applications until #{deadline}. If an application was rated before it was changed it needs to be rated again. +MailAllocationApplicationsRegisterDeadline deadline: Application period ends on #{deadline} +MailAllocationApplicationsRegisterDeadlineNothing: Currently no end of application period configured +MailAllocationApplicationsMayChangeMultiple: Please consider that applicants may change or delete their applications until the end of the respective central allocation's application period. If an application was rated before it was changed it needs to be rated again. +MailAllocationAllocationDeadline deadline: Please consider that all ratings have to be made before #{deadline}. +MailAllocationApplicationsAllocationDeadline deadline: Rating period ends on #{deadline} +MailAllocationApplicationsAllocationDeadlineNothing: Currently no end of rating period configured +MailAllocationAllocationDeadlineMultiple: Please consider that all ratings have to be made before the end of the respective rating period (see below). +MailAllocationUnratedApplicationsIntroMultiple n: There are unrated applications for your courses participating in #{n} central allocations: +MailAllocationUnratedApplications n: For there courses listed below, there exist applications made in the context of #{pluralEN n "the central allocation" "one of the central allocations"} which have either not yet been rated or which have changed since they were rated. +MailAllocationUnratedApplicationsCount i: #{i} #{pluralDE i "application" "applications"} +MailSubjectAllocationResults allocation: Placements have been made for the central allocation “#{allocation}” +AllocationResultsLecturer: In the course of the central allocations placements have been made as follows: +AllocationResultsLecturerSubstituteCoursesWarning: Please configure a deadline up to which you are able to accept substitute registrations for the following courses as soon as possible: +AllocationResultsStudent: You have been placed in: +AllocationNoResultsStudent: Unfortunately you were not placed in any courses. +AllocationResultStudent csh: You were placed in #{csh}. +AllocationResultsTip: The following information reflect the current state of the allocation and are subject to change (e.g. when handling succession). You will be informed separately if any future changes concern you. +AllocationResultsStudentTip: Listed below are placements in courses which you have received due to the mentioned central allocation and for which you have not left the respective course or have been deregistered. Thus placements you have been informed of already may be listed again. +AllocationResultStudentRegistrationTip: You were enrolled in the course mentioned above in Uni2work. +AllocationResultsStudentRegistrationTip: You were enrolled in the courses mentioned above in Uni2work. +MailAllocationNewCourseTip: The following course was added to the central allocation: +MailAllocationNewCourseEditApplicationsHere: You can modify your application here: +MailAllocationNewCourseApplyHere: You can apply here: + +#correctionsAssigned.hs + templates +MailSubjectCorrectionsAssigned csh sheetName: You were assigned corrections for #{sheetName} of #{csh} +MailCorrectionsAssignedIntro courseName termDesc sheetName n: You were assigned #{n} #{pluralEN n "correction" "corrections"} for #{sheetName} of #{courseName} (#{termDesc}). +MailCorrectionsTitle: Assigned corrections + +#correctionsNotDistributed.hs + templates +MailSubjectSubmissionsUnassigned csh sheetName: Corrections for #{sheetName} of #{csh} could not be distributed +MailSubmissionsUnassignedIntro n courseName termDesc sheetName: #{n} corrections for #{sheetName} of the course #{courseName} (#{termDesc}) could not be automatically distributed. + +#courseRegistered.hs + templates +MailSubjectCourseRegistered csh: You were enrolled for #{csh} +MailSubjectCourseRegisteredOther displayName csh: #{displayName} was enrolled for #{csh} +MailCourseRegisteredIntro courseName termDesc: You were enrolled for the course “#{courseName}” (#{termDesc}) +MailCourseRegisteredIntroOther displayName courseName termDesc: #{displayName} was enrolled for the course “#{courseName}” (#{termDesc}). + +#examActive.hs + templates +MailSubjectExamRegistrationActive csh examn: Registration is now allowed for #{examn} of #{csh} +MailExamRegistrationActiveIntro courseName termDesc examn: You may now register for #{examn} of the course #{courseName} (#{termDesc}). +MailSubjectExamRegistrationSoonInactive csh examn: The registration period for #{examn} of #{csh} ends shortly +MailExamRegistrationSoonInactiveIntro courseName termDesc examn: Soon you will no longer be allowed to register for #{examn} of #{courseName} (#{termDesc}). +MailSubjectExamDeregistrationSoonInactive csh examn: Deregistration for #{examn} in #{csh} ends shortly +MailExamDeregistrationSoonInactiveIntro courseName termDesc examn: Soon you will no longer be allowed to deregister from #{examn} of #{courseName} (#{termDesc}). + +#examOffice.hs + templates +MailSubjectExamOfficeExamResults coursen examn: Results for #{examn} of #{coursen} are now available +MailExamOfficeExamResultsIntro courseName termDesc examn: A course administrator has made the results for #{examn} of the course #{courseName} (#{termDesc}) available. +MailSubjectExamOfficeExamResultsChanged coursen examn: Results for #{examn} of #{coursen} were changed +MailExamOfficeExamResultsChangedIntro courseName termDesc examn: A course administrator has changed exam results for #{examn} of the course #{courseName} (#{termDesc}). +MailSubjectExamOfficeExternalExamResults coursen@CourseName examn@ExamName: Results for #{examn} in #{coursen} +MailExamOfficeExternalExamResultsIntro coursen@CourseName termDesc@Text examn@ExamName: A course administrator has changed or initially made available the results for #{examn} of the course {coursen} (#{termDesc}). + +#examOffice.hs + templates +MailSubjectExamResult csh examn: Results for #{examn} in #{csh} are now available +MailExamResultIntro courseName termDesc examn: You may now view your result for #{examn} of the course #{courseName} (#{termDesc}). + +#sheetActive.hs + templates +MailSubjectSheetActive csh sheetName: #{sheetName} in #{csh} was released +MailSheetActiveIntro courseName termDesc sheetName: You may now download #{sheetName} for #{courseName} (#{termDesc}). +MailSubjectSheetHint csh sheetName: Hints for #{sheetName} in #{csh} have been released +MailSheetHintIntro courseName termDesc sheetName: You may now download the hints for #{sheetName} in #{courseName} (#{termDesc}). +MailSubjectSheetSolution csh sheetName: Solutions for #{sheetName} in #{csh} have been released +MailSheetSolutionIntro courseName termDesc sheetName: You may now download the solutions for #{sheetName} in #{courseName} (#{termDesc}). + +#sheetInactive.hs + templates +MailSubjectSheetSoonInactive csh sheetName: The submission period for #{sheetName} of #{csh} ends shortly +MailSheetSoonInactiveIntro courseName termDesc sheetName: Soon you will no longer be allowed to submit for #{sheetName} of the course #{courseName} (#{termDesc}). +MailSubjectSheetInactive csh sheetName: The submission period for #{sheetName} of #{csh} has ended +MailSheetInactiveIntro courseName termDesc sheetName n num: The submission period for #{sheetName} of the course #{courseName} (#{termDesc}) has ended. #{noneOneMoreEN num "" "One participant" (toMessage num <> " participants")}#{noneOneMoreEN n "" "" (" made " <> toMessage num)}#{noneOneMoreEN n "There were no submissions" " made one submission" " submissions"}. +MailSheetInactiveIntroNoUserSubmission courseName termDesc sheetName n num: The submission period for #{sheetName} of the course #{courseName} (#{termDesc}) has ended. #{noneOneMoreEN num "" "One participant already" (toMessage num <> " participants already")}#{noneOneMoreEN n "" "" (" made " <> toMessage num)}#{noneOneMoreEN n "" " made one submission" " submissions"}. +MailSheetInactivePseudonymsCount n: The number of submissions above accounts only for the submissions already made directly in Uni2work. #{n} #{pluralEN n "pseudonym was" "pseudonyms were"} generated. +MailSheetInactiveParticipantsCount n: There #{pluralEN n "is" "are"} currently #{n} #{pluralEN n "participant" "participants"} registered for the course. + +#submissionEdited.hs +templates +MailSubjectSubmissionEdited csh shn: Your submisson for #{shn} in #{csh} was edited +MailSubmissionEditedIntro coursen shn termDesc displayName: #{displayName} edited your submission for #{shn} in #{coursen} (#{termDesc}). +MailSubjectSubmissionUserCreated csh shn: You were added to a submission for #{shn} in #{csh} +MailSubjectSubmissionUserCreatedOther displayName csh shn: An user was added to a submission for #{shn} in #{csh} +MailSubmissionUserCreatedIntro coursen shn termDesc: You were added to a submission for #{shn} in #{coursen} (#{termDesc}). +MailSubmissionUserCreatedOtherIntro displayName coursen shn termDesc: #{displayName} was added as to a submission for #{shn} in #{coursen} (#{termDesc}). +MailSubjectSubmissionUserDeleted csh shn: You were removed from your submission for #{shn} in #{csh} +MailSubjectSubmissionUserDeletedOther displayName csh shn: An user was removed from your submission for #{shn} in #{csh} +MailSubmissionUserDeletedIntro coursen shn termDesc: You were removed from your submission for #{shn} in #{coursen} (#{termDesc}). +MailSubmissionUserDeletedOtherIntro displayName coursen shn termDesc: #{displayName} was removed from your submission for #{shn} in #{coursen} (#{termDesc}). + +#submissionRated.hs + templates +MailSubjectSubmissionRated csh: Your #{csh}-submission was marked +MailSubmissionRatedIntro courseName termDesc: Your submission for #{courseName} (#{termDesc}) was marked. +AchievedOf achieved possible: #{achieved} of #{possible} +Passed: Passed +NotPassed: Failed + +#userAuthModeUpdate.hs + templates +MailSubjectUserAuthModeUpdate: Your Uni2work login +UserAuthModePWHashChangedToLDAP: You can now log in to Uni2work using your Campus-account +UserAuthModeLDAPChangedToPWHash: You can now log in to Uni2work using your Uni2work-internal account +AuthPWHashTip: You now need to use the login form labeled "Uni2work login". Please ensure that you have already set a password when you try to log in. +PasswordResetEmailIncoming: For security reasons you will receive a link to the page on which you can set and later change your password in a separate email. + +#userRightsUpdate.hs + templates +MailSubjectUserRightsUpdate name: Permissions for #{name} changed +MailSubjectUserSystemFunctionsUpdate name: Permissions for #{name} changed +MailUserRightsIntro name email: #{name} <#{email}> now has the following permissions: +MailNoLecturerRights: You don't currently have lecturer permissions for any department. +MailLecturerRights n: As a lecturer you may create new courses within your #{pluralEN n "department" "departments"}. +MailUserSystemFunctionsIntro name email: #{name} <#{email}> now has the following, not school restricted, permissions: +MailUserSystemFunctionsNoFunctions: None + +#utils.hs + templates +MailEditNotifications: Enable/Disable notifications diff --git a/messages/uniworx/uniworx_new/categories/settings/de-de-formal.msg b/messages/uniworx/uniworx_new/categories/settings/de-de-formal.msg index 043ae6012..03693d308 100644 --- a/messages/uniworx/uniworx_new/categories/settings/de-de-formal.msg +++ b/messages/uniworx/uniworx_new/categories/settings/de-de-formal.msg @@ -84,4 +84,27 @@ BtnResetTokens: Authorisierungs-Tokens invalidieren TokensLastReset: Tokens zuletzt invalidiert ProfileNever: Nie ProfileLastLdapSynchronisation: Letzte LDAP-Synchronisation -ProfileLdapPrimaryKey: LDAP-Primärschlüssel \ No newline at end of file +ProfileLdapPrimaryKey: LDAP-Primärschlüssel + +NotificationSettingsUpdate: Benachrichtigungs-Einstellungen erfolgreich gespeichert +NotificationSettingsHeading displayName@Text: Benachrichtigungs-Einstellungen für #{displayName} +UserDisplayEmailChanged: Öffentliche E-Mail-Adresse erfolgreich gesetzt +FavouriteVisited: Kürzlich besucht +FavouriteParticipant: Ihre Kurse +FavouriteManual: Favoriten +FavouriteCurrent: Aktueller Kurs +FavouritesPlaceholder: Anzahl Favoriten +FavouritesNotNatural: Anzahl der Favoriten muss eine natürliche Zahl sein! +FavouritesSemestersPlaceholder: Anzahl Semester +FavouritesSemestersNotNatural: Anzahl der Favoriten-Semester muss eine natürliche Zahl sein! +FormAllocationNotifications: Benachrichtigungen für neue Zentralanmeldungskurse +FormAllocationNotificationsTip: Wollen Sie eine Benachrichtigung per E-Mail erhalten wenn ein neuer Kurs zur Zentralanmeldung eingetragen wird? „Ja“ und „Nein“ überschreiben die entsprechende systemweite Einstellung unter "Benachrichtigungen" +SettingsUpdate: Einstellungen erfolgreich gespeichert +TokensResetSuccess: Authorisierungs-Tokens invalidiert +ProfileTitle: Benutzereinstellungen +HeadingProfileData: Persönliche Daten +ProfileRegistered: Angemeldet +LastEditByUser: Ihre letzte Bearbeitung +SubmissionGroupName: Gruppenname +TitleChangeUserDisplayEmail: Öffentliche E-Mail-Adresse setzen +LanguageChanged: Sprache erfolgreich geändert diff --git a/messages/uniworx/uniworx_new/categories/settings/en-eu.msg b/messages/uniworx/uniworx_new/categories/settings/en-eu.msg index 2da34520e..d54ba95ef 100644 --- a/messages/uniworx/uniworx_new/categories/settings/en-eu.msg +++ b/messages/uniworx/uniworx_new/categories/settings/en-eu.msg @@ -84,4 +84,27 @@ BtnResetTokens: Invalidate tokens TokensLastReset: Tokens last reset ProfileNever: Never ProfileLastLdapSynchronisation: Last LDAP synchronisation -ProfileLdapPrimaryKey: LDAP primary key \ No newline at end of file +ProfileLdapPrimaryKey: LDAP primary key + +NotificationSettingsUpdate: Successfully updated notification settings +NotificationSettingsHeading displayName: Notification settings for #{displayName} +UserDisplayEmailChanged: Successfully set display email +FavouriteVisited: Visited +FavouriteParticipant: Your courses +FavouriteManual: Favourites +FavouriteCurrent: Current course +FavouritesPlaceholder: Number of favourites +FavouritesNotNatural: Number of favourites must be a natural number! +FavouritesSemestersPlaceholder: Number of semesters +FavouritesSemestersNotNatural: Maximum number of semesters in favourites bar must be a natural number! +FormAllocationNotifications: Notifications for new central allocation courses +FormAllocationNotificationsTip: Do you want to receive a notification if a new course is added to the central allocation? “Yes” and “No” override the system wide setting under “Notifications” +SettingsUpdate: Successfully updated settings +TokensResetSuccess: Successfully invalidated all authorisation tokens +ProfileTitle: Settings +HeadingProfileData: Personal information +ProfileRegistered: Registered +LastEditByUser: Your last edit +SubmissionGroupName: Group name +TitleChangeUserDisplayEmail: Set display email +LanguageChanged: Language changed successfully diff --git a/messages/uniworx/uniworx_new/categories/system_message/de-de-formal.msg b/messages/uniworx/uniworx_new/categories/system_message/de-de-formal.msg new file mode 100644 index 000000000..1a557c3a2 --- /dev/null +++ b/messages/uniworx/uniworx_new/categories/system_message/de-de-formal.msg @@ -0,0 +1,40 @@ +SystemMessageNewsOnly: Nur auf "Aktuelles" +SystemMessageRecordChanged: Signifikante Änderung +SystemMessageRecordChangedTip: Soll der "zuletzt geändert"-Zeitstempel gesetzt werden? Nachrichten werden auf "Aktuelles" danach sortiert und bei signifikanten Änderungen erneut als Benachrichtigung unten rechts angezeigt. +SystemMessageUnhide: "Verstecken" ignorieren +SystemMessageUnhideTip: Soll die Nachricht für Benutzer:innen, die sie aktiv versteckt haben, erneut angezeigt werden? +SystemMessageCreated: Erstellt +SystemMessageLastChanged: Zuletzt geändert +SystemMessageLastUnhide: Zuletzt un-versteckt +SystemMessageFrom: Sichtbar ab +SystemMessageTo: Sichtbar bis +SystemMessageAuthenticatedOnly: Nur angemeldet +SystemMessageSeverity: Schwere +SystemMessagePriority: Priorität +SystemMessagePriorityNegative: Priorität darf nicht negativ sein +SystemMessageId: Id +SystemMessageSummaryContent: Zusammenfassung / Inhalt +SystemMessageSummary: Zusammenfassung +SystemMessageContent: Inhalt +SystemMessageLanguage: Sprache + +SystemMessageDelete: Löschen +SystemMessageActivate: Sichtbar schalten +SystemMessageDeactivate: Unsichtbar schalten +SystemMessageTimestamp: Zeitpunkt + +SystemMessagesDeleted: System-Nachrichten gelöscht: +SystemMessagesActivated: Aktivierungszeitpunkt folgender System-Nachrichten gesetzt: +SystemMessagesDeactivated: Deaktivierungszeitpunkt folgender System-Nachrichten gesetzt: +SystemMessageEmptySelection: Keine System-Nachrichten ausgewählt +SystemMessageAdded sysMsgId@CryptoUUIDSystemMessage: System-Nachricht hinzugefügt: #{toPathPiece sysMsgId} +SystemMessageEdit: Statusmeldung anpassen +SystemMessageEditTranslations: Übersetzungen anpassen +SystemMessageAddTranslation: Übersetzung hinzufügen + +SystemMessageEditSuccess: Statusmeldung angepasst. +SystemMessageAddTranslationSuccess: Übersetzung hinzugefügt. +SystemMessageEditTranslationSuccess: Übersetzung angepasst. +SystemMessageDeleteTranslationSuccess: Übersetzung entfernt. + +RFC1766: RFC1766-Sprachcode diff --git a/messages/uniworx/uniworx_new/categories/system_message/en-eu.msg b/messages/uniworx/uniworx_new/categories/system_message/en-eu.msg new file mode 100644 index 000000000..df7c84720 --- /dev/null +++ b/messages/uniworx/uniworx_new/categories/system_message/en-eu.msg @@ -0,0 +1,40 @@ +SystemMessageNewsOnly: Only on "News" +SystemMessageRecordChanged: Signifcant change +SystemMessageRecordChangedTip: Should the "last changed"-timestamp be adjusted? News are sorted by "last changed" on "News". After a significant change news items are displayed once again as a popup in the bottom right. +SystemMessageUnhide: Ignore previously hidden +SystemMessageUnhideTip: Should the news item be display again for users that have actively hidden it? +SystemMessageCreated: Created +SystemMessageLastChanged: Last changed +SystemMessageLastUnhide: Last unhidden +SystemMessageFrom: Visible from +SystemMessageTo: Visible to +SystemMessageAuthenticatedOnly: Only logged in users +SystemMessageSeverity: Severity +SystemMessagePriority: Priority +SystemMessagePriorityNegative: Priority may not be negative +SystemMessageId: Id +SystemMessageSummaryContent: Summary / Content +SystemMessageSummary: Summary +SystemMessageContent: Content +SystemMessageLanguage: Language + +SystemMessageDelete: Delete +SystemMessageActivate: Set to be visible +SystemMessageDeactivate: Set to be invisible +SystemMessageTimestamp: Timestamp + +SystemMessagesDeleted: System messages deleted: +SystemMessagesActivated: System messages set to become visible at: +SystemMessagesDeactivated: System messages set to become invisable at: +SystemMessageEmptySelection: No system messages selected +SystemMessageAdded sysMsgId: System message added: #{toPathPiece sysMsgId} +SystemMessageEdit: Edit system message +SystemMessageEditTranslations: Edit translations +SystemMessageAddTranslation: Add translation + +SystemMessageEditSuccess: Successfully edited system message. +SystemMessageAddTranslationSuccess: Successfully added translation. +SystemMessageEditTranslationSuccess: Successfully edited translation. +SystemMessageDeleteTranslationSuccess: Successfully deleted translation. + +RFC1766: RFC1766 language code diff --git a/messages/uniworx/uniworx_new/categories/term/de-de-formal.msg b/messages/uniworx/uniworx_new/categories/term/de-de-formal.msg new file mode 100644 index 000000000..47f8b740c --- /dev/null +++ b/messages/uniworx/uniworx_new/categories/term/de-de-formal.msg @@ -0,0 +1,29 @@ +TermStartMustMatchName: Jahreszahl im Namenskürzel stimmt nicht mit Semesterbeginn überein. +TermEndMustBeAfterStart: Semester darf nicht enden, bevor es beginnt. +TermLectureEndMustBeAfterStart: Vorlesungszeit muss vor ihrem Ende anfgangen. +TermStartMustBeBeforeLectureStart: Semester muss vor der Vorlesungszeit beginnen. +TermEndMustBeAfterLectureEnd: Vorlesungszeit muss vor dem Semester enden. +TermShort: Kürzel +TermCourseCount: Kurse +TermStart: Semesteranfang +TermEnd: Semesterende +LectureStart: Beginn Vorlesungen +TermEdited tid@TermId: Semester #{tid} erfolgreich editiert. +TermNewTitle: Semester editieren/anlegen. +InvalidInput: Eingaben bitte korrigieren. +Term: Semester +TermPlaceholder: W/S + vierstellige Jahreszahl +TermStartDay: Erster Tag +TermStartDayTooltip: Üblicherweise immer 1. April oder 1. Oktober +TermEndDay: Letzter Tag +TermEndDayTooltip: Üblicherweise immer 30. September oder 31. März +TermHolidays: Feiertage +TermHolidayPlaceholder: Feiertag +TermHolidayMissing: Feiertag wird benötigt +TermLectureStart: Beginn Vorlesungen +TermLectureEnd: Ende Vorlesungen +TermLectureEndTooltip: Meistens dauer das Sommersemester 14 Wochen und das Wintersemester 15 Wochen. +TermActive: Aktiv +NumCourses num@Int64: #{num} #{pluralDE num "Kurs" "Kurse"} +TermsHeading: Semesterübersicht +TermEditHeading: Semester editieren/anlegen diff --git a/messages/uniworx/uniworx_new/categories/term/en-eu.msg b/messages/uniworx/uniworx_new/categories/term/en-eu.msg new file mode 100644 index 000000000..c3f048056 --- /dev/null +++ b/messages/uniworx/uniworx_new/categories/term/en-eu.msg @@ -0,0 +1,29 @@ +TermStartMustMatchName: Shorthand number does not match semester start. +TermEndMustBeAfterStart: Semester end may not be before semester start. +TermLectureEndMustBeAfterStart: Lecture start may not be after lecture end. +TermStartMustBeBeforeLectureStart: Semester start must be before lecture start. +TermEndMustBeAfterLectureEnd: Lecture end must be before semester end. +TermShort: Shorthand +TermCourseCount: Courses +TermStart: Semester start +TermEnd: Semester end +LectureStart: Lectures start +TermEdited tid: Successfully edited semester #{tid} +TermNewTitle: Edit/create semester +InvalidInput: Invalid input +Term: Semester +TermPlaceholder: (W|S) +TermStartDay: Starting day +TermStartDayTooltip: Usually 1st of April or 1st of October +TermEndDay: Last day +TermEndDayTooltip: Usually 30th of September or 31st of March +TermHolidays: Legal holidays +TermHolidayPlaceholder: Legal holiday +TermHolidayMissing: Holiday is required +TermLectureStart: Lectures start +TermLectureEnd: Lectures end +TermLectureEndTooltip: Summer semesters are usually 14 weeks; winter semesters 15 +TermActive: Active +NumCourses num: #{num} #{pluralEN num "course" "courses"} +TermsHeading: Semesters +TermEditHeading: Edit semester diff --git a/messages/uniworx/uniworx_new/categories/user/de-de-formal.msg b/messages/uniworx/uniworx_new/categories/user/de-de-formal.msg index fea7735b1..90826460b 100644 --- a/messages/uniworx/uniworx_new/categories/user/de-de-formal.msg +++ b/messages/uniworx/uniworx_new/categories/user/de-de-formal.msg @@ -12,3 +12,56 @@ AdminUserAssimilate: Benutzer assimilieren UserAdded: Benutzer erfolgreich angelegt UserCollision: Benutzer konnte wegen Eindeutigkeit nicht angelegt werden HeadingUserAdd: Benutzer:in anlegen + +LdapSynced: LDAP-Synchronisiert +LdapSyncedBefore: Letzte LDAP-Synchronisation vor +UserSystemFunctions: Systemweite Rollen +UserSystemFunctionsSaved: Systemweite Rollen gespeichert +UserSystemFunctionsNotChanged: Es wurden keine systemweiten Rollen angepasst +AuthPWHash pwHash@Text: Uni2work +AuthPWHashAlreadyConfigured: Nutzer:in meldet sich bereits per Uni2work-Kennung an +AuthPWHashConfigured: Nutzer:in meldet sich nun per Uni2work-Kennung an +UsersCourseSchool: Institut +ActionNoUsersSelected: Keine Benutzer:innen ausgewählt +SynchroniseLdapUserQueued n@Int: LDAP-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen +SynchroniseLdapAllUsersQueued: LDAP-Synchronisation von allen Benutzer:innen angestoßen +UserListTitle: Komprehensive Benutzerliste +AccessRightsSaved: Berechtigungen erfolgreich verändert +AccessRightsNotChanged: Berechtigungen wurden nicht verändert +AuthLDAPLookupFailed: Nutzer:in konnte aufgrund eines LDAP-Fehlers nicht nachgeschlagen werden +AuthLDAPInvalidLookup: Bestehender Nutzer/Bestehende Nutzerin konnte nicht eindeutig einem LDAP-Eintrag zugeordnet werden +AuthLDAPAlreadyConfigured: Nutzer:in meldet sich bereits per Campus-Kennung in Uni2work an +AuthLDAPConfigured: Nutzer:in meldet sich nun per Campus-Kennung in Uni2work an +AuthLDAP: Campus +PasswordResetQueued: Link zum Passwort-Zurücksetzen versandt +UserAssimilateUser: Benutzer:in +AssimilateUserNotFound: E-Mail Adresse konnte keinem Benutzer/keiner Benutzerin zugeordnet werden +AssimilateUserHaveError: Beim Assimilieren ist ein Fehler aufgetreten +AssimilateUserHaveWarnings: Beim Assimilieren wurden Warnungen ausgegeben +AssimilateUserSuccess: Benutzer:in erfolgreich assimiliert +AdminUserHeadingFor: Benutzerprofil für +UnauthorizedPasswordResetToken: Dieses Authorisierungs-Token kann nicht mehr zum Passwort ändern benutzt werden +CurrentPassword: Aktuelles Passwort +CurrentPasswordInvalid: Aktuelles Passwort ist inkorrekt +NewPassword: Neues Passwort +NewPasswordRepeat: Wiederholung +PasswordRepeatInvalid: Wiederholung stimmt nicht mit neuem Passwort überein +UserPasswordHeadingFor: Passwort ändern für +PasswordChangedSuccess: Passwort erfolgreich geändert +MailSubjectSchoolFunctionInvitation school@SchoolName renderedFunction@Text: #{renderedFunction}-Einladung für „#{school}“ +MailSchoolFunctionInviteHeading school@SchoolName renderedFunction@Text: #{renderedFunction}-Einladung für „#{school}“ +SchoolFunctionInviteExplanation renderedFunction@Text: Sie wurden eingeladen, als #{renderedFunction} für ein Institut zu wirken. Sie erhalten, nachdem Sie die Einladung annehmen, erweiterte Rechte innerhalb des Instituts. +SchoolFunctionInvitationAccepted school@SchoolName renderedFunction@Text: #{renderedFunction}-Einladung als Dozent:in für „#{school}“ angenommen +FunctionaryInviteFunction: Funktion +FunctionaryInviteSchool: Institut +FunctionaryInviteField: Einzuladende E-Mail-Adressen +FunctionaryInviteHeading: Institut-Funktionäre hinzufügen +FunctionariesInvited n@Int: #{n} #{pluralDE n "Funktionär:in" "Funktionäre"} per E-Mail eingeladen +FunctionariesAdded n@Int: #{n} #{pluralDE n "Funktionär:in" "Funktionäre"} eingetragen +AdminUserRightsHeading: Benutzerrechte +AdminUserAuthHeading: Benutzer-Authentifizierung +UserAccountDeleted name@Text: Konto für #{name} wurde gelöscht! +UserSubmissionsDeleted n@Int: #{tshow n} Abgaben wurden unwiderruflich gelöscht. +UserGroupSubmissionsKept n@Int: #{tshow n} Gruppenabgaben verbleiben in der Datenbank, aber die Zuordnung zum Benutzer/zur Benutzerin wurde gelöscht. Gruppenabgaben können dadurch zu Einzelabgaben werden, die dann mit dem letzten Benutzer/der letzten Benutzerin gelöscht werden. +UserSubmissionGroupsDeleted count@Int64: #{tshow count} benannte Abgabengruppen wurden gelöscht, da sie ohne den Nutzer/die Nutzerin leer wären. +AuthMode: Authentifizierungsmodus \ No newline at end of file diff --git a/messages/uniworx/uniworx_new/categories/user/en-eu.msg b/messages/uniworx/uniworx_new/categories/user/en-eu.msg index 0c7b70889..c6dfcdd2e 100644 --- a/messages/uniworx/uniworx_new/categories/user/en-eu.msg +++ b/messages/uniworx/uniworx_new/categories/user/en-eu.msg @@ -12,3 +12,56 @@ AdminUserAssimilate: Assimilate user UserAdded: Successfully added user UserCollision: Could not create user due to uniqueness constraint HeadingUserAdd: Add user + +LdapSynced: LDAP-synchronised +LdapSyncedBefore: Last LDAP-synchronisation before +UserSystemFunctions: System wide roles +UserSystemFunctionsSaved: Successfully saved system wide roles +UserSystemFunctionsNotChanged: No system wide roles were changed +AuthPWHash pwHash: Uni2work +AuthPWHashAlreadyConfigured: User already logs in using their Uni2work account +AuthPWHashConfigured: User now logs in using their Uni2work account +UsersCourseSchool: Department +ActionNoUsersSelected: No users selected +SynchroniseLdapUserQueued n: Triggered LDAP synchronisation of #{n} #{pluralEN n "user" "users"}. +SynchroniseLdapAllUsersQueued: Triggered LDAP synchronisation of all users +UserListTitle: Comprehensive list of users +AccessRightsSaved: Successfully updated permissions +AccessRightsNotChanged: Permissions left unchanged +AuthLDAPLookupFailed: User could not be looked up due to a LDAP error +AuthLDAPInvalidLookup: Existing user could not be uniquely matched with a LDAP entry +AuthLDAPAlreadyConfigured: User already logs in using their campus account +AuthLDAPConfigured: User now logs in using their campus account +AuthLDAP: Campus +PasswordResetQueued: Sent link to reset password +UserAssimilateUser: User +AssimilateUserNotFound: Email could not be resolved to an user +AssimilateUserHaveError: An error occurred during assimilation +AssimilateUserHaveWarnings: Warnings were ermitted during assimilation +AssimilateUserSuccess: Successfully assimilated user +AdminUserHeadingFor: Profile of +UnauthorizedPasswordResetToken: This authorisation-token may no longer be used to change passwords +CurrentPassword: Current password +CurrentPasswordInvalid: Current password is incorrect +NewPassword: New password +NewPasswordRepeat: New password (again) +PasswordRepeatInvalid: New passwords do not match +UserPasswordHeadingFor: Change password for +PasswordChangedSuccess: Successfully changed password +MailSubjectSchoolFunctionInvitation school renderedFunction: Invitation to be #{renderedFunction} for “#{school}” +MailSchoolFunctionInviteHeading school renderedFunction: Invitation to be #{renderedFunction} for “#{school}” +SchoolFunctionInviteExplanation renderedFunction: You were invited to act as #{renderedFunction} for a department. By accepting the invitation you are granted elevated rights within the department. +SchoolFunctionInvitationAccepted school renderedFunction: Successfully accepted invitation to be #{renderedFunction} for “#{school}” +FunctionaryInviteFunction: Function +FunctionaryInviteSchool: Department +FunctionaryInviteField: Email addresses to invite +FunctionaryInviteHeading: Add department functionaries +FunctionariesInvited n: Invited #{n} #{pluralEN n "functionary" "functionaries"} via email +FunctionariesAdded n: Added #{n} #{pluralEN n "functionary" "functionaries"} +AdminUserRightsHeading: User permissions +AdminUserAuthHeading: User authentication +UserAccountDeleted name: User account for #{name} was deleted! +UserSubmissionsDeleted n: #{tshow n} #{pluralEN n "submission was" "submissions were"} permanently deleted. +UserGroupSubmissionsKept n: #{tshow n} #{pluralEN n "group submission was" "group submissions were"} kept. They are no longer associated with the deleted user. Group submissions can thus become as if made by a single user. Such submissions are deleted together with their last user. +UserSubmissionGroupsDeleted count: #{tshow count} #{pluralEN count "submission group was" "submission groups were"} deleted since #{pluralEN count "it" "they"} would have become empty. +AuthMode: Authenticationmode diff --git a/messages/uniworx/uniworx_new/utils/table_column/de-de-formal.de b/messages/uniworx/uniworx_new/utils/table_column/de-de-formal.de index 5323c1dd8..6c536b1ba 100644 --- a/messages/uniworx/uniworx_new/utils/table_column/de-de-formal.de +++ b/messages/uniworx/uniworx_new/utils/table_column/de-de-formal.de @@ -53,4 +53,7 @@ TableNoFilter: Keine Einschränkung TableUserMatriculation: Matrikelnummer TableColumnStudyFeatures: Studiendaten TableSchoolShort: Kürzel -TableSchoolName: Name \ No newline at end of file +TableSchoolName: Name +TableExamRegisterFrom: Anmeldung ab +TableExamRegisterTo: Anmeldung bis +TableAction: Aktion \ No newline at end of file diff --git a/messages/uniworx/uniworx_new/utils/table_column/en-eu.msg b/messages/uniworx/uniworx_new/utils/table_column/en-eu.msg index cb7623c32..9b15fa2e4 100644 --- a/messages/uniworx/uniworx_new/utils/table_column/en-eu.msg +++ b/messages/uniworx/uniworx_new/utils/table_column/en-eu.msg @@ -53,4 +53,7 @@ TableNoFilter: No restriction TableUserMatriculation: Matriculation TableColumnStudyFeatures: Features of study TableSchoolShort: Shorthand -TableSchoolName: Name \ No newline at end of file +TableSchoolName: Name +TableExamRegisterFrom: Register from +TableExamRegisterTo: Register to +TableAction: Action \ No newline at end of file diff --git a/messages/uniworx/uniworx_new/utils/utils/de-de-formal.de b/messages/uniworx/uniworx_new/utils/utils/de-de-formal.de index 01cc04e11..28d8d6128 100644 --- a/messages/uniworx/uniworx_new/utils/utils/de-de-formal.de +++ b/messages/uniworx/uniworx_new/utils/utils/de-de-formal.de @@ -1,19 +1,19 @@ #communication.hs -RecipientCustom: Weitere Empfänger -RGCourseParticipants: Kursteilnehmer -RGCourseLecturers: Kursverwalter -RGCourseCorrectors: Korrektoren -RGCourseTutors: Tutoren -RGCourseUnacceptedApplicants: Nicht akzeptierte Bewerber +RecipientCustom: Weitere Empfänger:innen +RGCourseParticipants: Kursteilnehmer:innen +RGCourseLecturers: Kursverwalter:innen +RGCourseCorrectors: Korrektor:innen +RGCourseTutors: Tutor:innen +RGCourseUnacceptedApplicants: Nicht akzeptierte Bewerber:innen RecipientToggleAll: Alle/Keine CommCourseTestSubject customSubject@Text: [TEST] #{customSubject} UtilCommCourseSubject: Kursmitteilung -CommRecipients: Empfänger +CommRecipients: Empfänger:innen CommRecipientsTip: Sie selbst erhalten immer eine Kopie der Nachricht -CommRecipientsList: Die an Sie selbst verschickte Kopie der Nachricht wird, zu Archivierungszwecken, eine vollständige Liste aller Empfänger enthalten. Die Empfängerliste wird im CSV-Format an die E-Mail angehängt. Andere Empfänger erhalten die Liste nicht. Bitte entfernen Sie dementsprechend den Anhang bevor Sie die E-Mail weiterleiten oder anderweitig mit Dritten teilen. +CommRecipientsList: Die an Sie selbst verschickte Kopie der Nachricht wird, zu Archivierungszwecken, eine vollständige Liste aller Empfänger:innen enthalten. Die Empfängerliste wird im CSV-Format an die E-Mail angehängt. Andere Empfänger:innen erhalten die Liste nicht. Bitte entfernen Sie dementsprechend den Anhang bevor Sie die E-Mail weiterleiten oder anderweitig mit Dritten teilen. UtilEMail: E-Mail UtilMultiEmailFieldTip: Es sind mehrere, Komma-separierte, E-Mail-Adressen möglich -RGTutorialParticipants tutn@TutorialName: Tutorium-Teilnehmer (#{tutn}) +RGTutorialParticipants tutn@TutorialName: Tutorium-Teilnehmer:innen (#{tutn}) RGExamRegistered examn@ExamName: Angemeldet zur Prüfung „#{examn}“ RGSheetSubmittor shn@SheetName: Abgebende für das Übungsblatt „#{shn}“ CommSubject: Betreff @@ -65,8 +65,8 @@ InvalidDateTimeFormat: Ungültiges Datums- und Zeitformat, JJJJ-MM-TTTHH:MM[:SS] AmbiguousUTCTime: Der angegebene Zeitpunkt lässt sich nicht eindeutig zu UTC konvertieren IllDefinedUTCTime: Der angegebene Zeitpunkt lässt sich nicht zu UTC konvertieren InvalidLangFormat: Ungültiger Sprach-Code (RFC1766) -MultiUserFieldExplanationAnyUser: Dieses Eingabefeld sucht in den Adressen aller Uni2work-Benutzer. -MultiUserFieldInvitationExplanation: An Adressen, die so keinem Uni2work-Benutzer zugeordnet werden können, wird eine Einladung per E-Mail versandt. +MultiUserFieldExplanationAnyUser: Dieses Eingabefeld sucht in den Adressen aller Uni2work-Benutzer:innen. +MultiUserFieldInvitationExplanation: An Adressen, die so keinem Uni2work-Benutzer/keiner Uni2work-Benutzerin zugeordnet werden können, wird eine Einladung per E-Mail versandt. MultiUserFieldInvitationExplanationAlways: Es wird an alle Adressen, die Sie hier angeben, eine Einladung per E-Mail versandt. AmbiguousEmail: E-Mail-Adresse nicht eindeutig UtilExamResultGrade: Note @@ -103,3 +103,9 @@ CorrectionAchievedPass: Bestanden SheetGradingCount': Anzahl SheetGradingPoints': Punkte SheetGradingPassing': Bestehen + +#utils.hs +DayIsAHoliday tid@TermId name@Text date@Text: "#{name}" (#{date}) ist ein Feiertag +DayIsOutOfLecture tid@TermId name@Text date@Text: "#{name}" (#{date}) ist außerhalb der Vorlesungszeit des #{tid} +DayIsOutOfTerm tid@TermId name@Text date@Text: "#{name}" (#{date}) liegt nicht im Semester #{tid} +UnauthorizedRedirect: Die angeforderte Seite existiert nicht oder Sie haben keine Berechtigung, die angeforderte Seite zu sehen. diff --git a/messages/uniworx/uniworx_new/utils/utils/en-eu.msg b/messages/uniworx/uniworx_new/utils/utils/en-eu.msg index f8aea2de5..e10a1c253 100644 --- a/messages/uniworx/uniworx_new/utils/utils/en-eu.msg +++ b/messages/uniworx/uniworx_new/utils/utils/en-eu.msg @@ -103,3 +103,9 @@ CorrectionAchievedPass: Passed SheetGradingCount': Number SheetGradingPoints': Points SheetGradingPassing': Passing + +#utils.hs +DayIsAHoliday tid name date: “#{name}” (#{date}) is a legal holiday +DayIsOutOfLecture tid name date: “#{name}” (#{date}) is not within lecture period of #{tid} +DayIsOutOfTerm tid name date: “#{name}” (#{date}) is not within #{tid} +UnauthorizedRedirect: The requested view does not exist or you haven't the required permissions to access it. diff --git a/models/allocations.model b/models/allocations.model index e92987fc3..a7773ab3b 100644 --- a/models/allocations.model +++ b/models/allocations.model @@ -31,6 +31,7 @@ AllocationMatching fingerprint AllocationFingerprint time UTCTime log FileContentReference + deriving Generic AllocationCourse allocation AllocationId @@ -38,6 +39,7 @@ AllocationCourse minCapacity Int -- if the course would get assigned fewer than this many applicants, restart the assignment process without the course acceptSubstitutes UTCTime Maybe UniqueAllocationCourse course + deriving Generic AllocationUser allocation AllocationId @@ -45,17 +47,18 @@ AllocationUser totalCourses Word64 -- number of total allocated courses for this user must be <= than this number priority AllocationPriority Maybe UniqueAllocationUser allocation user - deriving Eq Ord Show + deriving Eq Ord Show Generic AllocationDeregister -- self-inflicted user-deregistrations from an allocated course user UserId course CourseId Maybe time UTCTime reason Text Maybe -- if this deregistration was done by proxy (e.g. the lecturer pressed the button) - deriving Eq Ord Show + deriving Eq Ord Show Generic AllocationNotificationSetting user UserId allocation AllocationId isOptOut Bool - UniqueAllocationNotificationSetting user allocation \ No newline at end of file + UniqueAllocationNotificationSetting user allocation + deriving Generic \ No newline at end of file diff --git a/models/audit.model b/models/audit.model index 4524fdaf1..f2336b3cc 100644 --- a/models/audit.model +++ b/models/audit.model @@ -5,4 +5,4 @@ TransactionLog 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` - deriving Eq Read Show Generic Typeable \ No newline at end of file + deriving Eq Read Show Generic \ No newline at end of file diff --git a/models/changelog.model b/models/changelog.model index 4cc42cb12..58ec60aa0 100644 --- a/models/changelog.model +++ b/models/changelog.model @@ -2,3 +2,4 @@ ChangelogItemFirstSeen item ChangelogItem firstSeen Day Primary item + deriving Generic diff --git a/models/config.model b/models/config.model index 5ec2357d6..202160cc7 100644 --- a/models/config.model +++ b/models/config.model @@ -3,4 +3,5 @@ ClusterConfig setting ClusterSettingsKey -- I.e. Symmetric key for encrypting database-ids for use in URLs, Symmetric key for encrypting user-sessions so they can be saved directly as a browser-cookie, Symmetric key for encrypting error messages which might contain secret information, ... value Value -- JSON-encoded value - Primary setting \ No newline at end of file + Primary setting + deriving Generic \ No newline at end of file diff --git a/models/courses.model b/models/courses.model index d64ec14ac..581704aa5 100644 --- a/models/courses.model +++ b/models/courses.model @@ -3,6 +3,7 @@ DegreeCourse json -- for which degree programmes this course is appropriate fo degree StudyDegreeId terms StudyTermsId UniqueDegreeCourse course degree terms + deriving Generic Course -- Information about a single course; contained info is always visible to all users name (CI Text) description StoredMarkup Maybe -- user-defined large Html, ought to contain module description @@ -36,6 +37,7 @@ CourseEvent time Occurrences note StoredMarkup Maybe lastChanged UTCTime default=now() + deriving Generic CourseAppInstructionFile course CourseId @@ -43,16 +45,19 @@ CourseAppInstructionFile content FileContentReference Maybe modified UTCTime UniqueCourseAppInstructionFile course title + deriving Generic CourseEdit -- who edited when a row in table "Course", kept indefinitely (might be replaced by generic Audit Table; like all ...-Edit tables) user UserId time UTCTime course CourseId + deriving Generic Lecturer -- course ownership user UserId course CourseId type LecturerType default='"lecturer"'::jsonb UniqueLecturer user course -- note: multiple lecturers per course are allowed, but no duplicated rows in this table + deriving Generic CourseParticipant -- course enrolement course CourseId user UserId @@ -61,7 +66,7 @@ CourseParticipant -- course enrolement allocated AllocationId Maybe -- participant was centrally allocated state CourseParticipantState UniqueParticipant user course - deriving Eq Ord Show + deriving Eq Ord Show Generic -- Replace the last two by the following, once an audit log is available -- CourseUserNote -- lecturers of a specific course may share a text note on each enrolled student -- course CourseId @@ -75,13 +80,16 @@ CourseUserNote -- lecturers of a specific course may share a tex user UserId note StoredMarkup -- arbitrary user-defined text; visible only to lecturer of this course UniqueCourseUserNote user course + deriving Generic CourseUserNoteEdit -- who edited a participants course note when user UserId time UTCTime note CourseUserNoteId -- PROBLEM: deleted notes have no modification date any more + deriving Generic CourseUserExamOfficeOptOut course CourseId user UserId school SchoolId UniqueCourseUserExamOfficeOptOut course user school + deriving Generic diff --git a/models/courses/applications.model b/models/courses/applications.model index 4ed26ffd7..b5c342198 100644 --- a/models/courses/applications.model +++ b/models/courses/applications.model @@ -10,6 +10,7 @@ CourseApplication allocationPriority Word64 Maybe time UTCTime default=now() ratingTime UTCTime Maybe + deriving Generic CourseApplicationFile application CourseApplicationId @@ -17,3 +18,4 @@ CourseApplicationFile content FileContentReference Maybe modified UTCTime UniqueCourseApplicationFile application title + deriving Generic diff --git a/models/courses/favourite.model b/models/courses/favourite.model index 1c5077b77..f42f5f6c4 100644 --- a/models/courses/favourite.model +++ b/models/courses/favourite.model @@ -4,7 +4,9 @@ CourseFavourite -- which user accessed which course when, only display reason FavouriteReason lastVisit UTCTime UniqueCourseFavourite user course + deriving Generic CourseNoFavourite user UserId course CourseId - UniqueCourseNoFavourite user course \ No newline at end of file + UniqueCourseNoFavourite user course + deriving Generic \ No newline at end of file diff --git a/models/courses/materials.model b/models/courses/materials.model index 3a4767ec5..d020271bc 100644 --- a/models/courses/materials.model +++ b/models/courses/materials.model @@ -12,4 +12,5 @@ MaterialFile -- a file that is part of a material distribution title FilePath content FileContentReference Maybe modified UTCTime - UniqueMaterialFile material title \ No newline at end of file + UniqueMaterialFile material title + deriving Generic \ No newline at end of file diff --git a/models/courses/news.model b/models/courses/news.model index c31312d2e..c12bbe5d7 100644 --- a/models/courses/news.model +++ b/models/courses/news.model @@ -6,9 +6,11 @@ CourseNews content StoredMarkup summary StoredMarkup Maybe lastEdit UTCTime + deriving Generic CourseNewsFile news CourseNewsId title FilePath content FileContentReference Maybe modified UTCTime - UniqueCourseNewsFile news title \ No newline at end of file + UniqueCourseNewsFile news title + deriving Generic \ No newline at end of file diff --git a/models/exam-office.model b/models/exam-office.model index ab45e3abd..0fbd7330d 100644 --- a/models/exam-office.model +++ b/models/exam-office.model @@ -3,17 +3,21 @@ ExamOfficeField field StudyTermsId forced Bool UniqueExamOfficeField office field + deriving Generic ExamOfficeUser office UserId user UserId UniqueExamOfficeUser office user + deriving Generic ExamOfficeResultSynced school SchoolId Maybe office UserId result ExamResultId time UTCTime + deriving Generic ExamOfficeExternalResultSynced school SchoolId Maybe office UserId result ExternalExamResultId - time UTCTime \ No newline at end of file + time UTCTime + deriving Generic \ No newline at end of file diff --git a/models/exams.model b/models/exams.model index 27bdba1d8..1c79e1f7f 100644 --- a/models/exams.model +++ b/models/exams.model @@ -21,6 +21,7 @@ Exam staff Text Maybe partsFrom UTCTime Maybe UniqueExam course name + deriving Generic ExamPart exam ExamId number ExamPartNumber @@ -29,54 +30,58 @@ ExamPart weight Rational UniqueExamPartNumber exam number UniqueExamPartName exam name !force - deriving Read Show Eq Ord Generic Typeable + deriving Read Show Eq Ord Generic ExamOccurrence exam ExamId name ExamOccurrenceName room RoomReference Maybe roomHidden Bool default=false - capacity Word64 + capacity Word64 Maybe start UTCTime end UTCTime Maybe description StoredMarkup Maybe UniqueExamOccurrence exam name + deriving Generic ExamRegistration exam ExamId user UserId occurrence ExamOccurrenceId Maybe time UTCTime default=now() UniqueExamRegistration exam user - deriving Eq Ord Show + deriving Eq Ord Show Generic ExamPartResult examPart ExamPartId user UserId result ExamResultPoints lastChanged UTCTime default=now() UniqueExamPartResult examPart user - deriving Eq Ord Show + deriving Eq Ord Show Generic ExamBonus exam ExamId user UserId bonus Points lastChanged UTCTime default=now() UniqueExamBonus exam user - deriving Eq Ord Show + deriving Eq Ord Show Generic ExamResult exam ExamId user UserId result ExamResultPassedGrade lastChanged UTCTime default=now() UniqueExamResult exam user - deriving Eq Ord Show + deriving Eq Ord Show Generic ExamCorrector exam ExamId user UserId UniqueExamCorrector exam user + deriving Generic ExamPartCorrector part ExamPartId corrector ExamCorrectorId UniqueExamPartCorrector part corrector + deriving Generic ExamOfficeSchool school SchoolId exam ExamId - UniqueExamOfficeSchool exam school \ No newline at end of file + UniqueExamOfficeSchool exam school + deriving Generic diff --git a/models/external-exams.model b/models/external-exams.model index 0efe62669..06d83b688 100644 --- a/models/external-exams.model +++ b/models/external-exams.model @@ -6,6 +6,7 @@ ExternalExam defaultTime UTCTime Maybe gradingMode ExamGradingMode UniqueExternalExam term school courseName examName + deriving Generic ExternalExamResult user UserId exam ExternalExamId @@ -13,12 +14,14 @@ ExternalExamResult time UTCTime lastChanged UTCTime UniqueExternalExamResult exam user - deriving Eq Ord Show + deriving Eq Ord Show Generic ExternalExamStaff user UserId exam ExternalExamId UniqueExternalExamStaff exam user + deriving Generic ExternalExamOfficeSchool school SchoolId exam ExternalExamId - UniqueExternalExamOfficeSchool exam school \ No newline at end of file + UniqueExternalExamOfficeSchool exam school + deriving Generic \ No newline at end of file diff --git a/models/files.model b/models/files.model index 9a21f75b7..eb0c3ebf3 100644 --- a/models/files.model +++ b/models/files.model @@ -3,28 +3,34 @@ FileContentEntry ix Word64 chunkHash FileContentChunkId UniqueFileContentEntry hash ix + deriving Generic FileContentChunk hash FileContentChunkReference content ByteString contentBased Bool default=false -- For Migration Primary hash + deriving Generic FileContentChunkUnreferenced hash FileContentChunkId since UTCTime UniqueFileContentChunkUnreferenced hash + deriving Generic SessionFile content FileContentReference Maybe touched UTCTime + deriving Generic FileLock content FileContentReference instance InstanceId time UTCTime + deriving Generic FileChunkLock hash FileContentChunkReference instance InstanceId - time UTCTime \ No newline at end of file + time UTCTime + deriving Generic \ No newline at end of file diff --git a/models/invitations.model b/models/invitations.model index c915d08e4..91e3ba610 100644 --- a/models/invitations.model +++ b/models/invitations.model @@ -3,4 +3,5 @@ Invitation for Value data Value expiresAt UTCTime Maybe - UniqueInvitation email for \ No newline at end of file + UniqueInvitation email for + deriving Generic \ No newline at end of file diff --git a/models/jobs.model b/models/jobs.model index 4b8cf82f2..e238f49c6 100644 --- a/models/jobs.model +++ b/models/jobs.model @@ -6,7 +6,7 @@ QueuedJob lockInstance InstanceId Maybe -- instance that has started to execute this job lockTime UTCTime Maybe -- time when execution had begun writeLastExec Bool default=false -- record successful execution to CronLastExec - deriving Eq Read Show Generic Typeable + deriving Eq Read Show Generic -- Jobs are deleted from @QueuedJob@ after they are executed successfully and recorded in @CronLastExec@ -- There is a Cron-system that, at set intervals, queries the database for work to be done in the background (i.e. if a lecturer has set a sheet's submissions to be automatically distributed and the submission deadline passed since the last check, then queue a new job to actually do the distribution) @@ -16,9 +16,11 @@ CronLastExec time UTCTime -- When was the job executed instance InstanceId -- Which uni2work-instance did the work UniqueCronLastExec job + deriving Generic TokenBucket ident TokenBucketIdent lastValue Int64 lastAccess UTCTime - Primary ident \ No newline at end of file + Primary ident + deriving Generic \ No newline at end of file diff --git a/models/mail.model b/models/mail.model index 114c37ce9..b24420e74 100644 --- a/models/mail.model +++ b/models/mail.model @@ -6,8 +6,10 @@ SentMail recipient UserId Maybe headers MailHeaders contentRef SentMailContentId + deriving Generic SentMailContent hash MailContentReference content MailContent - Primary hash \ No newline at end of file + Primary hash + deriving Generic \ No newline at end of file diff --git a/models/schools.model b/models/schools.model index af9e54889..33975b7a3 100644 --- a/models/schools.model +++ b/models/schools.model @@ -16,7 +16,9 @@ SchoolLdap school SchoolId Maybe orgUnit (CI Text) UniqueOrgUnit orgUnit + deriving Generic SchoolTerms school SchoolId terms StudyTermsId - UniqueSchoolTerms school terms \ No newline at end of file + UniqueSchoolTerms school terms + deriving Generic \ No newline at end of file diff --git a/models/sheets.model b/models/sheets.model index a4d1fac2c..92845f112 100644 --- a/models/sheets.model +++ b/models/sheets.model @@ -21,6 +21,7 @@ SheetEdit -- who edited when a row in table "Course", kept i user UserId time UTCTime sheet SheetId + deriving Generic -- For anonoymous external submissions (i.e. paper submission tracked in uni2work) -- Map pseudonyms to users injectively in the context of a single sheet; for the next sheet all-new pseudonyms need to be created @@ -31,13 +32,14 @@ SheetPseudonym user UserId UniqueSheetPseudonym sheet pseudonym UniqueSheetPseudonymUser sheet user + deriving Generic SheetCorrector -- grant corrector role to user for a sheet user UserId sheet SheetId load Load -- portion of work that will be assigned to this corrector state CorrectorState default='CorrectorNormal' -- whether a corrector is assigned his load this time (e.g. in case of sickness) UniqueSheetCorrector user sheet - deriving Show Eq Ord + deriving Show Eq Ord Generic SheetFile -- a file that is part of an exercise sheet sheet SheetId type SheetFileType -- excercise, marking, hint or solution @@ -45,6 +47,7 @@ SheetFile -- a file that is part of an exercise sheet content FileContentReference Maybe modified UTCTime UniqueSheetFile sheet type title + deriving Generic PersonalisedSheetFile sheet SheetId user UserId @@ -53,11 +56,12 @@ PersonalisedSheetFile content FileContentReference Maybe modified UTCTime UniquePersonalisedSheetFile sheet user type title - deriving Eq Ord Read Show Generic Typeable + deriving Eq Ord Read Show Typeable Generic FallbackPersonalisedSheetFilesKey course CourseId index Word24 secret ByteString generated UTCTime - UniqueFallbackPersonalisedSheetFilesKey course index \ No newline at end of file + UniqueFallbackPersonalisedSheetFilesKey course index + deriving Generic \ No newline at end of file diff --git a/models/study-features.model b/models/study-features.model index 1c0b2e111..1c9c9cb20 100644 --- a/models/study-features.model +++ b/models/study-features.model @@ -10,13 +10,14 @@ StudyFeatures -- multiple entries possible for students pursuing several degree valid Bool default=true relevanceCached UUID Maybe UniqueStudyFeatures user degree field type semester - deriving Eq Show + deriving Eq Show Generic -- UniqueUserSubject ubuser degree field -- There exists a counterexample RelevantStudyFeatures term TermId studyFeatures StudyFeaturesId UniqueRelevantStudyFeatures term studyFeatures + deriving Generic StudyDegree -- Studienabschluss key Int -- LMU-internal key @@ -24,7 +25,7 @@ StudyDegree -- Studienabschluss name Text Maybe -- description given by LDAP Primary key -- column key is used as actual DB row key -- newtype Key StudyDegree = StudyDegreeKey' { unStudyDegreeKey :: Int } - deriving Eq Show + deriving Eq Show Generic StudyTerms -- Studiengang key Int -- standardised key shorthand Text Maybe -- admin determined shorthand @@ -33,11 +34,12 @@ StudyTerms -- Studiengang defaultType StudyFieldType Maybe Primary key -- column key is used as actual DB row key -- newtype Key StudyTerms = StudyTermsKey' { unStudyTermsKey :: Int } - deriving Eq Ord Show + deriving Eq Ord Show Generic StudySubTerms child StudyTermsId parent StudyTermsId UniqueStudySubTerms child parent + deriving Generic StudyTermNameCandidate -- No one at LMU is willing and able to tell us the meaning of the keys for StudyDegrees and StudyTerms. -- Each LDAP login provides an unordered set of keys and an unordered set of plain text description with an unknown 1-1 correspondence. -- This table helps us to infer which key belongs to which plain text by recording possible combinations at login. @@ -45,14 +47,14 @@ StudyTermNameCandidate -- No one at LMU is willing and able to tell us the me incidence TermCandidateIncidence -- random id, generated once per login to associate matching pairs key Int -- a possible key for the studyTermName or studySubTermName name Text -- studyTermName as plain text from LDAP - deriving Show Eq Ord + deriving Show Eq Ord Generic StudySubTermParentCandidate incidence TermCandidateIncidence key Int parent Int - deriving Show Eq Ord + deriving Show Eq Ord Generic StudyTermStandaloneCandidate incidence TermCandidateIncidence key Int - deriving Show Eq Ord + deriving Show Eq Ord Generic diff --git a/models/submissions.model b/models/submissions.model index 618306feb..9b9b500fb 100644 --- a/models/submissions.model +++ b/models/submissions.model @@ -10,6 +10,7 @@ SubmissionEdit -- user uploads new version of their submissio user UserId Maybe -- track id, important for group submissions time UTCTime submission SubmissionId + deriving Generic SubmissionFile json -- files that are part of a submission submission SubmissionId title FilePath @@ -18,17 +19,19 @@ SubmissionFile json -- files that are part of a submission isUpdate Bool -- is this the file updated by a corrector (original will always be retained) isDeletion Bool -- only set if isUpdate is also set, but file was deleted by corrector UniqueSubmissionFile submission title isUpdate - deriving Eq Ord Read Show + deriving Eq Ord Read Show Generic SubmissionUser -- which submission belongs to whom user UserId submission SubmissionId UniqueSubmissionUser user submission -- multiple users may share same submission, in case of (ad-hoc) submission groups + deriving Generic SubmissionGroup -- pre-defined submission groups; some courses only allow pre-defined submission groups course CourseId name SubmissionGroupName UniqueSubmissionGroup course name + deriving Generic SubmissionGroupUser -- Registered submission groups, just for checking upon submission, but independent of actual SubmissionUser submissionGroup SubmissionGroupId user UserId UniqueSubmissionGroupUser submissionGroup user - deriving Eq Ord Show \ No newline at end of file + deriving Eq Ord Show Generic \ No newline at end of file diff --git a/models/system-messages.model b/models/system-messages.model index 4fed20bf1..5ba6b3c53 100644 --- a/models/system-messages.model +++ b/models/system-messages.model @@ -13,6 +13,7 @@ SystemMessage defaultLanguage Lang -- Language of @content@ and @summary@ content StoredMarkup -- Detailed message shown when clicking on the @summary@-popup or when no @summary@ is specified summary StoredMarkup Maybe + deriving Generic SystemMessageTranslation -- Translation of a @SystemMessage@ into another language; which language to choose is determined by user-sent HTTP-headers message SystemMessageId @@ -20,9 +21,11 @@ SystemMessageTranslation -- Translation of a @SystemMessage@ into another langua content StoredMarkup summary StoredMarkup Maybe UniqueSystemMessageTranslation message language + deriving Generic SystemMessageHidden message SystemMessageId user UserId time UTCTime - UniqueSystemMessageHidden user message \ No newline at end of file + UniqueSystemMessageHidden user message + deriving Generic \ No newline at end of file diff --git a/models/tutorials.model b/models/tutorials.model index d193ff5d5..a364c203c 100644 --- a/models/tutorials.model +++ b/models/tutorials.model @@ -18,8 +18,10 @@ Tutor tutorial TutorialId user UserId UniqueTutor tutorial user + deriving Generic TutorialParticipant tutorial TutorialId user UserId UniqueTutorialParticipant tutorial user - deriving Eq Ord Show \ No newline at end of file + deriving Eq Ord Show + deriving Generic \ No newline at end of file diff --git a/models/users.model b/models/users.model index a8eb73c12..707da5e2f 100644 --- a/models/users.model +++ b/models/users.model @@ -44,21 +44,25 @@ UserFunction -- Administratively assigned functions (lecturer, admin, evaluation school SchoolId function SchoolFunction UniqueUserFunction user school function + deriving Generic UserSystemFunction user UserId function SystemFunction manual Bool isOptOut Bool UniqueUserSystemFunction user function + deriving Generic UserExamOffice user UserId field StudyTermsId UniqueUserExamOffice user field + deriving Generic 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 UserGroupMember group UserGroupName @@ -67,4 +71,6 @@ UserGroupMember UniquePrimaryUserGroupMember group primary !force UniqueUserGroupMember group user + + deriving Generic diff --git a/models/workflows.model b/models/workflows.model index 7561e9c65..d68a91cee 100644 --- a/models/workflows.model +++ b/models/workflows.model @@ -2,6 +2,7 @@ SharedWorkflowGraph hash WorkflowGraphReference graph (WorkflowGraph FileReference SqlBackendKey) -- UserId Primary hash + deriving Generic WorkflowDefinition graph SharedWorkflowGraphId @@ -9,6 +10,7 @@ WorkflowDefinition name WorkflowDefinitionName instanceCategory WorkflowInstanceCategory Maybe UniqueWorkflowDefinition name scope + deriving Generic WorkflowDefinitionDescription definition WorkflowDefinitionId @@ -16,6 +18,7 @@ WorkflowDefinitionDescription title Text description StoredMarkup Maybe UniqueWorkflowDefinitionDescription definition language + deriving Generic WorkflowDefinitionInstanceDescription definition WorkflowDefinitionId @@ -23,6 +26,7 @@ WorkflowDefinitionInstanceDescription title Text description StoredMarkup Maybe UniqueWorkflowDefinitionInstanceDescription definition language + deriving Generic WorkflowInstance definition WorkflowDefinitionId Maybe @@ -31,6 +35,7 @@ WorkflowInstance name WorkflowInstanceName category WorkflowInstanceCategory Maybe UniqueWorkflowInstance name scope + deriving Generic WorkflowInstanceDescription instance WorkflowInstanceId @@ -38,9 +43,11 @@ WorkflowInstanceDescription title Text description StoredMarkup Maybe UniqueWorkflowInstanceDescription instance language + deriving Generic WorkflowWorkflow instance WorkflowInstanceId Maybe scope (WorkflowScope TermIdentifier SchoolShorthand SqlBackendKey) -- TermId, SchoolId, CourseId graph SharedWorkflowGraphId state (WorkflowState FileReference SqlBackendKey) -- UserId + deriving Generic diff --git a/package-lock.json b/package-lock.json index 7c49f8ffa..5adae3a78 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "24.9.2", + "version": "25.8.1", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 558920360..d808691cf 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "24.9.2", + "version": "25.8.1", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index a3ca91a98..3f101e185 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 24.9.2 +version: 25.8.1 dependencies: - base - yesod @@ -162,6 +162,8 @@ dependencies: - nonce - IntervalMap - haskell-src-meta + - either + - xlsx other-extensions: - GeneralizedNewtypeDeriving - IncoherentInstances diff --git a/routes b/routes index b40036b29..14332ce5d 100644 --- a/routes +++ b/routes @@ -207,7 +207,7 @@ / SubShowR GET POST !ownerANDtimeANDuser-submissionsANDsubmission-groupANDexam-registeredANDpersonalised-sheet-files !ownerANDread !correctorANDread /delete SubDelR GET POST !ownerANDtimeANDuser-submissionsANDexam-registeredANDpersonalised-sheet-files /assign SubAssignR GET POST !lecturerANDtime - /correction CorrectionR GET POST !corrector !ownerANDreadANDrated + /correction CorrectionR GET POST !corrector !ownerANDreadANDratedANDexam-time /invite SInviteR GET POST !ownerANDtimeANDuser-submissionsANDsubmission-groupANDexam-registeredANDpersonalised-sheet-files !/#SubmissionFileType SubArchiveR GET !owner !corrector !/#SubmissionFileType/*FilePath SubDownloadR GET !owner !corrector diff --git a/src/Application.hs b/src/Application.hs index caa3902bc..bcaf1edda 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -112,6 +112,9 @@ import qualified Data.IntervalMap.Strict as IntervalMap import qualified Utils.Pool as Custom +import Utils.Postgresql +import Handler.Utils.Memcached (manageMemcachedLocalInvalidations) + -- Import all relevant handler modules here. -- (HPack takes care to add new modules to our cabal file nowadays.) import Handler.News @@ -208,7 +211,7 @@ makeFoundation appSettings''@AppSettings{..} = do -- from there, and then create the real foundation. let mkFoundation :: _ -> (forall m. MonadIO m => Custom.Pool' m DBConnLabel DBConnUseState SqlBackend) -> _ - mkFoundation appSettings' appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appUploadCache appVerpSecret appAuthKey = UniWorX {..} + mkFoundation appSettings' appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey = UniWorX {..} -- The UniWorX {..} syntax is an example of record wild cards. For more -- information, see: -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html @@ -224,6 +227,7 @@ makeFoundation appSettings''@AppSettings{..} = do (error "JSONWebKeySet forced in tempFoundation") (error "ClusterID forced in tempFoundation") (error "memcached forced in tempFoundation") + (error "memcachedLocal forced in tempFoundation") (error "MinioConn forced in tempFoundation") (error "VerpSecret forced in tempFoundation") (error "AuthKey forced in tempFoundation") @@ -295,11 +299,17 @@ makeFoundation appSettings''@AppSettings{..} = do appMemcached <- for appMemcachedConf $ \memcachedConf -> do $logDebugS "setup" "Memcached" memcachedKey <- clusterSetting (Proxy :: Proxy 'ClusterMemcachedKey) `customRunSqlPool` sqlPool - memcached <- createMemcached memcachedConf + memcachedConn <- createMemcached memcachedConf when appClearCache $ do $logWarnS "setup" "Clearing memcached" - liftIO $ Memcached.flushAll memcached - return (memcachedKey, memcached) + liftIO $ Memcached.flushAll memcachedConn + return AppMemcached{..} + appMemcachedLocal <- for appMemcachedLocalConf $ \ARCConf{..} -> do + memcachedLocalARC <- initARCHandle arccMaximumGhost arccMaximumWeight + void . Prometheus.register $ arcMetrics ARCMemcachedLocal memcachedLocalARC + memcachedLocalInvalidationQueue <- newTVarIO mempty + memcachedLocalHandleInvalidations <- allocateLinkedAsync . managePostgresqlChannel appDatabaseConf ChannelMemcachedLocalInvalidation $ manageMemcachedLocalInvalidations memcachedLocalARC memcachedLocalInvalidationQueue + return AppMemcachedLocal{..} appSessionStore <- mkSessionStore appSettings'' sqlPool `customRunSqlPool` sqlPool @@ -307,14 +317,14 @@ makeFoundation appSettings''@AppSettings{..} = do conn <- Minio.connect minioConf let isBucketExists Minio.BucketAlreadyOwnedByYou = True isBucketExists _ = False - either throwM return <=< Minio.runMinioWith conn $ do + throwLeft <=< Minio.runMinioWith conn $ do handleIf isBucketExists (const $ return ()) $ Minio.makeBucket appUploadCacheBucket Nothing handleIf isBucketExists (const $ return ()) $ Minio.makeBucket appUploadTmpBucket Nothing return conn $logDebugS "Runtime configuration" $ tshow appSettings' - let foundation = mkFoundation appSettings' sqlPool smtpPool ldapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appUploadCache appVerpSecret appAuthKey + let foundation = mkFoundation appSettings' sqlPool smtpPool ldapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey -- Return the foundation $logDebugS "setup" "Done" @@ -671,7 +681,7 @@ shutdownApp app = do for_ (appSmtpPool app) destroyAllResources for_ (appLdapPool app) . mapFailover $ views _2 destroyAllResources for_ (appWidgetMemcached app) Memcached.close - for_ (appMemcached app) $ views _2 Memcached.close + for_ (appMemcached app) $ views _memcachedConn Memcached.close release . fst $ appLogger app liftIO $ threadDelay 1e6 diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index 597163cd4..e4fee5cb2 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -129,14 +129,14 @@ campusUserWith withLdap' pool mode Creds{..} = either (throwM . CampusUserLdapEr _otherwise -> throwE CampusUserAmbiguous campusUserReTest :: (MonadUnliftIO m, MonadMask m, MonadLogger m) => Failover (LdapConf, LdapPool) -> (Nano -> Bool) -> FailoverMode -> Creds site -> m (Ldap.AttrList []) -campusUserReTest pool doTest mode creds = either throwM return =<< campusUserWith (\l -> flip (withLdapFailoverReTest l) doTest) pool mode creds +campusUserReTest pool doTest mode creds = throwLeft =<< campusUserWith (\l -> flip (withLdapFailoverReTest l) doTest) pool mode creds campusUserReTest' :: (MonadMask m, MonadLogger m, MonadUnliftIO m) => Failover (LdapConf, LdapPool) -> (Nano -> Bool) -> FailoverMode -> User -> m (Maybe (Ldap.AttrList [])) campusUserReTest' pool doTest mode User{userIdent} = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUserReTest pool doTest mode (Creds apLdap (CI.original userIdent) []) campusUser :: (MonadUnliftIO m, MonadMask m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> Creds site -> m (Ldap.AttrList []) -campusUser pool mode creds = either throwM return =<< campusUserWith withLdapFailover pool mode creds +campusUser pool mode creds = throwLeft =<< campusUserWith withLdapFailover pool mode creds campusUser' :: (MonadMask m, MonadUnliftIO m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> User -> m (Maybe (Ldap.AttrList [])) campusUser' pool mode User{userIdent} diff --git a/src/CryptoID.hs b/src/CryptoID.hs index 96e022d2a..f16aee18d 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -3,6 +3,7 @@ module CryptoID ( module CryptoID + , module CryptoID.Cached , module Data.CryptoID.Poly.ImplicitNamespace , module Data.UUID.Cryptographic.ImplicitNamespace , module System.FilePath.Cryptographic.ImplicitNamespace @@ -18,6 +19,7 @@ import qualified Data.CryptoID as E import Data.CryptoID.Poly.ImplicitNamespace hiding (decrypt, encrypt) import Data.UUID.Cryptographic.ImplicitNamespace hiding (decrypt, encrypt) import System.FilePath.Cryptographic.ImplicitNamespace hiding (decrypt, encrypt) +import CryptoID.Cached import qualified Data.Text as Text @@ -28,28 +30,6 @@ import Data.Aeson.Encoding (text) import Text.Blaze (ToMarkup(..)) -import qualified Data.CryptoID.Class.ImplicitNamespace as I - - -encrypt :: forall plaintext ciphertext m. - ( I.HasCryptoID ciphertext plaintext m - , KnownSymbol (CryptoIDNamespace ciphertext plaintext) - , MonadHandler m - , Typeable ciphertext - , PathPiece plaintext - ) - => plaintext -> m (I.CryptoID ciphertext plaintext) -encrypt plain = $cachedHereBinary (toPathPiece plain) $ I.encrypt plain - -decrypt :: forall plaintext ciphertext m. - ( I.HasCryptoID ciphertext plaintext m - , MonadHandler m - , Typeable plaintext - , PathPiece ciphertext - ) - => I.CryptoID ciphertext plaintext -> m plaintext -decrypt cipher = $cachedHereBinary (toPathPiece $ ciphertext cipher) $ I.decrypt cipher - instance {-# OVERLAPPING #-} MonadThrow m => MonadCrypto (ReaderT CryptoIDKey m) where type MonadCryptoKey (ReaderT CryptoIDKey m) = CryptoIDKey diff --git a/src/CryptoID/Cached.hs b/src/CryptoID/Cached.hs new file mode 100644 index 000000000..7301e01d3 --- /dev/null +++ b/src/CryptoID/Cached.hs @@ -0,0 +1,51 @@ +module CryptoID.Cached + ( encrypt, decrypt + ) where + +import Import.NoModel + +import qualified Data.Binary as Binary + +import qualified Data.CryptoID.Class.ImplicitNamespace as I + + +newtype CryptoIDDecryption ciphertext plaintext = CryptoIDDecryption plaintext + deriving (Typeable) +newtype CryptoIDEncryption ciphertext plaintext = CryptoIDEncryption ciphertext + deriving (Typeable) + +encrypt :: forall plaintext ciphertext m. + ( I.HasCryptoID ciphertext plaintext (HandlerFor (HandlerSite m)) + , Typeable plaintext, Typeable ciphertext + , Binary plaintext, Binary ciphertext + , MonadHandler m + ) + => plaintext -> m (I.CryptoID ciphertext plaintext) +encrypt plain = liftHandler $ do + (cachedEnc :: Maybe (CryptoIDEncryption ciphertext plaintext)) <- cacheByGet cacheKey + case cachedEnc of + Nothing -> do + cID@(I.CryptoID crypt) <- I.encrypt plain + cacheBySet cacheKey (CryptoIDEncryption crypt :: CryptoIDEncryption ciphertext plaintext) + cacheBySet (toStrict $ Binary.encode crypt) (CryptoIDDecryption plain :: CryptoIDDecryption ciphertext plaintext) + return cID + Just (CryptoIDEncryption crypt) -> return $ I.CryptoID crypt + where cacheKey = toStrict $ Binary.encode plain + +decrypt :: forall plaintext ciphertext m. + ( I.HasCryptoID ciphertext plaintext (HandlerFor (HandlerSite m)) + , Typeable plaintext, Typeable ciphertext + , Binary plaintext, Binary ciphertext + , MonadHandler m + ) + => I.CryptoID ciphertext plaintext -> m plaintext +decrypt cID@(I.CryptoID crypt) = liftHandler $ do + (cachedDec :: Maybe (CryptoIDDecryption ciphertext plaintext)) <- cacheByGet cacheKey + case cachedDec of + Nothing -> do + plain <- I.decrypt cID + cacheBySet (toStrict $ Binary.encode plain) (CryptoIDEncryption crypt :: CryptoIDEncryption ciphertext plaintext) + cacheBySet cacheKey (CryptoIDDecryption plain :: CryptoIDDecryption ciphertext plaintext) + return plain + Just (CryptoIDDecryption plain) -> return plain + where cacheKey = toStrict $ Binary.encode crypt diff --git a/src/Data/Encoding/Instances.hs b/src/Data/Encoding/Instances.hs index d9bf3748d..0d332c1aa 100644 --- a/src/Data/Encoding/Instances.hs +++ b/src/Data/Encoding/Instances.hs @@ -32,3 +32,10 @@ instance Read DynEncoding where instance Ord DynEncoding where compare = comparing show + +instance Hashable DynEncoding where + hashWithSalt s = hashWithSalt s . show + + +instance NFData DynEncoding where + rnf enc = rnf $ show enc diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index ca7bb0c46..a17b30cf1 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -20,7 +20,7 @@ module Database.Esqueleto.Utils , selectExists, selectNotExists , SqlHashable , sha256 - , maybe, maybe2, maybeEq, unsafeCoalesce + , maybe, maybe2, maybeEq, guardMaybe, unsafeCoalesce , bool , max, min , abs @@ -30,7 +30,7 @@ module Database.Esqueleto.Utils , unKey , selectCountRows , selectMaybe - , day, diffDays + , day, diffDays, diffTimes , exprLift , module Database.Esqueleto.Utils.TH ) where @@ -53,6 +53,8 @@ import Crypto.Hash (Digest, SHA256) import Data.Coerce (Coercible) +import Data.Time.Clock (NominalDiffTime) + {-# ANN any ("HLint: ignore Use any" :: String) #-} {-# ANN all ("HLint: ignore Use all" :: String) #-} @@ -127,19 +129,20 @@ substring (E.ERaw p1 f1) (E.ERaw p2 f2) (E.ERaw p3 f3) , strVals <> fromiVals <> foriVals ) substring a b c = substring (construct a) (construct b) (construct c) - where construct :: E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a) - construct (E.ERaw p f) = E.ERaw E.Parens $ \info -> - let (b1, vals) = f info - build ("?", [E.PersistList vals']) = - (E.uncommas $ replicate (length vals') "?", vals') - build expr = expr - in build (E.parensM p b1, vals) - construct (E.ECompositeKey f) = - E.ERaw E.Parens $ \info -> (E.uncommas $ f info, mempty) - construct (E.EAliasedValue i _) = - E.ERaw E.Never $ E.aliasedValueIdentToRawSql i - construct (E.EValueReference i i') = - E.ERaw E.Never $ E.valueReferenceToRawSql i i' + +construct :: E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a) +construct (E.ERaw p f) = E.ERaw E.Parens $ \info -> + let (b1, vals) = f info + build ("?", [E.PersistList vals']) = + (E.uncommas $ replicate (length vals') "?", vals') + build expr = expr + in build (E.parensM p b1, vals) +construct (E.ECompositeKey f) = + E.ERaw E.Parens $ \info -> (E.uncommas $ f info, mempty) +construct (E.EAliasedValue i _) = + E.ERaw E.Never $ E.aliasedValueIdentToRawSql i +construct (E.EValueReference i i') = + E.ERaw E.Never $ E.valueReferenceToRawSql i i' and, or :: Foldable f => f (E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool) and = F.foldr (E.&&.) true @@ -338,6 +341,13 @@ maybeEq a b = E.case_ ] (E.else_ $ a E.==. b) +guardMaybe :: PersistField a + => E.SqlExpr (E.Value (Maybe a)) + -> E.SqlQuery (E.SqlExpr (E.Value a)) +guardMaybe mVal = do + E.where_ $ isJust mVal + return $ E.veryUnsafeCoerceSqlExprValue mVal + bool :: PersistField a => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a) @@ -419,11 +429,22 @@ selectMaybe = fmap listToMaybe . E.select . (<* E.limit 1) day :: E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Day) day = E.unsafeSqlCastAs "date" -infixl 6 `diffDays` +infixl 6 `diffDays`, `diffTimes` diffDays :: E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Int) -- ^ PostgreSQL is weird. diffDays a b = E.veryUnsafeCoerceSqlExprValue $ a E.-. b + +diffTimes :: E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value NominalDiffTime) +diffTimes a b = unsafeExtract "EPOCH" $ a E.-. b + +unsafeExtract :: String -> E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value b) +unsafeExtract extr (E.ERaw vP vF) = E.ERaw E.Never $ \info -> + let (vTLB, vVals) = vF info + in ( "EXTRACT" <> E.parens (fromString extr <> " FROM " <> E.parensM vP vTLB) + , vVals + ) +unsafeExtract extr v = unsafeExtract extr $ construct v class ExprLift e a | e -> a where diff --git a/src/Database/Persist/Class/Instances.hs b/src/Database/Persist/Class/Instances.hs index 4a3a7208c..657a86800 100644 --- a/src/Database/Persist/Class/Instances.hs +++ b/src/Database/Persist/Class/Instances.hs @@ -30,9 +30,6 @@ instance PersistEntity record => Binary (Key record) where putList = Binary.putList . map toPersistValue get = either (fail . unpack) return . fromPersistValue =<< Binary.get -instance PersistEntity record => NFData (Key record) where - rnf = rnf . keyToValues - uniqueToMap :: PersistEntity record => Unique record -> Map (HaskellName, DBName) PersistValue uniqueToMap = fmap Map.fromList $ zip <$> persistUniqueToFieldNames <*> persistUniqueToValues diff --git a/src/Database/Persist/Sql/Types/Instances.hs b/src/Database/Persist/Sql/Types/Instances.hs index b7c33572b..4fd50d57a 100644 --- a/src/Database/Persist/Sql/Types/Instances.hs +++ b/src/Database/Persist/Sql/Types/Instances.hs @@ -8,6 +8,8 @@ import ClassyPrelude import Database.Persist.Sql +import Data.Binary (Binary) + instance BackendCompatible SqlWriteBackend SqlWriteBackend where projectBackend = id @@ -20,3 +22,6 @@ instance BackendCompatible SqlReadBackend SqlBackend where instance BackendCompatible SqlWriteBackend SqlBackend where projectBackend = SqlWriteBackend + +deriving newtype instance Binary (BackendKey SqlBackend) +deriving anyclass instance NFData (BackendKey SqlBackend) diff --git a/src/Database/Persist/Types/Instances.hs b/src/Database/Persist/Types/Instances.hs index d356217ca..cf05894f2 100644 --- a/src/Database/Persist/Types/Instances.hs +++ b/src/Database/Persist/Types/Instances.hs @@ -26,3 +26,6 @@ instance NFData PersistValue instance (NFData record, NFData (Key record)) => NFData (Entity record) where rnf Entity{..} = rnf entityKey `seq` rnf entityVal + +deriving instance Generic Checkmark +deriving anyclass instance NFData Checkmark diff --git a/src/Foundation.hs b/src/Foundation.hs index 6a9988f6c..66c4cd7c3 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -10,5 +10,5 @@ import Foundation.Instances as Foundation (ButtonClass(..), unsafeHandler) import Foundation.Authorization as Foundation import Foundation.SiteLayout as Foundation import Foundation.DB as Foundation -import Foundation.Navigation as Foundation (evalAccessCorrector) +import Foundation.Navigation as Foundation (evalAccessCorrector, NavigationCacheKey(..)) import Foundation.Yesod.Middleware as Foundation (updateFavourites) diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs index 52fb9926e..cd0c34b01 100644 --- a/src/Foundation/Authorization.hs +++ b/src/Foundation/Authorization.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableInstances, InstanceSigs #-} {-# OPTIONS_GHC -fno-warn-redundant-constraints -fprof-auto #-} module Foundation.Authorization @@ -8,10 +8,10 @@ module Foundation.Authorization , wouldHaveReadAccessTo, wouldHaveWriteAccessTo , wouldHaveReadAccessToIff, wouldHaveWriteAccessToIff , AuthContext(..), getAuthContext - , isDryRun + , isDryRun, isDryRunDB , maybeBearerToken, requireBearerToken , requireCurrentBearerRestrictions, maybeCurrentBearerRestrictions - , BearerAuthSite + , BearerAuthSite, MonadAP , routeAuthTags , orAR, andAR, notAR, trueAR, falseAR , evalWorkflowRoleFor, evalWorkflowRoleFor' @@ -34,8 +34,10 @@ import Handler.Utils.ExamOffice.ExternalExam import Handler.Utils.Workflow.CanonicalRoute import Handler.Utils.Memcached import Handler.Utils.I18n +import Handler.Utils.Routes import Utils.Course (courseIsVisible) import Utils.Workflow +import Utils.Metrics (observeAuthTagEvaluation, AuthTagEvalOutcome(..)) import qualified Data.Set as Set import qualified Data.Aeson as JSON @@ -58,6 +60,9 @@ import qualified Data.Conduit.Combinators as C import qualified Data.Binary as Binary +import GHC.TypeLits (TypeError) +import qualified GHC.TypeLits as TypeError (ErrorMessage(..)) + type BearerAuthSite site = ( MonadCrypto (HandlerFor site) @@ -93,21 +98,109 @@ data AccessPredicate = APPure (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Reader MsgRenderer AuthResult) | APHandler (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> HandlerFor UniWorX AuthResult) | APDB (ByteString -> (forall m. MonadAP m => AuthTagsEval m) -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT SqlReadBackend (HandlerFor UniWorX) AuthResult) + | APBind (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> HandlerFor UniWorX (Either AccessPredicate AuthResult)) + | APBindDB (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> HandlerFor UniWorX (Either (ReaderT SqlReadBackend (HandlerFor UniWorX) (Either AccessPredicate AuthResult)) (Either AccessPredicate AuthResult))) -class (MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => MonadAP m where - evalAccessPred :: HasCallStack => AccessPredicate -> ByteString -> (forall m'. MonadAP m' => AuthTagsEval m') -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult +class (MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX, MonadUnliftIO m) => MonadAP m where + evalAccessPred :: AccessPredicate -> ByteString -> (forall m'. MonadAP m' => AuthTagsEval m') -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult -instance {-# INCOHERENT #-} (MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => MonadAP m where - evalAccessPred aPred contCtx cont aid r w = liftHandler $ case aPred of + apRunDB :: forall a. ReaderT SqlReadBackend (HandlerFor UniWorX) a -> m a + +type family DisabledMonadAPInstance t err :: Constraint where + DisabledMonadAPInstance t err + = TypeError ( 'TypeError.Text "Used dangerous MonadAP instance for: " 'TypeError.:<>: 'TypeError.ShowType t + 'TypeError.:$$: 'TypeError.Text "This instance is currently disabled via TypeError because: " 'TypeError.:<>: err + 'TypeError.:$$: 'TypeError.Text "Please consider removing the usage triggering this error message before re-enabling or removing the instance." + ) + +instance ( BearerAuthSite UniWorX + -- , DisabledMonadAPInstance (HandlerFor UniWorX) ('TypeError.Text "It causes too many database connections") + ) => MonadAP (HandlerFor UniWorX) where + evalAccessPred :: HasCallStack => AccessPredicate -> ByteString -> (forall m'. MonadAP m' => AuthTagsEval m') -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> HandlerFor UniWorX AuthResult + evalAccessPred aPred contCtx cont aid r w = case aPred of (APPure p) -> runReader (p aid r w) <$> getMsgRenderer (APHandler p) -> p aid r w - (APDB p) -> runDBRead' callStack $ p contCtx cont aid r w + (APDB p) -> apRunDB $ p contCtx cont aid r w + (APBind p) -> evalAccessPred (APBindDB $ \aid' r' w' -> Right <$> p aid' r' w') contCtx cont aid r w + (APBindDB p) -> let contAP p' = evalAccessPred p' contCtx cont aid r w + in p aid r w >>= either apRunDB return >>= either contAP return -instance (MonadHandler m, HandlerSite m ~ UniWorX, BackendCompatible SqlReadBackend backend, BearerAuthSite UniWorX) => MonadAP (ReaderT backend m) where + apRunDB :: forall a. HasCallStack => ReaderT SqlReadBackend (HandlerFor UniWorX) a -> HandlerFor UniWorX a + apRunDB = runDBRead' callStack + +instance BearerAuthSite UniWorX => MonadAP (WidgetFor UniWorX) where + evalAccessPred :: HasCallStack => AccessPredicate -> ByteString -> (forall m'. MonadAP m' => AuthTagsEval m') -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> WidgetFor UniWorX AuthResult + evalAccessPred aPred contCtx cont aid r w = liftHandler $ evalAccessPred aPred contCtx cont aid r w + + apRunDB :: forall a. HasCallStack => ReaderT SqlReadBackend (HandlerFor UniWorX) a -> WidgetFor UniWorX a + apRunDB = liftHandler . apRunDB + +instance (MonadHandler m, HandlerSite m ~ UniWorX, BackendCompatible SqlReadBackend backend, BearerAuthSite UniWorX, MonadUnliftIO m) => MonadAP (ReaderT backend m) where evalAccessPred aPred contCtx cont aid r w = mapReaderT liftHandler . withReaderT (projectBackend @SqlReadBackend) $ case aPred of (APPure p) -> lift $ runReader (p aid r w) <$> getMsgRenderer (APHandler p) -> lift $ p aid r w (APDB p) -> p contCtx cont aid r w + (APBind p) -> evalAccessPred (APBindDB $ \aid' r' w' -> Right <$> p aid' r' w') contCtx cont aid r w + (APBindDB p) -> let contAP p' = evalAccessPred p' contCtx cont aid r w + in lift (p aid r w) >>= either id return >>= either contAP return + + apRunDB = hoist liftHandler . withReaderT projectBackend + +-- cacheAP :: ( Binary k +-- , Typeable v, Binary v +-- ) +-- => Maybe Expiry +-- -> k +-- -> HandlerFor UniWorX v +-- -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> v -> Either AccessPredicate (HandlerFor UniWorX AuthResult)) +-- -> AccessPredicate +-- cacheAP mExp k mkV cont = APBind $ \mAuthId route isWrite -> either (return . Left) (fmap Right) . cont mAuthId route isWrite =<< memcachedBy mExp k mkV + +cacheAPDB :: ( Binary k + , Typeable v, Binary v, NFData v + ) + => Maybe Expiry + -> k + -> ReaderT SqlReadBackend (HandlerFor UniWorX) v + -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> v -> Either AccessPredicate (HandlerFor UniWorX AuthResult)) + -> AccessPredicate +cacheAPDB mExp k mkV cont = APBindDB $ \mAuthId route isWrite -> do + cachedV <- memcachedByGet k + case cachedV of + Just v -> fmap Right . either (return . Left) (fmap Right) $ cont mAuthId route isWrite v + Nothing -> return . Left $ do + v <- mkV + memcachedBySet mExp k v + either (return . Left) (fmap Right . lift) $ cont mAuthId route isWrite v + +-- cacheAP' :: ( Binary k +-- , Typeable v, Binary v +-- ) +-- => Maybe Expiry +-- -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Maybe (k, HandlerFor UniWorX v)) +-- -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Maybe v -> Either AccessPredicate (HandlerFor UniWorX AuthResult)) +-- -> AccessPredicate +-- cacheAP' mExp mkKV cont = APBind $ \mAuthId route isWrite -> case mkKV mAuthId route isWrite of +-- Just (k, mkV) -> either (return . Left) (fmap Right) . cont mAuthId route isWrite . Just =<< memcachedBy mExp k mkV +-- Nothing -> either (return . Left) (fmap Right) $ cont mAuthId route isWrite Nothing + +cacheAPDB' :: ( Binary k + , Typeable v, Binary v, NFData v + ) + => Maybe Expiry + -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Maybe (k, ReaderT SqlReadBackend (HandlerFor UniWorX) v)) + -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Maybe v -> Either AccessPredicate (HandlerFor UniWorX AuthResult)) + -> AccessPredicate +cacheAPDB' mExp mkKV cont = APBindDB $ \mAuthId route isWrite -> case mkKV mAuthId route isWrite of + Just (k, mkV) -> do + cachedV <- memcachedByGet k + case cachedV of + Just v -> fmap Right . either (return . Left) (fmap Right) . cont mAuthId route isWrite $ Just v + Nothing -> return . Left $ do + v <- mkV + memcachedBySet mExp k v + either (return . Left) (fmap Right . lift) . cont mAuthId route isWrite $ Just v + Nothing -> fmap Right . either (return . Left) (fmap Right) $ cont mAuthId route isWrite Nothing orAR, andAR :: MsgRenderer -> AuthResult -> AuthResult -> AuthResult @@ -158,9 +251,10 @@ data AuthContext = AuthContext , authActiveTags :: AuthTagActive } deriving (Generic, Typeable) -deriving instance Eq (AuthId UniWorX) => Eq AuthContext -deriving instance (Read (AuthId UniWorX), Eq (AuthId UniWorX), Hashable (AuthId UniWorX)) => Read AuthContext -deriving instance (Show (AuthId UniWorX), Eq (AuthId UniWorX), Hashable (AuthId UniWorX)) => Show AuthContext +deriving stock instance Eq (AuthId UniWorX) => Eq AuthContext +deriving stock instance Ord (AuthId UniWorX) => Ord AuthContext +deriving stock instance (Read (AuthId UniWorX), Eq (AuthId UniWorX), Hashable (AuthId UniWorX)) => Read AuthContext +deriving stock instance (Show (AuthId UniWorX), Eq (AuthId UniWorX), Hashable (AuthId UniWorX)) => Show AuthContext deriving anyclass instance Hashable (AuthId UniWorX) => Hashable AuthContext deriving anyclass instance (Binary (AuthId UniWorX), Eq (AuthId UniWorX), Hashable (AuthId UniWorX)) => Binary AuthContext @@ -179,28 +273,39 @@ getAuthContext = liftHandler $ do return authCtx -isDryRun :: forall m. - ( HasCallStack - , MonadHandler m, HandlerSite m ~ UniWorX +newtype IsDryRun = MkIsDryRun { unIsDryRun :: Bool } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +isDryRun :: ( HasCallStack , BearerAuthSite UniWorX ) - => m Bool -isDryRun = $cachedHere . liftHandler $ orM + => HandlerFor UniWorX Bool +isDryRun = fmap unIsDryRun . cached . fmap MkIsDryRun $ runDBRead isDryRunDB + +isDryRunDB :: forall m backend. + ( HasCallStack + , MonadAP m, MonadCatch m + , BearerAuthSite UniWorX + , WithRunDB backend (HandlerFor UniWorX) m + , BackendCompatible SqlReadBackend backend + ) + => m Bool +isDryRunDB = fmap unIsDryRun . cached . fmap MkIsDryRun $ orM [ hasGlobalPostParam PostDryRun , hasGlobalGetParam GetDryRun , and2M bearerDryRun bearerRequired ] where bearerDryRun = has (_Just . _Object . ix "dry-run") <$> maybeCurrentBearerRestrictions @Value - bearerRequired = maybeT (return True) . catchIfMaybeT cPred . liftHandler $ do - mAuthId <- defaultMaybeAuthId - currentRoute <- maybe (permissionDeniedI MsgUnauthorizedToken404) return =<< getCurrentRoute - isWrite <- isWriteRequest currentRoute + bearerRequired = maybeT (return True) . catchIfMaybeT cPred $ do + mAuthId <- liftHandler defaultMaybeAuthId + currentRoute <- liftHandler $ maybe (permissionDeniedI MsgUnauthorizedToken404) return =<< getCurrentRoute + isWrite <- liftHandler $ isWriteRequest currentRoute let noTokenAuth :: AuthDNF -> AuthDNF noTokenAuth = over _dnfTerms . Set.filter . noneOf (re _nullable . folded) $ (== AuthToken) . plVar - dnf <- either throwM return $ routeAuthTags currentRoute + dnf <- throwLeft $ routeAuthTags currentRoute let eval :: forall m'. MonadAP m' => AuthTagsEval m' eval dnf' mAuthId' route' isWrite' = evalAuthTags 'isDryRun (AuthTagActive $ const True) eval (noTokenAuth dnf') mAuthId' route' isWrite' in guardAuthResult <=< evalWriterT $ eval dnf mAuthId currentRoute isWrite @@ -230,15 +335,20 @@ askBearerUnsafe = ExceptT . $cachedHere . liftHandler . runExceptT $ do $logWarnS "AuthToken" $ tshow other throwError =<< unauthorizedI MsgUnauthorizedTokenInvalid -validateBearer :: BearerAuthSite UniWorX +validateBearer :: forall m. + ( HasCallStack + , MonadHandler m, HandlerSite m ~ UniWorX + , MonadCatch m, MonadAP m + , BearerAuthSite UniWorX + ) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -- ^ @isWrite@ -> BearerToken UniWorX - -> ReaderT SqlReadBackend (HandlerFor UniWorX) AuthResult + -> m AuthResult validateBearer mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo validateBearer' mAuthId' route' isWrite' token' where - validateBearer' :: _ -> _ -> _ -> _ -> CachedMemoT (Maybe (AuthId UniWorX), Route UniWorX, Bool, BearerToken UniWorX) AuthResult (ReaderT SqlReadBackend (HandlerFor UniWorX)) AuthResult + validateBearer' :: _ -> _ -> _ -> _ -> CachedMemoT (Maybe (AuthId UniWorX), Route UniWorX, Bool, BearerToken UniWorX) AuthResult m AuthResult validateBearer' mAuthId route isWrite BearerToken{..} = lift . exceptT return return $ do iforM_ bearerRoutes $ \case BearerTokenRouteEval -> \routes -> guardMExceptT (HashSet.member route routes) $ unauthorizedI MsgUnauthorizedTokenInvalidRoute @@ -246,27 +356,6 @@ validateBearer mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo val cRoute <- MaybeT getCurrentRoute guard $ HashSet.member cRoute routes - bearerAuthority' <- flip foldMapM bearerAuthority $ \case - Left tVal - | JSON.Success groupName <- JSON.fromJSON tVal -> do - Entity _ primary <- maybeMExceptT (unauthorizedI MsgUnauthorizedTokenInvalidAuthorityGroup) . getBy $ UniquePrimaryUserGroupMember groupName Active - case bearerImpersonate of - Nothing -> return . Set.singleton $ userGroupMemberUser primary - Just iuid | iuid == userGroupMemberUser primary -> return . Set.singleton $ userGroupMemberUser primary - | otherwise -> do - unlessM (lift $ exists [UserGroupMemberUser ==. iuid, UserGroupMemberGroup ==. groupName]) $ - throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidImpersonation - return $ Set.singleton iuid - | otherwise -> throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidAuthorityValue - Right uid -> case bearerImpersonate of - Just iuid | uid == iuid -> return $ Set.singleton uid - | otherwise -> do - cID <- encrypt iuid - unlessM (is _Authorized <$> evalAccessWithFor [(AuthToken, False)] (Just uid) (AdminHijackUserR cID) True) $ - throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidImpersonation - return $ Set.singleton iuid - Nothing -> return $ Set.singleton uid - let -- Prevent infinite loops noTokenAuth :: AuthDNF -> AuthDNF @@ -274,64 +363,103 @@ validateBearer mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo val eval :: forall m'. MonadAP m' => AuthTagsEval m' eval dnf' mAuthId'' route'' isWrite'' = evalAuthTags 'validateBearer (AuthTagActive $ const True) eval (noTokenAuth dnf') mAuthId'' route'' isWrite'' - guardMExceptT (not $ Set.null bearerAuthority') $ unauthorizedI MsgUnauthorizedTokenInvalidNoAuthority + + bearerAuthority' <- hoist apRunDB $ do + bearerAuthority' <- flip foldMapM bearerAuthority $ \case + Left tVal + | JSON.Success groupName <- JSON.fromJSON tVal -> do + Entity _ primary <- maybeMExceptT (unauthorizedI MsgUnauthorizedTokenInvalidAuthorityGroup) . getBy $ UniquePrimaryUserGroupMember groupName Active + case bearerImpersonate of + Nothing -> return . Set.singleton $ userGroupMemberUser primary + Just iuid | iuid == userGroupMemberUser primary -> return . Set.singleton $ userGroupMemberUser primary + | otherwise -> do + unlessM (lift $ exists [UserGroupMemberUser ==. iuid, UserGroupMemberGroup ==. groupName]) $ + throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidImpersonation + return $ Set.singleton iuid + | otherwise -> throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidAuthorityValue + Right uid -> case bearerImpersonate of + Just iuid | uid == iuid -> return $ Set.singleton uid + | otherwise -> do + cID <- encrypt iuid + unlessM (lift $ is _Authorized <$> evalAccessWithFor [(AuthToken, False)] (Just uid) (AdminHijackUserR cID) True) $ + throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidImpersonation + return $ Set.singleton iuid + Nothing -> return $ Set.singleton uid + + guardMExceptT (not $ Set.null bearerAuthority') $ unauthorizedI MsgUnauthorizedTokenInvalidNoAuthority + + forM_ bearerAuthority' $ \uid -> do + User{userTokensIssuedAfter} <- maybeMExceptT (unauthorizedI MsgUnauthorizedTokenInvalidAuthority) $ get uid + guardMExceptT (Just bearerIssuedAt >= userTokensIssuedAfter) (unauthorizedI MsgUnauthorizedTokenExpired) + + return bearerAuthority' forM_ bearerAuthority' $ \uid -> do - User{userTokensIssuedAfter} <- maybeMExceptT (unauthorizedI MsgUnauthorizedTokenInvalidAuthority) $ get uid - guardMExceptT (Just bearerIssuedAt >= userTokensIssuedAfter) (unauthorizedI MsgUnauthorizedTokenExpired) - authorityVal <- do - dnf <- either throwM return $ routeAuthTags route - evalWriterT $ eval (noTokenAuth dnf) (Just uid) route isWrite + dnf <- throwLeft $ routeAuthTags route + lift . evalWriterT $ eval (noTokenAuth dnf) (Just uid) route isWrite guardExceptT (is _Authorized authorityVal) authorityVal whenIsJust bearerAddAuth $ \addDNF -> do $logDebugS "validateToken" $ tshow addDNF - additionalVal <- evalWriterT $ eval (noTokenAuth addDNF) mAuthId route isWrite + additionalVal <- lift . evalWriterT $ eval (noTokenAuth addDNF) mAuthId route isWrite guardExceptT (is _Authorized additionalVal) additionalVal return Authorized -maybeBearerToken :: ( MonadHandler m, HandlerSite m ~ UniWorX +maybeBearerToken :: ( HasCallStack + , MonadHandler m, HandlerSite m ~ UniWorX , BearerAuthSite UniWorX + , MonadAP m + , MonadCatch m ) => m (Maybe (BearerToken UniWorX)) -maybeBearerToken = liftHandler . runMaybeT $ catchIfMaybeT cPred requireBearerToken +maybeBearerToken = $cachedHere . runMaybeT $ catchIfMaybeT cPred requireBearerToken where cPred err = any ($ err) [ is $ _HCError . _PermissionDenied , is $ _HCError . _NotAuthenticated ] -requireBearerToken :: ( MonadHandler m, HandlerSite m ~ UniWorX +requireBearerToken :: forall m. + ( HasCallStack + , MonadHandler m, HandlerSite m ~ UniWorX , BearerAuthSite UniWorX + , MonadAP m + , MonadCatch m ) => m (BearerToken UniWorX) -requireBearerToken = liftHandler $ do +requireBearerToken = do bearer <- exceptT (guardAuthResult >=> error "askToken should not throw `Authorized`") return askBearerUnsafe mAuthId <- defaultMaybeAuthId -- `maybeAuthId` would be an infinite loop; this is equivalent to `maybeAuthId` but ignoring `bearerImpersonate` from any valid token currentRoute <- maybe (permissionDeniedI MsgUnauthorizedToken404) return =<< getCurrentRoute - isWrite <- isWriteRequest currentRoute - guardAuthResult <=< runDBRead $ validateBearer mAuthId currentRoute isWrite bearer + isWrite <- liftHandler $ isWriteRequest currentRoute + guardAuthResult =<< validateBearer mAuthId currentRoute isWrite bearer return bearer requireCurrentBearerRestrictions :: forall a m. - ( MonadHandler m, HandlerSite m ~ UniWorX + ( HasCallStack + , MonadHandler m, HandlerSite m ~ UniWorX , FromJSON a, ToJSON a , BearerAuthSite UniWorX + , MonadAP m + , MonadCatch m ) => m (Maybe a) -requireCurrentBearerRestrictions = liftHandler . runMaybeT $ do - bearer <- requireBearerToken +requireCurrentBearerRestrictions = runMaybeT $ do + bearer <- lift requireBearerToken route <- MaybeT getCurrentRoute hoistMaybe $ bearer ^? _bearerRestrictionIx route maybeCurrentBearerRestrictions :: forall a m. - ( MonadHandler m, HandlerSite m ~ UniWorX + ( HasCallStack + , MonadHandler m, HandlerSite m ~ UniWorX , FromJSON a, ToJSON a , BearerAuthSite UniWorX + , MonadAP m + , MonadCatch m ) => m (Maybe a) -maybeCurrentBearerRestrictions = liftHandler . runMaybeT $ do +maybeCurrentBearerRestrictions = runMaybeT $ do bearer <- MaybeT maybeBearerToken route <- MaybeT getCurrentRoute hoistMaybe $ bearer ^? _bearerRestrictionIx route @@ -339,134 +467,195 @@ maybeCurrentBearerRestrictions = liftHandler . runMaybeT $ do data AuthorizationCacheKey = AuthCacheWorkflowWorkflowEdgeActors CryptoFileNameWorkflowWorkflow | AuthCacheWorkflowWorkflowViewers CryptoFileNameWorkflowWorkflow + | AuthCacheWorkflowInstanceInitiators WorkflowInstanceName RouteWorkflowScope + | AuthCacheWorkflowInstanceWorkflowViewers WorkflowInstanceName RouteWorkflowScope + | AuthCacheSchoolFunctionList SchoolFunction | AuthCacheSystemFunctionList SystemFunction + | AuthCacheLecturerList | AuthCacheExternalExamStaffList | AuthCacheCorrectorList | AuthCacheExamCorrectorList | AuthCacheTutorList | AuthCacheSubmissionGroupUserList + | AuthCacheCourseRegisteredList TermId SchoolId CourseShorthand deriving (Eq, Ord, Read, Show, Generic, Typeable) - deriving anyclass (Binary) + deriving anyclass (Hashable, Binary) -tagAccessPredicate :: BearerAuthSite UniWorX +cacheAPSchoolFunction :: BearerAuthSite UniWorX + => SchoolFunction + -> Maybe Expiry + -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Set (AuthId UniWorX) -> Either AccessPredicate (HandlerFor UniWorX AuthResult)) + -> AccessPredicate +cacheAPSchoolFunction f mExp = cacheAPDB mExp (AuthCacheSchoolFunctionList f) mkFunctionList + where + mkFunctionList = fmap (setOf $ folded . _Value) . E.select . E.from $ \userFunction -> do + E.where_ $ userFunction E.^. UserFunctionFunction E.==. E.val f + return $ userFunction E.^. UserFunctionUser + +cacheAPSystemFunction :: BearerAuthSite UniWorX + => SystemFunction + -> Maybe Expiry + -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Set (AuthId UniWorX) -> Either AccessPredicate (HandlerFor UniWorX AuthResult)) + -> AccessPredicate +cacheAPSystemFunction f mExp = cacheAPDB mExp (AuthCacheSystemFunctionList f) mkFunctionList + where + mkFunctionList = fmap (setOf $ folded . _Value) . E.select . E.from $ \userSystemFunction -> do + E.where_ $ userSystemFunction E.^. UserSystemFunctionFunction E.==. E.val f + E.&&. E.not_ (userSystemFunction E.^. UserSystemFunctionIsOptOut) + return $ userSystemFunction E.^. UserSystemFunctionUser + +tagAccessPredicate :: ( HasCallStack + , BearerAuthSite UniWorX + ) => AuthTag -> AccessPredicate tagAccessPredicate AuthFree = trueAP -tagAccessPredicate AuthAdmin = APDB $ \_ _ mAuthId route _ -> case route of - -- Courses: access only to school admins - CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isAdmin <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` userAdmin) -> do - E.on $ course E.^. CourseSchool E.==. userAdmin E.^. UserFunctionSchool - E.where_ $ userAdmin E.^. UserFunctionUser E.==. E.val authId - E.&&. userAdmin E.^. UserFunctionFunction E.==. E.val SchoolAdmin - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolAdmin) - return Authorized - -- Allocations: access only to school admins - AllocationR tid ssh ash _ -> $cachedHereBinary (mAuthId, tid, ssh, ash) . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isAdmin <- lift . E.selectExists . E.from $ \(allocation `E.InnerJoin` userAdmin) -> do - E.on $ allocation E.^. AllocationSchool E.==. userAdmin E.^. UserFunctionSchool - E.where_ $ userAdmin E.^. UserFunctionUser E.==. E.val authId - E.&&. userAdmin E.^. UserFunctionFunction E.==. E.val SchoolAdmin - E.&&. allocation E.^. AllocationTerm E.==. E.val tid - E.&&. allocation E.^. AllocationSchool E.==. E.val ssh - E.&&. allocation E.^. AllocationShorthand E.==. E.val ash - guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolAdmin) - return Authorized - -- Schools: access only to school admins - SchoolR ssh _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isAdmin <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAdmin] - guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolAdmin) - return Authorized - -- other routes: access to any admin is granted here - _other -> $cachedHereBinary mAuthId . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - adrights <- lift $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAdmin] [] - guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin) - return Authorized -tagAccessPredicate AuthSystemExamOffice = APDB $ \_ _ mAuthId _ _ -> $cachedHereBinary mAuthId . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isExamOffice <- lift $ exists [UserSystemFunctionUser ==. authId, UserSystemFunctionFunction ==. SystemExamOffice, UserSystemFunctionIsOptOut ==. False] - guardMExceptT isExamOffice $ unauthorizedI MsgUnauthorizedSystemExamOffice - return Authorized -tagAccessPredicate AuthStudent = APDB $ \_ _ mAuthId _ _ -> $cachedHereBinary mAuthId . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isExamOffice <- lift $ exists [UserSystemFunctionUser ==. authId, UserSystemFunctionFunction ==. SystemStudent, UserSystemFunctionIsOptOut ==. False] - guardMExceptT isExamOffice $ unauthorizedI MsgUnauthorizedStudent - return Authorized -tagAccessPredicate AuthExamOffice = APDB $ \_ _ mAuthId route _ -> case route of - CExamR tid ssh csh examn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, examn) . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - hasUsers <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examResult) -> do - E.on $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId - E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId +tagAccessPredicate AuthAdmin = cacheAPSchoolFunction SchoolAdmin (Just $ Right diffHour) $ \mAuthId' route' _ adminList -> if + | maybe True (`Set.notMember` adminList) mAuthId' -> Right $ case route' of + _ | is _Nothing mAuthId' -> return AuthenticationRequired + CourseR{} -> unauthorizedI MsgUnauthorizedSchoolAdmin + AllocationR{} -> unauthorizedI MsgUnauthorizedSchoolAdmin + SchoolR _ _ -> unauthorizedI MsgUnauthorizedSchoolAdmin + _other -> unauthorizedI MsgUnauthorizedSiteAdmin + | otherwise -> Left $ APDB $ \_ _ mAuthId route _ -> case route of + -- Courses: access only to school admins + CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isAdmin <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` userAdmin) -> do + E.on $ course E.^. CourseSchool E.==. userAdmin E.^. UserFunctionSchool + E.where_ $ userAdmin E.^. UserFunctionUser E.==. E.val authId + E.&&. userAdmin E.^. UserFunctionFunction E.==. E.val SchoolAdmin + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + guardMExceptT isAdmin $ unauthorizedI MsgUnauthorizedSchoolAdmin + return Authorized + -- Allocations: access only to school admins + AllocationR tid ssh ash _ -> $cachedHereBinary (mAuthId, tid, ssh, ash) . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isAdmin <- lift . E.selectExists . E.from $ \(allocation `E.InnerJoin` userAdmin) -> do + E.on $ allocation E.^. AllocationSchool E.==. userAdmin E.^. UserFunctionSchool + E.where_ $ userAdmin E.^. UserFunctionUser E.==. E.val authId + E.&&. userAdmin E.^. UserFunctionFunction E.==. E.val SchoolAdmin + E.&&. allocation E.^. AllocationTerm E.==. E.val tid + E.&&. allocation E.^. AllocationSchool E.==. E.val ssh + E.&&. allocation E.^. AllocationShorthand E.==. E.val ash + guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolAdmin) + return Authorized + -- Schools: access only to school admins + SchoolR ssh _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isAdmin <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAdmin] + guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolAdmin) + return Authorized + -- other routes: access to any admin is granted here + _other -> $cachedHereBinary mAuthId . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + adrights <- lift $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAdmin] [] + guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin) + return Authorized +tagAccessPredicate AuthSystemExamOffice = cacheAPSystemFunction SystemExamOffice (Just $ Right diffHour) $ \mAuthId' _ _ examOfficeList -> if + | maybe True (`Set.notMember` examOfficeList) mAuthId' -> Right $ if + | is _Nothing mAuthId' -> return AuthenticationRequired + | otherwise -> unauthorizedI MsgUnauthorizedSystemExamOffice + | otherwise -> Left $ APDB $ \_ _ mAuthId _ _ -> $cachedHereBinary mAuthId . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isExamOffice <- lift $ exists [UserSystemFunctionUser ==. authId, UserSystemFunctionFunction ==. SystemExamOffice, UserSystemFunctionIsOptOut ==. False] + guardMExceptT isExamOffice $ unauthorizedI MsgUnauthorizedSystemExamOffice + return Authorized +tagAccessPredicate AuthStudent = cacheAPSystemFunction SystemStudent (Just $ Right diffHour) $ \mAuthId' _ _ studentList -> if + | maybe True (`Set.notMember` studentList) mAuthId' -> Right $ if + | is _Nothing mAuthId' -> return AuthenticationRequired + | otherwise -> unauthorizedI MsgUnauthorizedStudent + | otherwise -> Left $ APDB $ \_ _ mAuthId _ _ -> $cachedHereBinary mAuthId . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isExamOffice <- lift $ exists [UserSystemFunctionUser ==. authId, UserSystemFunctionFunction ==. SystemStudent, UserSystemFunctionIsOptOut ==. False] + guardMExceptT isExamOffice $ unauthorizedI MsgUnauthorizedStudent + return Authorized +tagAccessPredicate AuthExamOffice = cacheAPSchoolFunction SchoolExamOffice (Just $ Right diffHour) $ \mAuthId' route' _ examOfficeList -> if + | maybe True (`Set.notMember` examOfficeList) mAuthId' -> Right $ case route' of + _ | is _Nothing mAuthId' -> return AuthenticationRequired + CExamR{} -> unauthorizedI MsgUnauthorizedExamExamOffice + EExamR{} -> unauthorizedI MsgUnauthorizedExternalExamExamOffice + CourseR{} -> unauthorizedI MsgUnauthorizedExamExamOffice + SchoolR _ _ -> unauthorizedI MsgUnauthorizedSchoolExamOffice + _other -> unauthorizedI MsgUnauthorizedExamOffice + | otherwise -> Left $ APDB $ \_ _ mAuthId route _ -> case route of + CExamR tid ssh csh examn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, examn) . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + hasUsers <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examResult) -> do + E.on $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId + E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId - E.where_ $ course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - E.&&. exam E.^. ExamName E.==. E.val examn + E.where_ $ course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.&&. exam E.^. ExamName E.==. E.val examn - E.where_ $ examOfficeExamResultAuth (E.val authId) examResult - guardMExceptT hasUsers (unauthorizedI MsgUnauthorizedExamExamOffice) - return Authorized - EExamR tid ssh coursen examn _ -> $cachedHereBinary (mAuthId, tid, ssh, coursen, examn) . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - hasUsers <- lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` eexamResult) -> do - E.on $ eexam E.^. ExternalExamId E.==. eexamResult E.^. ExternalExamResultExam + E.where_ $ examOfficeExamResultAuth (E.val authId) examResult + guardMExceptT hasUsers (unauthorizedI MsgUnauthorizedExamExamOffice) + return Authorized + EExamR tid ssh coursen examn _ -> $cachedHereBinary (mAuthId, tid, ssh, coursen, examn) . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + hasUsers <- lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` eexamResult) -> do + E.on $ eexam E.^. ExternalExamId E.==. eexamResult E.^. ExternalExamResultExam - E.where_ $ eexam E.^. ExternalExamTerm E.==. E.val tid - E.&&. eexam E.^. ExternalExamSchool E.==. E.val ssh - E.&&. eexam E.^. ExternalExamCourseName E.==. E.val coursen - E.&&. eexam E.^. ExternalExamExamName E.==. E.val examn + E.where_ $ eexam E.^. ExternalExamTerm E.==. E.val tid + E.&&. eexam E.^. ExternalExamSchool E.==. E.val ssh + E.&&. eexam E.^. ExternalExamCourseName E.==. E.val coursen + E.&&. eexam E.^. ExternalExamExamName E.==. E.val examn - E.where_ $ examOfficeExternalExamResultAuth (E.val authId) eexamResult - guardMExceptT hasUsers $ unauthorizedI MsgUnauthorizedExternalExamExamOffice - return Authorized - CourseR _ ssh _ _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isExamOffice <- lift . existsBy $ UniqueUserFunction authId ssh SchoolExamOffice - guardMExceptT isExamOffice $ unauthorizedI MsgUnauthorizedExamExamOffice - return Authorized - SchoolR ssh _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isAdmin <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolExamOffice] - guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolExamOffice) - return Authorized - _other -> $cachedHereBinary mAuthId . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isExamOffice <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolExamOffice] - guardMExceptT isExamOffice (unauthorizedI MsgUnauthorizedExamOffice) - return Authorized -tagAccessPredicate AuthEvaluation = APDB $ \_ _ mAuthId route _ -> case route of - ParticipantsR _ ssh -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolEvaluation - guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedEvaluation - return Authorized - CourseR _ ssh _ _ -> $cachedHereBinary(mAuthId, ssh) . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolEvaluation - guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedEvaluation - return Authorized - _other -> $cachedHereBinary mAuthId . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isEvaluation <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolEvaluation] - guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedEvaluation - return Authorized -tagAccessPredicate AuthAllocationAdmin = APDB $ \_ _ mAuthId route _ -> case route of - AllocationR _ ssh _ _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolAllocation - guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedAllocationAdmin - return Authorized - CourseR _ ssh _ _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolAllocation - guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedAllocationAdmin - return Authorized - _other -> $cachedHereBinary mAuthId . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isEvaluation <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAllocation] - guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedAllocationAdmin - return Authorized + E.where_ $ examOfficeExternalExamResultAuth (E.val authId) eexamResult + guardMExceptT hasUsers $ unauthorizedI MsgUnauthorizedExternalExamExamOffice + return Authorized + CourseR _ ssh _ _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isExamOffice <- lift . existsBy $ UniqueUserFunction authId ssh SchoolExamOffice + guardMExceptT isExamOffice $ unauthorizedI MsgUnauthorizedExamExamOffice + return Authorized + SchoolR ssh _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isAdmin <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolExamOffice] + guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolExamOffice) + return Authorized + _other -> $cachedHereBinary mAuthId . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isExamOffice <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolExamOffice] + guardMExceptT isExamOffice (unauthorizedI MsgUnauthorizedExamOffice) + return Authorized +tagAccessPredicate AuthEvaluation = cacheAPSchoolFunction SchoolEvaluation (Just $ Right diffHour) $ \mAuthId' _ _ evaluationList -> if + | maybe True (`Set.notMember` evaluationList) mAuthId' -> Right $ if + | is _Nothing mAuthId' -> return AuthenticationRequired + | otherwise -> unauthorizedI MsgUnauthorizedEvaluation + | otherwise -> Left $ APDB $ \_ _ mAuthId route _ -> case route of + ParticipantsR _ ssh -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolEvaluation + guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedEvaluation + return Authorized + CourseR _ ssh _ _ -> $cachedHereBinary(mAuthId, ssh) . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolEvaluation + guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedEvaluation + return Authorized + _other -> $cachedHereBinary mAuthId . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isEvaluation <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolEvaluation] + guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedEvaluation + return Authorized +tagAccessPredicate AuthAllocationAdmin = cacheAPSchoolFunction SchoolAllocation (Just $ Right diffHour) $ \mAuthId' _ _ allocationList -> if + | maybe True (`Set.notMember` allocationList) mAuthId' -> Right $ if + | is _Nothing mAuthId' -> return AuthenticationRequired + | otherwise -> unauthorizedI MsgUnauthorizedAllocationAdmin + | otherwise -> Left $ APDB $ \_ _ mAuthId route _ -> case route of + AllocationR _ ssh _ _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolAllocation + guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedAllocationAdmin + return Authorized + CourseR _ ssh _ _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolAllocation + guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedAllocationAdmin + return Authorized + _other -> $cachedHereBinary mAuthId . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isEvaluation <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAllocation] + guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedAllocationAdmin + return Authorized tagAccessPredicate AuthToken = APDB $ \_ _ mAuthId route isWrite -> exceptT return return $ lift . validateBearer mAuthId route isWrite =<< askBearerUnsafe tagAccessPredicate AuthNoEscalation = APDB $ \_ _ mAuthId route _ -> case route of @@ -490,121 +679,182 @@ tagAccessPredicate AuthDevelopment = APHandler $ \_ r _ -> do #else return $ Unauthorized "Route under development" #endif -tagAccessPredicate AuthLecturer = APDB $ \_ _ mAuthId route _ -> case route of - CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isLecturer <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` lecturer) -> do - E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse - E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId + +tagAccessPredicate AuthLecturer = cacheAPDB' (Just $ Right diffMinute) mkLecturerList $ \mAuthId' route' _ mLecturerList -> if + | Just lecturerList <- mLecturerList + , maybe True (`Set.notMember` lecturerList) mAuthId' -> Right $ case route' of + _ | is _Nothing mAuthId' -> return AuthenticationRequired + CourseR{} -> unauthorizedI MsgUnauthorizedLecturer + AllocationR{} -> unauthorizedI MsgUnauthorizedAllocationLecturer + EExamR{} -> unauthorizedI MsgUnauthorizedExternalExamLecturer + _other -> unauthorizedI MsgUnauthorizedSchoolLecturer + | otherwise -> Left $ APDB $ \_ _ mAuthId route _ -> case route of + CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isLecturer <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` lecturer) -> do + E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse + E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + guardMExceptT isLecturer (unauthorizedI MsgUnauthorizedLecturer) + return Authorized + AllocationR tid ssh ash _ -> $cachedHereBinary (mAuthId, tid, ssh, ash) . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isLecturer <- lift . E.selectExists . E.from $ \(allocation `E.InnerJoin` allocationCourse `E.InnerJoin` course `E.InnerJoin` lecturer) -> do + E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse + E.on $ course E.^. CourseId E.==. allocationCourse E.^. AllocationCourseCourse + E.on $ allocation E.^. AllocationId E.==. allocationCourse E.^. AllocationCourseAllocation + E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId + E.&&. allocation E.^. AllocationTerm E.==. E.val tid + E.&&. allocation E.^. AllocationSchool E.==. E.val ssh + E.&&. allocation E.^. AllocationShorthand E.==. E.val ash + guardMExceptT isLecturer $ unauthorizedI MsgUnauthorizedAllocationLecturer + return Authorized + EExamR tid ssh coursen examn _ -> $cachedHereBinary (mAuthId, tid, ssh, coursen, examn) . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isLecturer <- lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` staff) -> do + E.on $ eexam E.^. ExternalExamId E.==. staff E.^. ExternalExamStaffExam + E.where_ $ staff E.^. ExternalExamStaffUser E.==. E.val authId + E.&&. eexam E.^. ExternalExamTerm E.==. E.val tid + E.&&. eexam E.^. ExternalExamSchool E.==. E.val ssh + E.&&. eexam E.^. ExternalExamCourseName E.==. E.val coursen + E.&&. eexam E.^. ExternalExamExamName E.==. E.val examn + guardMExceptT isLecturer $ unauthorizedI MsgUnauthorizedExternalExamLecturer + return Authorized + -- lecturer for any school will do + _ -> $cachedHereBinary mAuthId . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolLecturer] [] + return Authorized + where + mkLecturerList _ route _ = case route of + CourseR{} -> cacheLecturerList + AllocationR{} -> cacheLecturerList + EExamR{} -> Just + ( AuthCacheExternalExamStaffList + , fmap (setOf $ folded . _Value) . E.select . E.from $ return . (E.^. ExternalExamStaffUser) + ) + _other -> Just + ( AuthCacheSchoolFunctionList SchoolLecturer + , fmap (setOf $ folded . _Value) . E.select . E.from $ \userFunction -> do + E.where_ $ userFunction E.^. UserFunctionFunction E.==. E.val SchoolLecturer + return $ userFunction E.^. UserFunctionUser + ) + where + cacheLecturerList = Just + ( AuthCacheLecturerList + , fmap (setOf $ folded . _Value) . E.select . E.from $ return . (E.^. LecturerUser) + ) +tagAccessPredicate AuthCorrector = cacheAPDB (Just $ Right diffMinute) AuthCacheCorrectorList mkCorrectorList $ \mAuthId' route' _ correctorList -> if + | maybe True (`Set.notMember` correctorList) mAuthId' -> Right $ case route' of + _ | is _Nothing mAuthId' -> return AuthenticationRequired + CSubmissionR{} -> unauthorizedI MsgUnauthorizedSubmissionCorrector + CSheetR{} -> unauthorizedI MsgUnauthorizedSheetCorrector + CourseR{} -> unauthorizedI MsgUnauthorizedCorrector + _other -> unauthorizedI MsgUnauthorizedCorrectorAny + | otherwise -> Left $ APDB $ \_ _ mAuthId route _ -> exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + case route of + CSubmissionR _ _ _ _ cID _ -> lift . $cachedHereBinary (authId, cID) . maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do + sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID + guardM . lift . E.selectExists . E.from $ \submission -> + E.where_ $ submission E.^. SubmissionId E.==. E.val sid + E.&&. submission E.^. SubmissionRatingBy E.==. E.justVal authId + return Authorized + CSheetR tid ssh csh shn _ -> lift . $cachedHereBinary (authId, tid, ssh, csh, shn) . maybeT (unauthorizedI MsgUnauthorizedSheetCorrector) $ do + guardM . lift . E.selectExists . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do + E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId + E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId + E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val authId + E.where_ $ course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.&&. sheet E.^. SheetName E.==. E.val shn + return Authorized + CourseR tid ssh csh _ -> lift . $cachedHereBinary (mAuthId, tid, ssh, csh) . maybeT (unauthorizedI MsgUnauthorizedCorrector) $ do + guardM . lift . E.selectExists . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do + E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId + E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId + E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val authId + E.where_ $ course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + return Authorized + _ -> lift . $cachedHereBinary mAuthId . maybeT (unauthorizedI MsgUnauthorizedCorrectorAny) $ do + guardM . lift . E.selectExists . E.from $ \sheetCorrector -> + E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val authId + return Authorized + where + mkCorrectorList = execWriterT $ do + tellM . fmap (setOf $ folded . _Value . _Just) . E.select . E.from $ \submission -> do + E.where_ . E.isJust $ submission E.^. SubmissionRatingBy + return $ submission E.^. SubmissionRatingBy + tellM . fmap (setOf $ folded . _Value) . E.select . E.from $ return . (E.^. SheetCorrectorUser) +tagAccessPredicate AuthExamCorrector = cacheAPDB (Just $ Right diffMinute) AuthCacheExamCorrectorList mkExamCorrectorList $ \mAuthId' route' _ examCorrectorList -> if + | maybe True (`Set.notMember` examCorrectorList) mAuthId' -> Right $ case route' of + _ | is _Nothing mAuthId' -> return AuthenticationRequired + CExamR{} -> unauthorizedI MsgUnauthorizedExamCorrector + CourseR{} -> unauthorizedI MsgUnauthorizedExamCorrector + r -> $unsupportedAuthPredicate AuthExamCorrector r + | otherwise -> Left $ APDB $ \_ _ mAuthId route _ -> case route of + CExamR tid ssh csh examn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, examn) . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isCorrector <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examCorrector) -> do + E.on $ examCorrector E.^. ExamCorrectorExam E.==. exam E.^. ExamId + E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId + E.where_ $ examCorrector E.^. ExamCorrectorUser E.==. E.val authId E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh - guardMExceptT isLecturer (unauthorizedI MsgUnauthorizedLecturer) - return Authorized - AllocationR tid ssh ash _ -> $cachedHereBinary (mAuthId, tid, ssh, ash) . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isLecturer <- lift . E.selectExists . E.from $ \(allocation `E.InnerJoin` allocationCourse `E.InnerJoin` course `E.InnerJoin` lecturer) -> do - E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse - E.on $ course E.^. CourseId E.==. allocationCourse E.^. AllocationCourseCourse - E.on $ allocation E.^. AllocationId E.==. allocationCourse E.^. AllocationCourseAllocation - E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId - E.&&. allocation E.^. AllocationTerm E.==. E.val tid - E.&&. allocation E.^. AllocationSchool E.==. E.val ssh - E.&&. allocation E.^. AllocationShorthand E.==. E.val ash - guardMExceptT isLecturer $ unauthorizedI MsgUnauthorizedAllocationLecturer - return Authorized - EExamR tid ssh coursen examn _ -> $cachedHereBinary (mAuthId, tid, ssh, coursen, examn) . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isLecturer <- lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` staff) -> do - E.on $ eexam E.^. ExternalExamId E.==. staff E.^. ExternalExamStaffExam - E.where_ $ staff E.^. ExternalExamStaffUser E.==. E.val authId - E.&&. eexam E.^. ExternalExamTerm E.==. E.val tid - E.&&. eexam E.^. ExternalExamSchool E.==. E.val ssh - E.&&. eexam E.^. ExternalExamCourseName E.==. E.val coursen - E.&&. eexam E.^. ExternalExamExamName E.==. E.val examn - guardMExceptT isLecturer $ unauthorizedI MsgUnauthorizedExternalExamLecturer - return Authorized - -- lecturer for any school will do - _ -> $cachedHereBinary mAuthId . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolLecturer] [] - return Authorized -tagAccessPredicate AuthCorrector = APDB $ \_ _ mAuthId route _ -> exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - resList <- $cachedHereBinary mAuthId . lift . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do - E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId - E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId - E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val authId - return (course E.^. CourseId, sheet E.^. SheetId) - let - resMap :: Map CourseId (Set SheetId) - resMap = Map.fromListWith Set.union [ (cid, Set.singleton sid) | (E.Value cid, E.Value sid) <- resList ] - case route of - CSubmissionR _ _ _ _ cID _ -> $cachedHereBinary (mAuthId, cID) . maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do - sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID - Submission{..} <- MaybeT . lift $ get sid - guard $ Just authId == submissionRatingBy - return Authorized - CSheetR tid ssh csh shn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, shn) . maybeT (unauthorizedI MsgUnauthorizedSheetCorrector) $ do - Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh - Entity sid _ <- MaybeT . lift . getBy $ CourseSheet cid shn - guard $ sid `Set.member` fromMaybe Set.empty (resMap !? cid) - return Authorized - CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . maybeT (unauthorizedI MsgUnauthorizedCorrector) $ do - Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh - guard $ cid `Set.member` Map.keysSet resMap - return Authorized - _ -> do - guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny) - return Authorized -tagAccessPredicate AuthExamCorrector = APDB $ \_ _ mAuthId route _ -> case route of - CExamR tid ssh csh examn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, examn) . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isCorrector <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examCorrector) -> do - E.on $ examCorrector E.^. ExamCorrectorExam E.==. exam E.^. ExamId - E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId - E.where_ $ examCorrector E.^. ExamCorrectorUser E.==. E.val authId - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - E.&&. exam E.^. ExamName E.==. E.val examn - guardMExceptT isCorrector $ unauthorizedI MsgUnauthorizedExamCorrector - return Authorized - CourseR tid ssh csh _ -> $cachedHereBinary (tid, ssh, csh) . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isCorrector <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examCorrector) -> do - E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse - E.on $ exam E.^. ExamId E.==. examCorrector E.^. ExamCorrectorExam - E.where_ $ examCorrector E.^. ExamCorrectorUser E.==. E.val authId - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - guardMExceptT isCorrector $ unauthorizedI MsgUnauthorizedExamCorrector - return Authorized - r -> $unsupportedAuthPredicate AuthExamCorrector r -tagAccessPredicate AuthTutor = APDB $ \_ _ mAuthId route _ -> exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - resList <- $cachedHereBinary authId . lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do - E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId - E.on $ tutorial E.^. TutorialCourse E.==. course E.^. CourseId - E.where_ $ tutor E.^. TutorUser E.==. E.val authId - return (course E.^. CourseId, tutorial E.^. TutorialId) - let - resMap :: Map CourseId (Set TutorialId) - resMap = Map.fromListWith Set.union [ (cid, Set.singleton tutid) | (E.Value cid, E.Value tutid) <- resList ] - case route of - CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialTutor) $ do - Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh - Entity tutid _ <- $cachedHereBinary (cid, tutn) . MaybeT . lift . getBy $ UniqueTutorial cid tutn - guard $ tutid `Set.member` fromMaybe Set.empty (resMap !? cid) - return Authorized - CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnauthorizedCourseTutor) $ do - Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh - guard $ cid `Set.member` Map.keysSet resMap - return Authorized - _ -> do - guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedTutor) - return Authorized + E.&&. exam E.^. ExamName E.==. E.val examn + guardMExceptT isCorrector $ unauthorizedI MsgUnauthorizedExamCorrector + return Authorized + CourseR tid ssh csh _ -> $cachedHereBinary (tid, ssh, csh) . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isCorrector <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examCorrector) -> do + E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse + E.on $ exam E.^. ExamId E.==. examCorrector E.^. ExamCorrectorExam + E.where_ $ examCorrector E.^. ExamCorrectorUser E.==. E.val authId + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + guardMExceptT isCorrector $ unauthorizedI MsgUnauthorizedExamCorrector + return Authorized + r -> $unsupportedAuthPredicate AuthExamCorrector r + where + mkExamCorrectorList = fmap (setOf $ folded . _Value) . E.select . E.from $ return . (E.^. ExamCorrectorUser) +tagAccessPredicate AuthTutor = cacheAPDB (Just $ Right diffMinute) AuthCacheTutorList mkTutorList $ \mAuthId' route' _ tutorList -> if + | maybe True (`Set.notMember` tutorList) mAuthId' -> Right $ case route' of + _ | is _Nothing mAuthId' -> return AuthenticationRequired + CTutorialR{} -> unauthorizedI MsgUnauthorizedTutorialTutor + CourseR{} -> unauthorizedI MsgUnauthorizedCourseTutor + _other -> unauthorizedI MsgUnauthorizedTutor + | otherwise -> Left $ APDB $ \_ _ mAuthId route _ -> exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + resList <- $cachedHereBinary authId . lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do + E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId + E.on $ tutorial E.^. TutorialCourse E.==. course E.^. CourseId + E.where_ $ tutor E.^. TutorUser E.==. E.val authId + return (course E.^. CourseId, tutorial E.^. TutorialId) + let + resMap :: Map CourseId (Set TutorialId) + resMap = Map.fromListWith Set.union [ (cid, Set.singleton tutid) | (E.Value cid, E.Value tutid) <- resList ] + case route of + CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialTutor) $ do + Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh + Entity tutid _ <- $cachedHereBinary (cid, tutn) . MaybeT . lift . getBy $ UniqueTutorial cid tutn + guard $ tutid `Set.member` fromMaybe Set.empty (resMap !? cid) + return Authorized + CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnauthorizedCourseTutor) $ do + Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh + guard $ cid `Set.member` Map.keysSet resMap + return Authorized + _ -> do + guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedTutor) + return Authorized + where + mkTutorList = fmap (setOf $ folded . _Value) . E.select . E.from $ return . (E.^. TutorUser) tagAccessPredicate AuthTutorControl = APDB $ \_ _ _ route _ -> case route of CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialTutorControl) $ do Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh @@ -614,16 +864,17 @@ tagAccessPredicate AuthTutorControl = APDB $ \_ _ _ route _ -> case route of r -> $unsupportedAuthPredicate AuthTutorControl r tagAccessPredicate AuthSubmissionGroup = APDB $ \_ _ mAuthId route _ -> case route of CSubmissionR tid ssh csh shn cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionSubmissionGroup) $ do - course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh - Entity _ Sheet{..} <- $cachedHereBinary (course, shn) . MaybeT . getBy $ CourseSheet course shn - smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID - groups <- $cachedHereBinary cID . lift . fmap (Set.fromList . fmap E.unValue) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionUser) -> do - E.on $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. submissionUser E.^. SubmissionUserUser - E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val smId - return $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup - unless (Set.null groups || isn't _RegisteredGroups sheetGrouping) $ do - uid <- hoistMaybe mAuthId - guardM . lift $ exists [SubmissionGroupUserUser ==. uid, SubmissionGroupUserSubmissionGroup <-. Set.toList groups] + course <- MaybeT . $cachedHereBinary (tid, ssh, csh) . getKeyBy $ TermSchoolCourseShort tid ssh csh + Entity _ Sheet{..} <- MaybeT . $cachedHereBinary (course, shn) . getBy $ CourseSheet course shn + when (is _RegisteredGroups sheetGrouping) $ do + smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID + groups <- $cachedHereBinary cID . lift . fmap (Set.fromList . fmap E.unValue) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionUser) -> do + E.on $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. submissionUser E.^. SubmissionUserUser + E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val smId + return $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup + unless (Set.null groups) $ do + uid <- hoistMaybe mAuthId + guardM . lift $ exists [SubmissionGroupUserUser ==. uid, SubmissionGroupUserSubmissionGroup <-. Set.toList groups] return Authorized CSheetR tid ssh csh sheetn _ -> maybeT (unauthorizedI MsgUnauthorizedSheetSubmissionGroup) $ do course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh @@ -897,19 +1148,49 @@ tagAccessPredicate AuthCourseTime = APDB $ \_ _ _mAuthId route _ -> case route o guardMExceptT courseVisible (unauthorizedI MsgUnauthorizedCourseTime) return Authorized r -> $unsupportedAuthPredicate AuthCourseTime r -tagAccessPredicate AuthCourseRegistered = APDB $ \_ _ mAuthId route _ -> case route of - CourseR tid ssh csh _ -> exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isRegistered <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` courseParticipant) -> do - E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse - E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val authId - E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - guardMExceptT isRegistered (unauthorizedI MsgUnauthorizedRegistered) +tagAccessPredicate AuthExamTime = APDB $ \_ _ _ route _ -> case route of + CSubmissionR tid ssh csh shn _cID CorrectionR -> maybeT (unauthorizedI MsgUnauthorizedCorrectionExamTime) $ do + cid <- MaybeT . $cachedHereBinary (tid, ssh, csh) . getKeyBy $ TermSchoolCourseShort tid ssh csh + Entity _sid Sheet{..} <- MaybeT . $cachedHereBinary (cid, shn) . getBy $ CourseSheet cid shn + whenIsJust (sheetType ^? _examPart . from _SqlKey) $ \epId -> do + ExamPart{examPartExam} <- MaybeT . $cachedHereBinary epId $ get epId + Exam{..} <- MaybeT . $cachedHereBinary examPartExam $ get examPartExam + now <- liftIO getCurrentTime + guard $ NTop (Just now) >= NTop examFinished return Authorized - r -> $unsupportedAuthPredicate AuthCourseRegistered r + r -> $unsupportedAuthPredicate AuthExamTime r +tagAccessPredicate AuthCourseRegistered = cacheAPDB' (Just $ Right diffMinute) mkAuthCacheCourseRegisteredList $ \mAuthId' route' _ mCourseRegisteredList -> if + | Just courseRegisteredList <- mCourseRegisteredList + , maybe True (`Set.notMember` courseRegisteredList) mAuthId' -> Right $ case route' of + _ | is _Nothing mAuthId' -> return AuthenticationRequired + CourseR{} -> unauthorizedI MsgUnauthorizedRegistered + r -> $unsupportedAuthPredicate AuthCourseRegistered r + | otherwise -> Left $ APDB $ \_ _ mAuthId route _ -> case route of + CourseR tid ssh csh _ -> exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isRegistered <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` courseParticipant) -> do + E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse + E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val authId + E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + guardMExceptT isRegistered (unauthorizedI MsgUnauthorizedRegistered) + return Authorized + r -> $unsupportedAuthPredicate AuthCourseRegistered r + where + mkAuthCacheCourseRegisteredList _ route _ = case route of + CourseR tid ssh csh _ -> Just + ( AuthCacheCourseRegisteredList tid ssh csh + , fmap (setOf $ folded . _Value) . E.select . E.from $ \(course `E.InnerJoin` courseParticipant) -> do + E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse + E.where_ $ courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + return $ courseParticipant E.^. CourseParticipantUser + ) + _other -> Nothing tagAccessPredicate AuthTutorialRegistered = APDB $ \_ _ mAuthId route _ -> case route of CTutorialR tid ssh csh tutn _ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId @@ -1223,8 +1504,10 @@ tagAccessPredicate AuthCapacity = APDB $ \_ _ _ route _ -> case route of cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh eid <- $cachedHereBinary (cid, examn) . MaybeT . getKeyBy $ UniqueExam cid examn Entity occId ExamOccurrence{..} <- $cachedHereBinary (eid, occn) . MaybeT . getBy $ UniqueExamOccurrence eid occn - registered <- $cachedHereBinary occId . lift $ fromIntegral <$> count [ ExamRegistrationOccurrence ==. Just occId, ExamRegistrationExam ==. eid ] - guard $ examOccurrenceCapacity > registered + -- Nothing means unlimited size + whenIsJust examOccurrenceCapacity $ \capacity -> do + registered <- $cachedHereBinary occId . lift $ fromIntegral <$> count [ ExamRegistrationOccurrence ==. Just occId, ExamRegistrationExam ==. eid ] + guard $ capacity > registered return Authorized CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgTutorialNoCapacity) $ do cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh @@ -1254,47 +1537,69 @@ tagAccessPredicate AuthRegisterGroup = APDB $ \_ _ mAuthId route _ -> case route guard $ not hasOther return Authorized r -> $unsupportedAuthPredicate AuthRegisterGroup r -tagAccessPredicate AuthEmpty = APDB $ \_ _ mAuthId route _ - -> let workflowInstanceWorkflowsEmpty rScope win = selectLanguageI18n <=< $cachedHereBinary (mAuthId, route) . maybeT (unauthorizedI18n MsgUnauthorizedWorkflowWorkflowsNotEmpty) $ do - scope <- fromRouteWorkflowScope rScope - let dbScope = scope ^. _DBWorkflowScope - getWorkflowWorkflows = E.selectSource . E.from $ \(workflowWorkflow `E.InnerJoin` workflowInstance) -> do - E.on $ workflowWorkflow E.^. WorkflowWorkflowInstance E.==. E.just (workflowInstance E.^. WorkflowInstanceId) - E.where_ $ workflowInstance E.^. WorkflowInstanceName E.==. E.val win - E.&&. workflowInstance E.^. WorkflowInstanceScope E.==. E.val dbScope - return ( workflowWorkflow E.^. WorkflowWorkflowId - , workflowWorkflow E.^. WorkflowWorkflowScope - ) - checkAccess (E.Value wwId, E.Value wwScope) = maybeT (return False) $ do - cID <- encrypt wwId - rScope' <- toRouteWorkflowScope $ _DBWorkflowScope # wwScope - guardM . fmap (is _Authorized) . flip (evalAccessFor mAuthId) False $ _WorkflowScopeRoute # (rScope', WorkflowWorkflowR cID WWWorkflowR) - return True - guardM . fmap not . lift . runConduit $ getWorkflowWorkflows .| C.mapM checkAccess .| C.or - return AuthorizedI18n - in case route of - r | Just (rScope, WorkflowInstanceR win WIWorkflowsR) <- r ^? _WorkflowScopeRoute - -> workflowInstanceWorkflowsEmpty rScope win - EExamListR -> exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - hasExternalExams <- $cachedHereBinary authId . lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` eexamStaff) -> do - E.on $ eexam E.^. ExternalExamId E.==. eexamStaff E.^. ExternalExamStaffExam - E.where_ $ eexamStaff E.^. ExternalExamStaffUser E.==. E.val authId - E.||. E.exists (E.from $ \externalExamResult -> - E.where_ $ externalExamResult E.^. ExternalExamResultExam E.==. eexam E.^. ExternalExamId - E.&&. externalExamResult E.^. ExternalExamResultUser E.==. E.val authId - ) - guardMExceptT (not hasExternalExams) $ unauthorizedI MsgUnauthorizedExternalExamListNotEmpty - return Authorized - CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNotEmpty) $ do - -- Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh - cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh - assertM_ (<= 0) . $cachedHereBinary cid . lift $ count [ CourseParticipantCourse ==. cid ] - assertM_ not . $cachedHereBinary cid . lift $ E.selectExists . E.from $ \(sheet `E.InnerJoin` submission) -> do - E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet - E.where_ $ sheet E.^. SheetCourse E.==. E.val cid - return Authorized - r -> $unsupportedAuthPredicate AuthEmpty r +tagAccessPredicate AuthEmpty = APDB $ \evalCtx eval' mAuthId route _ -> do + mr <- getMsgRenderer + let orAR', _andAR' :: forall m'. Monad m' => m' AuthResult -> m' AuthResult -> m' AuthResult + orAR' = shortCircuitM (is _Authorized) (orAR mr) + _andAR' = shortCircuitM (is _Unauthorized) (andAR mr) + + workflowInstanceWorkflowsEmpty rScope win = selectLanguageI18n <=< $cachedHereBinary (evalCtx, mAuthId, route) . maybeT (unauthorizedI18n MsgUnauthorizedWorkflowWorkflowsNotEmpty) $ do + roles <- memcacheAuth' (Right diffDay) (AuthCacheWorkflowInstanceWorkflowViewers win rScope) $ do + scope <- fromRouteWorkflowScope rScope + let dbScope = scope ^. _DBWorkflowScope + getWorkflowWorkflows = E.selectSource . E.from $ \(workflowWorkflow `E.InnerJoin` workflowInstance) -> do + E.on $ workflowWorkflow E.^. WorkflowWorkflowInstance E.==. E.just (workflowInstance E.^. WorkflowInstanceId) + E.where_ $ workflowInstance E.^. WorkflowInstanceName E.==. E.val win + E.&&. workflowInstance E.^. WorkflowInstanceScope E.==. E.val dbScope + return workflowWorkflow + workflowRoles (Entity wwId WorkflowWorkflow{..}) = do + wwGraph <- getSharedIdWorkflowGraph workflowWorkflowGraph + let + nodeViewers = do + WorkflowAction{..} <- otoList workflowWorkflowState + (node, WGN{..}) <- itoListOf (_wgNodes . ifolded) wwGraph + guard $ node == wpTo + WorkflowNodeView{..} <- hoistMaybe wgnViewers + return $ toNullable wnvViewers + payloadViewers = do + (prevActs, act) <- zip (inits $ otoList workflowWorkflowState) $ otoList workflowWorkflowState + prevAct <- hoistMaybe $ prevActs ^? _last + payload <- Map.keys $ wpPayload act + guard $ Map.lookup payload (workflowStateCurrentPayloads prevActs) /= Map.lookup payload (wpPayload act) + fmap (toNullable . wpvViewers) . hoistMaybe $ Map.lookup payload . wgnPayloadView =<< Map.lookup (wpTo prevAct) (wgNodes wwGraph) + return . Set.mapMonotonic ((workflowWorkflowScope, wwId), ) $ fold nodeViewers <> fold payloadViewers + lift . runConduit $ getWorkflowWorkflows .| C.foldMapM workflowRoles + let + evalRole ((wwScope, wwId), role) = do + rScope' <- toRouteWorkflowScope $ _DBWorkflowScope # wwScope + cID <- encrypt wwId + let route' = _WorkflowScopeRoute # (rScope', WorkflowWorkflowR cID WWWorkflowR) + lift . evalWriterT $ evalWorkflowRoleFor' eval' mAuthId (Just wwId) role route' False + guardM . fmap (isn't _Authorized) $ ofoldl1' orAR' . mapNonNull evalRole =<< hoistMaybe (fromNullable $ otoList roles) + return AuthorizedI18n + in case route of + r | Just (rScope, WorkflowInstanceR win WIWorkflowsR) <- r ^? _WorkflowScopeRoute + -> workflowInstanceWorkflowsEmpty rScope win + EExamListR -> exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + hasExternalExams <- $cachedHereBinary authId . lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` eexamStaff) -> do + E.on $ eexam E.^. ExternalExamId E.==. eexamStaff E.^. ExternalExamStaffExam + E.where_ $ eexamStaff E.^. ExternalExamStaffUser E.==. E.val authId + E.||. E.exists (E.from $ \externalExamResult -> + E.where_ $ externalExamResult E.^. ExternalExamResultExam E.==. eexam E.^. ExternalExamId + E.&&. externalExamResult E.^. ExternalExamResultUser E.==. E.val authId + ) + guardMExceptT (not hasExternalExams) $ unauthorizedI MsgUnauthorizedExternalExamListNotEmpty + return Authorized + CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNotEmpty) $ do + -- Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh + cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh + assertM_ (<= 0) . $cachedHereBinary cid . lift $ count [ CourseParticipantCourse ==. cid ] + assertM_ not . $cachedHereBinary cid . lift $ E.selectExists . E.from $ \(sheet `E.InnerJoin` submission) -> do + E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet + E.where_ $ sheet E.^. SheetCourse E.==. E.val cid + return Authorized + r -> $unsupportedAuthPredicate AuthEmpty r tagAccessPredicate AuthMaterials = APDB $ \_ _ _ route _ -> case route of CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do Entity _ Course{..} <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh @@ -1415,18 +1720,16 @@ tagAccessPredicate AuthWorkflow = APDB $ \evalCtx eval' mAuthId route isWrite -> wInitiate win rScope = selectLanguageI18n <=< $memcacheAuthHere' (Right diffDay) (evalCtx, route, mAuthId) . maybeT (unauthorizedI18n MsgUnauthorizedWorkflowInitiate) $ do -- @isWrite@ not included since it should make no difference regarding initiation (in the end that will always be a write) - scope <- MaybeT . $cachedHereBinary rScope . runMaybeT $ fromRouteWorkflowScope rScope - Entity _ WorkflowInstance{..} <- $cachedHereBinary (win, scope) . MaybeT . getBy . UniqueWorkflowInstance win $ scope ^. _DBWorkflowScope - wiGraph <- lift $ getSharedIdWorkflowGraph workflowInstanceGraph - let - edges = do + roles <- memcacheAuth' (Right diffDay) (AuthCacheWorkflowInstanceInitiators win rScope) $ do + scope <- MaybeT . $cachedHereBinary rScope . runMaybeT $ fromRouteWorkflowScope rScope + Entity _ WorkflowInstance{..} <- $cachedHereBinary (win, scope) . MaybeT . getBy . UniqueWorkflowInstance win $ scope ^. _DBWorkflowScope + wiGraph <- lift $ getSharedIdWorkflowGraph workflowInstanceGraph + return . fold $ do WGN{..} <- wiGraph ^.. _wgNodes . folded WorkflowGraphEdgeInitial{..} <- wgnEdges ^.. folded - hoistMaybe . fromNullable $ wgeActors ^.. folded - let - evalRole role = lift . evalWriterT $ evalWorkflowRoleFor' eval' mAuthId Nothing role route isWrite - checkEdge actors = ofoldr1 orAR' (mapNonNull evalRole actors) - guardM . fmap (is _Authorized) $ ofoldr1 orAR' . mapNonNull checkEdge =<< hoistMaybe (fromNullable edges) + return wgeActors + let evalRole role = lift . evalWriterT $ evalWorkflowRoleFor' eval' mAuthId Nothing role route isWrite + guardM . fmap (is _Authorized) $ ofoldl1' orAR' . mapNonNull evalRole =<< hoistMaybe (fromNullable $ toList roles) return AuthorizedI18n wWorkflow isWrite' cID @@ -1447,7 +1750,7 @@ tagAccessPredicate AuthWorkflow = APDB $ \evalCtx eval' mAuthId route isWrite -> let evalRole role = lift . evalWriterT $ evalWorkflowRoleFor' eval' mAuthId (Just wwId) role route isWrite - guardM . fmap (is _Authorized) $ ofoldr1 orAR' . mapNonNull evalRole =<< hoistMaybe (fromNullable $ otoList edges) + guardM . fmap (is _Authorized) $ ofoldl1' orAR' . mapNonNull evalRole =<< hoistMaybe (fromNullable $ otoList edges) return Authorized | otherwise = flip orAR' (wWorkflow True cID) . maybeT (unauthorizedI MsgUnauthorizedWorkflowRead) $ do (wwId, roles) <- memcacheAuth' (Right diffDay) (AuthCacheWorkflowWorkflowViewers cID) $ do @@ -1473,7 +1776,7 @@ tagAccessPredicate AuthWorkflow = APDB $ \evalCtx eval' mAuthId route isWrite -> let evalRole role = lift . evalWriterT $ evalWorkflowRoleFor' eval' mAuthId (Just wwId) role route isWrite - guardM . fmap (is _Authorized) $ ofoldr1 orAR' . mapNonNull evalRole =<< hoistMaybe (fromNullable $ otoList roles) + guardM . fmap (is _Authorized) $ ofoldl1' orAR' . mapNonNull evalRole =<< hoistMaybe (fromNullable $ otoList roles) return Authorized wFiles wwCID wpl stCID = maybeT (unauthorizedI MsgUnauthorizedWorkflowFiles) $ do wwId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt wwCID @@ -1551,7 +1854,12 @@ evalAuthTags ctx authActive@AuthTagActive{..} cont (map (Set.toList . toNullable where evalAccessPred' authTag' mAuthId' route' isWrite' = lift $ do $logDebugS "evalAccessPred" $ tshow (authTag', mAuthId', route', isWrite') - evalAccessPred (tagAccessPredicate authTag') contCtx cont mAuthId' route' isWrite' + observeAuthTagEvaluation authTag' (classifyHandler route') $ do + res <- evalAccessPred (tagAccessPredicate authTag') contCtx cont mAuthId' route' isWrite' + return . (res, ) $ case res of + Authorized -> OutcomeAuthorized + Unauthorized _ -> OutcomeUnauthorized + AuthenticationRequired -> OutcomeAuthenticationRequired evalAuthLiteral :: AuthLiteral -> WriterT (Set AuthTag) m AuthResult evalAuthLiteral PLVariable{..} = evalAuthTag plVar @@ -1580,13 +1888,13 @@ evalAuthTags ctx authActive@AuthTagActive{..} cont (map (Set.toList . toNullable return result -evalAccessWithFor :: (HasCallStack, MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => [(AuthTag, Bool)] -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult +evalAccessWithFor :: (HasCallStack, MonadThrow m, MonadAP m) => [(AuthTag, Bool)] -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult evalAccessWithFor assumptions mAuthId route isWrite = do isSelf <- (== mAuthId) <$> liftHandler defaultMaybeAuthId tagActive <- if | isSelf -> fromMaybe def <$> lookupSessionJson SessionActiveAuthTags | otherwise -> return . AuthTagActive $ const True - dnf <- either throwM return $ routeAuthTags route + dnf <- throwLeft $ routeAuthTags route let adjDNF = ala Endo foldMap (map ((=<<) . uncurry dnfAssumeValue) assumptions) . Just evalAdj :: forall m'. MonadAP m' => AuthTagsEval m' evalAdj (adjDNF -> dnf') mAuthId' route' isWrite' = case dnf' of @@ -1598,42 +1906,42 @@ evalAccessWithFor assumptions mAuthId route isWrite = do tellSessionJson SessionInactiveAuthTags deactivated return result -evalAccessFor :: (HasCallStack, MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult +evalAccessFor :: (HasCallStack, MonadThrow m, MonadAP m) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult evalAccessFor = evalAccessWithFor [] -evalAccessForDB :: (HasCallStack, MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX, BackendCompatible SqlReadBackend backend) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT backend m AuthResult +evalAccessForDB :: (HasCallStack, MonadThrow m, MonadAP m, BackendCompatible SqlReadBackend backend) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT backend m AuthResult evalAccessForDB = evalAccessFor -evalAccessWith :: (HasCallStack, MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => [(AuthTag, Bool)] -> Route UniWorX -> Bool -> m AuthResult +evalAccessWith :: (HasCallStack, MonadThrow m, MonadAP m) => [(AuthTag, Bool)] -> Route UniWorX -> Bool -> m AuthResult evalAccessWith assumptions route isWrite = do mAuthId <- liftHandler maybeAuthId evalAccessWithFor assumptions mAuthId route isWrite -evalAccessWithDB :: (HasCallStack, MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX, BackendCompatible SqlReadBackend backend) => [(AuthTag, Bool)] -> Route UniWorX -> Bool -> ReaderT backend m AuthResult +evalAccessWithDB :: (HasCallStack, MonadThrow m, MonadAP m, BackendCompatible SqlReadBackend backend) => [(AuthTag, Bool)] -> Route UniWorX -> Bool -> ReaderT backend m AuthResult evalAccessWithDB = evalAccessWith -evalAccess :: (HasCallStack, MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => Route UniWorX -> Bool -> m AuthResult +evalAccess :: (HasCallStack, MonadThrow m, MonadAP m) => Route UniWorX -> Bool -> m AuthResult evalAccess = evalAccessWith [] -evalAccessDB :: (HasCallStack, MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX, BackendCompatible SqlReadBackend backend) => Route UniWorX -> Bool -> ReaderT backend m AuthResult +evalAccessDB :: (HasCallStack, MonadThrow m, MonadAP m, BackendCompatible SqlReadBackend backend) => Route UniWorX -> Bool -> ReaderT backend m AuthResult evalAccessDB = evalAccess -- | Check whether the current user is authorized by `evalAccess` for the given route -- Convenience function for a commonly used code fragment -hasAccessTo :: (HasCallStack, MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => Route UniWorX -> Bool -> m Bool +hasAccessTo :: (HasCallStack, MonadThrow m, MonadAP m) => Route UniWorX -> Bool -> m Bool hasAccessTo route isWrite = (== Authorized) <$> evalAccess route isWrite -- | Check whether the current user is authorized by `evalAccess` to read from the given route -- Convenience function for a commonly used code fragment -hasReadAccessTo :: (HasCallStack, MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => Route UniWorX -> m Bool +hasReadAccessTo :: (HasCallStack, MonadThrow m, MonadAP m) => Route UniWorX -> m Bool hasReadAccessTo = flip hasAccessTo False -- | Check whether the current user is authorized by `evalAccess` to rwrite to the given route -- Convenience function for a commonly used code fragment -hasWriteAccessTo :: (HasCallStack, MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => Route UniWorX -> m Bool +hasWriteAccessTo :: (HasCallStack, MonadThrow m, MonadAP m) => Route UniWorX -> m Bool hasWriteAccessTo = flip hasAccessTo True -wouldHaveAccessTo :: (HasCallStack, MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) +wouldHaveAccessTo :: (HasCallStack, MonadThrow m, MonadAP m) => [(AuthTag, Bool)] -- ^ Assumptions -> Route UniWorX -> Bool @@ -1641,7 +1949,7 @@ wouldHaveAccessTo :: (HasCallStack, MonadThrow m, MonadHandler m, HandlerSite m wouldHaveAccessTo assumptions route isWrite = (== Authorized) <$> evalAccessWith assumptions route isWrite wouldHaveReadAccessTo, wouldHaveWriteAccessTo - :: (HasCallStack, MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) + :: (HasCallStack, MonadThrow m, MonadAP m) => [(AuthTag, Bool)] -- ^ Assumptions -> Route UniWorX -> m Bool @@ -1649,7 +1957,7 @@ wouldHaveReadAccessTo assumptions route = wouldHaveAccessTo assumptions route Fa wouldHaveWriteAccessTo assumptions route = wouldHaveAccessTo assumptions route True wouldHaveReadAccessToIff, wouldHaveWriteAccessToIff - :: (HasCallStack, MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) + :: (HasCallStack, MonadThrow m, MonadAP m) => [(AuthTag, Bool)] -- ^ Assumptions -> Route UniWorX -> m Bool @@ -1659,9 +1967,7 @@ wouldHaveWriteAccessToIff assumptions route = and2M (not <$> hasWriteAccessTo ro evalWorkflowRoleFor' :: forall m backend. ( HasCallStack - , MonadHandler m - , HandlerSite m ~ UniWorX - , BearerAuthSite UniWorX + , MonadAP (ReaderT backend m), MonadIO m , BackendCompatible SqlReadBackend backend ) => (forall m'. MonadAP m' => AuthTagsEval m') @@ -1708,9 +2014,7 @@ evalWorkflowRoleFor' eval mAuthId mwwId wRole route isWrite = do WorkflowRoleAuthorized{..} -> eval (predDNFEntail $ workflowRoleAuthorized `predDNFOr` defaultAuthDNF) mAuthId route isWrite evalWorkflowRoleFor :: ( HasCallStack - , MonadHandler m - , HandlerSite m ~ UniWorX - , BearerAuthSite UniWorX + , MonadAP (ReaderT backend m), MonadIO m , BackendCompatible SqlReadBackend backend ) => Maybe UserId @@ -1733,10 +2037,9 @@ evalWorkflowRoleFor mAuthId mwwId wRole route isWrite = do return result hasWorkflowRole :: ( HasCallStack - , MonadHandler m - , HandlerSite m ~ UniWorX - , BearerAuthSite UniWorX + , MonadAP (ReaderT backend m) , BackendCompatible SqlReadBackend backend + , MonadHandler m, HandlerSite m ~ UniWorX ) => Maybe WorkflowWorkflowId -> WorkflowRole UserId @@ -1749,12 +2052,12 @@ hasWorkflowRole mwwId wRole route isWrite = do mayViewWorkflowAction' :: forall backend m fileid. ( HasCallStack - , MonadHandler m - , HandlerSite m ~ UniWorX - , BearerAuthSite UniWorX + , MonadAP (ReaderT backend m) , BackendCompatible SqlReadBackend backend , MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey , MonadCatch m + , MonadHandler m, HandlerSite m ~ UniWorX + , MonadUnliftIO m ) => (forall m'. MonadAP m' => AuthTagsEval m') -> Maybe UserId @@ -1764,7 +2067,7 @@ mayViewWorkflowAction' :: forall backend m fileid. mayViewWorkflowAction' eval mAuthId wwId WorkflowAction{..} = hoist (withReaderT $ projectBackend @SqlReadBackend) . maybeT (return False) $ do WorkflowWorkflow{..} <- MaybeT . lift $ get wwId rScope <- hoist lift . toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope - cID <- hoist lift . catchMaybeT (Proxy @CryptoIDError) . lift $ encrypt wwId + cID <- catchMaybeT (Proxy @CryptoIDError) . lift . lift $ encrypt wwId WorkflowGraph{..} <- lift . lift $ getSharedIdWorkflowGraph workflowWorkflowGraph let canonRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR) evalWorkflowRole'' role = lift $ is _Authorized <$> evalWorkflowRoleFor' eval mAuthId (Just wwId) role canonRoute False @@ -1780,12 +2083,12 @@ mayViewWorkflowAction' eval mAuthId wwId WorkflowAction{..} = hoist (withReaderT mayViewWorkflowAction :: forall backend m fileid. ( HasCallStack - , MonadHandler m - , HandlerSite m ~ UniWorX - , BearerAuthSite UniWorX + , MonadAP (ReaderT backend m) , BackendCompatible SqlReadBackend backend , MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey , MonadCatch m + , MonadHandler m, HandlerSite m ~ UniWorX + , MonadUnliftIO m ) => Maybe UserId -> WorkflowWorkflowId diff --git a/src/Foundation/DB.hs b/src/Foundation/DB.hs index 25cce0f45..87f93a952 100644 --- a/src/Foundation/DB.hs +++ b/src/Foundation/DB.hs @@ -1,6 +1,7 @@ module Foundation.DB ( runDBRead, runDBRead' , runSqlPoolRetry, runSqlPoolRetry' + , dbPoolPressured ) where import Import.NoFoundation hiding (runDB, getDBRunner) @@ -61,3 +62,13 @@ runDBRead' :: CallStack -> ReaderT SqlReadBackend (HandlerFor UniWorX) a -> (Han runDBRead' lbl action = do $logDebugS "YesodPersist" "runDBRead" flip (runSqlPoolRetry' . withReaderT SqlReadBackend $ [executeQQ|SET TRANSACTION READ ONLY|] *> action) lbl . appConnPool =<< getYesod + +dbPoolPressured :: ( MonadHandler m + , HandlerSite m ~ UniWorX + ) + => m Bool +dbPoolPressured = do + connPool <- getsYesod @_ @(Custom.Pool' IO _ _ _) appConnPool + case Custom.getPoolMaxAvailable connPool of + Nothing -> return False + Just lim -> atomically $ (>= lim) <$> Custom.getPoolInUseCount connPool diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index aa078fc90..92c9a4c1a 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -9,8 +9,11 @@ module Foundation.I18n , UniWorXSheetMessage(..), UniWorXAdminMessage(..), UniWorXSubmissionMessage(..) , UniWorXTutorialMessage(..), UniWorXUserMessage(..), UniWorXButtonMessage(..) , UniWorXFormMessage(..), UniWorXRatingMessage(..), UniWorXTableColumnMessage(..) - , UniWorXTablePaginationMessage(..),UniWorXUtilMessage(..) - , ShortTermIdentifier(..) + , UniWorXTablePaginationMessage(..),UniWorXUtilMessage(..), UniWorXAuthorizationMessage(..) + , UniWorXMaterialMessage(..), UniWorXParticipantsMessage(..), UniWorXHealthMessage(..), UniWorXInfoMessage(..) + , UniWorXMetricsMessage(..), UniWorXNewsMessage(..), UniWorXSchoolMessage(..), UniWorXSystemMessageMessage(..) + , UniWorXTermMessage(..), UniWorXSendMessage(..) + , ShortTermIdentifier(..) , MsgLanguage(..) , ShortSex(..) , ShortWeekDay(..) @@ -143,13 +146,24 @@ mkMessageAddition ''UniWorX "Settings" "messages/uniworx/uniworx_new/categories/ mkMessageAddition ''UniWorX "Help" "messages/uniworx/uniworx_new/categories/help" "de-de-formal" mkMessageAddition ''UniWorX "Navigation" "messages/uniworx/uniworx_new/utils/navigation" "de-de-formal" mkMessageAddition ''UniWorX "Workflow" "messages/uniworx/uniworx_new/categories/workflows" "de-de-formal" -mkMessageAddition ''UniWorX "Course" "messages/uniworx/uniworx_new/categories/courses" "de-de-formal" -mkMessageAddition ''UniWorX "Allocation" "messages/uniworx/uniworx_new/categories/allocation" "de-de-formal" -mkMessageAddition ''UniWorX "Exam" "messages/uniworx/uniworx_new/categories/exam" "de-de-formal" -mkMessageAddition ''UniWorX "Sheet" "messages/uniworx/uniworx_new/categories/sheet" "de-de-formal" +mkMessageAddition ''UniWorX "Course" "messages/uniworx/uniworx_new/categories/courses/courses" "de-de-formal" +mkMessageAddition ''UniWorX "Allocation" "messages/uniworx/uniworx_new/categories/courses/allocation" "de-de-formal" +mkMessageAddition ''UniWorX "Exam" "messages/uniworx/uniworx_new/categories/courses/exam" "de-de-formal" +mkMessageAddition ''UniWorX "Sheet" "messages/uniworx/uniworx_new/categories/courses/sheet" "de-de-formal" mkMessageAddition ''UniWorX "Admin" "messages/uniworx/uniworx_new/categories/admin" "de-de-formal" -mkMessageAddition ''UniWorX "Submission" "messages/uniworx/uniworx_new/categories/submission" "de-de-formal" -mkMessageAddition ''UniWorX "Tutorial" "messages/uniworx/uniworx_new/categories/tutorial" "de-de-formal" +mkMessageAddition ''UniWorX "Submission" "messages/uniworx/uniworx_new/categories/courses/submission" "de-de-formal" +mkMessageAddition ''UniWorX "Tutorial" "messages/uniworx/uniworx_new/categories/courses/tutorial" "de-de-formal" +mkMessageAddition ''UniWorX "Material" "messages/uniworx/uniworx_new/categories/courses/material" "de-de-formal" +mkMessageAddition ''UniWorX "Authorization" "messages/uniworx/uniworx_new/categories/authorization" "de-de-formal" +mkMessageAddition ''UniWorX "Health" "messages/uniworx/uniworx_new/categories/health" "de-de-formal" +mkMessageAddition ''UniWorX "Info" "messages/uniworx/uniworx_new/categories/info" "de-de-formal" +mkMessageAddition ''UniWorX "Metrics" "messages/uniworx/uniworx_new/categories/metrics" "de-de-formal" +mkMessageAddition ''UniWorX "News" "messages/uniworx/uniworx_new/categories/news" "de-de-formal" +mkMessageAddition ''UniWorX "School" "messages/uniworx/uniworx_new/categories/school" "de-de-formal" +mkMessageAddition ''UniWorX "SystemMessage" "messages/uniworx/uniworx_new/categories/system_message" "de-de-formal" +mkMessageAddition ''UniWorX "Participants" "messages/uniworx/uniworx_new/categories/courses/participants" "de-de-formal" +mkMessageAddition ''UniWorX "Term" "messages/uniworx/uniworx_new/categories/term" "de-de-formal" +mkMessageAddition ''UniWorX "Send" "messages/uniworx/uniworx_new/categories/send" "de-de-formal" mkMessageAddition ''UniWorX "User" "messages/uniworx/uniworx_new/categories/user" "de-de-formal" mkMessageAddition ''UniWorX "Button" "messages/uniworx/uniworx_new/utils/buttons" "de-de-formal" mkMessageAddition ''UniWorX "Form" "messages/uniworx/uniworx_new/utils/form" "de-de-formal" @@ -250,6 +264,7 @@ embedRenderMessage ''UniWorX ''SchoolFunction id embedRenderMessage ''UniWorX ''SystemFunction id embedRenderMessage ''UniWorX ''CsvPreset id embedRenderMessage ''UniWorX ''Quoting ("Csv" <>) +embedRenderMessage ''UniWorX ''CsvFormat ("Csv" <>) embedRenderMessage ''UniWorX ''FavouriteReason id embedRenderMessage ''UniWorX ''Sex id embedRenderMessage ''UniWorX ''ExamGradingMode id diff --git a/src/Foundation/Instances.hs b/src/Foundation/Instances.hs index 6070c9a44..6c43332ee 100644 --- a/src/Foundation/Instances.hs +++ b/src/Foundation/Instances.hs @@ -107,7 +107,8 @@ instance Yesod UniWorX where -- The page to be redirected to when authentication is required. authRoute _ = Just $ AuthR LoginR - isAuthorized = evalAccess + isAuthorized :: HasCallStack => Route UniWorX -> Bool -> HandlerFor UniWorX AuthResult + isAuthorized r w = runDBRead $ evalAccess r w addStaticContent = UniWorX.addStaticContent @@ -184,14 +185,15 @@ instance YesodAuth UniWorX where _other -> Auth.germanMessage where lang = Text.splitOn "-" $ selectLanguage' appLanguages ls - maybeAuthId = runMaybeT $ authIdFromBearer <|> MaybeT defaultMaybeAuthId + maybeAuthId :: (HasCallStack, MonadHandler m, HandlerSite m ~ UniWorX) => m (Maybe (AuthId UniWorX)) + maybeAuthId = $cachedHere . runMaybeT $ authIdFromBearer <|> MaybeT defaultMaybeAuthId where authIdFromBearer = do - BearerToken{..} <- MaybeT maybeBearerToken + BearerToken{..} <- MaybeT . liftHandler $ runDBRead maybeBearerToken hoistMaybe bearerImpersonate instance YesodAuthPersist UniWorX where getAuthEntity :: (HasCallStack, MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m (Maybe User) - getAuthEntity = liftHandler . runDBRead' callStack . get + getAuthEntity = liftHandler . runDBRead . get instance YesodMail UniWorX where diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index e5f753f01..d57751dd8 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -7,6 +7,7 @@ module Foundation.Navigation ( NavQuickView(..), NavType(..), NavLevel(..), NavHeaderRole(..), NavLink(..), Nav(..), NavChildren , _navModal, _navMethod, _navData, _navLabel, _navType, _navForceActive, _navHeaderRole, _navIcon, _navLink, _navChildren , _NavHeader, _NavHeaderContainer, _NavPageActionPrimary, _NavPageActionSecondary, _NavFooter + , NavigationCacheKey(..) , navBaseRoute, navLinkRoute , pageActions , pageQuickActions @@ -14,6 +15,7 @@ module Foundation.Navigation , navAccess , navQuick , evalAccessCorrector + , breadcrumb ) where import Import.NoFoundation hiding (runDB) @@ -22,7 +24,6 @@ import Foundation.Type import Foundation.Routes import Foundation.I18n import Foundation.Authorization -import Foundation.DB import Handler.Utils.Memcached import Handler.Utils.ExamOffice.Course @@ -41,12 +42,20 @@ import qualified Data.Conduit.Combinators as C import Utils.Workflow import Handler.Utils.Workflow.CanonicalRoute +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Data.List (inits) + + +type Breadcrumb = (Text, Maybe (Route UniWorX)) + -- Define breadcrumbs. -i18nCrumb :: (RenderMessage (HandlerSite m) msg, MonadHandler m) +i18nCrumb :: forall msg m. + (RenderMessage UniWorX msg, MonadHandler m, HandlerSite m ~ UniWorX) => msg - -> Maybe (Route (HandlerSite m)) - -> m (Text, Maybe (Route (HandlerSite m))) + -> Maybe (Route UniWorX) + -> m Breadcrumb i18nCrumb msg mbR = do mr <- getMessageRender return (mr msg, mbR) @@ -59,359 +68,364 @@ i18nCrumb msg mbR = do -- Keep in mind that Breadcrumbs are also shown by the 403-Handler, -- i.e. information might be leaked by not performing permission checks if the -- breadcrumb value depends on sensitive content (like an user's name). -instance BearerAuthSite UniWorX => YesodBreadcrumbs UniWorX where - breadcrumb (AuthR _) = i18nCrumb MsgBreadcrumbLogin $ Just NewsR - breadcrumb (StaticR _) = i18nCrumb MsgBreadcrumbStatic Nothing - breadcrumb (WellKnownR _) = i18nCrumb MsgBreadcrumbWellKnown Nothing - breadcrumb MetricsR = i18nCrumb MsgBreadcrumbMetrics Nothing - breadcrumb ErrorR = i18nCrumb MsgBreadcrumbError Nothing +breadcrumb :: ( BearerAuthSite UniWorX + , WithRunDB SqlReadBackend (HandlerFor UniWorX) m + , MonadHandler m, HandlerSite m ~ UniWorX + ) + => Route UniWorX + -> m Breadcrumb +breadcrumb (AuthR _) = i18nCrumb MsgMenuLogin $ Just NewsR +breadcrumb (StaticR _) = i18nCrumb MsgBreadcrumbStatic Nothing +breadcrumb (WellKnownR _) = i18nCrumb MsgBreadcrumbWellKnown Nothing +breadcrumb MetricsR = i18nCrumb MsgBreadcrumbMetrics Nothing +breadcrumb ErrorR = i18nCrumb MsgBreadcrumbError Nothing - breadcrumb NewsR = i18nCrumb MsgBreadcrumbNews Nothing - breadcrumb UsersR = i18nCrumb MsgBreadcrumbUser $ Just AdminR - breadcrumb AdminUserAddR = i18nCrumb MsgBreadcrumbUserAdd $ Just UsersR - breadcrumb (AdminUserR cID) = maybeT (i18nCrumb MsgBreadcrumbUser $ Just UsersR) $ do - guardM . hasReadAccessTo $ AdminUserR cID - uid <- decrypt cID - User{..} <- MaybeT . runDBRead $ 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) = do - mayList <- hasReadAccessTo UsersR - if - | mayList - -> i18nCrumb MsgBreadcrumbUserNotifications . Just $ AdminUserR cID - | otherwise - -> i18nCrumb MsgBreadcrumbUserNotifications $ Just ProfileR - breadcrumb (UserPasswordR cID) = do - mayList <- hasReadAccessTo UsersR - if - | mayList - -> i18nCrumb MsgBreadcrumbUserPassword . Just $ AdminUserR cID - | otherwise - -> i18nCrumb MsgBreadcrumbUserPassword $ Just ProfileR - breadcrumb AdminNewFunctionaryInviteR = i18nCrumb MsgBreadcrumbLecturerInvite $ Just UsersR - breadcrumb AdminFunctionaryInviteR = i18nCrumb MsgBreadcrumbFunctionaryInvite Nothing +breadcrumb NewsR = i18nCrumb MsgMenuNews Nothing +breadcrumb UsersR = i18nCrumb MsgMenuUsers $ Just AdminR +breadcrumb AdminUserAddR = i18nCrumb MsgMenuUserAdd $ Just UsersR +breadcrumb (AdminUserR cID) = useRunDB . maybeT (i18nCrumb MsgBreadcrumbUser $ Just UsersR) $ do + guardM . lift . hasReadAccessTo $ AdminUserR cID + 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 + mayList <- hasReadAccessTo UsersR + if + | mayList + -> i18nCrumb MsgMenuUserNotifications . Just $ AdminUserR cID + | otherwise + -> i18nCrumb MsgMenuUserNotifications $ Just ProfileR +breadcrumb (UserPasswordR cID) = useRunDB $ do + mayList <- hasReadAccessTo UsersR + if + | mayList + -> i18nCrumb MsgMenuUserPassword . Just $ AdminUserR cID + | otherwise + -> i18nCrumb MsgMenuUserPassword $ Just ProfileR +breadcrumb AdminNewFunctionaryInviteR = i18nCrumb MsgMenuLecturerInvite $ Just UsersR +breadcrumb AdminFunctionaryInviteR = i18nCrumb MsgBreadcrumbFunctionaryInvite Nothing - breadcrumb AdminR = i18nCrumb MsgBreadcrumbAdminHeading Nothing - breadcrumb AdminFeaturesR = i18nCrumb MsgBreadcrumbAdminFeaturesHeading $ Just AdminR - breadcrumb AdminTestR = i18nCrumb MsgBreadcrumbAdminTest $ Just AdminR - breadcrumb AdminErrMsgR = i18nCrumb MsgBreadcrumbAdminErrMsg $ Just AdminR - breadcrumb AdminTokensR = i18nCrumb MsgBreadcrumbAdminTokens $ Just AdminR - breadcrumb AdminCrontabR = i18nCrumb MsgBreadcrumbAdminCrontab $ Just AdminR +breadcrumb AdminR = i18nCrumb MsgAdminHeading Nothing +breadcrumb AdminFeaturesR = i18nCrumb MsgAdminFeaturesHeading $ Just AdminR +breadcrumb AdminTestR = i18nCrumb MsgMenuAdminTest $ Just AdminR +breadcrumb AdminErrMsgR = i18nCrumb MsgMenuAdminErrMsg $ Just AdminR +breadcrumb AdminTokensR = i18nCrumb MsgMenuAdminTokens $ Just AdminR +breadcrumb AdminCrontabR = i18nCrumb MsgBreadcrumbAdminCrontab $ Just AdminR - breadcrumb SchoolListR = i18nCrumb MsgBreadcrumbSchoolList $ Just AdminR - breadcrumb (SchoolR ssh sRoute) = case sRoute of - SchoolEditR -> maybeT (i18nCrumb MsgBreadcrumbSchool $ Just SchoolListR) $ do - School{..} <- MaybeT . runDBRead $ get ssh - isAdmin <- hasReadAccessTo SchoolListR - return (CI.original schoolName, bool Nothing (Just SchoolListR) isAdmin) +breadcrumb SchoolListR = i18nCrumb MsgMenuSchoolList $ Just AdminR +breadcrumb (SchoolR ssh sRoute) = case sRoute of + SchoolEditR -> useRunDB . maybeT (i18nCrumb MsgBreadcrumbSchool $ Just SchoolListR) $ do + School{..} <- MaybeT $ get ssh + isAdmin <- lift $ hasReadAccessTo SchoolListR + return (CI.original schoolName, bool Nothing (Just SchoolListR) isAdmin) - SchoolWorkflowInstanceListR -> i18nCrumb MsgBreadcrumbWorkflowInstanceList . Just $ SchoolR ssh SchoolEditR - SchoolWorkflowInstanceNewR -> i18nCrumb MsgBreadcrumbWorkflowInstanceNew . Just $ SchoolR ssh SchoolWorkflowInstanceListR - SchoolWorkflowInstanceR win sRoute' -> case sRoute' of - SWIEditR -> do - mayList <- hasReadAccessTo . SchoolR ssh $ SchoolWorkflowInstanceR win SWIWorkflowsR - desc <- runDBRead . runMaybeT $ do - guard mayList - wiId <- MaybeT . getKeyBy . UniqueWorkflowInstance win . WSSchool $ unSchoolKey ssh - MaybeT $ selectWorkflowInstanceDescription wiId - let bRoute = SchoolR ssh SchoolWorkflowInstanceListR - case desc of - Nothing -> i18nCrumb (MsgBreadcrumbWorkflowInstanceEdit win) $ Just bRoute - Just (Entity _ WorkflowInstanceDescription{..}) -> i18nCrumb workflowInstanceDescriptionTitle $ Just bRoute - SWIDeleteR -> i18nCrumb MsgBreadcrumbWorkflowInstanceDelete . Just . SchoolR ssh $ SchoolWorkflowInstanceR win SWIEditR - SWIWorkflowsR -> i18nCrumb MsgBreadcrumbWorkflowInstanceWorkflowList . Just . SchoolR ssh $ SchoolWorkflowInstanceR win SWIEditR - SWIInitiateR -> do - mayEdit <- hasReadAccessTo . SchoolR ssh $ SchoolWorkflowInstanceR win SWIEditR - i18nCrumb MsgBreadcrumbWorkflowInstanceInitiate . Just . SchoolR ssh $ if - | mayEdit -> SchoolWorkflowInstanceR win SWIEditR - | otherwise -> SchoolWorkflowInstanceListR - SchoolWorkflowWorkflowListR -> i18nCrumb MsgBreadcrumbWorkflowWorkflowList . Just $ SchoolR ssh SchoolWorkflowInstanceListR - SchoolWorkflowWorkflowR cID sRoute' -> case sRoute' of - SWWWorkflowR -> i18nCrumb (MsgBreadcrumbWorkflowWorkflow cID) . Just $ SchoolR ssh SchoolWorkflowWorkflowListR - SWWFilesR _ _ -> i18nCrumb MsgBreadcrumbWorkflowWorkflowFiles . Just . SchoolR ssh $ SchoolWorkflowWorkflowR cID SWWWorkflowR - SWWEditR -> i18nCrumb MsgBreadcrumbWorkflowWorkflowEdit . Just . SchoolR ssh $ SchoolWorkflowWorkflowR cID SWWWorkflowR - SWWDeleteR -> i18nCrumb MsgBreadcrumbWorkflowWorkflowDelete . Just . SchoolR ssh $ SchoolWorkflowWorkflowR cID SWWWorkflowR - breadcrumb SchoolNewR = i18nCrumb MsgBreadcrumbSchoolNew $ Just SchoolListR - - breadcrumb (ExamOfficeR EOExamsR) = i18nCrumb MsgBreadcrumbExamOfficeExams Nothing - breadcrumb (ExamOfficeR EOFieldsR) = i18nCrumb MsgBreadcrumbExamOfficeFields . Just $ ExamOfficeR EOExamsR - breadcrumb (ExamOfficeR EOUsersR) = i18nCrumb MsgBreadcrumbExamOfficeUsers . Just $ ExamOfficeR EOExamsR - breadcrumb (ExamOfficeR EOUsersInviteR) = i18nCrumb MsgBreadcrumbExamOfficeUserInvite Nothing - - breadcrumb InfoR = i18nCrumb MsgBreadcrumbInformation Nothing - breadcrumb InfoLecturerR = i18nCrumb MsgBreadcrumbInfoLecturerTitle $ Just InfoR - breadcrumb LegalR = i18nCrumb MsgBreadcrumbLegal $ Just InfoR - breadcrumb InfoAllocationR = i18nCrumb MsgBreadcrumbAllocationInfo $ Just InfoR - breadcrumb VersionR = i18nCrumb MsgBreadcrumbVersion $ Just InfoR - breadcrumb FaqR = i18nCrumb MsgBreadcrumbFaq $ Just InfoR - - - breadcrumb HelpR = i18nCrumb MsgBreadcrumbHelp Nothing - - - breadcrumb HealthR = i18nCrumb MsgBreadcrumbHealth Nothing - breadcrumb InstanceR = i18nCrumb MsgBreadcrumbInstance Nothing - - breadcrumb ProfileR = i18nCrumb MsgBreadcrumbProfile Nothing - breadcrumb SetDisplayEmailR = i18nCrumb MsgBreadcrumbUserDisplayEmail $ Just ProfileR - breadcrumb ProfileDataR = i18nCrumb MsgBreadcrumbProfileData $ Just ProfileR - breadcrumb AuthPredsR = i18nCrumb MsgBreadcrumbAuthPreds $ Just ProfileR - breadcrumb CsvOptionsR = i18nCrumb MsgBreadcrumbCsvOptions $ Just ProfileR - breadcrumb LangR = i18nCrumb MsgMenuLanguage $ Just ProfileR - - breadcrumb StorageKeyR = i18nCrumb MsgBreadcrumbStorageKey Nothing - - breadcrumb TermShowR = i18nCrumb MsgBreadcrumbTermShow $ Just NewsR - breadcrumb TermCurrentR = i18nCrumb MsgBreadcrumbTermCurrent $ Just TermShowR - breadcrumb TermEditR = i18nCrumb MsgBreadcrumbTermCreate $ Just TermShowR - breadcrumb (TermEditExistR tid) = i18nCrumb MsgBreadcrumbTermEdit . Just $ TermCourseListR tid - breadcrumb (TermCourseListR tid) = maybeT (i18nCrumb MsgBreadcrumbTerm $ Just CourseListR) $ do -- redirect only, used in other breadcrumbs - guardM . lift . runDBRead $ isJust <$> get tid - i18nCrumb (ShortTermIdentifier $ unTermKey tid) $ Just CourseListR - - breadcrumb (TermSchoolCourseListR tid ssh) = maybeT (i18nCrumb MsgBreadcrumbSchool . Just $ TermCourseListR tid) $ do -- redirect only, used in other breadcrumbs - guardM . lift . runDBRead $ - (&&) <$> fmap isJust (get ssh) - <*> fmap isJust (get tid) - return (CI.original $ unSchoolKey ssh, Just $ TermCourseListR tid) - - breadcrumb AllocationListR = i18nCrumb MsgBreadcrumbAllocationListTitle $ Just NewsR - breadcrumb (AllocationR tid ssh ash sRoute) = case sRoute of - AShowR -> maybeT (i18nCrumb MsgBreadcrumbAllocation $ Just AllocationListR) $ do - mr <- getMessageRender - Entity _ Allocation{allocationName} <- MaybeT . runDBRead . getBy $ TermSchoolAllocationShort tid ssh ash - return ([st|#{allocationName} (#{mr (ShortTermIdentifier (unTermKey tid))}, #{CI.original (unSchoolKey ssh)})|], Just AllocationListR) - ARegisterR -> i18nCrumb MsgBreadcrumbAllocationRegister . Just $ AllocationR tid ssh ash AShowR - AApplyR cID -> maybeT (i18nCrumb MsgBreadcrumbCourse . Just $ AllocationR tid ssh ash AShowR) $ do - cid <- decrypt cID - Course{..} <- hoist runDBRead $ do - aid <- MaybeT . getKeyBy $ TermSchoolAllocationShort tid ssh ash - guardM . lift $ exists [ AllocationCourseAllocation ==. aid, AllocationCourseCourse ==. cid ] - MaybeT $ get cid - return (CI.original courseName, Just $ AllocationR tid ssh ash AShowR) - AUsersR -> i18nCrumb MsgBreadcrumbAllocationUsers . Just $ AllocationR tid ssh ash AShowR - APriosR -> i18nCrumb MsgBreadcrumbAllocationPriorities . Just $ AllocationR tid ssh ash AUsersR - AComputeR -> i18nCrumb MsgBreadcrumbAllocationCompute . Just $ AllocationR tid ssh ash AUsersR - AAcceptR -> i18nCrumb MsgBreadcrumbAllocationAccept . Just $ AllocationR tid ssh ash AUsersR - AAddUserR -> i18nCrumb MsgBreadcrumbAllocationAddUser . Just $ AllocationR tid ssh ash AUsersR - - breadcrumb ParticipantsListR = i18nCrumb MsgBreadcrumbParticipantsList $ Just CourseListR - breadcrumb (ParticipantsR _ _) = i18nCrumb MsgBreadcrumbParticipants $ Just ParticipantsListR - breadcrumb ParticipantsIntersectR = i18nCrumb MsgBreadcrumbParticipantsIntersect $ Just ParticipantsListR - - breadcrumb CourseListR = i18nCrumb MsgBreadcrumbCourseList Nothing - breadcrumb CourseNewR = i18nCrumb MsgBreadcrumbCourseNew $ Just CourseListR - breadcrumb (CourseR tid ssh csh CShowR) = maybeT (i18nCrumb MsgBreadcrumbCourse . Just $ TermSchoolCourseListR tid ssh) $ do - guardM . lift . runDBRead . existsBy $ TermSchoolCourseShort tid ssh csh - return (CI.original csh, Just $ TermSchoolCourseListR tid ssh) - breadcrumb (CourseR tid ssh csh CEditR) = i18nCrumb MsgBreadcrumbCourseEdit . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh CUsersR) = i18nCrumb MsgBreadcrumbCourseMembers . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh CAddUserR) = i18nCrumb MsgBreadcrumbCourseAddMembers . Just $ CourseR tid ssh csh CUsersR - breadcrumb (CourseR tid ssh csh CInviteR) = i18nCrumb MsgBreadcrumbCourseParticipantInvitation . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh CExamOfficeR) = i18nCrumb MsgBreadcrumbCourseExamOffice . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh (CUserR cID)) = maybeT (i18nCrumb MsgBreadcrumbUser . Just $ CourseR tid ssh csh CUsersR) $ do - guardM . hasReadAccessTo . CourseR tid ssh csh $ CUserR cID - uid <- decrypt cID - User{userDisplayName} <- MaybeT . runDBRead $ get uid - return (userDisplayName, Just $ CourseR tid ssh csh CUsersR) - breadcrumb (CourseR tid ssh csh CCorrectionsR) = i18nCrumb MsgBreadcrumbSubmissions . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh CAssignR) = i18nCrumb MsgBreadcrumbCorrectionsAssign . Just $ CourseR tid ssh csh CCorrectionsR - breadcrumb (CourseR tid ssh csh SheetListR) = i18nCrumb MsgBreadcrumbSheetList . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh SheetNewR ) = i18nCrumb MsgBreadcrumbSheetNew . Just $ CourseR tid ssh csh SheetListR - breadcrumb (CourseR tid ssh csh SheetCurrentR) = i18nCrumb MsgBreadcrumbSheetCurrent . Just $ CourseR tid ssh csh SheetListR - breadcrumb (CourseR tid ssh csh SheetOldUnassignedR) = i18nCrumb MsgBreadcrumbSheetOldUnassigned . Just $ CourseR tid ssh csh SheetListR - breadcrumb (CourseR tid ssh csh CCommR ) = i18nCrumb MsgBreadcrumbCourseCommunication . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh CTutorialListR) = i18nCrumb MsgBreadcrumbTutorialList . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh CTutorialNewR) = i18nCrumb MsgBreadcrumbTutorialNew . Just $ CourseR tid ssh csh CTutorialListR - breadcrumb (CourseR tid ssh csh CFavouriteR) = i18nCrumb MsgBreadcrumbCourseFavourite . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh CRegisterR) = i18nCrumb MsgBreadcrumbCourseRegister . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh CRegisterTemplateR) = i18nCrumb MsgBreadcrumbCourseRegisterTemplate . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh CLecInviteR) = i18nCrumb MsgBreadcrumbLecturerInvite . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh CDeleteR) = i18nCrumb MsgBreadcrumbCourseDelete . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh CHiWisR) = i18nCrumb MsgBreadcrumbHiWis . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh CNotesR) = i18nCrumb MsgBreadcrumbCourseNotes . Just $ CourseR tid ssh csh CShowR - - breadcrumb (CourseR tid ssh csh CNewsNewR) = i18nCrumb MsgBreadcrumbCourseNewsNew . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh (CourseNewsR cID sRoute)) = case sRoute of - CNShowR -> i18nCrumb MsgBreadcrumbCourseNews . Just $ CourseR tid ssh csh CShowR - CNEditR -> i18nCrumb MsgBreadcrumbCourseNewsEdit . Just $ CNewsR tid ssh csh cID CNShowR - CNDeleteR -> i18nCrumb MsgBreadcrumbCourseNewsDelete . Just $ CNewsR tid ssh csh cID CNShowR - CNArchiveR -> i18nCrumb MsgBreadcrumbCourseNewsArchive . Just $ CNewsR tid ssh csh cID CNShowR - CNFileR _ -> i18nCrumb MsgBreadcrumbCourseNewsFile . Just $ CNewsR tid ssh csh cID CNShowR - - breadcrumb (CourseR tid ssh csh CEventsNewR) = i18nCrumb MsgBreadcrumbCourseEventNew . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh (CourseEventR _cID sRoute)) = case sRoute of - CEvEditR -> i18nCrumb MsgBreadcrumbCourseEventEdit . Just $ CourseR tid ssh csh CShowR - CEvDeleteR -> i18nCrumb MsgBreadcrumbCourseEventDelete . Just $ CourseR tid ssh csh CShowR - - breadcrumb (CourseR tid ssh csh CExamListR) = i18nCrumb MsgBreadcrumbExamList . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh CExamNewR) = i18nCrumb MsgBreadcrumbExamNew . Just $ CourseR tid ssh csh CExamListR - - breadcrumb (CourseR tid ssh csh CApplicationsR) = i18nCrumb MsgBreadcrumbCourseApplications . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh CAppsFilesR) = i18nCrumb MsgBreadcrumbCourseAppsFiles . Just $ CourseR tid ssh csh CApplicationsR - - breadcrumb (CourseR tid ssh csh (CourseApplicationR cID sRoute)) = case sRoute of - CAEditR -> maybeT (i18nCrumb MsgBreadcrumbApplicant . Just $ CourseR tid ssh csh CApplicationsR) $ do - guardM . hasReadAccessTo $ CApplicationR tid ssh csh cID CAEditR - appId <- decrypt cID - User{..} <- hoist runDBRead $ MaybeT (get appId) >>= MaybeT . get . courseApplicationUser - return (userDisplayName, Just $ CourseR tid ssh csh CApplicationsR) - CAFilesR -> i18nCrumb MsgBreadcrumbApplicationFiles . Just $ CApplicationR tid ssh csh cID CAEditR - - breadcrumb (CourseR tid ssh csh (ExamR examn sRoute)) = case sRoute of - EShowR -> maybeT (i18nCrumb MsgBreadcrumbExam . Just $ CourseR tid ssh csh CExamListR) $ do - guardM . hasReadAccessTo $ CExamR tid ssh csh examn EShowR - return (CI.original examn, Just $ CourseR tid ssh csh CExamListR) - EEditR -> i18nCrumb MsgBreadcrumbExamEdit . Just $ CExamR tid ssh csh examn EShowR - EUsersR -> i18nCrumb MsgBreadcrumbExamUsers . Just $ CExamR tid ssh csh examn EShowR - EAddUserR -> i18nCrumb MsgBreadcrumbExamAddMembers . Just $ CExamR tid ssh csh examn EUsersR - EGradesR -> i18nCrumb MsgBreadcrumbExamGrades . Just $ CExamR tid ssh csh examn EShowR - ECInviteR -> i18nCrumb MsgBreadcrumbExamCorrectorInvite . Just $ CExamR tid ssh csh examn EShowR - EInviteR -> i18nCrumb MsgBreadcrumbExamParticipantInvite . Just $ CExamR tid ssh csh examn EShowR - ERegisterR -> i18nCrumb MsgBreadcrumbExamRegister . Just $ CExamR tid ssh csh examn EShowR - ERegisterOccR _occn -> i18nCrumb MsgBreadcrumbExamRegister . Just $ CExamR tid ssh csh examn EShowR - EAutoOccurrenceR -> i18nCrumb MsgBreadcrumbExamAutoOccurrence . Just $ CExamR tid ssh csh examn EUsersR - ECorrectR -> i18nCrumb MsgBreadcrumbExamCorrect . Just $ CExamR tid ssh csh examn EShowR - - breadcrumb (CourseR tid ssh csh (TutorialR tutn sRoute)) = case sRoute of - TUsersR -> maybeT (i18nCrumb MsgBreadcrumbTutorial . Just $ CourseR tid ssh csh CTutorialListR) $ do - guardM . hasReadAccessTo $ CTutorialR tid ssh csh tutn TUsersR - return (CI.original tutn, Just $ CourseR tid ssh csh CTutorialListR) - TEditR -> i18nCrumb MsgBreadcrumbTutorialEdit . Just $ CTutorialR tid ssh csh tutn TUsersR - TDeleteR -> i18nCrumb MsgBreadcrumbTutorialDelete . Just $ CTutorialR tid ssh csh tutn TUsersR - TCommR -> i18nCrumb MsgBreadcrumbTutorialComm . Just $ CTutorialR tid ssh csh tutn TUsersR - TRegisterR -> i18nCrumb MsgBreadcrumbTutorialRegister . Just $ CourseR tid ssh csh CShowR - TInviteR -> i18nCrumb MsgBreadcrumbTutorInvite . Just $ CTutorialR tid ssh csh tutn TUsersR - - breadcrumb (CourseR tid ssh csh (SheetR shn sRoute)) = case sRoute of - SShowR -> maybeT (i18nCrumb MsgBreadcrumbSheet . Just $ CourseR tid ssh csh SheetListR) $ do - guardM . hasReadAccessTo $ CSheetR tid ssh csh shn SShowR - return (CI.original shn, Just $ CourseR tid ssh csh SheetListR) - SEditR -> i18nCrumb MsgBreadcrumbSheetEdit . Just $ CSheetR tid ssh csh shn SShowR - SDelR -> i18nCrumb MsgMenuSheetDelete . Just $ CSheetR tid ssh csh shn SShowR - SSubsR -> i18nCrumb MsgBreadcrumbSubmissions . Just $ CSheetR tid ssh csh shn SShowR - SAssignR -> i18nCrumb MsgBreadcrumbCorrectionsAssign . Just $ CSheetR tid ssh csh shn SSubsR - SubmissionNewR -> i18nCrumb MsgBreadcrumbSubmissionNew . Just $ CSheetR tid ssh csh shn SShowR - SubmissionOwnR -> i18nCrumb MsgBreadcrumbSubmissionOwn . Just $ CSheetR tid ssh csh shn SShowR - SubmissionR cid sRoute' -> case sRoute' of - SubShowR -> do - mayList <- hasReadAccessTo $ CSheetR tid ssh csh shn SSubsR - if - | mayList - -> i18nCrumb MsgBreadcrumbSubmission . Just $ CSheetR tid ssh csh shn SSubsR - | otherwise - -> i18nCrumb MsgBreadcrumbSubmission . Just $ CSheetR tid ssh csh shn SShowR - CorrectionR -> i18nCrumb MsgBreadcrumbCorrection . Just $ CSubmissionR tid ssh csh shn cid SubShowR - SubDelR -> i18nCrumb MsgBreadcrumbSubmissionDelete . Just $ CSubmissionR tid ssh csh shn cid SubShowR - SubAssignR -> i18nCrumb MsgBreadcrumbCorrectorAssignTitle . Just $ CSubmissionR tid ssh csh shn cid SubShowR - SInviteR -> i18nCrumb MsgBreadcrumbSubmissionUserInvite . Just $ CSubmissionR tid ssh csh shn cid SubShowR - SubArchiveR sft -> i18nCrumb sft . Just $ CSubmissionR tid ssh csh shn cid SubShowR - SubDownloadR _ _ -> i18nCrumb MsgBreadcrumbSubmissionFile . Just $ CSubmissionR tid ssh csh shn cid SubShowR - SArchiveR -> i18nCrumb MsgBreadcrumbSheetArchive . Just $ CSheetR tid ssh csh shn SShowR - SIsCorrR -> i18nCrumb MsgBreadcrumbSheetIsCorrector . Just $ CSheetR tid ssh csh shn SShowR - SPseudonymR -> i18nCrumb MsgBreadcrumbSheetPseudonym . Just $ CSheetR tid ssh csh shn SShowR - SCorrInviteR -> i18nCrumb MsgBreadcrumbSheetCorrectorInvite . Just $ CSheetR tid ssh csh shn SShowR - SZipR sft -> i18nCrumb sft . Just $ CSheetR tid ssh csh shn SShowR - SFileR _ _ -> i18nCrumb MsgBreadcrumbSheetFile . Just $ CSheetR tid ssh csh shn SShowR - SPersonalFilesR -> i18nCrumb MsgBreadcrumbSheetPersonalisedFiles . Just $ CSheetR tid ssh csh shn SShowR - - breadcrumb (CourseR tid ssh csh MaterialListR) = i18nCrumb MsgBreadcrumbMaterialList . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh MaterialNewR ) = i18nCrumb MsgBreadcrumbMaterialNew . Just $ CourseR tid ssh csh MaterialListR - breadcrumb (CourseR tid ssh csh (MaterialR mnm sRoute)) = case sRoute of - MShowR -> maybeT (i18nCrumb MsgBreadcrumbMaterial . Just $ CourseR tid ssh csh MaterialListR) $ do - guardM . hasReadAccessTo $ CMaterialR tid ssh csh mnm MShowR - return (CI.original mnm, Just $ CourseR tid ssh csh MaterialListR) - MEditR -> i18nCrumb MsgBreadcrumbMaterialEdit . Just $ CMaterialR tid ssh csh mnm MShowR - MDelR -> i18nCrumb MsgBreadcrumbMaterialDelete . Just $ CMaterialR tid ssh csh mnm MShowR - MArchiveR -> i18nCrumb MsgBreadcrumbMaterialArchive . Just $ CMaterialR tid ssh csh mnm MShowR - MFileR _ -> i18nCrumb MsgBreadcrumbMaterialFile . Just $ CMaterialR tid ssh csh mnm MShowR - MVideoR _ -> i18nCrumb MsgBreadcrumbMaterialVideo . Just $ CMaterialR tid ssh csh mnm MShowR - - breadcrumb (CourseR tid ssh csh CPersonalFilesR) = i18nCrumb MsgBreadcrumbCourseSheetPersonalisedFiles . Just $ CourseR tid ssh csh CShowR - - breadcrumb CorrectionsR = i18nCrumb MsgBreadcrumbCorrections Nothing - breadcrumb CorrectionsUploadR = i18nCrumb MsgBreadcrumbCorrectionsUpload $ Just CorrectionsR - breadcrumb CorrectionsCreateR = i18nCrumb MsgBreadcrumbCorrectionsCreate $ Just CorrectionsR - breadcrumb CorrectionsGradeR = i18nCrumb MsgBreadcrumbCorrectionsGrade $ Just CorrectionsR - breadcrumb CorrectionsDownloadR = i18nCrumb MsgBreadcrumbCorrectionsDownload $ Just CorrectionsR - - breadcrumb (CryptoUUIDDispatchR _) = i18nCrumb MsgBreadcrumbCryptoIDDispatch Nothing - - breadcrumb (MessageR _) = do - mayList <- (== Authorized) <$> evalAccess MessageListR False - if - | mayList -> i18nCrumb MsgBreadcrumbSystemMessage $ Just MessageListR - | otherwise -> i18nCrumb MsgBreadcrumbSystemMessage $ Just NewsR - breadcrumb MessageListR = i18nCrumb MsgBreadcrumbMessageList $ Just AdminR - breadcrumb (MessageHideR cID) = i18nCrumb MsgBreadcrumbMessageHide . Just $ MessageR cID - - breadcrumb GlossaryR = i18nCrumb MsgBreadcrumbGlossary $ Just InfoR - - breadcrumb EExamListR = i18nCrumb MsgBreadcrumbExternalExamList Nothing - breadcrumb EExamNewR = do - isEO <- hasReadAccessTo $ ExamOfficeR EOExamsR - i18nCrumb MsgBreadcrumbExternalExamNew . Just $ if - | isEO -> ExamOfficeR EOExamsR - | otherwise -> EExamListR - breadcrumb (EExamR tid ssh coursen examn sRoute) = case sRoute of - EEShowR -> do - isEO <- hasReadAccessTo $ ExamOfficeR EOExamsR - maybeT (i18nCrumb MsgBreadcrumbExternalExam . Just $ bool EExamListR (ExamOfficeR EOExamsR) isEO) $ do - guardM . hasReadAccessTo $ EExamR tid ssh coursen examn EEShowR - i18nCrumb (MsgBreadcrumbExternalExamShow coursen examn) . Just $ if - | isEO -> ExamOfficeR EOExamsR - | otherwise -> EExamListR - EEEditR -> i18nCrumb MsgBreadcrumbExternalExamEdit . Just $ EExamR tid ssh coursen examn EEShowR - EEUsersR -> i18nCrumb MsgBreadcrumbExternalExamUsers . Just $ EExamR tid ssh coursen examn EEShowR - EEGradesR -> i18nCrumb MsgBreadcrumbExternalExamGrades . Just $ EExamR tid ssh coursen examn EEShowR - EEStaffInviteR -> i18nCrumb MsgBreadcrumbExternalExamStaffInvite . Just $ EExamR tid ssh coursen examn EEShowR - EECorrectR -> i18nCrumb MsgBreadcrumbExternalExamCorrect . Just $ EExamR tid ssh coursen examn EEShowR - - breadcrumb AdminWorkflowDefinitionListR = i18nCrumb MsgBreadcrumbAdminWorkflowDefinitionList $ Just AdminR - breadcrumb AdminWorkflowDefinitionNewR = i18nCrumb MsgBreadcrumbAdminWorkflowDefinitionNew $ Just AdminWorkflowDefinitionListR - breadcrumb (AdminWorkflowDefinitionR wfdScope wfdName sRoute) = case sRoute of - AWDEditR -> do - MsgRenderer mr <- getMsgRenderer - i18nCrumb (MsgBreadcrumbAdminWorkflowDefinitionEdit (mr wfdScope) wfdName) $ Just AdminWorkflowDefinitionListR - AWDDeleteR -> i18nCrumb MsgBreadcrumbAdminWorkflowDefinitionDelete . Just $ AdminWorkflowDefinitionR wfdScope wfdName AWDEditR - AWDInstantiateR -> i18nCrumb MsgBreadcrumbAdminWorkflowDefinitionInstantiate . Just $ AdminWorkflowDefinitionR wfdScope wfdName AWDEditR - breadcrumb AdminWorkflowInstanceListR = i18nCrumb MsgBreadcrumbAdminWorkflowInstanceList $ Just AdminWorkflowDefinitionListR - breadcrumb AdminWorkflowInstanceNewR = i18nCrumb MsgBreadcrumbAdminWorkflowInstanceNew $ Just AdminWorkflowInstanceListR - breadcrumb (AdminWorkflowInstanceR _cID sRoute) = case sRoute of - AWIEditR -> i18nCrumb MsgBreadcrumbAdminWorkflowInstanceEdit $ Just AdminWorkflowInstanceListR - breadcrumb AdminWorkflowWorkflowListR = i18nCrumb MsgBreadcrumbAdminWorkflowWorkflowList $ Just AdminWorkflowInstanceListR - breadcrumb AdminWorkflowWorkflowNewR = i18nCrumb MsgBreadcrumbAdminWorkflowWorkflowNew $ Just AdminWorkflowWorkflowListR - - breadcrumb GlobalWorkflowInstanceListR = i18nCrumb MsgBreadcrumbGlobalWorkflowInstanceList Nothing - breadcrumb GlobalWorkflowInstanceNewR = i18nCrumb MsgBreadcrumbWorkflowInstanceNew $ Just GlobalWorkflowInstanceListR - breadcrumb (GlobalWorkflowInstanceR win sRoute) = case sRoute of - GWIEditR -> do - mayList <- hasReadAccessTo $ GlobalWorkflowInstanceR win GWIWorkflowsR - desc <- runDBRead . runMaybeT $ do - guard mayList - wiId <- MaybeT . getKeyBy $ UniqueWorkflowInstance win WSGlobal + SchoolWorkflowInstanceListR -> i18nCrumb MsgBreadcrumbWorkflowInstanceList . Just $ SchoolR ssh SchoolEditR + SchoolWorkflowInstanceNewR -> i18nCrumb MsgBreadcrumbWorkflowInstanceNew . Just $ SchoolR ssh SchoolWorkflowInstanceListR + SchoolWorkflowInstanceR win sRoute' -> case sRoute' of + SWIEditR -> do + desc <- useRunDB . runMaybeT $ do + guardM . lift . hasReadAccessTo . SchoolR ssh $ SchoolWorkflowInstanceR win SWIWorkflowsR + wiId <- MaybeT . getKeyBy . UniqueWorkflowInstance win . WSSchool $ unSchoolKey ssh MaybeT $ selectWorkflowInstanceDescription wiId + let bRoute = SchoolR ssh SchoolWorkflowInstanceListR case desc of - Nothing -> i18nCrumb (MsgBreadcrumbWorkflowInstanceEdit win) $ Just GlobalWorkflowInstanceListR - Just (Entity _ WorkflowInstanceDescription{..}) -> i18nCrumb workflowInstanceDescriptionTitle $ Just GlobalWorkflowInstanceListR - GWIDeleteR -> i18nCrumb MsgBreadcrumbWorkflowInstanceDelete . Just $ GlobalWorkflowInstanceR win GWIEditR - GWIWorkflowsR -> i18nCrumb MsgBreadcrumbWorkflowInstanceWorkflowList . Just $ GlobalWorkflowInstanceR win GWIEditR - GWIInitiateR -> do - mayEdit <- hasReadAccessTo $ GlobalWorkflowInstanceR win GWIEditR - i18nCrumb MsgBreadcrumbWorkflowInstanceInitiate . Just $ if - | mayEdit -> GlobalWorkflowInstanceR win GWIEditR - | otherwise -> GlobalWorkflowInstanceListR - breadcrumb GlobalWorkflowWorkflowListR = i18nCrumb MsgBreadcrumbWorkflowWorkflowList $ Just GlobalWorkflowInstanceListR - breadcrumb (GlobalWorkflowWorkflowR cID sRoute) = case sRoute of - GWWWorkflowR -> i18nCrumb (MsgBreadcrumbWorkflowWorkflow cID) $ Just GlobalWorkflowWorkflowListR - GWWFilesR _ _ -> i18nCrumb MsgBreadcrumbWorkflowWorkflowFiles . Just $ GlobalWorkflowWorkflowR cID GWWWorkflowR - GWWEditR -> i18nCrumb MsgBreadcrumbWorkflowWorkflowEdit . Just $ GlobalWorkflowWorkflowR cID GWWWorkflowR - GWWDeleteR -> i18nCrumb MsgBreadcrumbWorkflowWorkflowDelete . Just $ GlobalWorkflowWorkflowR cID GWWWorkflowR + Nothing -> i18nCrumb (MsgBreadcrumbWorkflowInstanceEdit win) $ Just bRoute + Just (Entity _ WorkflowInstanceDescription{..}) -> i18nCrumb workflowInstanceDescriptionTitle $ Just bRoute + SWIDeleteR -> i18nCrumb MsgBreadcrumbWorkflowInstanceDelete . Just . SchoolR ssh $ SchoolWorkflowInstanceR win SWIEditR + SWIWorkflowsR -> i18nCrumb MsgBreadcrumbWorkflowInstanceWorkflowList . Just . SchoolR ssh $ SchoolWorkflowInstanceR win SWIEditR + SWIInitiateR -> useRunDB $ do + mayEdit <- hasReadAccessTo . SchoolR ssh $ SchoolWorkflowInstanceR win SWIEditR + i18nCrumb MsgBreadcrumbWorkflowInstanceInitiate . Just . SchoolR ssh $ if + | mayEdit -> SchoolWorkflowInstanceR win SWIEditR + | otherwise -> SchoolWorkflowInstanceListR + SchoolWorkflowWorkflowListR -> i18nCrumb MsgBreadcrumbWorkflowWorkflowList . Just $ SchoolR ssh SchoolWorkflowInstanceListR + SchoolWorkflowWorkflowR cID sRoute' -> case sRoute' of + SWWWorkflowR -> i18nCrumb (MsgBreadcrumbWorkflowWorkflow cID) . Just $ SchoolR ssh SchoolWorkflowWorkflowListR + SWWFilesR _ _ -> i18nCrumb MsgBreadcrumbWorkflowWorkflowFiles . Just . SchoolR ssh $ SchoolWorkflowWorkflowR cID SWWWorkflowR + SWWEditR -> i18nCrumb MsgBreadcrumbWorkflowWorkflowEdit . Just . SchoolR ssh $ SchoolWorkflowWorkflowR cID SWWWorkflowR + SWWDeleteR -> i18nCrumb MsgBreadcrumbWorkflowWorkflowDelete . Just . SchoolR ssh $ SchoolWorkflowWorkflowR cID SWWWorkflowR +breadcrumb SchoolNewR = i18nCrumb MsgMenuSchoolNew $ Just SchoolListR - breadcrumb TopWorkflowInstanceListR = i18nCrumb MsgBreadcrumbTopWorkflowInstanceList Nothing - breadcrumb TopWorkflowWorkflowListR = i18nCrumb MsgBreadcrumbTopWorkflowWorkflowList $ Just TopWorkflowInstanceListR +breadcrumb (ExamOfficeR EOExamsR) = i18nCrumb MsgMenuExamOfficeExams Nothing +breadcrumb (ExamOfficeR EOFieldsR) = i18nCrumb MsgMenuExamOfficeFields . Just $ ExamOfficeR EOExamsR +breadcrumb (ExamOfficeR EOUsersR) = i18nCrumb MsgMenuExamOfficeUsers . Just $ ExamOfficeR EOExamsR +breadcrumb (ExamOfficeR EOUsersInviteR) = i18nCrumb MsgBreadcrumbExamOfficeUserInvite Nothing + +breadcrumb InfoR = i18nCrumb MsgMenuInformation Nothing +breadcrumb InfoLecturerR = i18nCrumb MsgInfoLecturerTitle $ Just InfoR +breadcrumb LegalR = i18nCrumb MsgMenuLegal $ Just InfoR +breadcrumb InfoAllocationR = i18nCrumb MsgBreadcrumbAllocationInfo $ Just InfoR +breadcrumb VersionR = i18nCrumb MsgMenuVersion $ Just InfoR +breadcrumb FaqR = i18nCrumb MsgBreadcrumbFaq $ Just InfoR + + +breadcrumb HelpR = i18nCrumb MsgMenuHelp Nothing + + +breadcrumb HealthR = i18nCrumb MsgMenuHealth Nothing +breadcrumb InstanceR = i18nCrumb MsgMenuInstance Nothing + +breadcrumb ProfileR = i18nCrumb MsgBreadcrumbProfile Nothing +breadcrumb SetDisplayEmailR = i18nCrumb MsgUserDisplayEmail $ Just ProfileR +breadcrumb ProfileDataR = i18nCrumb MsgMenuProfileData $ Just ProfileR +breadcrumb AuthPredsR = i18nCrumb MsgMenuAuthPreds $ Just ProfileR +breadcrumb CsvOptionsR = i18nCrumb MsgCsvOptions $ Just ProfileR +breadcrumb LangR = i18nCrumb MsgMenuLanguage $ Just ProfileR + +breadcrumb StorageKeyR = i18nCrumb MsgBreadcrumbStorageKey Nothing + +breadcrumb TermShowR = i18nCrumb MsgMenuTermShow $ Just NewsR +breadcrumb TermCurrentR = i18nCrumb MsgMenuTermCurrent $ Just TermShowR +breadcrumb TermEditR = i18nCrumb MsgMenuTermCreate $ Just TermShowR +breadcrumb (TermEditExistR tid) = i18nCrumb MsgMenuTermEdit . Just $ TermCourseListR tid +breadcrumb (TermCourseListR tid) = useRunDB . maybeT (i18nCrumb MsgBreadcrumbTerm $ Just CourseListR) $ do -- redirect only, used in other breadcrumbs + guardM . lift $ isJust <$> get tid + i18nCrumb (ShortTermIdentifier $ unTermKey tid) $ Just CourseListR + +breadcrumb (TermSchoolCourseListR tid ssh) = useRunDB . maybeT (i18nCrumb MsgBreadcrumbSchool . Just $ TermCourseListR tid) $ do -- redirect only, used in other breadcrumbs + guardM . lift $ + (&&) <$> fmap isJust (get ssh) + <*> fmap isJust (get tid) + return (CI.original $ unSchoolKey ssh, Just $ TermCourseListR tid) + +breadcrumb AllocationListR = i18nCrumb MsgAllocationListTitle $ Just NewsR +breadcrumb (AllocationR tid ssh ash sRoute) = case sRoute of + AShowR -> useRunDB . maybeT (i18nCrumb MsgBreadcrumbAllocation $ Just AllocationListR) $ do + mr <- getMessageRender + Entity _ Allocation{allocationName} <- MaybeT . getBy $ TermSchoolAllocationShort tid ssh ash + return ([st|#{allocationName} (#{mr (ShortTermIdentifier (unTermKey tid))}, #{CI.original (unSchoolKey ssh)})|], Just AllocationListR) + ARegisterR -> i18nCrumb MsgBreadcrumbAllocationRegister . Just $ AllocationR tid ssh ash AShowR + AApplyR cID -> useRunDB . maybeT (i18nCrumb MsgBreadcrumbCourse . Just $ AllocationR tid ssh ash AShowR) $ do + cid <- decrypt cID + Course{..} <- do + aid <- MaybeT . getKeyBy $ TermSchoolAllocationShort tid ssh ash + guardM . lift $ exists [ AllocationCourseAllocation ==. aid, AllocationCourseCourse ==. cid ] + MaybeT $ get cid + return (CI.original courseName, Just $ AllocationR tid ssh ash AShowR) + AUsersR -> i18nCrumb MsgBreadcrumbAllocationUsers . Just $ AllocationR tid ssh ash AShowR + APriosR -> i18nCrumb MsgBreadcrumbAllocationPriorities . Just $ AllocationR tid ssh ash AUsersR + AComputeR -> i18nCrumb MsgBreadcrumbAllocationCompute . Just $ AllocationR tid ssh ash AUsersR + AAcceptR -> i18nCrumb MsgBreadcrumbAllocationAccept . Just $ AllocationR tid ssh ash AUsersR + AAddUserR -> i18nCrumb MsgBreadcrumbAllocationAddUser . Just $ AllocationR tid ssh ash AUsersR + +breadcrumb ParticipantsListR = i18nCrumb MsgBreadcrumbParticipantsList $ Just CourseListR +breadcrumb (ParticipantsR _ _) = i18nCrumb MsgBreadcrumbParticipants $ Just ParticipantsListR +breadcrumb ParticipantsIntersectR = i18nCrumb MsgMenuParticipantsIntersect $ Just ParticipantsListR + +breadcrumb CourseListR = i18nCrumb MsgMenuCourseList Nothing +breadcrumb CourseNewR = i18nCrumb MsgMenuCourseNew $ Just CourseListR +breadcrumb (CourseR tid ssh csh CShowR) = useRunDB . maybeT (i18nCrumb MsgBreadcrumbCourse . Just $ TermSchoolCourseListR tid ssh) $ do + guardM . lift . existsBy $ TermSchoolCourseShort tid ssh csh + return (CI.original csh, Just $ TermSchoolCourseListR tid ssh) +breadcrumb (CourseR tid ssh csh CEditR) = i18nCrumb MsgMenuCourseEdit . Just $ CourseR tid ssh csh CShowR +breadcrumb (CourseR tid ssh csh CUsersR) = i18nCrumb MsgMenuCourseMembers . Just $ CourseR tid ssh csh CShowR +breadcrumb (CourseR tid ssh csh CAddUserR) = i18nCrumb MsgMenuCourseAddMembers . Just $ CourseR tid ssh csh CUsersR +breadcrumb (CourseR tid ssh csh CInviteR) = i18nCrumb MsgBreadcrumbCourseParticipantInvitation . Just $ CourseR tid ssh csh CShowR +breadcrumb (CourseR tid ssh csh CExamOfficeR) = i18nCrumb MsgMenuCourseExamOffice . Just $ CourseR tid ssh csh CShowR +breadcrumb (CourseR tid ssh csh (CUserR cID)) = useRunDB . maybeT (i18nCrumb MsgBreadcrumbUser . Just $ CourseR tid ssh csh CUsersR) $ do + guardM . lift . hasReadAccessTo . CourseR tid ssh csh $ CUserR cID + uid <- decrypt cID + User{userDisplayName} <- MaybeT $ get uid + return (userDisplayName, Just $ CourseR tid ssh csh CUsersR) +breadcrumb (CourseR tid ssh csh CCorrectionsR) = i18nCrumb MsgMenuSubmissions . Just $ CourseR tid ssh csh CShowR +breadcrumb (CourseR tid ssh csh CAssignR) = i18nCrumb MsgMenuCorrectionsAssign . Just $ CourseR tid ssh csh CCorrectionsR +breadcrumb (CourseR tid ssh csh SheetListR) = i18nCrumb MsgMenuSheetList . Just $ CourseR tid ssh csh CShowR +breadcrumb (CourseR tid ssh csh SheetNewR ) = i18nCrumb MsgMenuSheetNew . Just $ CourseR tid ssh csh SheetListR +breadcrumb (CourseR tid ssh csh SheetCurrentR) = i18nCrumb MsgMenuSheetCurrent . Just $ CourseR tid ssh csh SheetListR +breadcrumb (CourseR tid ssh csh SheetOldUnassignedR) = i18nCrumb MsgMenuSheetOldUnassigned . Just $ CourseR tid ssh csh SheetListR +breadcrumb (CourseR tid ssh csh CCommR ) = i18nCrumb MsgMenuCourseCommunication . Just $ CourseR tid ssh csh CShowR +breadcrumb (CourseR tid ssh csh CTutorialListR) = i18nCrumb MsgMenuTutorialList . Just $ CourseR tid ssh csh CShowR +breadcrumb (CourseR tid ssh csh CTutorialNewR) = i18nCrumb MsgMenuTutorialNew . Just $ CourseR tid ssh csh CTutorialListR +breadcrumb (CourseR tid ssh csh CFavouriteR) = i18nCrumb MsgBreadcrumbCourseFavourite . Just $ CourseR tid ssh csh CShowR +breadcrumb (CourseR tid ssh csh CRegisterR) = i18nCrumb MsgBreadcrumbCourseRegister . Just $ CourseR tid ssh csh CShowR +breadcrumb (CourseR tid ssh csh CRegisterTemplateR) = i18nCrumb MsgBreadcrumbCourseRegisterTemplate . Just $ CourseR tid ssh csh CShowR +breadcrumb (CourseR tid ssh csh CLecInviteR) = i18nCrumb MsgBreadcrumbLecturerInvite . Just $ CourseR tid ssh csh CShowR +breadcrumb (CourseR tid ssh csh CDeleteR) = i18nCrumb MsgMenuCourseDelete . Just $ CourseR tid ssh csh CShowR +breadcrumb (CourseR tid ssh csh CHiWisR) = i18nCrumb MsgBreadcrumbHiWis . Just $ CourseR tid ssh csh CShowR +breadcrumb (CourseR tid ssh csh CNotesR) = i18nCrumb MsgBreadcrumbCourseNotes . Just $ CourseR tid ssh csh CShowR + +breadcrumb (CourseR tid ssh csh CNewsNewR) = i18nCrumb MsgMenuCourseNewsNew . Just $ CourseR tid ssh csh CShowR +breadcrumb (CourseR tid ssh csh (CourseNewsR cID sRoute)) = case sRoute of + CNShowR -> i18nCrumb MsgBreadcrumbCourseNews . Just $ CourseR tid ssh csh CShowR + CNEditR -> i18nCrumb MsgMenuCourseNewsEdit . Just $ CNewsR tid ssh csh cID CNShowR + CNDeleteR -> i18nCrumb MsgBreadcrumbCourseNewsDelete . Just $ CNewsR tid ssh csh cID CNShowR + CNArchiveR -> i18nCrumb MsgBreadcrumbCourseNewsArchive . Just $ CNewsR tid ssh csh cID CNShowR + CNFileR _ -> i18nCrumb MsgBreadcrumbCourseNewsFile . Just $ CNewsR tid ssh csh cID CNShowR + +breadcrumb (CourseR tid ssh csh CEventsNewR) = i18nCrumb MsgMenuCourseEventNew . Just $ CourseR tid ssh csh CShowR +breadcrumb (CourseR tid ssh csh (CourseEventR _cID sRoute)) = case sRoute of + CEvEditR -> i18nCrumb MsgMenuCourseEventEdit . Just $ CourseR tid ssh csh CShowR + CEvDeleteR -> i18nCrumb MsgBreadcrumbCourseEventDelete . Just $ CourseR tid ssh csh CShowR + +breadcrumb (CourseR tid ssh csh CExamListR) = i18nCrumb MsgMenuExamList . Just $ CourseR tid ssh csh CShowR +breadcrumb (CourseR tid ssh csh CExamNewR) = i18nCrumb MsgMenuExamNew . Just $ CourseR tid ssh csh CExamListR + +breadcrumb (CourseR tid ssh csh CApplicationsR) = i18nCrumb MsgMenuCourseApplications . Just $ CourseR tid ssh csh CShowR +breadcrumb (CourseR tid ssh csh CAppsFilesR) = i18nCrumb MsgBreadcrumbCourseAppsFiles . Just $ CourseR tid ssh csh CApplicationsR + +breadcrumb (CourseR tid ssh csh (CourseApplicationR cID sRoute)) = case sRoute of + CAEditR -> useRunDB . maybeT (i18nCrumb MsgBreadcrumbApplicant . Just $ CourseR tid ssh csh CApplicationsR) $ do + guardM . lift . hasReadAccessTo $ CApplicationR tid ssh csh cID CAEditR + appId <- decrypt cID + User{..} <- MaybeT (get appId) >>= MaybeT . get . courseApplicationUser + return (userDisplayName, Just $ CourseR tid ssh csh CApplicationsR) + CAFilesR -> i18nCrumb MsgBreadcrumbApplicationFiles . Just $ CApplicationR tid ssh csh cID CAEditR + +breadcrumb (CourseR tid ssh csh (ExamR examn sRoute)) = case sRoute of + EShowR -> useRunDB . maybeT (i18nCrumb MsgBreadcrumbExam . Just $ CourseR tid ssh csh CExamListR) $ do + guardM . lift . hasReadAccessTo $ CExamR tid ssh csh examn EShowR + return (CI.original examn, Just $ CourseR tid ssh csh CExamListR) + EEditR -> i18nCrumb MsgMenuExamEdit . Just $ CExamR tid ssh csh examn EShowR + EUsersR -> i18nCrumb MsgMenuExamUsers . Just $ CExamR tid ssh csh examn EShowR + EAddUserR -> i18nCrumb MsgMenuExamAddMembers . Just $ CExamR tid ssh csh examn EUsersR + EGradesR -> i18nCrumb MsgMenuExamGrades . Just $ CExamR tid ssh csh examn EShowR + ECInviteR -> i18nCrumb MsgBreadcrumbExamCorrectorInvite . Just $ CExamR tid ssh csh examn EShowR + EInviteR -> i18nCrumb MsgBreadcrumbExamParticipantInvite . Just $ CExamR tid ssh csh examn EShowR + ERegisterR -> i18nCrumb MsgBreadcrumbExamRegister . Just $ CExamR tid ssh csh examn EShowR + ERegisterOccR _occn -> i18nCrumb MsgBreadcrumbExamRegister . Just $ CExamR tid ssh csh examn EShowR + EAutoOccurrenceR -> i18nCrumb MsgBreadcrumbExamAutoOccurrence . Just $ CExamR tid ssh csh examn EUsersR + ECorrectR -> i18nCrumb MsgMenuExamCorrect . Just $ CExamR tid ssh csh examn EShowR + +breadcrumb (CourseR tid ssh csh (TutorialR tutn sRoute)) = case sRoute of + TUsersR -> useRunDB . maybeT (i18nCrumb MsgBreadcrumbTutorial . Just $ CourseR tid ssh csh CTutorialListR) $ do + guardM . lift . hasReadAccessTo $ CTutorialR tid ssh csh tutn TUsersR + return (CI.original tutn, Just $ CourseR tid ssh csh CTutorialListR) + TEditR -> i18nCrumb MsgMenuTutorialEdit . Just $ CTutorialR tid ssh csh tutn TUsersR + TDeleteR -> i18nCrumb MsgMenuTutorialDelete . Just $ CTutorialR tid ssh csh tutn TUsersR + TCommR -> i18nCrumb MsgMenuTutorialComm . Just $ CTutorialR tid ssh csh tutn TUsersR + TRegisterR -> i18nCrumb MsgBreadcrumbTutorialRegister . Just $ CourseR tid ssh csh CShowR + TInviteR -> i18nCrumb MsgBreadcrumbTutorInvite . Just $ CTutorialR tid ssh csh tutn TUsersR + +breadcrumb (CourseR tid ssh csh (SheetR shn sRoute)) = case sRoute of + SShowR -> useRunDB . maybeT (i18nCrumb MsgBreadcrumbSheet . Just $ CourseR tid ssh csh SheetListR) $ do + guardM . lift . hasReadAccessTo $ CSheetR tid ssh csh shn SShowR + return (CI.original shn, Just $ CourseR tid ssh csh SheetListR) + SEditR -> i18nCrumb MsgMenuSheetEdit . Just $ CSheetR tid ssh csh shn SShowR + SDelR -> i18nCrumb MsgMenuSheetDelete . Just $ CSheetR tid ssh csh shn SShowR + SSubsR -> i18nCrumb MsgMenuSubmissions . Just $ CSheetR tid ssh csh shn SShowR + SAssignR -> i18nCrumb MsgMenuCorrectionsAssign . Just $ CSheetR tid ssh csh shn SSubsR + SubmissionNewR -> i18nCrumb MsgMenuSubmissionNew . Just $ CSheetR tid ssh csh shn SShowR + SubmissionOwnR -> i18nCrumb MsgMenuSubmissionOwn . Just $ CSheetR tid ssh csh shn SShowR + SubmissionR cid sRoute' -> case sRoute' of + SubShowR -> useRunDB $ do + mayList <- hasReadAccessTo $ CSheetR tid ssh csh shn SSubsR + if + | mayList + -> i18nCrumb MsgBreadcrumbSubmission . Just $ CSheetR tid ssh csh shn SSubsR + | otherwise + -> i18nCrumb MsgBreadcrumbSubmission . Just $ CSheetR tid ssh csh shn SShowR + CorrectionR -> i18nCrumb MsgMenuCorrection . Just $ CSubmissionR tid ssh csh shn cid SubShowR + SubDelR -> i18nCrumb MsgMenuSubmissionDelete . Just $ CSubmissionR tid ssh csh shn cid SubShowR + SubAssignR -> i18nCrumb MsgCorrectorAssignTitle . Just $ CSubmissionR tid ssh csh shn cid SubShowR + SInviteR -> i18nCrumb MsgBreadcrumbSubmissionUserInvite . Just $ CSubmissionR tid ssh csh shn cid SubShowR + SubArchiveR sft -> i18nCrumb sft . Just $ CSubmissionR tid ssh csh shn cid SubShowR + SubDownloadR _ _ -> i18nCrumb MsgBreadcrumbSubmissionFile . Just $ CSubmissionR tid ssh csh shn cid SubShowR + SArchiveR -> i18nCrumb MsgBreadcrumbSheetArchive . Just $ CSheetR tid ssh csh shn SShowR + SIsCorrR -> i18nCrumb MsgBreadcrumbSheetIsCorrector . Just $ CSheetR tid ssh csh shn SShowR + SPseudonymR -> i18nCrumb MsgBreadcrumbSheetPseudonym . Just $ CSheetR tid ssh csh shn SShowR + SCorrInviteR -> i18nCrumb MsgBreadcrumbSheetCorrectorInvite . Just $ CSheetR tid ssh csh shn SShowR + SZipR sft -> i18nCrumb sft . Just $ CSheetR tid ssh csh shn SShowR + SFileR _ _ -> i18nCrumb MsgBreadcrumbSheetFile . Just $ CSheetR tid ssh csh shn SShowR + SPersonalFilesR -> i18nCrumb MsgBreadcrumbSheetPersonalisedFiles . Just $ CSheetR tid ssh csh shn SShowR + +breadcrumb (CourseR tid ssh csh MaterialListR) = i18nCrumb MsgMenuMaterialList . Just $ CourseR tid ssh csh CShowR +breadcrumb (CourseR tid ssh csh MaterialNewR ) = i18nCrumb MsgMenuMaterialNew . Just $ CourseR tid ssh csh MaterialListR +breadcrumb (CourseR tid ssh csh (MaterialR mnm sRoute)) = case sRoute of + MShowR -> useRunDB . maybeT (i18nCrumb MsgBreadcrumbMaterial . Just $ CourseR tid ssh csh MaterialListR) $ do + guardM . lift . hasReadAccessTo $ CMaterialR tid ssh csh mnm MShowR + return (CI.original mnm, Just $ CourseR tid ssh csh MaterialListR) + MEditR -> i18nCrumb MsgMenuMaterialEdit . Just $ CMaterialR tid ssh csh mnm MShowR + MDelR -> i18nCrumb MsgMenuMaterialDelete . Just $ CMaterialR tid ssh csh mnm MShowR + MArchiveR -> i18nCrumb MsgBreadcrumbMaterialArchive . Just $ CMaterialR tid ssh csh mnm MShowR + MFileR _ -> i18nCrumb MsgBreadcrumbMaterialFile . Just $ CMaterialR tid ssh csh mnm MShowR + MVideoR _ -> i18nCrumb MsgBreadcrumbMaterialVideo . Just $ CMaterialR tid ssh csh mnm MShowR + +breadcrumb (CourseR tid ssh csh CPersonalFilesR) = i18nCrumb MsgBreadcrumbCourseSheetPersonalisedFiles . Just $ CourseR tid ssh csh CShowR + +breadcrumb CorrectionsR = i18nCrumb MsgMenuCorrections Nothing +breadcrumb CorrectionsUploadR = i18nCrumb MsgMenuCorrectionsUpload $ Just CorrectionsR +breadcrumb CorrectionsCreateR = i18nCrumb MsgMenuCorrectionsCreate $ Just CorrectionsR +breadcrumb CorrectionsGradeR = i18nCrumb MsgMenuCorrectionsGrade $ Just CorrectionsR +breadcrumb CorrectionsDownloadR = i18nCrumb MsgMenuCorrectionsDownload $ Just CorrectionsR + +breadcrumb (CryptoUUIDDispatchR _) = i18nCrumb MsgBreadcrumbCryptoIDDispatch Nothing + +breadcrumb (MessageR _) = do + mayList <- useRunDB $ hasReadAccessTo MessageListR + if + | mayList -> i18nCrumb MsgBreadcrumbSystemMessage $ Just MessageListR + | otherwise -> i18nCrumb MsgBreadcrumbSystemMessage $ Just NewsR +breadcrumb MessageListR = i18nCrumb MsgMenuMessageList $ Just AdminR +breadcrumb (MessageHideR cID) = i18nCrumb MsgBreadcrumbMessageHide . Just $ MessageR cID + +breadcrumb GlossaryR = i18nCrumb MsgMenuGlossary $ Just InfoR + +breadcrumb EExamListR = i18nCrumb MsgMenuExternalExamList Nothing +breadcrumb EExamNewR = do + isEO <- useRunDB . hasReadAccessTo $ ExamOfficeR EOExamsR + i18nCrumb MsgBreadcrumbExternalExamNew . Just $ if + | isEO -> ExamOfficeR EOExamsR + | otherwise -> EExamListR +breadcrumb (EExamR tid ssh coursen examn sRoute) = case sRoute of + EEShowR -> do + (isEO, mayShow) <- useRunDB $ (,) + <$> hasReadAccessTo (ExamOfficeR EOExamsR) + <*> hasReadAccessTo (EExamR tid ssh coursen examn EEShowR) + maybeT (i18nCrumb MsgBreadcrumbExternalExam . Just $ bool EExamListR (ExamOfficeR EOExamsR) isEO) $ do + guard mayShow + i18nCrumb (MsgBreadcrumbExternalExamShow coursen examn) . Just $ if + | isEO -> ExamOfficeR EOExamsR + | otherwise -> EExamListR + EEEditR -> i18nCrumb MsgBreadcrumbExternalExamEdit . Just $ EExamR tid ssh coursen examn EEShowR + EEUsersR -> i18nCrumb MsgBreadcrumbExternalExamUsers . Just $ EExamR tid ssh coursen examn EEShowR + EEGradesR -> i18nCrumb MsgBreadcrumbExternalExamGrades . Just $ EExamR tid ssh coursen examn EEShowR + EEStaffInviteR -> i18nCrumb MsgBreadcrumbExternalExamStaffInvite . Just $ EExamR tid ssh coursen examn EEShowR + EECorrectR -> i18nCrumb MsgBreadcrumbExternalExamCorrect . Just $ EExamR tid ssh coursen examn EEShowR + +breadcrumb AdminWorkflowDefinitionListR = i18nCrumb MsgBreadcrumbAdminWorkflowDefinitionList $ Just AdminR +breadcrumb AdminWorkflowDefinitionNewR = i18nCrumb MsgBreadcrumbAdminWorkflowDefinitionNew $ Just AdminWorkflowDefinitionListR +breadcrumb (AdminWorkflowDefinitionR wfdScope wfdName sRoute) = case sRoute of + AWDEditR -> do + MsgRenderer mr <- getMsgRenderer + i18nCrumb (MsgBreadcrumbAdminWorkflowDefinitionEdit (mr wfdScope) wfdName) $ Just AdminWorkflowDefinitionListR + AWDDeleteR -> i18nCrumb MsgBreadcrumbAdminWorkflowDefinitionDelete . Just $ AdminWorkflowDefinitionR wfdScope wfdName AWDEditR + AWDInstantiateR -> i18nCrumb MsgBreadcrumbAdminWorkflowDefinitionInstantiate . Just $ AdminWorkflowDefinitionR wfdScope wfdName AWDEditR +breadcrumb AdminWorkflowInstanceListR = i18nCrumb MsgBreadcrumbAdminWorkflowInstanceList $ Just AdminWorkflowDefinitionListR +breadcrumb AdminWorkflowInstanceNewR = i18nCrumb MsgBreadcrumbAdminWorkflowInstanceNew $ Just AdminWorkflowInstanceListR +breadcrumb (AdminWorkflowInstanceR _cID sRoute) = case sRoute of + AWIEditR -> i18nCrumb MsgBreadcrumbAdminWorkflowInstanceEdit $ Just AdminWorkflowInstanceListR +breadcrumb AdminWorkflowWorkflowListR = i18nCrumb MsgBreadcrumbAdminWorkflowWorkflowList $ Just AdminWorkflowInstanceListR +breadcrumb AdminWorkflowWorkflowNewR = i18nCrumb MsgBreadcrumbAdminWorkflowWorkflowNew $ Just AdminWorkflowWorkflowListR + +breadcrumb GlobalWorkflowInstanceListR = i18nCrumb MsgBreadcrumbGlobalWorkflowInstanceList Nothing +breadcrumb GlobalWorkflowInstanceNewR = i18nCrumb MsgBreadcrumbWorkflowInstanceNew $ Just GlobalWorkflowInstanceListR +breadcrumb (GlobalWorkflowInstanceR win sRoute) = case sRoute of + GWIEditR -> do + desc <- useRunDB . runMaybeT $ do + guardM . lift . hasReadAccessTo $ GlobalWorkflowInstanceR win GWIWorkflowsR + wiId <- MaybeT . getKeyBy $ UniqueWorkflowInstance win WSGlobal + MaybeT $ selectWorkflowInstanceDescription wiId + case desc of + Nothing -> i18nCrumb (MsgBreadcrumbWorkflowInstanceEdit win) $ Just GlobalWorkflowInstanceListR + Just (Entity _ WorkflowInstanceDescription{..}) -> i18nCrumb workflowInstanceDescriptionTitle $ Just GlobalWorkflowInstanceListR + GWIDeleteR -> i18nCrumb MsgBreadcrumbWorkflowInstanceDelete . Just $ GlobalWorkflowInstanceR win GWIEditR + GWIWorkflowsR -> i18nCrumb MsgBreadcrumbWorkflowInstanceWorkflowList . Just $ GlobalWorkflowInstanceR win GWIEditR + GWIInitiateR -> do + mayEdit <- useRunDB . hasReadAccessTo $ GlobalWorkflowInstanceR win GWIEditR + i18nCrumb MsgBreadcrumbWorkflowInstanceInitiate . Just $ if + | mayEdit -> GlobalWorkflowInstanceR win GWIEditR + | otherwise -> GlobalWorkflowInstanceListR +breadcrumb GlobalWorkflowWorkflowListR = i18nCrumb MsgBreadcrumbWorkflowWorkflowList $ Just GlobalWorkflowInstanceListR +breadcrumb (GlobalWorkflowWorkflowR cID sRoute) = case sRoute of + GWWWorkflowR -> i18nCrumb (MsgBreadcrumbWorkflowWorkflow cID) $ Just GlobalWorkflowWorkflowListR + GWWFilesR _ _ -> i18nCrumb MsgBreadcrumbWorkflowWorkflowFiles . Just $ GlobalWorkflowWorkflowR cID GWWWorkflowR + GWWEditR -> i18nCrumb MsgBreadcrumbWorkflowWorkflowEdit . Just $ GlobalWorkflowWorkflowR cID GWWWorkflowR + GWWDeleteR -> i18nCrumb MsgBreadcrumbWorkflowWorkflowDelete . Just $ GlobalWorkflowWorkflowR cID GWWWorkflowR + +breadcrumb TopWorkflowInstanceListR = i18nCrumb MsgBreadcrumbTopWorkflowInstanceList Nothing +breadcrumb TopWorkflowWorkflowListR = i18nCrumb MsgBreadcrumbTopWorkflowWorkflowList $ Just TopWorkflowInstanceListR data NavQuickView @@ -432,7 +446,7 @@ data NavType , navData :: [(Text, Text)] } deriving (Eq, Ord, Read, Show, Generic, Typeable) - deriving anyclass (Binary) + deriving anyclass (Hashable, Binary) makeLenses_ ''NavType makePrisms ''NavType @@ -443,10 +457,14 @@ data NavLevel = NavLevelTop | NavLevelInner data NavHeaderRole = NavHeaderPrimary | NavHeaderSecondary deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) +data NavAccess = NavAccessDB (ReaderT SqlReadBackend Handler Bool) + | NavAccessHandler (Handler Bool) + | NavAccessTrue + data NavLink = forall msg route. (RenderMessage UniWorX msg, HasRoute UniWorX route, RedirectUrl UniWorX route) => NavLink { navLabel :: msg , navRoute :: route - , navAccess' :: Handler Bool + , navAccess' :: NavAccess , navType :: NavType , navQuick' :: NavQuickView -> Any , navForceActive :: Bool @@ -501,29 +519,48 @@ type family ChildrenNavChildren a where ChildrenNavChildren a = Children ChGeneric a -navAccess :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m, BearerAuthSite UniWorX) => Nav -> MaybeT m Nav -navAccess = execStateT $ do - guardM $ preuse _navLink >>= maybe (return True) navLinkAccess +data NavigationCacheKey + = NavCacheRouteAccess AuthContext NavType (Route UniWorX) + | NavCacheHaveWorkflowWorkflowsRoles RouteWorkflowScope + | NavCacheHaveTopWorkflowInstancesRoles | NavCacheHaveTopWorkflowWorkflowsRoles + | NavCacheHaveTopWorkflowsInstances AuthContext + deriving (Generic, Typeable) - _navChildren <~ (filterM navLinkAccess =<< use _navChildren) +deriving stock instance Eq (AuthId UniWorX) => Eq NavigationCacheKey +deriving stock instance Ord (AuthId UniWorX) => Ord NavigationCacheKey +deriving stock instance (Read (AuthId UniWorX), Eq (AuthId UniWorX), Hashable (AuthId UniWorX)) => Read NavigationCacheKey +deriving stock instance (Show (AuthId UniWorX), Eq (AuthId UniWorX), Hashable (AuthId UniWorX)) => Show NavigationCacheKey +deriving anyclass instance Hashable (AuthId UniWorX) => Hashable NavigationCacheKey +deriving anyclass instance (Binary (AuthId UniWorX), Eq (AuthId UniWorX), Hashable (AuthId UniWorX)) => Binary NavigationCacheKey + + +navAccess :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m, WithRunDB SqlReadBackend (HandlerFor UniWorX) m, BearerAuthSite UniWorX) => Nav -> MaybeT m Nav +navAccess = execStateT $ do + guardM $ preuse _navLink >>= lift . lift . maybe (return True) navLinkAccess + + _navChildren <~ (filterM (lift . lift . navLinkAccess) =<< use _navChildren) whenM (hasn't _navLink <$> use id) $ guardM $ not . null <$> use _navChildren -navLinkAccess :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m, BearerAuthSite UniWorX) => NavLink -> m Bool -navLinkAccess NavLink{..} = handle shortCircuit $ liftHandler navAccess' `and2M` accessCheck navType navRoute +navLinkAccess :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m, WithRunDB SqlReadBackend (HandlerFor UniWorX) m, BearerAuthSite UniWorX) => NavLink -> m Bool +navLinkAccess NavLink{..} = case navAccess' of + NavAccessHandler naNoDb -> handle shortCircuit $ liftHandler naNoDb `and2M` accessCheck navType navRoute + NavAccessDB naDb -> handle shortCircuit . useRunDB $ naDb `and2M` accessCheck navType navRoute + NavAccessTrue -> accessCheck navType navRoute where shortCircuit :: HandlerContents -> m Bool shortCircuit _ = return False - accessCheck :: HasRoute UniWorX route => NavType -> route -> m Bool + accessCheck :: forall m' route. (MonadHandler m', HandlerSite m' ~ UniWorX, MonadThrow m', WithRunDB SqlReadBackend (HandlerFor UniWorX) m', HasRoute UniWorX route) => NavType -> route -> m' Bool accessCheck nt (urlRoute -> route) = do authCtx <- getAuthContext - $memcachedByHere (Just $ Right 120) (authCtx, nt, route) $ + memcachedBy (Just . Right $ 2 * diffMinute) (NavCacheRouteAccess authCtx nt route) . useRunDB $ bool hasWriteAccessTo hasReadAccessTo (is _NavTypeLink nt) route defaultLinks :: ( MonadHandler m , HandlerSite m ~ UniWorX , MonadThrow m + , WithRunDB SqlReadBackend (HandlerFor UniWorX) m , BearerAuthSite UniWorX ) => m [Nav] defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the header. @@ -533,7 +570,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , navLink = NavLink { navLabel = MsgMenuLogout , navRoute = AuthR LogoutR - , navAccess' = is _Just <$> maybeAuthId + , navAccess' = NavAccessHandler $ is _Just <$> maybeAuthId , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -545,7 +582,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , navLink = NavLink { navLabel = MsgMenuLogin , navRoute = AuthR LoginR - , navAccess' = is _Nothing <$> maybeAuthId + , navAccess' = NavAccessHandler $ is _Nothing <$> maybeAuthId , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False @@ -557,7 +594,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , navLink = NavLink { navLabel = MsgMenuProfile , navRoute = ProfileR - , navAccess' = is _Just <$> maybeAuthId + , navAccess' = NavAccessHandler $ is _Just <$> maybeAuthId , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -571,7 +608,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the let navChildren = flip map (toList appLanguages) $ \lang -> NavLink { navLabel = MsgLanguage lang , navRoute = (LangR, [(toPathPiece GetReferer, toPathPiece currentRoute) | currentRoute <- hoistMaybe mCurrentRoute ]) - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeButton { navMethod = POST , navData = [(toPathPiece PostLanguage, lang)] @@ -597,7 +634,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , navLink = NavLink { navLabel = MsgMenuHelp , navRoute = (HelpR, [(toPathPiece GetReferer, toPathPiece currentRoute) | currentRoute <- hoistMaybe mCurrentRoute ]) - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False @@ -606,7 +643,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , return $ NavFooter NavLink { navLabel = MsgMenuDataProt , navRoute = LegalR :#: ("data-protection" :: Text) - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -614,7 +651,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , return $ NavFooter NavLink { navLabel = MsgMenuTermsUse , navRoute = LegalR :#: ("terms-of-use" :: Text) - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -622,7 +659,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , return $ NavFooter NavLink { navLabel = MsgMenuCopyright , navRoute = LegalR :#: ("copyright" :: Text) - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -630,7 +667,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , return $ NavFooter NavLink { navLabel = MsgMenuImprint , navRoute = LegalR :#: ("imprint" :: Text) - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -638,7 +675,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , return $ NavFooter NavLink { navLabel = MsgMenuInformation , navRoute = InfoR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -646,7 +683,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , return $ NavFooter NavLink { navLabel = MsgMenuFaq , navRoute = FaqR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -654,7 +691,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , return $ NavFooter NavLink { navLabel = MsgMenuGlossary , navRoute = GlossaryR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -665,7 +702,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , navLink = NavLink { navLabel = MsgMenuNews , navRoute = NewsR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -677,7 +714,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , navLink = NavLink { navLabel = MsgMenuCourseList , navRoute = CourseListR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -689,7 +726,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , navLink = NavLink { navLabel = MsgMenuCorrections , navRoute = CorrectionsR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -701,7 +738,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , navLink = NavLink { navLabel = MsgMenuExamOfficeExams , navRoute = ExamOfficeR EOExamsR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -709,7 +746,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the } , do authCtx <- getAuthContext - (haveInstances, haveWorkflows) <- $memcachedByHere (Just $ Right diffDay) authCtx . liftHandler . runDBRead $ (,) -- We don't expect haveTopWorkflowWorkflows to be relevant and haveTopWorkflowInstances shouldn't change often + (haveInstances, haveWorkflows) <- lift . memcachedBy (Just . Right $ 2 * diffMinute) (NavCacheHaveTopWorkflowsInstances authCtx) . useRunDB $ (,) <$> haveTopWorkflowInstances <*> haveTopWorkflowWorkflows @@ -719,7 +756,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , navLink = NavLink { navLabel = MsgMenuTopWorkflowInstanceList , navRoute = TopWorkflowInstanceListR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -731,7 +768,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , navLink = NavLink { navLabel = MsgMenuTopWorkflowWorkflowListHeader , navRoute = TopWorkflowWorkflowListR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -746,7 +783,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the [ NavLink { navLabel = MsgMenuUsers , navRoute = UsersR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -754,7 +791,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , NavLink { navLabel = MsgMenuSchoolList , navRoute = SchoolListR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -762,7 +799,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , NavLink { navLabel = MsgMenuAdminFeaturesHeading , navRoute = AdminFeaturesR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -770,7 +807,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , NavLink { navLabel = MsgMenuMessageList , navRoute = MessageListR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -778,7 +815,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , NavLink { navLabel = MsgMenuAdminErrMsg , navRoute = AdminErrMsgR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -786,7 +823,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , NavLink { navLabel = MsgMenuAdminTokens , navRoute = AdminTokensR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -794,7 +831,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , NavLink { navLabel = MsgMenuAdminWorkflowDefinitionList , navRoute = AdminWorkflowDefinitionListR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -802,7 +839,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , NavLink { navLabel = MsgMenuAdminCrontab , navRoute = AdminCrontabR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -810,7 +847,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , NavLink { navLabel = MsgMenuAdminTest , navRoute = AdminTestR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -825,7 +862,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the [ NavLink { navLabel = MsgMenuCourseNew , navRoute = CourseNewR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -833,7 +870,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , NavLink { navLabel = MsgMenuExternalExamList , navRoute = EExamListR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -841,7 +878,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , NavLink { navLabel = MsgMenuTermShow , navRoute = TermShowR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -849,15 +886,15 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , NavLink { navLabel = MsgMenuAllocationList , navRoute = AllocationListR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False } , NavLink - { navLabel = MsgInfoLecturerTitle + { navLabel = MsgMenuInfoLecturerTitle , navRoute = InfoLecturerR - , navAccess' = hasWriteAccessTo CourseNewR + , navAccess' = NavAccessDB $ hasWriteAccessTo CourseNewR , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -869,8 +906,9 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the pageActions :: ( MonadHandler m , HandlerSite m ~ UniWorX , MonadCatch m + , WithRunDB SqlReadBackend (HandlerFor UniWorX) m , BearerAuthSite UniWorX - , BackendCompatible SqlReadBackend (YesodPersistBackend UniWorX) + , MonadUnliftIO m ) => Route UniWorX -> m [Nav] pageActions NewsR = return @@ -878,7 +916,7 @@ pageActions NewsR = return { navLink = NavLink { navLabel = MsgMenuOpenCourses , navRoute = (CourseListR, [("courses-openregistration", toPathPiece True)]) - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -889,7 +927,7 @@ pageActions NewsR = return { navLink = NavLink { navLabel = MsgMenuOpenAllocations , navRoute = (AllocationListR, [("allocations-active", toPathPiece True)]) - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -906,7 +944,7 @@ pageActions (CourseR tid ssh csh CShowR) = do let examListBound :: Num a => a examListBound = 4 -- guaranteed random; chosen by fair dice roll - examListExams <- liftHandler . runDBRead $ do + examListExams <- useRunDB $ do examNames <- E.select . E.from $ \(course `E.InnerJoin` exam) -> do E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId E.where_ $ course E.^. CourseTerm E.==. E.val tid @@ -919,7 +957,7 @@ pageActions (CourseR tid ssh csh CShowR) = do return NavLink { navLabel = examn , navRoute = CExamR tid ssh csh examn EShowR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewFavourite , navForceActive = False @@ -931,7 +969,7 @@ pageActions (CourseR tid ssh csh CShowR) = do { navLink = NavLink { navLabel = MsgMenuCourseMembers , navRoute = CourseR tid ssh csh CUsersR - , navAccess' = + , navAccess' = NavAccessDB $ let courseWhere course = course <$ do E.where_ $ course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh @@ -941,7 +979,7 @@ pageActions (CourseR tid ssh csh CShowR) = do E.where_ $ courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive void $ courseWhere course mayRegister = hasWriteAccessTo $ CourseR tid ssh csh CAddUserR - in runDBRead $ mayRegister `or2M` hasParticipants + in mayRegister `or2M` hasParticipants , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewFavourite , navForceActive = False @@ -955,7 +993,7 @@ pageActions (CourseR tid ssh csh CShowR) = do { navLink = NavLink { navLabel = MsgMenuMaterialList , navRoute = CourseR tid ssh csh MaterialListR - , navAccess' = + , navAccess' = NavAccessDB $ let lecturerAccess = hasWriteAccessTo $ CourseR tid ssh csh MaterialNewR -- Always show for lecturers to create new material materialAccess mnm = hasReadAccessTo $ CMaterialR tid ssh csh mnm MShowR -- otherwise show only if the user can see at least one of the contents existsVisible = do @@ -966,7 +1004,7 @@ pageActions (CourseR tid ssh csh CShowR) = do E.&&. course E.^. CourseShorthand E.==. E.val csh return $ material E.^. MaterialName anyM matNames (materialAccess . E.unValue) - in runDBRead $ lecturerAccess `or2M` existsVisible + in lecturerAccess `or2M` existsVisible , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewFavourite , navForceActive = False @@ -977,7 +1015,7 @@ pageActions (CourseR tid ssh csh CShowR) = do { navLink = NavLink { navLabel = MsgMenuSheetList , navRoute = CourseR tid ssh csh SheetListR - , navAccess' = + , navAccess' = NavAccessDB $ let lecturerAccess = hasWriteAccessTo $ CourseR tid ssh csh SheetNewR -- Always show for lecturers to create new sheets sheetAccess shn = hasReadAccessTo $ CSheetR tid ssh csh shn SShowR -- othwerwise show only if the user can see at least one of the contents existsVisible = do @@ -988,7 +1026,7 @@ pageActions (CourseR tid ssh csh CShowR) = do E.&&. course E.^. CourseShorthand E.==. E.val csh return $ sheet E.^. SheetName anyM sheetNames $ sheetAccess . E.unValue - in runDBRead $ lecturerAccess `or2M` existsVisible + in lecturerAccess `or2M` existsVisible , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewFavourite , navForceActive = False @@ -999,7 +1037,7 @@ pageActions (CourseR tid ssh csh CShowR) = do { navLink = NavLink { navLabel = MsgMenuTutorialList , navRoute = CourseR tid ssh csh CTutorialListR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewFavourite , navForceActive = False @@ -1010,7 +1048,7 @@ pageActions (CourseR tid ssh csh CShowR) = do { navLink = NavLink { navLabel = MsgMenuExamList , navRoute = CourseR tid ssh csh CExamListR - , navAccess' = + , navAccess' = NavAccessDB $ let lecturerAccess = hasWriteAccessTo $ CourseR tid ssh csh CExamNewR examAccess examn = hasReadAccessTo $ CExamR tid ssh csh examn EShowR existsVisible = do @@ -1021,7 +1059,7 @@ pageActions (CourseR tid ssh csh CShowR) = do E.&&. course E.^. CourseShorthand E.==. E.val csh return $ exam E.^. ExamName anyM examNames $ examAccess . E.unValue - in runDBRead $ lecturerAccess `or2M` existsVisible + in lecturerAccess `or2M` existsVisible , navType = NavTypeLink { navModal = False } , navQuick' = bool (navQuick NavQuickViewFavourite) mempty showExamList , navForceActive = False @@ -1034,7 +1072,7 @@ pageActions (CourseR tid ssh csh CShowR) = do { navLink = NavLink { navLabel = MsgMenuCourseCommunication , navRoute = CourseR tid ssh csh CCommR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewFavourite , navForceActive = False @@ -1045,13 +1083,12 @@ pageActions (CourseR tid ssh csh CShowR) = do { navLink = NavLink { navLabel = MsgMenuCourseExamOffice , navRoute = CourseR tid ssh csh CExamOfficeR - , navAccess' = do + , navAccess' = NavAccessDB $ do uid <- requireAuthId - runDBRead $ do - cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh - E.selectExists $ do - (_school, isForced) <- courseExamOfficeSchools (E.val uid) (E.val cid) - E.where_ $ E.not_ isForced + cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh + E.selectExists $ do + (_school, isForced) <- courseExamOfficeSchools (E.val uid) (E.val cid) + E.where_ $ E.not_ isForced , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False @@ -1061,7 +1098,7 @@ pageActions (CourseR tid ssh csh CShowR) = do { navLink = NavLink { navLabel = MsgMenuCourseEdit , navRoute = CourseR tid ssh csh CEditR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1073,7 +1110,7 @@ pageActions (CourseR tid ssh csh CShowR) = do , navRoute = ( CourseNewR , [("tid", toPathPiece tid), ("ssh", toPathPiece ssh), ("csh", toPathPiece csh)] ) - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1083,7 +1120,7 @@ pageActions (CourseR tid ssh csh CShowR) = do { navLink = NavLink { navLabel = MsgMenuCourseDelete , navRoute = CourseR tid ssh csh CDeleteR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1095,7 +1132,7 @@ pageActions (ExamOfficeR EOExamsR) = return { navLink = NavLink { navLabel = MsgMenuExamOfficeFields , navRoute = ExamOfficeR EOFieldsR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False @@ -1106,7 +1143,7 @@ pageActions (ExamOfficeR EOExamsR) = return { navLink = NavLink { navLabel = MsgMenuExamOfficeUsers , navRoute = ExamOfficeR EOUsersR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False @@ -1119,7 +1156,7 @@ pageActions SchoolListR = return { navLink = NavLink { navLabel = MsgMenuSchoolNew , navRoute = SchoolNewR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1132,7 +1169,7 @@ pageActions UsersR = return { navLink = NavLink { navLabel = MsgMenuLecturerInvite , navRoute = AdminNewFunctionaryInviteR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False @@ -1143,7 +1180,7 @@ pageActions UsersR = return { navLink = NavLink { navLabel = MsgMenuUserAdd , navRoute = AdminUserAddR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False @@ -1156,7 +1193,7 @@ pageActions (AdminUserR cID) = return { navLink = NavLink { navLabel = MsgMenuUserNotifications , navRoute = UserNotificationR cID - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False @@ -1167,9 +1204,9 @@ pageActions (AdminUserR cID) = return { navLink = NavLink { navLabel = MsgMenuUserPassword , navRoute = UserPasswordR cID - , navAccess' = do + , navAccess' = NavAccessDB $ do uid <- decrypt cID - User{userAuthentication} <- runDBRead $ get404 uid + User{userAuthentication} <- get404 uid return $ is _AuthPWHash userAuthentication , navType = NavTypeLink { navModal = True } , navQuick' = mempty @@ -1183,7 +1220,7 @@ pageActions InfoR = return { navLink = NavLink { navLabel = MsgMenuInfoLecturerTitle , navRoute = InfoLecturerR - , navAccess' = hasWriteAccessTo CourseNewR + , navAccess' = NavAccessDB $ hasWriteAccessTo CourseNewR , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1194,7 +1231,7 @@ pageActions InfoR = return { navLink = NavLink { navLabel = MsgMenuLegal , navRoute = LegalR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1205,7 +1242,7 @@ pageActions InfoR = return { navLink = NavLink { navLabel = MsgMenuFaq , navRoute = FaqR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1216,7 +1253,7 @@ pageActions InfoR = return { navLink = NavLink { navLabel = MsgMenuGlossary , navRoute = GlossaryR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1229,7 +1266,7 @@ pageActions VersionR = return { navLink = NavLink { navLabel = MsgMenuInfoLecturerTitle , navRoute = InfoLecturerR - , navAccess' = hasWriteAccessTo CourseNewR + , navAccess' = NavAccessDB $ hasWriteAccessTo CourseNewR , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1240,7 +1277,7 @@ pageActions VersionR = return { navLink = NavLink { navLabel = MsgMenuLegal , navRoute = LegalR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1251,7 +1288,7 @@ pageActions VersionR = return { navLink = NavLink { navLabel = MsgMenuFaq , navRoute = FaqR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1262,7 +1299,7 @@ pageActions VersionR = return { navLink = NavLink { navLabel = MsgMenuGlossary , navRoute = GlossaryR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1275,7 +1312,7 @@ pageActions HealthR = return { navLink = NavLink { navLabel = MsgMenuInstance , navRoute = InstanceR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1288,7 +1325,7 @@ pageActions InstanceR = return { navLink = NavLink { navLabel = MsgMenuHealth , navRoute = HealthR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1301,7 +1338,7 @@ pageActions HelpR = return { navLink = NavLink { navLabel = MsgMenuFaq , navRoute = FaqR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1312,7 +1349,7 @@ pageActions HelpR = return { navLink = NavLink { navLabel = MsgMenuInfoLecturerTitle , navRoute = InfoLecturerR - , navAccess' = hasWriteAccessTo CourseNewR + , navAccess' = NavAccessDB $ hasWriteAccessTo CourseNewR , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1328,7 +1365,7 @@ pageActions HelpR = return return NavLink { navLabel , navRoute = InfoLecturerR :#: section - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1338,7 +1375,7 @@ pageActions HelpR = return { navLink = NavLink { navLabel = MsgMenuGlossary , navRoute = GlossaryR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1351,7 +1388,7 @@ pageActions ProfileR = return { navLink = NavLink { navLabel = MsgMenuProfileData , navRoute = ProfileDataR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1362,7 +1399,7 @@ pageActions ProfileR = return { navLink = NavLink { navLabel = MsgMenuAuthPreds , navRoute = AuthPredsR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False @@ -1373,7 +1410,7 @@ pageActions ProfileR = return { navLink = NavLink { navLabel = MsgMenuCsvOptions , navRoute = CsvOptionsR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False @@ -1388,7 +1425,7 @@ pageActions TermShowR = do { navLink = NavLink { navLabel = MsgMenuTermCreate , navRoute = TermEditR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1399,7 +1436,7 @@ pageActions TermShowR = do { navLink = NavLink { navLabel = MsgMenuParticipantsList , navRoute = ParticipantsListR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1412,7 +1449,7 @@ pageActions (AllocationR tid ssh ash AShowR) = return { navLink = NavLink { navLabel = MsgMenuAllocationInfo , navRoute = InfoAllocationR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False @@ -1423,7 +1460,7 @@ pageActions (AllocationR tid ssh ash AShowR) = return { navLink = NavLink { navLabel = MsgMenuAllocationUsers , navRoute = AllocationR tid ssh ash AUsersR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1434,7 +1471,7 @@ pageActions (AllocationR tid ssh ash AShowR) = return { navLink = NavLink { navLabel = MsgMenuAllocationCompute , navRoute = AllocationR tid ssh ash AComputeR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1447,7 +1484,7 @@ pageActions (AllocationR tid ssh ash AUsersR) = return { navLink = NavLink { navLabel = MsgMenuAllocationPriorities , navRoute = AllocationR tid ssh ash APriosR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1458,7 +1495,7 @@ pageActions (AllocationR tid ssh ash AUsersR) = return { navLink = NavLink { navLabel = MsgMenuAllocationCompute , navRoute = AllocationR tid ssh ash AComputeR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1469,7 +1506,7 @@ pageActions (AllocationR tid ssh ash AUsersR) = return { navLink = NavLink { navLabel = MsgMenuAllocationAddUser , navRoute = AllocationR tid ssh ash AAddUserR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1484,7 +1521,7 @@ pageActions CourseListR = do { navLink = NavLink { navLabel = MsgMenuCourseNew , navRoute = CourseNewR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1495,7 +1532,7 @@ pageActions CourseListR = do { navLink = NavLink { navLabel = MsgMenuAllocationList , navRoute = AllocationListR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1506,7 +1543,7 @@ pageActions CourseListR = do { navLink = NavLink { navLabel = MsgMenuParticipantsList , navRoute = ParticipantsListR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1519,7 +1556,7 @@ pageActions CourseNewR = return { navLink = NavLink { navLabel = MsgMenuInfoLecturerTitle , navRoute = InfoLecturerR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1532,7 +1569,7 @@ pageActions (CourseR tid ssh csh CCorrectionsR) = return { navLink = NavLink { navLabel = MsgMenuCorrectionsAssign , navRoute = CourseR tid ssh csh CAssignR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewPageActionSecondary <> navQuick NavQuickViewFavourite , navForceActive = False @@ -1548,12 +1585,12 @@ pageActions (CourseR tid ssh csh CCorrectionsR) = return , ("corrections-course", toPathPiece csh) ] ) - , navAccess' = do + , navAccess' = NavAccessDB $ do muid <- maybeAuthId case muid of Nothing -> return False (Just uid) -> do - runDBRead . E.selectExists . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission) -> do + E.selectExists . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission) -> do E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId E.where_ $ submission E.^. SubmissionRatingBy E.==. E.just (E.val uid) @@ -1575,7 +1612,7 @@ pageActions (CourseR tid ssh csh SheetListR) = do { navLink = NavLink { navLabel = MsgMenuSubmissions , navRoute = CourseR tid ssh csh CCorrectionsR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewPageActionSecondary <> navQuick NavQuickViewFavourite , navForceActive = False @@ -1589,10 +1626,9 @@ pageActions (CourseR tid ssh csh SheetListR) = do { navLink = NavLink { navLabel = MsgMenuSheetCurrent , navRoute = CourseR tid ssh csh SheetCurrentR - , navAccess' = - runDBRead . maybeT (return False) $ do - void . MaybeT $ sheetCurrent tid ssh csh - return True + , navAccess' = NavAccessDB . maybeT (return False) $ do + void . MaybeT $ sheetCurrent tid ssh csh + return True , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewPageActionSecondary <> navQuick NavQuickViewFavourite , navForceActive = False @@ -1603,10 +1639,9 @@ pageActions (CourseR tid ssh csh SheetListR) = do { navLink = NavLink { navLabel = MsgMenuSheetOldUnassigned , navRoute = CourseR tid ssh csh SheetOldUnassignedR - , navAccess' = - runDBRead . maybeT (return False) $ do - void . MaybeT $ sheetOldUnassigned tid ssh csh - return True + , navAccess' = NavAccessDB . maybeT (return False) $ do + void . MaybeT $ sheetOldUnassigned tid ssh csh + return True , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewPageActionSecondary <> navQuick NavQuickViewFavourite , navForceActive = False @@ -1619,7 +1654,7 @@ pageActions (CourseR tid ssh csh SheetListR) = do { navLink = NavLink { navLabel = MsgMenuSheetNew , navRoute = CourseR tid ssh csh SheetNewR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewPageActionSecondary <> navQuick NavQuickViewFavourite , navForceActive = False @@ -1632,7 +1667,7 @@ pageActions (CourseR tid ssh csh CUsersR) = return { navLink = NavLink { navLabel = MsgMenuCourseAddMembers , navRoute = CourseR tid ssh csh CAddUserR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = navQuick NavQuickViewPageActionSecondary , navForceActive = False @@ -1643,7 +1678,7 @@ pageActions (CourseR tid ssh csh CUsersR) = return { navLink = NavLink { navLabel = MsgMenuCourseApplications , navRoute = CourseR tid ssh csh CApplicationsR - , navAccess' = + , navAccess' = NavAccessDB $ let courseWhere course = course <$ do E.where_ $ course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh @@ -1657,7 +1692,7 @@ pageActions (CourseR tid ssh csh CUsersR) = return courseAllocation = E.selectExists . E.from $ \(course `E.InnerJoin` allocationCourse) -> do E.on $ course E.^. CourseId E.==. allocationCourse E.^. AllocationCourseCourse void $ courseWhere course - in runDBRead $ courseAllocation `or2M` courseApplications `or2M` existsApplications + in courseAllocation `or2M` courseApplications `or2M` existsApplications , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewPageActionSecondary <> navQuick NavQuickViewFavourite , navForceActive = False @@ -1670,7 +1705,7 @@ pageActions (CourseR tid ssh csh MaterialListR) = return { navLink = NavLink { navLabel = MsgMenuMaterialNew , navRoute = CourseR tid ssh csh MaterialNewR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewPageActionSecondary , navForceActive = False @@ -1683,7 +1718,7 @@ pageActions (CMaterialR tid ssh csh mnm MShowR) = return { navLink = NavLink { navLabel = MsgMenuMaterialEdit , navRoute = CMaterialR tid ssh csh mnm MEditR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1694,7 +1729,7 @@ pageActions (CMaterialR tid ssh csh mnm MShowR) = return { navLink = NavLink { navLabel = MsgMenuMaterialDelete , navRoute = CMaterialR tid ssh csh mnm MDelR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False @@ -1706,7 +1741,7 @@ pageActions (CourseR tid ssh csh CTutorialListR) = return { navLink = NavLink { navLabel = MsgMenuTutorialNew , navRoute = CourseR tid ssh csh CTutorialNewR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewPageActionSecondary , navForceActive = False @@ -1719,7 +1754,7 @@ pageActions (CTutorialR tid ssh csh tutn TEditR) = return { navLink = NavLink { navLabel = MsgMenuTutorialDelete , navRoute = CTutorialR tid ssh csh tutn TDeleteR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1731,7 +1766,7 @@ pageActions (CTutorialR tid ssh csh tutn TUsersR) = return { navLink = NavLink { navLabel = MsgMenuTutorialComm , navRoute = CTutorialR tid ssh csh tutn TCommR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1742,7 +1777,7 @@ pageActions (CTutorialR tid ssh csh tutn TUsersR) = return { navLink = NavLink { navLabel = MsgMenuTutorialEdit , navRoute = CTutorialR tid ssh csh tutn TEditR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1753,7 +1788,7 @@ pageActions (CTutorialR tid ssh csh tutn TUsersR) = return { navLink = NavLink { navLabel = MsgMenuTutorialDelete , navRoute = CTutorialR tid ssh csh tutn TDeleteR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1765,7 +1800,7 @@ pageActions (CourseR tid ssh csh CExamListR) = return { navLink = NavLink { navLabel = MsgMenuExamNew , navRoute = CourseR tid ssh csh CExamNewR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewPageActionSecondary , navForceActive = False @@ -1781,7 +1816,7 @@ pageActions (CExamR tid ssh csh examn EShowR) = do { navLink = NavLink { navLabel = MsgMenuExamEdit , navRoute = CExamR tid ssh csh examn EEditR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1792,7 +1827,7 @@ pageActions (CExamR tid ssh csh examn EShowR) = do { navLink = NavLink { navLabel = MsgMenuExamUsers , navRoute = CExamR tid ssh csh examn EUsersR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1803,7 +1838,7 @@ pageActions (CExamR tid ssh csh examn EShowR) = do { navLink = NavLink { navLabel = MsgMenuExamGrades , navRoute = CExamR tid ssh csh examn EGradesR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1814,7 +1849,7 @@ pageActions (CExamR tid ssh csh examn EShowR) = do { navLink = NavLink { navLabel = MsgMenuExamCorrect , navRoute = CExamR tid ssh csh examn ECorrectR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1827,7 +1862,7 @@ pageActions (CExamR tid ssh csh examn ECorrectR) = return { navLink = NavLink { navLabel = MsgMenuExamUsers , navRoute = CExamR tid ssh csh examn EUsersR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1838,7 +1873,7 @@ pageActions (CExamR tid ssh csh examn ECorrectR) = return { navLink = NavLink { navLabel = MsgMenuExamGrades , navRoute = CExamR tid ssh csh examn EGradesR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1849,7 +1884,7 @@ pageActions (CExamR tid ssh csh examn ECorrectR) = return { navLink = NavLink { navLabel = MsgMenuExamEdit , navRoute = CExamR tid ssh csh examn EEditR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1861,7 +1896,7 @@ pageActions (CExamR tid ssh csh examn EUsersR) = return { navLink = NavLink { navLabel = MsgMenuExamAddMembers , navRoute = CExamR tid ssh csh examn EAddUserR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = navQuick NavQuickViewPageActionSecondary , navForceActive = False @@ -1872,7 +1907,7 @@ pageActions (CExamR tid ssh csh examn EUsersR) = return { navLink = NavLink { navLabel = MsgMenuExamGrades , navRoute = CExamR tid ssh csh examn EGradesR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1883,7 +1918,7 @@ pageActions (CExamR tid ssh csh examn EUsersR) = return { navLink = NavLink { navLabel = MsgMenuExamCorrect , navRoute = CExamR tid ssh csh examn ECorrectR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1896,7 +1931,7 @@ pageActions (CExamR tid ssh csh examn EGradesR) = return { navLink = NavLink { navLabel = MsgMenuExamUsers , navRoute = CExamR tid ssh csh examn EUsersR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewPageActionSecondary , navForceActive = False @@ -1907,7 +1942,7 @@ pageActions (CExamR tid ssh csh examn EGradesR) = return { navLink = NavLink { navLabel = MsgMenuExamCorrect , navRoute = CExamR tid ssh csh examn ECorrectR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1922,7 +1957,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) = do { navLink = NavLink { navLabel = MsgMenuSubmissions , navRoute = CSheetR tid ssh csh shn SSubsR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1936,12 +1971,11 @@ pageActions (CSheetR tid ssh csh shn SShowR) = do { navLink = NavLink { navLabel = MsgMenuSubmissionOwn , navRoute = CSheetR tid ssh csh shn SubmissionOwnR - , navAccess' = - runDBRead . maybeT (return False) $ do - uid <- MaybeT $ liftHandler maybeAuthId - submissions <- lift $ submissionList tid csh shn uid - guard . not $ null submissions - return True + , navAccess' = NavAccessDB . maybeT (return False) $ do + uid <- MaybeT $ liftHandler maybeAuthId + submissions <- lift $ submissionList tid csh shn uid + guard . not $ null submissions + return True , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1954,7 +1988,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) = do { navLink = NavLink { navLabel = MsgMenuSheetPersonalisedFiles , navRoute = CSheetR tid ssh csh shn SPersonalFilesR - , navAccess' = + , navAccess' = NavAccessDB $ let onlyPersonalised = fmap (maybe False $ not . E.unValue) . E.selectMaybe . E.from $ \(sheet `E.InnerJoin` course) -> do E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId E.where_$ sheet E.^. SheetName E.==. E.val shn @@ -1969,7 +2003,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) = do E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh - in runDBRead $ or2M onlyPersonalised hasPersonalised + in or2M onlyPersonalised hasPersonalised , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False @@ -1980,7 +2014,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) = do { navLink = NavLink { navLabel = MsgMenuSheetEdit , navRoute = CSheetR tid ssh csh shn SEditR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -1991,7 +2025,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) = do { navLink = NavLink { navLabel = MsgMenuSheetClone , navRoute = (CourseR tid ssh csh SheetNewR, [("shn", toPathPiece shn)]) - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2001,7 +2035,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) = do { navLink = NavLink { navLabel = MsgMenuSheetDelete , navRoute = CSheetR tid ssh csh shn SDelR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2013,14 +2047,14 @@ pageActions (CSheetR tid ssh csh shn SSubsR) = return { navLink = NavLink { navLabel = MsgMenuSubmissionNew , navRoute = CSheetR tid ssh csh shn SubmissionNewR - , navAccess' = + , navAccess' = NavAccessDB $ let submissionAccess = hasWriteAccessTo $ CSheetR tid ssh csh shn SSubsR hasNoSubmission = maybeT (return False) $ do uid <- MaybeT $ liftHandler maybeAuthId submissions <- lift $ submissionList tid csh shn uid guard $ null submissions return True - in runDBRead $ hasNoSubmission `or2M` submissionAccess + in hasNoSubmission `or2M` submissionAccess , navType = NavTypeLink { navModal = True } , navQuick' = navQuick NavQuickViewPageActionSecondary , navForceActive = False @@ -2037,7 +2071,7 @@ pageActions (CSheetR tid ssh csh shn SSubsR) = return , ("corrections-sheet", toPathPiece shn) ] ) - , navAccess' = (== Authorized) <$> evalAccessCorrector tid ssh csh + , navAccess' = NavAccessDB $ (== Authorized) <$> evalAccessCorrector tid ssh csh , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewPageActionSecondary , navForceActive = False @@ -2048,7 +2082,7 @@ pageActions (CSheetR tid ssh csh shn SSubsR) = return { navLink = NavLink { navLabel = MsgMenuCorrectionsAssign , navRoute = CSheetR tid ssh csh shn SAssignR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewPageActionSecondary , navForceActive = False @@ -2061,7 +2095,7 @@ pageActions (CSubmissionR tid ssh csh shn cid SubShowR) = return { navLink = NavLink { navLabel = MsgMenuCorrection , navRoute = CSubmissionR tid ssh csh shn cid CorrectionR - , navAccess' = hasWriteAccessTo $ CSubmissionR tid ssh csh shn cid CorrectionR + , navAccess' = NavAccessDB . hasWriteAccessTo $ CSubmissionR tid ssh csh shn cid CorrectionR , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2072,7 +2106,7 @@ pageActions (CSubmissionR tid ssh csh shn cid SubShowR) = return { navLink = NavLink { navLabel = MsgMenuCorrectorAssignTitle , navRoute = CSubmissionR tid ssh csh shn cid SubAssignR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False @@ -2083,7 +2117,7 @@ pageActions (CSubmissionR tid ssh csh shn cid SubShowR) = return { navLink = NavLink { navLabel = MsgMenuSubmissionDelete , navRoute = CSubmissionR tid ssh csh shn cid SubDelR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2095,7 +2129,7 @@ pageActions (CSubmissionR tid ssh csh shn cid CorrectionR) = return { navLink = NavLink { navLabel = MsgMenuCorrectorAssignTitle , navRoute = CSubmissionR tid ssh csh shn cid SubAssignR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False @@ -2106,7 +2140,7 @@ pageActions (CSubmissionR tid ssh csh shn cid CorrectionR) = return { navLink = NavLink { navLabel = MsgMenuSubmissionDelete , navRoute = CSubmissionR tid ssh csh shn cid SubDelR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2118,7 +2152,7 @@ pageActions (CourseR tid ssh csh CApplicationsR) = return { navLink = NavLink { navLabel = MsgMenuCourseApplicationsFiles , navRoute = CourseR tid ssh csh CAppsFilesR - , navAccess' = + , navAccess' = NavAccessDB $ let appAccess (E.Value appId) = do cID <- encrypt appId hasReadAccessTo $ CApplicationR tid ssh csh cID CAFilesR @@ -2130,7 +2164,7 @@ pageActions (CourseR tid ssh csh CApplicationsR) = return E.where_ . E.exists . E.from $ \courseApplicationFile -> E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. courseApplication E.^. CourseApplicationId return $ courseApplication E.^. CourseApplicationId - in runDBRead . runConduit $ appSource .| anyMC appAccess + in runConduit $ appSource .| anyMC appAccess , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2141,10 +2175,9 @@ pageActions (CourseR tid ssh csh CApplicationsR) = return { navLink = NavLink { navLabel = MsgMenuCourseMembers , navRoute = CourseR tid ssh csh CUsersR - , navAccess' = - runDBRead $ do - cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh - exists [ CourseParticipantCourse ==. cid ] + , navAccess' = NavAccessDB $ do + cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh + exists [ CourseParticipantCourse ==. cid ] , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2157,7 +2190,7 @@ pageActions CorrectionsR = return { navLink = NavLink { navLabel = MsgMenuCorrectionsDownload , navRoute = CorrectionsDownloadR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewPageActionSecondary , navForceActive = False @@ -2168,7 +2201,7 @@ pageActions CorrectionsR = return { navLink = NavLink { navLabel = MsgMenuCorrectionsUpload , navRoute = CorrectionsUploadR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = navQuick NavQuickViewPageActionSecondary , navForceActive = False @@ -2179,7 +2212,7 @@ pageActions CorrectionsR = return { navLink = NavLink { navLabel = MsgMenuCorrectionsCreate , navRoute = CorrectionsCreateR - , navAccess' = runDBRead . maybeT (return False) $ do + , navAccess' = NavAccessDB . maybeT (return False) $ do uid <- MaybeT $ liftHandler maybeAuthId sheets <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse @@ -2203,7 +2236,7 @@ pageActions CorrectionsR = return { navLink = NavLink { navLabel = MsgMenuCorrectionsGrade , navRoute = CorrectionsGradeR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2218,7 +2251,7 @@ pageActions CorrectionsGradeR = do { navLink = NavLink { navLabel = MsgMenuCorrections , navRoute = CorrectionsR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2231,7 +2264,7 @@ pageActions EExamListR = return { navLink = NavLink { navLabel = MsgMenuExternalExamNew , navRoute = EExamNewR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2244,7 +2277,7 @@ pageActions (EExamR tid ssh coursen examn EEShowR) = return { navLink = NavLink { navLabel = MsgMenuExternalExamEdit , navRoute = EExamR tid ssh coursen examn EEEditR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2255,7 +2288,7 @@ pageActions (EExamR tid ssh coursen examn EEShowR) = return { navLink = NavLink { navLabel = MsgMenuExternalExamUsers , navRoute = EExamR tid ssh coursen examn EEUsersR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2266,7 +2299,7 @@ pageActions (EExamR tid ssh coursen examn EEShowR) = return { navLink = NavLink { navLabel = MsgMenuExternalExamGrades , navRoute = EExamR tid ssh coursen examn EEGradesR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2277,7 +2310,7 @@ pageActions (EExamR tid ssh coursen examn EEShowR) = return { navLink = NavLink { navLabel = MsgMenuExternalExamCorrect , navRoute = EExamR tid ssh coursen examn EECorrectR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2290,7 +2323,7 @@ pageActions (EExamR tid ssh coursen examn EEGradesR) = return { navLink = NavLink { navLabel = MsgMenuExternalExamCorrect , navRoute = EExamR tid ssh coursen examn EECorrectR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2301,7 +2334,7 @@ pageActions (EExamR tid ssh coursen examn EEGradesR) = return { navLink = NavLink { navLabel = MsgMenuExternalExamUsers , navRoute = EExamR tid ssh coursen examn EEUsersR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2312,7 +2345,7 @@ pageActions (EExamR tid ssh coursen examn EEGradesR) = return { navLink = NavLink { navLabel = MsgMenuExternalExamEdit , navRoute = EExamR tid ssh coursen examn EEEditR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2325,7 +2358,7 @@ pageActions (EExamR tid ssh coursen examn EECorrectR) = return { navLink = NavLink { navLabel = MsgMenuExternalExamGrades , navRoute = EExamR tid ssh coursen examn EEGradesR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2336,7 +2369,7 @@ pageActions (EExamR tid ssh coursen examn EECorrectR) = return { navLink = NavLink { navLabel = MsgMenuExternalExamUsers , navRoute = EExamR tid ssh coursen examn EEUsersR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2347,7 +2380,7 @@ pageActions (EExamR tid ssh coursen examn EECorrectR) = return { navLink = NavLink { navLabel = MsgMenuExternalExamEdit , navRoute = EExamR tid ssh coursen examn EEEditR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2360,7 +2393,7 @@ pageActions (EExamR tid ssh coursen examn EEUsersR) = return { navLink = NavLink { navLabel = MsgMenuExternalExamGrades , navRoute = EExamR tid ssh coursen examn EEGradesR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2371,7 +2404,7 @@ pageActions (EExamR tid ssh coursen examn EEUsersR) = return { navLink = NavLink { navLabel = MsgMenuExternalExamCorrect , navRoute = EExamR tid ssh coursen examn EECorrectR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2382,7 +2415,7 @@ pageActions (EExamR tid ssh coursen examn EEUsersR) = return { navLink = NavLink { navLabel = MsgMenuExternalExamEdit , navRoute = EExamR tid ssh coursen examn EEEditR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2395,7 +2428,7 @@ pageActions ParticipantsListR = return { navLink = NavLink { navLabel = MsgMenuCsvOptions , navRoute = CsvOptionsR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False @@ -2407,7 +2440,7 @@ pageActions ParticipantsListR = return { navLink = NavLink { navLabel = MsgMenuParticipantsIntersect , navRoute = ParticipantsIntersectR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False} , navQuick' = navQuick NavQuickViewPageActionSecondary , navForceActive = False @@ -2420,7 +2453,7 @@ pageActions AdminWorkflowDefinitionListR = return { navLink = NavLink { navLabel = MsgMenuAdminWorkflowDefinitionNew , navRoute = AdminWorkflowDefinitionNewR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2431,7 +2464,7 @@ pageActions AdminWorkflowDefinitionListR = return { navLink = NavLink { navLabel = MsgMenuAdminWorkflowInstanceList , navRoute = AdminWorkflowInstanceListR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2444,7 +2477,7 @@ pageActions (AdminWorkflowDefinitionR wds wdn AWDEditR) = return { navLink = NavLink { navLabel = MsgMenuAdminWorkflowDefinitionDelete , navRoute = AdminWorkflowDefinitionR wds wdn AWDDeleteR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False @@ -2454,7 +2487,7 @@ pageActions (AdminWorkflowDefinitionR wds wdn AWDEditR) = return { navLink = NavLink { navLabel = MsgMenuAdminWorkflowDefinitionInstantiate , navRoute = AdminWorkflowDefinitionR wds wdn AWDInstantiateR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False @@ -2467,7 +2500,7 @@ pageActions AdminWorkflowInstanceListR = return { navLink = NavLink { navLabel = MsgMenuAdminWorkflowInstanceNew , navRoute = AdminWorkflowInstanceNewR - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2480,7 +2513,7 @@ pageActions route | Just (rScope, WorkflowInstanceListR) <- route ^? _WorkflowSc { navLink = NavLink { navLabel = MsgMenuWorkflowWorkflowList , navRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowListR) - , navAccess' = runDBRead $ haveWorkflowWorkflows rScope + , navAccess' = NavAccessDB $ haveWorkflowWorkflows rScope , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2493,7 +2526,7 @@ pageActions route | Just (rScope, WorkflowInstanceR win WIEditR) <- route ^? _Wo { navLink = NavLink { navLabel = MsgMenuWorkflowInstanceDelete , navRoute = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIDeleteR) - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2503,7 +2536,7 @@ pageActions route | Just (rScope, WorkflowInstanceR win WIEditR) <- route ^? _Wo { navLink = NavLink { navLabel = MsgMenuWorkflowInstanceWorkflows , navRoute = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIWorkflowsR) - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2514,7 +2547,7 @@ pageActions route | Just (rScope, WorkflowInstanceR win WIEditR) <- route ^? _Wo { navLink = NavLink { navLabel = MsgMenuWorkflowInstanceInitiate , navRoute = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIInitiateR) - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2527,7 +2560,7 @@ pageActions route | Just (rScope, WorkflowWorkflowR cID WWWorkflowR) <- route ^? { navLink = NavLink { navLabel = MsgMenuWorkflowWorkflowEdit , navRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWEditR) - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2537,7 +2570,7 @@ pageActions route | Just (rScope, WorkflowWorkflowR cID WWWorkflowR) <- route ^? { navLink = NavLink { navLabel = MsgMenuWorkflowWorkflowDelete , navRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWDeleteR) - , navAccess' = return True + , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2549,7 +2582,7 @@ pageActions TopWorkflowInstanceListR = return { navLink = NavLink { navLabel = MsgMenuTopWorkflowWorkflowList , navRoute = TopWorkflowWorkflowListR - , navAccess' = runDBRead haveTopWorkflowWorkflows + , navAccess' = NavAccessDB haveTopWorkflowWorkflows , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2576,11 +2609,11 @@ submissionList tid csh shn uid = withReaderT (projectBackend @SqlReadBackend) . return $ submission E.^. SubmissionId -pageQuickActions :: ( MonadCatch m +pageQuickActions :: ( MonadCatch m, MonadUnliftIO m , MonadHandler m , HandlerSite m ~ UniWorX + , WithRunDB SqlReadBackend (HandlerFor UniWorX) m , BearerAuthSite UniWorX - , BackendCompatible SqlReadBackend (YesodPersistBackend UniWorX) ) => NavQuickView -> Route UniWorX -> m [NavLink] pageQuickActions qView route = do @@ -2589,40 +2622,52 @@ pageQuickActions qView route = do filterM navLinkAccess $ items' ^.. typesUsing @NavChildren @NavLink . filtered (getAny . ($ qView) . navQuick') -- | Verify that the currently logged in user is lecturer or corrector for at least one sheet for the given course -evalAccessCorrector - :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) - => TermId -> SchoolId -> CourseShorthand -> m AuthResult +evalAccessCorrector :: (MonadAP m, MonadThrow m) => TermId -> SchoolId -> CourseShorthand -> m AuthResult evalAccessCorrector tid ssh csh = evalAccess (CourseR tid ssh csh CNotesR) False -_haveWorkflowInstances, haveWorkflowWorkflows +haveWorkflowWorkflows :: ( MonadHandler m, HandlerSite m ~ UniWorX , BackendCompatible SqlReadBackend backend , BearerAuthSite UniWorX ) => RouteWorkflowScope -> ReaderT backend m Bool -_haveWorkflowInstances rScope = hoist liftHandler . withReaderT (projectBackend @SqlReadBackend) . maybeT (return False) $ do - scope <- fromRouteWorkflowScope rScope +haveWorkflowWorkflows rScope = hoist liftHandler . withReaderT (projectBackend @SqlReadBackend) . $cachedHereBinary rScope . maybeT (return False) $ do + roles <- memcachedBy (Just $ Right diffDay) (NavCacheHaveWorkflowWorkflowsRoles rScope) $ do + scope <- fromRouteWorkflowScope rScope - let checkAccess (Entity _ WorkflowInstance{..}) - = hasReadAccessTo $ _WorkflowScopeRoute # (rScope, WorkflowInstanceR workflowInstanceName WIInitiateR) - getInstances = E.selectSource . E.from $ \workflowInstance -> do - E.where_ $ workflowInstance E.^. WorkflowInstanceScope E.==. E.val (scope ^. _DBWorkflowScope) - return workflowInstance - - $cachedHereBinary scope . runConduit $ transPipe lift getInstances .| C.mapM checkAccess .| C.or -haveWorkflowWorkflows rScope = hoist liftHandler . withReaderT (projectBackend @SqlReadBackend) . maybeT (return False) $ do - scope <- fromRouteWorkflowScope rScope - - let checkAccess (E.Value wwId) = do - cID <- lift . lift $ encrypt wwId - hasReadAccessTo $ _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR) + let getWorkflows = E.selectSource . E.from $ \workflowWorkflow -> do E.where_ $ workflowWorkflow E.^. WorkflowWorkflowScope E.==. E.val (scope ^. _DBWorkflowScope) - return $ workflowWorkflow E.^. WorkflowWorkflowId + return workflowWorkflow + workflowRoles (Entity wwId WorkflowWorkflow{..}) = do + wwGraph <- lift $ getSharedIdWorkflowGraph workflowWorkflowGraph + let + nodeViewers = do + WorkflowAction{..} <- otoList workflowWorkflowState + (node, WGN{..}) <- itoListOf (_wgNodes . ifolded) wwGraph + guard $ node == wpTo + WorkflowNodeView{..} <- hoistMaybe wgnViewers + return $ toNullable wnvViewers + payloadViewers = do + (prevActs, act) <- zip (inits $ otoList workflowWorkflowState) $ otoList workflowWorkflowState + prevAct <- hoistMaybe $ prevActs ^? _last + payload <- Map.keys $ wpPayload act + guard $ Map.lookup payload (workflowStateCurrentPayloads prevActs) /= Map.lookup payload (wpPayload act) + fmap (toNullable . wpvViewers) . hoistMaybe $ Map.lookup payload . wgnPayloadView =<< Map.lookup (wpTo prevAct) (wgNodes wwGraph) - $cachedHereBinary scope . runConduit $ transPipe lift getWorkflows .| C.mapM checkAccess .| C.or + cID <- encrypt wwId + return . Set.mapMonotonic ((wwId, cID), ) $ fold nodeViewers <> fold payloadViewers + + runConduit $ transPipe lift getWorkflows .| C.foldMapM workflowRoles + + let + evalRole ((wwId, cID), role) = do + let route = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR) + is _Authorized <$> hasWorkflowRole (Just wwId) role route False + + lift $ anyM roles evalRole haveTopWorkflowInstances, haveTopWorkflowWorkflows :: ( MonadHandler m, HandlerSite m ~ UniWorX @@ -2630,18 +2675,59 @@ haveTopWorkflowInstances, haveTopWorkflowWorkflows , BearerAuthSite UniWorX ) => ReaderT backend m Bool -haveTopWorkflowInstances = hoist liftHandler . withReaderT (projectBackend @SqlReadBackend) . maybeT (return False) $ - let checkAccess (Entity _ WorkflowInstance{..}) = do +haveTopWorkflowInstances = hoist liftHandler . withReaderT (projectBackend @SqlReadBackend) . $cachedHere . maybeT (return False) $ do + roles <- memcachedBy (Just $ Right diffDay) NavCacheHaveTopWorkflowInstancesRoles $ do + let + getInstances = E.selectSource . E.from $ \workflowInstance -> do + E.where_ . isTopWorkflowScopeSql $ workflowInstance E.^. WorkflowInstanceScope + return workflowInstance + instanceRoles (Entity _ WorkflowInstance{..}) = do rScope <- toRouteWorkflowScope $ _DBWorkflowScope # workflowInstanceScope - hasReadAccessTo $ _WorkflowScopeRoute # (rScope, WorkflowInstanceR workflowInstanceName WIInitiateR) - getInstances = selectSource [] [] - isTop (Entity _ WorkflowInstance{..}) = isTopWorkflowScope workflowInstanceScope - in $cachedHere . runConduit $ transPipe lift getInstances .| C.filter isTop .| C.mapM checkAccess .| C.or -haveTopWorkflowWorkflows = hoist liftHandler . withReaderT (projectBackend @SqlReadBackend) . maybeT (return False) $ - let checkAccess (Entity wwId WorkflowWorkflow{..}) = do + wiGraph <- lift $ getSharedIdWorkflowGraph workflowInstanceGraph + return . Set.mapMonotonic ((rScope, workflowInstanceName), ) . fold $ do + WGN{..} <- wiGraph ^.. _wgNodes . folded + WorkflowGraphEdgeInitial{..} <- wgnEdges ^.. folded + return wgeActors + runConduit $ transPipe lift getInstances .| C.foldMapM instanceRoles + + let + evalRole :: _ -> ReaderT SqlReadBackend (HandlerFor UniWorX) Bool + evalRole ((rScope, win), role) = do + let route = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIInitiateR) + is _Authorized <$> hasWorkflowRole Nothing role route False + + lift $ anyM roles evalRole +haveTopWorkflowWorkflows = hoist liftHandler . withReaderT (projectBackend @SqlReadBackend) . $cachedHere . maybeT (return False) $ do + roles <- memcachedBy (Just $ Right diffDay) NavCacheHaveTopWorkflowWorkflowsRoles $ do + let + getWorkflows = E.selectSource . E.from $ \workflowWorkflow -> do + E.where_ . isTopWorkflowScopeSql $ workflowWorkflow E.^. WorkflowWorkflowScope + return workflowWorkflow + workflowRoles (Entity wwId WorkflowWorkflow{..}) = do + wwGraph <- lift $ getSharedIdWorkflowGraph workflowWorkflowGraph rScope <- toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope - cID <- lift . lift $ encrypt wwId - hasReadAccessTo $ _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR) - getWorkflows = selectSource [] [] - isTop (Entity _ WorkflowWorkflow{..}) = isTopWorkflowScope workflowWorkflowScope - in $cachedHere . runConduit $ transPipe lift getWorkflows .| C.filter isTop .| C.mapM checkAccess .| C.or + let + nodeViewers = do + WorkflowAction{..} <- otoList workflowWorkflowState + (node, WGN{..}) <- itoListOf (_wgNodes . ifolded) wwGraph + guard $ node == wpTo + WorkflowNodeView{..} <- hoistMaybe wgnViewers + return $ toNullable wnvViewers + payloadViewers = do + (prevActs, act) <- zip (inits $ otoList workflowWorkflowState) $ otoList workflowWorkflowState + prevAct <- hoistMaybe $ prevActs ^? _last + payload <- Map.keys $ wpPayload act + guard $ Map.lookup payload (workflowStateCurrentPayloads prevActs) /= Map.lookup payload (wpPayload act) + fmap (toNullable . wpvViewers) . hoistMaybe $ Map.lookup payload . wgnPayloadView =<< Map.lookup (wpTo prevAct) (wgNodes wwGraph) + + cID <- encrypt wwId + return . Set.mapMonotonic ((wwId, cID, rScope), ) $ fold nodeViewers <> fold payloadViewers + runConduit $ transPipe lift getWorkflows .| C.foldMapM workflowRoles + + let + evalRole :: _ -> ReaderT SqlReadBackend (HandlerFor UniWorX) Bool + evalRole ((wwId, cID, rScope), role) = do + let route = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR) + is _Authorized <$> hasWorkflowRole (Just wwId) role route False + + lift $ anyM roles evalRole diff --git a/src/Foundation/SiteLayout.hs b/src/Foundation/SiteLayout.hs index 3ba3ef155..68941ea31 100644 --- a/src/Foundation/SiteLayout.hs +++ b/src/Foundation/SiteLayout.hs @@ -7,14 +7,14 @@ module Foundation.SiteLayout , getSystemMessageState ) where -import Import.NoFoundation hiding (embedFile) +import Import.NoFoundation hiding (embedFile, runDB) import Foundation.Type import Foundation.Authorization import Foundation.Routes import Foundation.Navigation import Foundation.I18n -import Foundation.DB +import Foundation.Yesod.Persist import Utils.SystemMessage import Utils.Form @@ -54,16 +54,15 @@ data MemcachedLimitKeyFavourites deriving anyclass (Hashable, Binary) -siteLayoutMsg :: (RenderMessage site msg, site ~ UniWorX, BearerAuthSite UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), BackendCompatible SqlReadBackend (YesodPersistBackend UniWorX), Button UniWorX ButtonSubmit) => msg -> WidgetFor UniWorX () -> HandlerFor UniWorX Html +siteLayoutMsg :: (RenderMessage site msg, site ~ UniWorX, BearerAuthSite UniWorX, YesodPersistBackend UniWorX ~ SqlBackend, Button UniWorX ButtonSubmit) => msg -> WidgetFor UniWorX () -> HandlerFor UniWorX Html siteLayoutMsg = siteLayout . i18n {-# DEPRECATED siteLayoutMsg' "Use siteLayoutMsg" #-} -siteLayoutMsg' :: (RenderMessage site msg, site ~ UniWorX, BearerAuthSite UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), BackendCompatible SqlReadBackend (YesodPersistBackend UniWorX), Button UniWorX ButtonSubmit) => msg -> WidgetFor UniWorX () -> HandlerFor UniWorX Html +siteLayoutMsg' :: (RenderMessage site msg, site ~ UniWorX, BearerAuthSite UniWorX, YesodPersistBackend UniWorX ~ SqlBackend, Button UniWorX ButtonSubmit) => msg -> WidgetFor UniWorX () -> HandlerFor UniWorX Html siteLayoutMsg' = siteLayoutMsg siteLayout :: ( BearerAuthSite UniWorX - , BackendCompatible SqlBackend (YesodPersistBackend UniWorX) - , BackendCompatible SqlReadBackend (YesodPersistBackend UniWorX) + , YesodPersistBackend UniWorX ~ SqlBackend , Button UniWorX ButtonSubmit ) => WidgetFor UniWorX () -- ^ `pageHeading` @@ -71,8 +70,7 @@ siteLayout :: ( BearerAuthSite UniWorX siteLayout = siteLayout' . Just siteLayout' :: ( BearerAuthSite UniWorX - , BackendCompatible SqlBackend (YesodPersistBackend UniWorX) - , BackendCompatible SqlReadBackend (YesodPersistBackend UniWorX) + , YesodPersistBackend UniWorX ~ SqlBackend , Button UniWorX ButtonSubmit ) => Maybe (WidgetFor UniWorX ()) -- ^ `pageHeading` @@ -89,24 +87,6 @@ siteLayout' overrideHeading widget = do currentApproot' <- siteApproot <$> getYesod <*> (reqWaiRequest <$> getRequest) - -- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance. - let - breadcrumbs' mcRoute = do - mr <- getMessageRender - case mcRoute of - Nothing -> return (mr MsgErrorResponseTitleNotFound, []) - Just cRoute -> do - (title, next) <- breadcrumb cRoute - crumbs <- go [] next - return (title, crumbs) - where - go crumbs Nothing = return crumbs - go crumbs (Just cRoute) = do - hasAccess <- hasReadAccessTo cRoute - (title, next) <- breadcrumb cRoute - go ((cRoute, title, hasAccess) : crumbs) next - (title, parents) <- breadcrumbs' mcurrentRoute - -- let isParent :: Route UniWorX -> Bool -- isParent r = r == (fst parents) @@ -114,11 +94,12 @@ siteLayout' overrideHeading widget = do now <- liftIO getCurrentTime - -- Lookup Favourites & Theme if possible - (favourites', maxFavouriteTerms, currentTheme) <- do - muid <- maybeAuthPair + -- Lookup Favourites, Breadcrumbs, Headline, & Theme if possible + (favourites', (title, parents), nav', contentHeadline, mmsgs, maxFavouriteTerms, currentTheme) <- do + muid <- maybeAuthPair - favCourses'' <- runDBRead . E.select . E.from $ \(course `E.LeftOuterJoin` courseFavourite) -> do + (favCourses, breadcrumbs'', nav', contentHeadline, mmsgs) <- runDB $ do + favCourses'' <- withReaderT (projectBackend @SqlReadBackend) . E.select . E.from $ \(course `E.LeftOuterJoin` courseFavourite) -> do E.on $ E.just (course E.^. CourseId) E.==. courseFavourite E.?. CourseFavouriteCourse E.&&. courseFavourite E.?. CourseFavouriteUser E.==. E.val (view _1 <$> muid) @@ -167,17 +148,58 @@ siteLayout' overrideHeading widget = do , courseVisible ) - favCourses' <- forM favCourses'' $ \((E.Value cName, E.Value tid, E.Value ssh, E.Value csh), reason, E.Value courseVisible) -> do + favCourses' <- withReaderT (projectBackend @SqlReadBackend) . forM favCourses'' $ \((E.Value cName, E.Value tid, E.Value ssh, E.Value csh), reason, E.Value courseVisible) -> do mayView <- hasReadAccessTo $ CourseR tid ssh csh CShowR mayEdit <- hasWriteAccessTo $ CourseR tid ssh csh CEditR return ((cName, tid, ssh, csh), reason, courseVisible, mayView, mayEdit) let favCourses = favCourses' & filter (\(_, _, _, mayView, _) -> mayView) - return ( favCourses - , maybe userDefaultMaxFavouriteTerms userMaxFavouriteTerms $ view _2 <$> muid - , maybe userDefaultTheme userTheme $ view _2 <$> muid - ) + breadcrumbs'' + <- let breadcrumbs' mcRoute = do + mr <- getMessageRender + case mcRoute of + Nothing -> return (mr MsgErrorResponseTitleNotFound, []) + Just cRoute -> do + (title, next) <- breadcrumb cRoute + crumbs <- go [] next + return (title, crumbs) + where + go crumbs Nothing = return crumbs + go crumbs (Just cRoute) = do + hasAccess <- hasReadAccessTo cRoute + (title, next) <- breadcrumb cRoute + go ((cRoute, title, hasAccess) : crumbs) next + in withReaderT (projectBackend @SqlReadBackend) $ breadcrumbs' mcurrentRoute + + nav'' <- withReaderT (projectBackend @SqlReadBackend) $ mconcat <$> sequence + [ defaultLinks + , maybe (return []) pageActions mcurrentRoute + ] + nav' <- withReaderT (projectBackend @SqlReadBackend) $ catMaybes <$> mapM (runMaybeT . navAccess) nav'' + + -- contentHeadline :: Maybe (WidgetFor UniWorX ()) + contentHeadline <- withReaderT (projectBackend @SqlReadBackend) . runMaybeT $ hoistMaybe overrideHeading <|> (pageHeading =<< hoistMaybe mcurrentRoute) + + mmsgs <- if + | isModal -> return mempty + | otherwise -> do + applySystemMessages + authTagPivots <- fromMaybe Set.empty <$> takeSessionJson SessionInactiveAuthTags + forM_ authTagPivots $ + \authTag -> addMessageWidget Info $ msgModal [whamlet|_{MsgUnauthorizedDisabledTag authTag}|] (Left $ SomeRoute (AuthPredsR, catMaybes [(toPathPiece GetReferer, ) . toPathPiece <$> mcurrentRoute])) + getMessages + + return (favCourses, breadcrumbs'', nav', contentHeadline, mmsgs) + + return ( favCourses + , breadcrumbs'' + , nav' + , contentHeadline + , mmsgs + , maybe userDefaultMaxFavouriteTerms userMaxFavouriteTerms $ view _2 <$> muid + , maybe userDefaultTheme userTheme $ view _2 <$> muid + ) let favouriteTerms :: [TermIdentifier] favouriteTerms = take maxFavouriteTerms . Set.toDescList $ foldMap (\((_, tid, _, _), _, _, _, _) -> Set.singleton $ unTermKey tid) favourites' @@ -191,37 +213,26 @@ siteLayout' overrideHeading widget = do langs <- selectLanguages appLanguages <$> languages let cK = MemcachedKeyFavouriteQuickActions (tid, ssh, csh) ctx langs $logDebugS "FavouriteQuickActions" $ tshow cK <> " Checking..." - items <- memcachedLimitedKeyTimeoutBy - MemcachedLimitKeyFavourites appFavouritesQuickActionsBurstsize appFavouritesQuickActionsAvgInverseRate 1 - (Right <$> appFavouritesQuickActionsCacheTTL) - appFavouritesQuickActionsTimeout - cK - cK - . observeFavouritesQuickActionsDuration $ do - $logDebugS "FavouriteQuickActions" $ tshow cK <> " Starting..." - items' <- pageQuickActions NavQuickViewFavourite courseRoute - items <- forM items' $ \n@NavLink{navLabel} -> fmap (mr navLabel,) $ toTextUrl =<< navLinkRoute n - $logDebugS "FavouriteQuickActions" $ tshow cK <> " Done." - return items + poolIsPressured <- dbPoolPressured + items <- if + | poolIsPressured -> Nothing <$ observeFavouritesSkippedDueToDBLoad + | otherwise -> memcachedLimitedKeyTimeoutBy + MemcachedLimitKeyFavourites appFavouritesQuickActionsBurstsize appFavouritesQuickActionsAvgInverseRate 1 + (Right <$> appFavouritesQuickActionsCacheTTL) + appFavouritesQuickActionsTimeout + cK + cK + . observeFavouritesQuickActionsDuration . runDBRead $ do + $logDebugS "FavouriteQuickActions" $ tshow cK <> " Starting..." + items' <- pageQuickActions NavQuickViewFavourite courseRoute + items <- forM items' $ \n@NavLink{navLabel} -> fmap (mr navLabel,) $ toTextUrl =<< navLinkRoute n + $logDebugS "FavouriteQuickActions" $ tshow cK <> " Done." + return items $logDebugS "FavouriteQuickActions" $ tshow cK <> " returning " <> tshow (is _Just items) return (c, courseRoute, items, favouriteReason, courseVisible, mayView, mayEdit) - nav'' <- mconcat <$> sequence - [ defaultLinks - , maybe (return []) pageActions mcurrentRoute - ] - nav' <- catMaybes <$> mapM (runMaybeT . navAccess) nav'' nav <- forM nav' $ \n -> (n,,,) <$> newIdent <*> traverse (toTextUrl <=< navLinkRoute) (n ^? _navLink) <*> traverse (\nc -> (nc,, ) <$> newIdent <*> (toTextUrl <=< navLinkRoute) nc) (n ^. _navChildren) - mmsgs <- if - | isModal -> return mempty - | otherwise -> do - applySystemMessages - authTagPivots <- fromMaybe Set.empty <$> takeSessionJson SessionInactiveAuthTags - forM_ authTagPivots $ - \authTag -> addMessageWidget Info $ msgModal [whamlet|_{MsgUnauthorizedDisabledTag authTag}|] (Left $ SomeRoute (AuthPredsR, catMaybes [(toPathPiece GetReferer, ) . toPathPiece <$> mcurrentRoute])) - getMessages - -- (langFormView, langFormEnctype) <- generateFormPost $ identifyForm FIDLanguage langForm -- let langFormView' = wrapForm langFormView def -- { formAction = Just $ SomeRoute LangR @@ -358,8 +369,6 @@ siteLayout' overrideHeading widget = do where isNavFooter = has $ _1 . _NavFooter alerts :: WidgetFor UniWorX () alerts = $(widgetFile "widgets/alerts/alerts") - contentHeadline :: Maybe (WidgetFor UniWorX ()) - contentHeadline = overrideHeading <|> (pageHeading =<< mcurrentRoute) breadcrumbsWgt :: WidgetFor UniWorX () breadcrumbsWgt = $(widgetFile "widgets/breadcrumbs/breadcrumbs") pageaction :: WidgetFor UniWorX () @@ -417,19 +426,25 @@ getSystemMessageState smId = liftHandler $ do where foldSt (Entity _ SystemMessageHidden{..}) = MergeHashMap . HashMap.singleton systemMessageHiddenMessage $ mempty { userSystemMessageHidden = Just systemMessageHiddenTime } -applySystemMessages :: (MonadHandler m, HandlerSite m ~ UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), BearerAuthSite UniWorX) => m () -applySystemMessages = liftHandler . maybeT_ . catchMPlus (Proxy @CryptoIDError) $ do +applySystemMessages :: forall m. + ( MonadHandler m, HandlerSite m ~ UniWorX + , YesodPersistBackend UniWorX ~ SqlBackend + , BearerAuthSite UniWorX + , WithRunDB SqlBackend (HandlerFor UniWorX) m + , MonadCatch m + ) => m () +applySystemMessages = maybeT_ . catchMPlus (Proxy @CryptoIDError) $ do lift $ maybeAuthId >>= traverse_ syncSystemMessageHidden - cRoute <- lift getCurrentRoute + cRoute <- getCurrentRoute guard $ cRoute /= Just NewsR - lift . runDBRead . runConduit $ selectSource [] [Asc SystemMessageManualPriority] .| C.mapM_ applyMessage + lift . useRunDB . runConduit $ selectSource [] [Asc SystemMessageManualPriority] .| C.mapM_ applyMessage where - syncSystemMessageHidden :: UserId -> HandlerFor UniWorX () - syncSystemMessageHidden uid = runDB . withReaderT projectBackend $ do - smSt <- lookupRegisteredCookiesJson id CookieSystemMessageState :: SqlPersistT (HandlerFor UniWorX) (MergeHashMap CryptoUUIDSystemMessage UserSystemMessageState) - iforM_ smSt $ \cID UserSystemMessageState{..} -> do + syncSystemMessageHidden :: UserId -> m () + syncSystemMessageHidden uid = do + smSt <- lookupRegisteredCookiesJson id CookieSystemMessageState :: m (MergeHashMap CryptoUUIDSystemMessage UserSystemMessageState) + iforM_ smSt $ \cID UserSystemMessageState{..} -> useRunDB $ do smId <- decrypt cID whenIsJust userSystemMessageHidden $ \systemMessageHiddenTime -> void $ upsert SystemMessageHidden @@ -446,12 +461,12 @@ applySystemMessages = liftHandler . maybeT_ . catchMPlus (Proxy @CryptoIDError) -> fmap MergeHashMap . assertM' (/= mempty) $ HashMap.update (\smSt' -> assertM' (/= mempty) $ smSt' { userSystemMessageHidden = Nothing, userSystemMessageUnhidden = Nothing }) cID hm - applyMessage :: Entity SystemMessage -> ReaderT SqlReadBackend (HandlerFor UniWorX) () + applyMessage :: Entity SystemMessage -> ReaderT SqlBackend (HandlerFor UniWorX) () applyMessage (Entity smId SystemMessage{..}) = maybeT_ $ do guard $ not systemMessageNewsOnly - cID <- encrypt smId - void . assertM (== Authorized) . lift $ evalAccessDB (MessageR cID) False + cID <- lift $ encrypt smId + guardM . lift . hasReadAccessTo $ MessageR cID now <- liftIO getCurrentTime guard $ NTop systemMessageFrom <= NTop (Just now) @@ -482,103 +497,110 @@ applySystemMessages = liftHandler . maybeT_ . catchMPlus (Proxy @CryptoIDError) -- All handlers whose code is under our control should use -- `siteLayout` instead; `pageHeading` is only a fallback solution for -- e.g. subsites like `AuthR` -pageHeading :: ( YesodPersist UniWorX - , BackendCompatible SqlBackend (YesodPersistBackend UniWorX) - ) => Route UniWorX -> Maybe Widget +pageHeading :: ( YesodPersistBackend UniWorX ~ SqlBackend + , WithRunDB SqlReadBackend (HandlerFor UniWorX) m + , MonadHandler m + ) => Route UniWorX -> MaybeT m Widget pageHeading (AuthR _) - = Just $ i18n MsgLoginHeading + = return $ i18n MsgLoginHeading pageHeading NewsR - = Just $ i18n MsgNewsHeading + = return $ i18n MsgNewsHeading pageHeading UsersR - = Just $ i18n MsgUsers + = return $ i18n MsgUsers pageHeading (AdminUserR _) - = Just $ i18n MsgAdminUserHeading + = return $ i18n MsgAdminUserHeading pageHeading AdminTestR - = Just [whamlet|Internal Code Demonstration Page|] + = return [whamlet|Internal Code Demonstration Page|] pageHeading AdminErrMsgR - = Just $ i18n MsgErrMsgHeading + = return $ i18n MsgErrMsgHeading pageHeading InfoR - = Just $ i18n MsgInfoHeading + = return $ i18n MsgInfoHeading pageHeading LegalR - = Just $ i18n MsgLegalHeading + = return $ i18n MsgLegalHeading pageHeading VersionR - = Just $ i18n MsgVersionHeading + = return $ i18n MsgVersionHeading pageHeading HelpR - = Just $ i18n MsgHelpRequestHeading + = return $ i18n MsgHelpRequest pageHeading ProfileR - = Just $ i18n MsgProfileHeading + = return $ i18n MsgProfileHeading pageHeading ProfileDataR - = Just $ i18n MsgProfileDataHeading + = return $ i18n MsgProfileDataHeading pageHeading TermShowR - = Just $ i18n MsgTermsHeading +<<<<<<< Updated upstream + = return $ i18n MsgTermsHeading +======= + = Just $ i18n MsgHeadingTermsHeading +>>>>>>> Stashed changes pageHeading TermCurrentR - = Just $ i18n MsgTermCurrent + = return $ i18n MsgTermCurrent pageHeading TermEditR - = Just $ i18n MsgTermEditHeading +<<<<<<< Updated upstream + = return $ i18n MsgTermEditHeading +======= + = Just $ i18n MsgHeadingTermEditHeading +>>>>>>> Stashed changes pageHeading (TermEditExistR tid) - = Just $ i18n $ MsgTermEditTid tid + = return $ i18n $ MsgTermEditTid tid pageHeading (TermCourseListR tid) - = Just . i18n . MsgTermCourseListHeading $ tid -pageHeading (TermSchoolCourseListR tid ssh) - = Just $ do - School{schoolName=school} <- handlerToWidget . runDB . withReaderT (projectBackend @SqlBackend) $ get404 ssh - i18n $ MsgTermSchoolCourseListHeading tid school + = return . i18n . MsgTermCourseListHeading $ tid +pageHeading (TermSchoolCourseListR tid ssh) = do + School{schoolName=school} <- MaybeT . useRunDB $ get ssh + return . i18n $ MsgTermSchoolCourseListHeading tid school pageHeading CourseListR - = Just $ i18n MsgCourseListTitle + = return $ i18n MsgCourseListTitle pageHeading CourseNewR - = Just $ i18n MsgCourseNewHeading -pageHeading (CourseR tid ssh csh CShowR) - = Just $ do - Entity _ Course{..} <- handlerToWidget . runDB . withReaderT (projectBackend @SqlBackend) . getBy404 $ TermSchoolCourseShort tid ssh csh - toWidget courseName + = return $ i18n MsgCourseNewHeading +pageHeading (CourseR tid ssh csh CShowR) = do + Entity _ Course{..} <- MaybeT . useRunDB . getBy $ TermSchoolCourseShort tid ssh csh + return $ toWidget courseName -- (CourseR tid csh CRegisterR) -- just for POST pageHeading (CourseR tid ssh csh CEditR) - = Just $ i18n $ MsgCourseEditHeading tid ssh csh + = return $ i18n $ MsgCourseEditHeading tid ssh csh pageHeading (CourseR tid ssh csh CCorrectionsR) - = Just $ i18n $ MsgSubmissionsCourse tid ssh csh + = return $ i18n $ MsgSubmissionsCourse tid ssh csh pageHeading (CourseR tid ssh csh SheetListR) - = Just $ i18n $ MsgSheetList tid ssh csh + = return $ i18n $ MsgSheetList tid ssh csh pageHeading (CourseR tid ssh csh SheetNewR) - = Just $ i18n $ MsgSheetNewHeading tid ssh csh + = return $ i18n $ MsgSheetNewHeading tid ssh csh pageHeading (CSheetR tid ssh csh shn SShowR) - = Just $ i18n $ MsgSheetTitleHead tid ssh csh shn - -- = Just $ i18n $ prependCourseTitle tid ssh csh $ SomeMessage shn -- TODO: for consistency use prependCourseTitle throughout ERROR: circularity + = return $ i18n $ MsgSheetTitle tid ssh csh shn + -- = return $ i18n $ prependCourseTitle tid ssh csh $ SomeMessage shn -- TODO: for consistency use prependCourseTitle throughout ERROR: circularity pageHeading (CSheetR tid ssh csh shn SEditR) - = Just $ i18n $ MsgSheetEditHead tid ssh csh shn + = return $ i18n $ MsgSheetEditHead tid ssh csh shn pageHeading (CSheetR tid ssh csh shn SDelR) - = Just $ i18n $ MsgSheetDelHead tid ssh csh shn + = return $ i18n $ MsgSheetDelHead tid ssh csh shn pageHeading (CSheetR _tid _ssh _csh shn SSubsR) - = Just $ i18n $ MsgSubmissionsSheet shn + = return $ i18n $ MsgSubmissionsSheet shn pageHeading (CSheetR tid ssh csh shn SubmissionNewR) - = Just $ i18n $ MsgSubmissionEditHead tid ssh csh shn + = return $ i18n $ MsgSubmissionEditHead tid ssh csh shn pageHeading (CSheetR tid ssh csh shn SubmissionOwnR) - = Just $ i18n $ MsgSubmissionEditHead tid ssh csh shn + = return $ i18n $ MsgSubmissionEditHead tid ssh csh shn pageHeading (CSubmissionR tid ssh csh shn _ SubShowR) -- TODO: Rethink this one! - = Just $ i18n $ MsgSubmissionEditHead tid ssh csh shn + = return $ i18n $ MsgSubmissionEditHead tid ssh csh shn -- (CSubmissionR tid csh shn cid SubArchiveR) -- just a download pageHeading (CSubmissionR tid ssh csh shn cid CorrectionR) - = Just $ i18n $ MsgCorrectionHead tid ssh csh shn cid + = return $ i18n $ MsgCorrectionHead tid ssh csh shn cid -- (CSubmissionR tid csh shn cid SubDownloadR) -- just a download -- (CSheetR tid ssh csh shn SFileR) -- just for Downloads pageHeading CorrectionsR - = Just $ i18n MsgCorrectionsTitle + = return $ i18n MsgCorrectionsTitle pageHeading CorrectionsUploadR - = Just $ i18n MsgCorrUpload + = return $ i18n MsgCorrUpload pageHeading CorrectionsCreateR - = Just $ i18n MsgCorrCreate + = return $ i18n MsgCorrCreate pageHeading CorrectionsGradeR - = Just $ i18n MsgCorrGrade + = return $ i18n MsgCorrGrade pageHeading (MessageR _) - = Just $ i18n MsgSystemMessageHeading + = return $ i18n MsgSystemMessageHeading pageHeading MessageListR - = Just $ i18n MsgSystemMessageListHeading + = return $ i18n MsgSystemMessageListHeading -- TODO: add headings for more single course- and single term-pages pageHeading _ - = Nothing + = mzero diff --git a/src/Foundation/Type.hs b/src/Foundation/Type.hs index 6f9fb8091..3b7494d3c 100644 --- a/src/Foundation/Type.hs +++ b/src/Foundation/Type.hs @@ -5,6 +5,10 @@ module Foundation.Type ( UniWorX(..) , SomeSessionStorage(..) , _SessionStorageMemcachedSql, _SessionStorageAcid + , AppMemcached(..) + , _memcachedKey, _memcachedConn + , AppMemcachedLocal(..) + , _memcachedLocalARC , SMTPPool , _appSettings', _appStatic, _appConnPool, _appSmtpPool, _appLdapPool, _appWidgetMemcached, _appHttpManager, _appLogger, _appLogSettings, _appCryptoIDKey, _appClusterID, _appInstanceID, _appJobState, _appSessionStore, _appSecretBoxKey, _appJSONWebKeySet, _appHealthReport, _appMemcached, _appUploadCache, _appVerpSecret, _appAuthKey , DB, Form, MsgRenderer, MailM, DBFile @@ -30,15 +34,35 @@ import qualified Utils.Pool as Custom import Utils.Metrics (DBConnUseState) +import qualified Data.ByteString.Lazy as Lazy +import Data.Time.Clock.POSIX (POSIXTime) +import GHC.Fingerprint (Fingerprint) + type SMTPPool = Pool SMTPConnection data SomeSessionStorage = SessionStorageMemcachedSql { sessionStorageMemcachedSql :: MemcachedSqlStorage SessionMap } | SessionStorageAcid { sessionStorageAcid :: AcidStorage SessionMap } + deriving (Generic, Typeable) makePrisms ''SomeSessionStorage +data AppMemcached = AppMemcached + { memcachedKey :: AEAD.Key + , memcachedConn :: Memcached.Connection + } deriving (Generic, Typeable) + +makeLenses_ ''AppMemcached + +data AppMemcachedLocal = AppMemcachedLocal + { memcachedLocalARC :: ARCHandle (Fingerprint, Lazy.ByteString) Int (NFDynamic, Maybe POSIXTime) + , memcachedLocalHandleInvalidations :: Async () + , memcachedLocalInvalidationQueue :: TVar (Seq (Fingerprint, Lazy.ByteString)) + } deriving (Generic, Typeable) + +makeLenses_ ''AppMemcachedLocal + -- | The foundation datatype for your application. This can be a good place to -- keep settings and values requiring initialization before your application -- starts running, such as database connections. Every handler will have @@ -61,14 +85,15 @@ data UniWorX = UniWorX , appSecretBoxKey :: SecretBox.Key , appJSONWebKeySet :: Jose.JwkSet , appHealthReport :: TVar (Set (UTCTime, HealthReport)) - , appMemcached :: Maybe (AEAD.Key, Memcached.Connection) + , appMemcached :: Maybe AppMemcached + , appMemcachedLocal :: Maybe AppMemcachedLocal , appUploadCache :: Maybe MinioConn , appVerpSecret :: VerpSecret , appAuthKey :: Auth.Key , appFileSourceARC :: Maybe (ARCHandle (FileContentChunkReference, (Int, Int)) Int ByteString) , appFileSourcePrewarm :: Maybe (LRUHandle (FileContentChunkReference, (Int, Int)) UTCTime Int ByteString) , appFileInjectInhibit :: TVar (IntervalMap UTCTime (Set FileContentReference)) - } + } deriving (Typeable) makeLenses_ ''UniWorX instance HasInstanceID UniWorX InstanceId where diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index f114b23e4..b4e72497e 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -15,6 +15,8 @@ import Handler.Utils.Profile import Handler.Utils.StudyFeatures import Handler.Utils.SchoolLdap import Handler.Utils.LdapSystemFunctions +import Handler.Utils.Memcached +import Foundation.Authorization (AuthorizationCacheKey(..)) import Yesod.Auth.Message import Auth.LDAP @@ -469,9 +471,10 @@ upsertCampusUser upsertMode ldapData = do Right str <- return $ Text.decodeUtf8' v' assertM' (not . Text.null) $ Text.strip str - iforM_ userSystemFunctions $ \func preset -> if - | preset -> void $ upsert (UserSystemFunction userId func False False) [] - | otherwise -> deleteWhere [UserSystemFunctionUser ==. userId, UserSystemFunctionFunction ==. func, UserSystemFunctionIsOptOut ==. False, UserSystemFunctionManual ==. False] + iforM_ userSystemFunctions $ \func preset -> do + memcachedByInvalidate (AuthCacheSystemFunctionList func) $ Proxy @(Set UserId) + if | preset -> void $ upsert (UserSystemFunction userId func False False) [] + | otherwise -> deleteWhere [UserSystemFunctionUser ==. userId, UserSystemFunctionFunction ==. func, UserSystemFunctionIsOptOut ==. False, UserSystemFunctionManual ==. False] return user where diff --git a/src/Foundation/Yesod/ErrorHandler.hs b/src/Foundation/Yesod/ErrorHandler.hs index 181392774..4669a6bac 100644 --- a/src/Foundation/Yesod/ErrorHandler.hs +++ b/src/Foundation/Yesod/ErrorHandler.hs @@ -11,6 +11,7 @@ import Foundation.I18n import Foundation.Authorization import Foundation.SiteLayout import Foundation.Routes +import Foundation.DB import qualified Data.Aeson as JSON import qualified Data.Text as Text @@ -24,13 +25,12 @@ errorHandler :: ( MonadSecretBox (HandlerFor UniWorX) , MonadAuth (HandlerFor UniWorX) , BearerAuthSite UniWorX , Button UniWorX ButtonSubmit - , BackendCompatible SqlBackend (YesodPersistBackend UniWorX) - , BackendCompatible SqlReadBackend (YesodPersistBackend UniWorX) + , YesodPersistBackend UniWorX ~ SqlBackend ) => ErrorResponse -> HandlerFor UniWorX TypedContent errorHandler err = do let shouldEncrypt' = getsYesod $ view _appEncryptErrors - canDecrypt' = is _Authorized <$> evalAccess AdminErrMsgR True + canDecrypt' = runDBRead $ hasWriteAccessTo AdminErrMsgR decrypted' <- runMaybeT $ do internalErrorContent <- hoistMaybe $ err ^? _InternalError exceptTMaybe $ encodedSecretBoxOpen @Text internalErrorContent diff --git a/src/Foundation/Yesod/Middleware.hs b/src/Foundation/Yesod/Middleware.hs index 650236778..3aa73ab4f 100644 --- a/src/Foundation/Yesod/Middleware.hs +++ b/src/Foundation/Yesod/Middleware.hs @@ -59,7 +59,7 @@ yesodMiddleware = cacheControlMiddleware . storeBearerMiddleware . csrfMiddlewar case route of -- update Course Favourites here CourseR tid ssh csh _ -> do void . lift . runDB . runMaybeT $ do - guardM . lift $ (== Authorized) <$> evalAccessDB (CourseR tid ssh csh CShowR) False + guardM . lift . hasReadAccessTo $ CourseR tid ssh csh CShowR lift . updateFavourites $ Just (tid, ssh, csh) _other -> return () normalizeRouteMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a @@ -321,7 +321,7 @@ routeNormalizers = map (hoist (hoist liftHandler . withReaderT projectBackend) . & typesUsing @RouteChildren @WorkflowPayloadLabel . filtered (== wpl) .~ wpl' verifySubmission = maybeOrig $ \route -> do CSubmissionR _tid _ssh _csh _shn cID sr <- return route - sId <- $cachedHereBinary cID $ decrypt cID + sId <- decrypt cID Submission{submissionSheet} <- MaybeT . $cachedHereBinary cID . lift $ get sId Sheet{sheetCourse, sheetName} <- MaybeT . $cachedHereBinary submissionSheet . lift $ get submissionSheet Course{courseTerm, courseSchool, courseShorthand} <- MaybeT . $cachedHereBinary sheetCourse . lift $ get sheetCourse diff --git a/src/Foundation/Yesod/Persist.hs b/src/Foundation/Yesod/Persist.hs index 6c9a06864..6c7bccae4 100644 --- a/src/Foundation/Yesod/Persist.hs +++ b/src/Foundation/Yesod/Persist.hs @@ -1,6 +1,8 @@ module Foundation.Yesod.Persist ( runDB, getDBRunner , runDB', getDBRunner' + -- , runCachedDBRunner + -- , runCachedDBRunner' , module Foundation.DB ) where @@ -31,10 +33,10 @@ runDB' :: ( YesodPersistBackend UniWorX ~ SqlBackend => CallStack -> YesodDB UniWorX a -> HandlerFor UniWorX a runDB' lbl action = do $logDebugS "YesodPersist" "runDB" - dryRun <- isDryRun - let action' - | dryRun = action <* transactionUndo - | otherwise = action + let action' = do + dryRun <- isDryRunDB + if | dryRun -> action <* transactionUndo + | otherwise -> action flip (runSqlPoolRetry' action') lbl . appConnPool =<< getYesod @@ -73,10 +75,35 @@ getDBRunner' lbl = do return . (, cleanup) $ DBRunner (\action -> do - dryRun <- isDryRun - let action' - | dryRun = action <* transactionUndo - | otherwise = action + let action' = do + dryRun <- isDryRunDB + if | dryRun -> action <* transactionUndo + | otherwise -> action $logDebugS "YesodPersist" "runDBRunner" runDBRunner action' ) + +-- runCachedDBRunner :: ( BackendCompatible backend (YesodPersistBackend UniWorX) +-- , YesodPersistBackend UniWorX ~ SqlBackend +-- , BearerAuthSite UniWorX +-- , HasCallStack +-- ) +-- => CachedDBRunner backend (HandlerFor UniWorX) a +-- -> HandlerFor UniWorX a +-- runCachedDBRunner = runCachedDBRunner' callStack + +-- runCachedDBRunner' :: ( BackendCompatible backend (YesodPersistBackend UniWorX) +-- , YesodPersistBackend UniWorX ~ SqlBackend +-- , BearerAuthSite UniWorX +-- ) +-- => CallStack +-- -> CachedDBRunner backend (HandlerFor UniWorX) a +-- -> HandlerFor UniWorX a +-- runCachedDBRunner' lbl act = do +-- cleanups <- newTVarIO [] +-- res <- flip runCachedDBRunnerSTM act $ do +-- (runner, cleanup) <- getDBRunner' lbl +-- atomically . modifyTVar' cleanups $ (:) cleanup +-- return $ fromDBRunner runner +-- mapM_ liftHandler =<< readTVarIO cleanups +-- return res diff --git a/src/Handler/Admin/Test.hs b/src/Handler/Admin/Test.hs index 3ca061080..2de4ec9f2 100644 --- a/src/Handler/Admin/Test.hs +++ b/src/Handler/Admin/Test.hs @@ -42,6 +42,7 @@ emailTestForm = (,) <*> areq (selectField $ dateTimeFormatOptions SelFormatDate) (fslI MsgDateFormat) Nothing <*> areq (selectField $ dateTimeFormatOptions SelFormatTime) (fslI MsgTimeFormat) Nothing ) + <*> pure def ) where toMailDateTimeFormat dt d t = \case diff --git a/src/Handler/Admin/Tokens.hs b/src/Handler/Admin/Tokens.hs index 1fb765236..0d29853a6 100644 --- a/src/Handler/Admin/Tokens.hs +++ b/src/Handler/Admin/Tokens.hs @@ -16,15 +16,43 @@ import Data.Map ((!), (!?)) import qualified Data.Text as Text +import qualified Database.Esqueleto as E hiding (random_) +import qualified Database.Esqueleto.PostgreSQL as E +import qualified Data.Conduit.Combinators as C + +import Data.List (genericTake) + +import System.Random.Shuffle (shuffleM) + + +data BTFImpersonate + = BTFISingle + { btfiUser :: UserId + } + | BTFIRandom + { btfiCount :: Int64 + , btfiWeightActivity :: Bool + } + deriving (Eq, Ord, Generic, Typeable) + +data BTFImpersonate' = BTFINone' | BTFISingle' | BTFIRandom' + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + deriving (Universe, Finite, Hashable) +nullaryPathPiece ''BTFImpersonate' $ let noNone n | n == "none" = "impersonate-" <> n + | otherwise = n + in noNone . camelToPathPiece' 1 . dropSuffix "'" +embedRenderMessage ''UniWorX ''BTFImpersonate' $ ("BearerTokenImpersonate" <>) . dropPrefix "BTFI" . dropSuffix "'" + data BearerTokenForm = BearerTokenForm - { btfAuthority :: HashSet (Either UserGroupName UserId) - , btfRoutes :: Maybe (HashSet (Route UniWorX)) - , btfRestrict :: HashMap (Route UniWorX) Value - , btfAddAuth :: Maybe AuthDNF - , btfExpiresAt :: Maybe (Maybe UTCTime) - , btfStartsAt :: Maybe UTCTime - } + { btfAuthority :: HashSet (Either UserGroupName UserId) + , btfImpersonate :: Maybe BTFImpersonate + , btfRoutes :: Maybe (HashSet (Route UniWorX)) + , btfRestrict :: HashMap (Route UniWorX) Value + , btfAddAuth :: Maybe AuthDNF + , btfExpiresAt :: Maybe (Maybe UTCTime) + , btfStartsAt :: Maybe UTCTime + } deriving (Generic, Typeable) bearerTokenForm :: WForm Handler (FormResult BearerTokenForm) bearerTokenForm = do @@ -37,6 +65,15 @@ bearerTokenForm = do btfAuthority' = (<>) <$> btfAuthorityGroups <*> ((hoistMaybe =<< btfAuthorityUsers) <|> pure HashSet.empty) + let + btfiActs = mapF $ \case + BTFINone' -> pure Nothing + BTFISingle' -> Just . BTFISingle <$> apreq (checkMap (left MsgBearerTokenImpersonateUnknownUser) Right $ userField False Nothing) (fslpI MsgBearerTokenImpersonateSingleUser (mr MsgLdapIdentificationOrEmail)) Nothing + BTFIRandom' -> fmap Just $ BTFIRandom + <$> apreq (posIntFieldI MsgBearerTokenImpersonateRandomNegative) (fslI MsgBearerTokenImpersonateRandomCount) (Just 1) + <*> apopt checkBoxField (fslI MsgBearerTokenImpersonateRandomWeightActivity) (Just True) + btfImpersonate' <- multiActionW btfiActs (fslI MsgBearerTokenImpersonate) Nothing + let btfRoutesForm = HashSet.fromList <$> massInputListA routeField (const "") MsgBearerTokenRouteMissing (\p -> Just . SomeRoute $ AdminTokensR :#: p) ("token-routes" :: Text) (fslI MsgBearerTokenRoutes & setTooltip MsgBearerTokenRoutesTip) True Nothing btfRoutes' <- optionalActionW btfRoutesForm (fslI MsgBearerTokenRestrictRoutes) (Just True) @@ -68,6 +105,7 @@ bearerTokenForm = do return $ BearerTokenForm <$> btfAuthority' + <*> btfImpersonate' <*> btfRoutes' <*> btfRestrict' <*> btfAddAuth' @@ -86,7 +124,43 @@ postAdminTokensR = do & HashSet.insert (Right uid) & HashSet.map (left toJSON) - fmap Just . encodeBearer . set _bearerRestrictions btfRestrict =<< bearerToken btfAuthority' Nothing (maybe HashMap.empty (HashMap.singleton BearerTokenRouteEval) btfRoutes) btfAddAuth btfExpiresAt btfStartsAt + case btfImpersonate of + Just BTFIRandom{..} -> do + MsgRenderer mr <- getMsgRenderer + now <- liftIO getCurrentTime + users <- runDB $ if + | not btfiWeightActivity -> fmap (fmap E.unValue) . E.select . E.from $ \user -> do + E.orderBy [E.asc $ E.random_ @Int64] + E.limit btfiCount + return $ user E.^. UserId + | otherwise -> do + users <- fmap (fmap E.unValue) . E.select . E.from $ \user -> do + E.orderBy [ E.asc . E.isNothing $ user E.^. UserLastAuthentication + , E.desc $ user E.^. UserLastAuthentication + ] + E.limit $ 2 * btfiCount + return $ user E.^. UserId + genericTake btfiCount <$> shuffleM users + + let + toTokenFile :: UserId -> DB (Either Void DBFile) + toTokenFile uid' = do + cID <- encrypt uid' :: DB CryptoUUIDUser + tok <- encodeBearer . set _bearerRestrictions btfRestrict =<< bearerToken btfAuthority' (Just uid') (maybe HashMap.empty (HashMap.singleton BearerTokenRouteEval) btfRoutes) btfAddAuth btfExpiresAt btfStartsAt + return . Right $ File + { fileTitle = unpack (toPathPiece cID) <.> "jwt" + , fileModified = now + , fileContent = Just . yield $ unJwt tok + } + + sendResponse <=< serveZipArchive' ((ensureExtension `on` unpack) extensionZip (mr MsgBearerTokenArchiveName)) $ yieldMany users .| C.mapM toTokenFile + + _other -> do + let btfImpersonate' = btfImpersonate <&> \case + BTFISingle{..} -> btfiUser + _other -> error "btfImpersonate: not BTFISingle where expected" + + fmap Just . encodeBearer . set _bearerRestrictions btfRestrict =<< bearerToken btfAuthority' btfImpersonate' (maybe HashMap.empty (HashMap.singleton BearerTokenRouteEval) btfRoutes) btfAddAuth btfExpiresAt btfStartsAt siteLayoutMsg MsgHeadingAdminTokens $ do setTitleI MsgHeadingAdminTokens diff --git a/src/Handler/Allocation/AddUser.hs b/src/Handler/Allocation/AddUser.hs index 95640192f..24230e64b 100644 --- a/src/Handler/Allocation/AddUser.hs +++ b/src/Handler/Allocation/AddUser.hs @@ -61,7 +61,7 @@ postAAddUserR tid ssh ash = do unless (courseApplicationCourse `Map.member` aauApplications) $ audit $ TransactionCourseApplicationDeleted courseApplicationCourse courseApplicationUser appId - iforM_ aauApplications $ \cId ApplicationForm{..} -> maybeT (return ()) $ do + iforM_ aauApplications $ \cId ApplicationForm{..} -> maybeT_ $ do prio <- hoistMaybe afPriority let rated = afRatingVeto || is _Just afRatingPoints appId <- lift $ insert CourseApplication diff --git a/src/Handler/Allocation/Application.hs b/src/Handler/Allocation/Application.hs index 5ef12ca96..bbd7da7db 100644 --- a/src/Handler/Allocation/Application.hs +++ b/src/Handler/Allocation/Application.hs @@ -174,11 +174,12 @@ applicationForm maId@(is _Just -> isAlloc) cid muid ApplicationFormMode{..} mcsr (filesRes, filesView) <- let mkFs = bool MsgCourseApplicationFile MsgCourseApplicationArchive + prevAppFiles (Entity aId _) = runDBSource $ selectSource [CourseApplicationFileApplication ==. aId] [Asc CourseApplicationFileTitle] .| C.map (view $ _FileReference . _1) in if | not afmApplicantEdit || is _NoUpload courseApplicationsFiles -> return (FormSuccess Nothing, Nothing) | otherwise - -> fmap (over _2 $ Just . ($ [])) . aFormToForm $ fileUploadForm False (fslI . mkFs) courseApplicationsFiles + -> fmap (over _2 $ Just . ($ [])) . aFormToForm $ fileUploadForm False (fslI . mkFs) courseApplicationsFiles (prevAppFiles <$> mApp) (vetoRes, vetoView) <- if | afmLecturer diff --git a/src/Handler/Allocation/Users.hs b/src/Handler/Allocation/Users.hs index 104d0193b..99b898d09 100644 --- a/src/Handler/Allocation/Users.hs +++ b/src/Handler/Allocation/Users.hs @@ -165,8 +165,6 @@ postAUsersR tid ssh ash = do allocMatching <- fmap (view _4) . hoistMaybe $ allocMap !? (tid, ssh, ash) return $ Map.fromListWith (<>) [ (uid, opoint cid) | (uid, cid) <- Set.toList allocMatching ] :: _ (Map UserId (NonNull (Set CourseId))) - csvName <- getMessageRender <*> pure (MsgAllocationUsersCsvName tid ssh ash) - let allocationUsersDBTable = DBTable{..} where @@ -296,6 +294,8 @@ postAUsersR tid ssh ash = do dbtParams = def dbtIdent :: Text dbtIdent = "allocation-users" + dbtCsvName = MsgAllocationUsersCsvName tid ssh ash + dbtCsvSheetName = MsgAllocationUsersCsvSheetName tid ssh ash dbtCsvEncode = return DBTCsvEncode { dbtCsvExportForm = pure () , dbtCsvDoEncode = \() -> C.mapM $ \(_, row) -> flip runReaderT row $ @@ -311,7 +311,7 @@ postAUsersR tid ssh ash = do <*> view (resultAssignedCourses . _Integral) <*> views (resultUser . _entityKey) (\uid -> maybe 0 (fromIntegral . olength) . Map.lookup uid <$> allocMatching) <*> view (resultAllocationUser . _entityVal . _allocationUserPriority) - , dbtCsvName = unpack csvName + , dbtCsvName, dbtCsvSheetName , dbtCsvNoExportData = Just id , dbtCsvHeader = \_ -> return . userTableCsvHeader $ is _Just allocMatching , dbtCsvExampleData = Nothing diff --git a/src/Handler/Course/Application/Files.hs b/src/Handler/Course/Application/Files.hs index 05b229560..9daf7e0df 100644 --- a/src/Handler/Course/Application/Files.hs +++ b/src/Handler/Course/Application/Files.hs @@ -57,8 +57,8 @@ getCAppsFilesR tid ssh csh = do E.&&. course E.^. CourseShorthand E.==. E.val csh return (allocation, user, courseApplication) apps' <- flip filterM apps $ \(_, _, Entity appId _) -> do - cID <- cachedByBinary appId $ encrypt appId - hasReadAccessTo $ CApplicationR tid ssh csh cID CAFilesR + cID <- encrypt appId + lift . hasReadAccessTo $ CApplicationR tid ssh csh cID CAFilesR let applicationAllocs = setOf (folded . _1) apps' @@ -87,7 +87,7 @@ getCAppsFilesR tid ssh csh = do = id forM_ apps' $ \(mbAlloc, Entity _ User{..}, Entity appId CourseApplication{..}) -> do - cID <- cachedByBinary appId $ encrypt appId :: _ CryptoFileNameCourseApplication + cID <- encrypt appId :: _ CryptoFileNameCourseApplication let mkAppDir = mkAllocationDir (entityVal <$> mbAlloc) . () (unpack [st|#{CI.foldedCase $ ciphertext cID}-#{CI.foldCase userSurname}|]) fileEntitySource = E.selectSource . E.from $ \courseApplicationFile -> do E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. E.val appId diff --git a/src/Handler/Course/Application/List.hs b/src/Handler/Course/Application/List.hs index 21ef97ee0..798eaaab7 100644 --- a/src/Handler/Course/Application/List.hs +++ b/src/Handler/Course/Application/List.hs @@ -232,7 +232,6 @@ postCApplicationsR tid ssh csh = do now <- liftIO getCurrentTime Entity cid Course{..} <- getBy404 $ TermSchoolCourseShort tid ssh csh - csvName <- getMessageRender <*> pure (MsgCourseApplicationsTableCsvName tid ssh csh) let allocationLink :: Allocation -> SomeRoute UniWorX allocationLink Allocation{..} = SomeRoute $ AllocationR allocationTerm allocationSchool allocationShorthand AShowR @@ -358,7 +357,9 @@ postCApplicationsR tid ssh csh = do } dbtParams = def - dbtCsvEncode = simpleCsvEncodeM csvName $ CourseApplicationsTableCsv + dbtCsvName = MsgCourseApplicationsTableCsvName tid ssh csh + dbtCsvSheetName = MsgCourseApplicationsTableCsvSheetName tid ssh csh + dbtCsvEncode = simpleCsvEncodeM dbtCsvName dbtCsvSheetName $ CourseApplicationsTableCsv <$> preview (resultAllocation . _entityVal . _allocationShorthand) <*> (preview (resultCourseApplication . _entityKey) >>= traverse encrypt) <*> preview (resultUser . _entityVal . _userDisplayName) diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index c17782d90..afcd9ee89 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -303,7 +303,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB <*> allocationForm <*> apopt checkBoxField (fslI MsgCourseApplicationRequired & setTooltip MsgCourseApplicationRequiredTip) (cfAppRequired <$> template) <*> aopt htmlField (fslI MsgCourseApplicationInstructions & setTooltip MsgCourseApplicationInstructionsTip) (cfAppInstructions <$> template) - <*> aopt (multiFileField' . fromMaybe (return ()) $ cfAppInstructionFiles =<< template) (fslI MsgCourseApplicationTemplate & setTooltip MsgCourseApplicationTemplateTip) (cfAppInstructionFiles <$> template) + <*> aopt (multiFileField' . maybeVoid $ cfAppInstructionFiles =<< template) (fslI MsgCourseApplicationTemplate & setTooltip MsgCourseApplicationTemplateTip) (cfAppInstructionFiles <$> template) <*> apopt checkBoxField (fslI MsgCourseApplicationsText & setTooltip MsgCourseApplicationsTextTip) (cfAppText <$> template) <*> uploadModeForm (fslI MsgCourseApplicationsFiles & setTooltip MsgCourseApplicationsFilesTip) (fmap cfAppFiles template <|> pure NoUpload) <*> apopt checkBoxField (fslI MsgCourseApplicationRatingsVisible & setTooltip MsgCourseApplicationRatingsVisibleTip) (cfAppRatingsVisible <$> template) @@ -328,7 +328,7 @@ validateCourse = do now <- liftIO getCurrentTime uid <- liftHandler requireAuthId - userAdmin <- hasWriteAccessTo $ SchoolR cfSchool SchoolEditR + userAdmin <- lift . hasWriteAccessTo $ SchoolR cfSchool SchoolEditR newAllocationTerm <- for (acfAllocation <$> cfAllocation) $ lift . fmap allocationTerm . getJust prevAllocationCourse <- join <$> traverse (lift . getBy . UniqueAllocationCourse) cfCourseId @@ -514,6 +514,7 @@ courseEditHandler miButtonAction mbCourseForm = do sinkInvitationsF lecturerInvitationConfig $ map (\(lEmail, mLty) -> (lEmail, cid, (InvDBDataLecturer mLty, InvTokenDataLecturer))) invites insert_ $ CourseEdit aid now cid upsertAllocationCourse cid $ cfAllocation res + memcachedByInvalidate AuthCacheLecturerList $ Proxy @(Set UserId) return insertOkay case insertOkay of Just _ -> do @@ -573,6 +574,8 @@ courseEditHandler miButtonAction mbCourseForm = do in void . replaceFileReferences mkFilter (CourseAppInstructionFileResidual cid) . sequence_ $ cfAppInstructionFiles res upsertAllocationCourse cid $ cfAllocation res + + memcachedByInvalidate AuthCacheLecturerList $ Proxy @(Set UserId) addMessageI Success $ MsgCourseEditOk tid ssh csh return True diff --git a/src/Handler/Course/LecturerInvite.hs b/src/Handler/Course/LecturerInvite.hs index 56bf8cc73..a8d379711 100644 --- a/src/Handler/Course/LecturerInvite.hs +++ b/src/Handler/Course/LecturerInvite.hs @@ -10,6 +10,7 @@ import Import import Utils.Form import Handler.Utils.Invitations +import Handler.Utils.Memcached import qualified Data.CaseInsensitive as CI @@ -74,8 +75,8 @@ lecturerInvitationConfig = InvitationConfig{..} where toJunction jLecturerType = (JunctionLecturer{..}, ()) lFs :: FieldSettings UniWorX - lFs = fslI MsgCourseLecturerType & setTooltip MsgCourseLecturerRightsIdentical - invitationInsertHook _ _ _ _ _ = id + lFs = fslI MsgLecturerType & setTooltip MsgCourseLecturerRightsIdentical + invitationInsertHook _ _ _ _ _ = (*>) (memcachedByInvalidate AuthCacheLecturerList $ Proxy @(Set UserId)) invitationSuccessMsg (Entity _ Course{..}) (Entity _ Lecturer{..}) = do MsgRenderer mr <- getMsgRenderer return . SomeMessage $ MsgLecturerInvitationAccepted (mr lecturerType) courseShorthand diff --git a/src/Handler/Course/News/Form.hs b/src/Handler/Course/News/Form.hs index 33e9a1938..f8cd56363 100644 --- a/src/Handler/Course/News/Form.hs +++ b/src/Handler/Course/News/Form.hs @@ -23,7 +23,7 @@ courseNewsForm :: Maybe CourseNewsForm -> Form CourseNewsForm courseNewsForm template = identifyForm FIDCourseNews . renderWForm FormStandard $ do now <- liftIO getCurrentTime - let oldFileIds = fromMaybe (return ()) $ template >>= cnfFiles + let oldFileIds = maybeVoid $ template >>= cnfFiles cTime = ceilingQuarterHour now visibleFromTip | Just vFrom <- template >>= cnfVisibleFrom diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index 858d6cd84..b91c65edf 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -92,11 +92,12 @@ participantInvitationConfig = InvitationConfig{..} invitationForm _ _ _ = hoistAForm lift . wFormToAForm $ do now <- liftIO getCurrentTime return . pure . (, ()) $ JunctionParticipant now Nothing CourseParticipantActive - invitationInsertHook _ _ (_, InvTokenDataParticipant{..}) CourseParticipant{..} _ act = do + invitationInsertHook _ (Entity _ Course{..}) (_, InvTokenDataParticipant{..}) CourseParticipant{..} _ act = do deleteBy $ UniqueParticipant courseParticipantUser courseParticipantCourse -- there are no foreign key references to @{CourseParticipant}; therefor we can delete and recreate to simulate upsert res <- act -- insertUnique audit $ TransactionCourseParticipantEdit courseParticipantCourse courseParticipantUser void $ setUserSubmissionGroup courseParticipantCourse courseParticipantUser invTokenParticipantSubmissionGroup + memcachedByInvalidate (AuthCacheCourseRegisteredList courseTerm courseSchool courseShorthand) (Proxy @(Set UserId)) return res invitationSuccessMsg (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseParticipantInvitationAccepted (CI.original courseName) diff --git a/src/Handler/Course/Register.hs b/src/Handler/Course/Register.hs index 1a88bfc3c..3affd85ee 100644 --- a/src/Handler/Course/Register.hs +++ b/src/Handler/Course/Register.hs @@ -132,11 +132,12 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do appFilesRes <- let mkFs | courseApplicationsRequired = bool MsgCourseApplicationFile MsgCourseApplicationArchive | otherwise = bool MsgCourseRegistrationFile MsgCourseRegistrationArchive + prevAppFiles (Entity aId _) = runDBSource $ selectSource [CourseApplicationFileApplication ==. aId] [Asc CourseApplicationFileTitle] .| C.map (view $ _FileReference . _1) in if | isRegistered -> return $ FormSuccess Nothing | otherwise - -> aFormToWForm $ fileUploadForm False (fslI . mkFs) courseApplicationsFiles + -> aFormToWForm $ fileUploadForm False (fslI . mkFs) courseApplicationsFiles (prevAppFiles <$> application) mayViewCourseAfterDeregistration <- liftHandler . runDB $ E.selectExists . E.from $ \course -> E.where_ $ course E.^. CourseId E.==. E.val cid @@ -222,6 +223,7 @@ postCRegisterR tid ssh csh = do = return $ Just () mkRegistration = do audit $ TransactionCourseParticipantEdit cid uid + memcachedByInvalidate (AuthCacheCourseRegisteredList courseTerm courseSchool courseShorthand) (Proxy @(Set UserId)) entityKey <$> upsert (CourseParticipant cid uid cTime Nothing CourseParticipantActive) [ CourseParticipantRegistration =. cTime @@ -238,7 +240,7 @@ postCRegisterR tid ssh csh = do BtnCourseDeregister -> runDB . setSerializable $ do part <- fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid forM_ part $ \(Entity _partId CourseParticipant{..}) -> do - deregisterParticipant uid cid + deregisterParticipant uid course when (is _Just courseParticipantAllocated) $ do updateBy (UniqueParticipant uid cid) [ CourseParticipantState =. CourseParticipantInactive courseDeregisterNoShow ] @@ -284,12 +286,13 @@ deleteApplications uid cid = do deleteApplicationFiles :: CourseApplicationId -> DB () deleteApplicationFiles appId = deleteWhere [ CourseApplicationFileApplication ==. appId ] -deregisterParticipant :: UserId -> CourseId -> DB () -deregisterParticipant uid cid = do +deregisterParticipant :: UserId -> Entity Course -> DB () +deregisterParticipant uid (Entity cid Course{..}) = do part <- fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid forM_ part $ \(Entity partId CourseParticipant{}) -> do update partId [CourseParticipantState =. CourseParticipantInactive False] audit $ TransactionCourseParticipantDeleted cid uid + memcachedByInvalidate (AuthCacheCourseRegisteredList courseTerm courseSchool courseShorthand) (Proxy @(Set UserId)) examRegistrations <- E.select . E.from $ \(examRegistration `E.InnerJoin` exam) -> do E.on $ examRegistration E.^. ExamRegistrationExam E.==. exam E.^. ExamId diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index 3c886075b..b4c2cd9d7 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -84,7 +84,7 @@ getCShowR tid ssh csh = do cTime <- NTop . Just <$> liftIO getCurrentTime news <- forMaybeM news' $ \(Entity nId n@CourseNews{..}) -> do cID <- encrypt nId :: MaybeT (MaybeT DB) CryptoUUIDCourseNews - guardM . hasReadAccessTo $ CNewsR tid ssh csh cID CNShowR + guardM . lift . lift . hasReadAccessTo $ CNewsR tid ssh csh cID CNShowR let visible = cTime >= NTop courseNewsVisibleFrom files' <- lift . lift . E.select . E.from $ \newsFile -> do E.where_ $ newsFile E.^. CourseNewsFileNews E.==. E.val nId @@ -93,8 +93,8 @@ getCShowR tid ssh csh = do & over (mapped . _1) E.unValue & over (mapped . _2) E.unValue lastEditText <- formatTime SelFormatDateTime $ maybe id max (guardOn visible =<< courseNewsVisibleFrom) courseNewsLastEdit - mayEditNews <- hasWriteAccessTo $ CNewsR tid ssh csh cID CNEditR - mayDelete <- hasWriteAccessTo $ CNewsR tid ssh csh cID CNDeleteR + mayEditNews <- lift . lift . hasWriteAccessTo $ CNewsR tid ssh csh cID CNEditR + mayDelete <- lift . lift . hasWriteAccessTo $ CNewsR tid ssh csh cID CNDeleteR files <- lift . lift $ forM files'' $ \f@(_isDir, fPath) -> fmap (f ,) . toTextUrl . CNewsR tid ssh csh cID $ CNFileR fPath archiveUrl <- lift . lift . toTextUrl $ CNewsR tid ssh csh cID CNArchiveR @@ -121,17 +121,17 @@ getCShowR tid ssh csh = do mayReRegister <- lift . courseMayReRegister $ Entity cid course - mayViewSheets <- hasReadAccessTo $ CourseR tid ssh csh SheetListR + mayViewSheets <- lift . hasReadAccessTo $ CourseR tid ssh csh SheetListR sheets <- lift . E.select . E.from $ \sheet -> do E.where_ $ sheet E.^. SheetCourse E.==. E.val cid return $ sheet E.^. SheetName - mayViewAnySheet <- anyM sheets $ \(E.Value shn) -> hasReadAccessTo $ CSheetR tid ssh csh shn SShowR + mayViewAnySheet <- lift . anyM sheets $ \(E.Value shn) -> hasReadAccessTo $ CSheetR tid ssh csh shn SShowR - mayViewMaterials <- hasReadAccessTo $ CourseR tid ssh csh MaterialListR + mayViewMaterials <- lift . hasReadAccessTo $ CourseR tid ssh csh MaterialListR materials <- lift . E.select . E.from $ \material -> do E.where_ $ material E.^. MaterialCourse E.==. E.val cid return $ material E.^. MaterialName - mayViewAnyMaterial <- anyM materials $ \(E.Value mnm) -> hasReadAccessTo $ CMaterialR tid ssh csh mnm MShowR + mayViewAnyMaterial <- lift . anyM materials $ \(E.Value mnm) -> hasReadAccessTo $ CMaterialR tid ssh csh mnm MShowR return (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,mApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mayReRegister, (mayViewSheets, mayViewAnySheet), (mayViewMaterials, mayViewAnyMaterial)) diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs index 9e50f1cb5..22ae53961 100644 --- a/src/Handler/Course/User.hs +++ b/src/Handler/Course/User.hs @@ -87,25 +87,25 @@ postCUserR tid ssh csh uCId = do siteLayout headingLong $ do setTitleI headingShort - forM_ sections . fromMaybe $ return () + mapM_ maybeVoid sections courseUserProfileSection :: Entity Course -> Entity User -> MaybeT Handler Widget -courseUserProfileSection (Entity cid Course{..}) (Entity uid User{ userShowSex = _, ..}) = do +courseUserProfileSection course@(Entity cid Course{..}) (Entity uid User{ userShowSex = _, ..}) = do showSex <- maybe False (userShowSex . entityVal) <$> maybeAuth currentRoute <- MaybeT getCurrentRoute (mRegistration, studies) <- lift . runDB $ do registration <- fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid - studies <- E.select $ E.from $ \(course `E.InnerJoin` studyfeat `E.InnerJoin` studydegree `E.InnerJoin` studyterms) -> do + studies <- E.select $ E.from $ \(course' `E.InnerJoin` studyfeat `E.InnerJoin` studydegree `E.InnerJoin` studyterms) -> do E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId - E.on $ isCourseStudyFeature course studyfeat + E.on $ isCourseStudyFeature course' studyfeat E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid - E.where_ $ course E.^. CourseId E.==. E.val cid + E.where_ $ course' E.^. CourseId E.==. E.val cid return (studyfeat, studydegree, studyterms) return (registration, studies) - mayRegister <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CAddUserR + mayRegister <- lift . hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CAddUserR let regButton | is _Just mRegistration = BtnCourseDeregister | otherwise = BtnCourseRegister @@ -138,7 +138,8 @@ courseUserProfileSection (Entity cid Course{..}) (Entity uid User{ userShowSex = | Just (Entity _pId CourseParticipant{..}) <- mRegistration -> do lift . runDB $ do - deregisterParticipant courseParticipantUser courseParticipantCourse + unless (courseParticipantCourse == cid) $ error "courseParticipantCourse does not match cid" + deregisterParticipant courseParticipantUser course whenIsJust mbReason $ \(reason, noShow) -> do updateBy (UniqueParticipant uid cid) [ CourseParticipantState =. CourseParticipantInactive noShow ] @@ -181,7 +182,7 @@ courseUserProfileSection (Entity cid Course{..}) (Entity uid User{ userShowSex = courseUserNoteSection :: Entity Course -> Entity User -> MaybeT Handler Widget courseUserNoteSection (Entity cid Course{..}) (Entity uid _) = do - guardM . hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CUsersR + guardM . lift . hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CUsersR currentRoute <- MaybeT getCurrentRoute @@ -240,7 +241,7 @@ courseUserNoteSection (Entity cid Course{..}) (Entity uid _) = do courseUserSubmissionsSection :: Entity Course -> Entity User -> MaybeT Handler Widget courseUserSubmissionsSection (Entity cid Course{..}) (Entity uid _) = do - guardM . hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CCorrectionsR + guardM . lift . hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CCorrectionsR let whereClause = (E.&&.) <$> courseIs cid <*> userIs uid colonnade = mconcat -- should match getSSubsR for consistent UX @@ -279,7 +280,7 @@ courseUserSubmissionsSection (Entity cid Course{..}) (Entity uid _) = do courseUserExamsSection :: Entity Course -> Entity User -> MaybeT Handler Widget courseUserExamsSection (Entity cid Course{..}) (Entity uid _) = do - guardM . hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CExamNewR + guardM . lift . hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CExamNewR uCID <- encrypt uid @@ -366,7 +367,7 @@ courseUserExamsSection (Entity cid Course{..}) (Entity uid _) = do ExamSetResultData <$> aopt (examResultModeField (Just $ SomeMessage MsgExamResultNone) ExamGradingMixed) (fslI MsgTableExamResult) Nothing ] - (res, formWgt) <- multiActionM actionMap (fslI MsgAction) Nothing csrf + (res, formWgt) <- multiActionM actionMap (fslI MsgTableAction) Nothing csrf let formRes = (, mempty) . First . Just <$> res return (formRes, formWgt) , dbParamsFormEvaluate = liftHandler . runFormPost @@ -489,7 +490,7 @@ courseUserTutorialsSection (Entity cid Course{..}) (Entity uid _) = do pure TutorialDeregisterData ] - (res, formWgt) <- multiActionM actionMap (fslI MsgAction) Nothing csrf + (res, formWgt) <- multiActionM actionMap (fslI MsgTableAction) Nothing csrf let formRes = (, mempty) . First . Just <$> res return (formRes, formWgt) , dbParamsFormEvaluate = liftHandler . runFormPost diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index 5fb2092df..c3d09c773 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -35,6 +35,10 @@ import Database.Persist.Sql (updateWhereCount) import Handler.Sheet.PersonalisedFiles +import qualified Data.Text.Lazy as Lazy (Text) + +import qualified Data.Aeson as JSON + type UserTableExpr = ( E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant) @@ -167,7 +171,9 @@ colUserSheets shns = cap (Sortable Nothing caption) $ foldMap userSheetCol shns data UserTableCsv = UserTableCsv - { csvUserName :: UserDisplayName + { csvUserSurname :: UserSurname + , csvUserFirstName :: UserFirstName + , csvUserName :: UserDisplayName , csvUserSex :: Maybe Sex , csvUserMatriculation :: Maybe UserMatriculation , csvUserEmail :: UserEmail @@ -183,7 +189,9 @@ makeLenses_ ''UserTableCsv instance Csv.ToNamedRecord UserTableCsv where toNamedRecord UserTableCsv{..} = Csv.namedRecord $ - [ "name" Csv..= csvUserName + [ "surname" Csv..= csvUserSurname + , "first-name" Csv..= csvUserFirstName + , "name" Csv..= csvUserName , "sex" Csv..= csvUserSex , "matriculation" Csv..= csvUserMatriculation , "email" Csv..= csvUserEmail @@ -208,7 +216,9 @@ instance Csv.ToNamedRecord UserTableCsv where ] instance CsvColumnsExplained UserTableCsv where csvColumnsExplanations _ = mconcat - [ single "name" MsgCsvColumnUserName + [ single "surname" MsgCsvColumnUserSurname + , single "first-name" MsgCsvColumnUserFirstName + , single "name" MsgCsvColumnUserName , single "sex" MsgCsvColumnUserSex , single "matriculation" MsgCsvColumnUserMatriculation , single "email" MsgCsvColumnUserEmail @@ -231,7 +241,7 @@ instance Default UserCsvExportData where userTableCsvHeader :: Bool -> [Entity Tutorial] -> [Entity Sheet] -> UserCsvExportData -> Csv.Header userTableCsvHeader showSex tuts sheets UserCsvExportData{..} = Csv.header $ - [ "name" ] ++ + [ "surname", "first-name", "name" ] ++ [ "sex" | showSex ] ++ [ "matriculation", "email", "study-features"] ++ [ "tutorial" | hasEmptyRegGroup ] ++ @@ -243,6 +253,58 @@ userTableCsvHeader showSex tuts sheets UserCsvExportData{..} = Csv.header $ hasEmptyRegGroup = has (folded . _entityVal . _tutorialRegGroup . _Nothing) tuts regGroups = Set.toList $ setOf (folded . _entityVal . _tutorialRegGroup . _Just) tuts +data UserTableJson = UserTableJson + { jsonUserSurname :: UserSurname + , jsonUserFirstName :: UserFirstName + , jsonUserName :: UserDisplayName + , jsonUserSex :: Maybe (Maybe Sex) + , jsonUserMatriculation :: Maybe UserMatriculation + , jsonUserEmail :: UserEmail + , jsonUserStudyFeatures :: UserTableStudyFeatures + , jsonUserSubmissionGroup :: Maybe SubmissionGroupName + , jsonUserRegistration :: UTCTime + , jsonUserNote :: Maybe Lazy.Text + , jsonUserTutorials :: Set TutorialName + , jsonUserTutorialGroups :: Map (CI Text) (Maybe TutorialName) + , jsonUserExams :: Set ExamName + , jsonUserSheets :: Map SheetName UserTableJsonSheetResult + } deriving (Generic, Typeable) + +data UserTableJsonSheetResult = UserTableJsonSheetResult + { jsonSheetType :: SheetType UserTableJsonSheetTypeExamPartRef + , jsonPoints :: Maybe Points + } deriving (Generic, Typeable) + +data UserTableJsonSheetTypeExamPartRef = UserTableJsonSheetTypeExamPartRef + { jsonExam :: ExamName + , jsonExamPart :: ExamPartNumber + } deriving (Generic, Typeable) + +deriveToJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + } ''UserTableJsonSheetTypeExamPartRef + +deriveToJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + } ''UserTableJsonSheetResult + +instance ToJSON UserTableJson where + toJSON UserTableJson{..} = JSON.object $ catMaybes + [ pure $ "surname" JSON..= jsonUserSurname + , pure $ "first-name" JSON..= jsonUserFirstName + , pure $ "name" JSON..= jsonUserName + , ("sex" JSON..=) <$> jsonUserSex + , ("matriculation" JSON..=) <$> jsonUserMatriculation + , pure $ "email" JSON..= jsonUserEmail + , ("study-features" JSON..=) <$> assertM' (views _Wrapped $ not . onull) jsonUserStudyFeatures + , ("submission-group" JSON..=) <$> jsonUserSubmissionGroup + , pure $ "registration" JSON..= jsonUserRegistration + , ("note" JSON..=) <$> jsonUserNote + , ("tutorials" JSON..=) <$> assertM' (not . onull) jsonUserTutorials + , ("tutorial-groups" JSON..=) <$> assertM' (any $ is _Just) jsonUserTutorialGroups + , ("exams" JSON..=) <$> assertM' (not . onull) jsonUserExams + , ("sheets" JSON..=) <$> assertM' (any $ has (to jsonPoints . _Just)) jsonUserSheets + ] data CourseUserAction = CourseUserSendMail | CourseUserRegisterTutorial @@ -294,7 +356,6 @@ makeCourseUserTable :: forall h p cols act act'. makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do currentRoute <- fromMaybe (error "makeCourseUserTable called from 404-handler") <$> liftHandler getCurrentRoute Course{..} <- getJust cid - csvName <- getMessageRender <*> pure (MsgCourseUserCsvName courseTerm courseSchool courseShorthand) tutorials <- selectList [ TutorialCourse ==. cid ] [] exams <- selectList [ ExamCourse ==. cid ] [] sheets <- selectList [SheetCourse ==. cid] [Desc SheetActiveTo, Desc SheetActiveFrom] @@ -447,11 +508,13 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just - <$> multiActionA acts (fslI MsgAction) Nothing + <$> multiActionA acts (fslI MsgTableAction) Nothing , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormResult = id , dbParamsFormIdent = def } + dbtCsvName = MsgCourseUserCsvName courseTerm courseSchool courseShorthand + dbtCsvSheetName = MsgCourseUserCsvSheetName courseTerm courseSchool courseShorthand dbtCsvEncode = do csvColumns' <- csvColumns return $ DBTCsvEncode @@ -459,7 +522,9 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do <$> apopt checkBoxField (fslI MsgCourseUserCsvIncludeSheets & setTooltip MsgCourseUserCsvIncludeSheetsTip) (Just $ csvUserIncludeSheets def) , dbtCsvDoEncode = \UserCsvExportData{} -> C.mapM $ \(_, row) -> flip runReaderT row $ UserTableCsv - <$> view (hasUser . _userDisplayName) + <$> view (hasUser . _userSurname) + <*> view (hasUser . _userFirstName) + <*> view (hasUser . _userDisplayName) <*> view (hasUser . _userSex) <*> view (hasUser . _userMatrikelnummer) <*> view (hasUser . _userEmail) @@ -471,18 +536,43 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do -- <*> (over (_2.traverse._Just) (examName . entityVal) . over (_1.traverse) (examName . entityVal) <$> view _userExams) <*> (over traverse (examName . entityVal) <$> view _userExams) <*> views _userSheets (set (mapped . _1 . mapped) ()) - , dbtCsvName = unpack csvName + , dbtCsvName, dbtCsvSheetName , dbtCsvNoExportData = Nothing , dbtCsvHeader = return . Vector.filter csvColumns' . userTableCsvHeader showSex tutorials sheets . fromMaybe def , dbtCsvExampleData = Nothing } - where - userNote = runMaybeT $ do - noteId <- MaybeT . preview $ _userTableNote . _Just - CourseUserNote{..} <- lift . lift $ getJust noteId - return courseUserNoteNote + userNote = runMaybeT $ do + noteId <- MaybeT . preview $ _userTableNote . _Just + CourseUserNote{..} <- lift . lift $ getJust noteId + return courseUserNoteNote dbtCsvDecode = Nothing - dbtExtraReps = withCsvExtraRep (UserCsvExportData True) dbtCsvEncode [] + dbtExtraReps = withCsvExtraRep dbtCsvSheetName (UserCsvExportData True) dbtCsvEncode + [ DBTExtraRep $ toPrettyJSON <$> repUserJson, DBTExtraRep $ toYAML <$> repUserJson + ] + + repUserJson :: ConduitT (E.Value UserId, UserTableData) Void DB (Map CryptoUUIDUser UserTableJson) + repUserJson = C.foldMapM $ \(E.Value uid, res) -> Map.singleton <$> encrypt uid <*> mkUserTableJson res + where + mkUserTableJson res' = flip runReaderT res' $ UserTableJson + <$> view (hasUser . _userSurname) + <*> view (hasUser . _userFirstName) + <*> view (hasUser . _userDisplayName) + <*> views (hasUser . _userSex) (guardOn showSex) + <*> view (hasUser . _userMatrikelnummer) + <*> view (hasUser . _userEmail) + <*> view _userStudyFeatures + <*> preview (_userSubmissionGroup . _entityVal . _submissionGroupName) + <*> view _userTableRegistration + <*> (fmap markupInput <$> userNote) + <*> view (_userTutorials . _1 . folded . to (Set.singleton . tutorialName . entityVal)) + <*> views (_userTutorials . _2) (over (traverse . _Just) $ tutorialName . entityVal) + <*> view (_userExams . folded . to (Set.singleton . examName . entityVal)) + <*> (fmap (fmap $ uncurry UserTableJsonSheetResult) . traverseOf (traverse . _1) (lift . resolveSheetType') =<< view _userSheets) + resolveSheetType' sType = do + sType' <- resolveSheetType cid sType + for sType' $ \(Entity _ ExamPart{..}) -> do + Exam{..} <- getJust examPartExam + return $ UserTableJsonSheetTypeExamPartRef examName examPartNumber over _1 postprocess <$> dbTable psValidator DBTable{..} where postprocess :: FormResult (First act', DBFormResult UserId Bool UserTableData) -> FormResult (act', Set UserId) @@ -509,7 +599,7 @@ getCUsersR, postCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCUsersR = postCUsersR postCUsersR tid ssh csh = do showSex <- getShowSex - (Entity cid Course{..}, numParticipants, (participantRes,participantTable)) <- runDB $ do + (course@(Entity cid Course{..}), numParticipants, (participantRes,participantTable)) <- runDB $ do mayRegister <- hasWriteAccessTo $ CourseR tid ssh csh CAddUserR ent@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh hasTutorials <- exists [TutorialCourse ==. cid] @@ -607,7 +697,8 @@ postCUsersR tid ssh csh = do Sum nrDel <- fmap mconcat . runDB . forM (Set.toList selectedUsers) $ \uid -> fmap (maybe mempty Sum) . runMaybeT $ do now <- liftIO getCurrentTime Entity _ CourseParticipant{..} <- MaybeT . fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid - lift $ deregisterParticipant courseParticipantUser courseParticipantCourse + unless (courseParticipantCourse == cid) $ error "courseParticipantCourse does not match cid" + lift $ deregisterParticipant courseParticipantUser course case deregisterSelfImposed of Just (reason, noShow) | is _Just courseParticipantAllocated -> lift $ do diff --git a/src/Handler/Exam/AddUser.hs b/src/Handler/Exam/AddUser.hs index 533905861..22a0dd2a5 100644 --- a/src/Handler/Exam/AddUser.hs +++ b/src/Handler/Exam/AddUser.hs @@ -129,7 +129,7 @@ postEAddUserR tid ssh csh examn = do unless registerCourse $ throwError $ mempty { aurNoCourseRegistration = pure userEmail } - guardAuthResult =<< lift (lift $ evalAccessDB (CourseR tid ssh csh CAddUserR) True) + lift . lift . hoist lift $ guardAuthResult =<< evalAccessDB (CourseR tid ssh csh CAddUserR) True lift . lift . void $ upsert diff --git a/src/Handler/Exam/AutoOccurrence.hs b/src/Handler/Exam/AutoOccurrence.hs index 1d4fe0b26..df036163b 100644 --- a/src/Handler/Exam/AutoOccurrence.hs +++ b/src/Handler/Exam/AutoOccurrence.hs @@ -10,11 +10,11 @@ import Handler.Utils import Handler.Utils.Exam import qualified Data.Map as Map +import qualified Data.Set as Set import qualified Database.Esqueleto as E import Database.Persist.Sql (updateWhereCount) - newtype ExamAutoOccurrenceCalculateForm = ExamAutoOccurrenceCalculateForm { eaofConfig :: ExamAutoOccurrenceConfig } deriving stock (Eq, Ord, Read, Show, Generic, Typeable) @@ -23,8 +23,9 @@ newtype ExamAutoOccurrenceCalculateForm = ExamAutoOccurrenceCalculateForm makeLenses_ ''ExamAutoOccurrenceCalculateForm data ExamAutoOccurrenceAcceptForm = ExamAutoOccurrenceAcceptForm - { eaofMapping :: Maybe (ExamOccurrenceMapping ExamOccurrenceId) + { eaofMapping :: ExamOccurrenceMapping ExamOccurrenceId , eaofAssignment :: Map UserId (Maybe ExamOccurrenceId) + , eaofSuccess :: Bool } deriving (Eq, Ord, Read, Show, Generic, Typeable) deriveJSON defaultOptions @@ -35,26 +36,65 @@ data ExamAutoOccurrenceButton = BtnExamAutoOccurrenceCalculate | BtnExamAutoOccurrenceAccept | BtnExamAutoOccurrenceNudgeUp | BtnExamAutoOccurrenceNudgeDown + | BtnExamAutoOccurrenceIgnore | BtnExamAutoOccurrenceReconsider deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) instance Universe ExamAutoOccurrenceButton instance Finite ExamAutoOccurrenceButton nullaryPathPiece ''ExamAutoOccurrenceButton $ camelToPathPiece' 4 -embedRenderMessage ''UniWorX ''ExamAutoOccurrenceButton id instance Button UniWorX ExamAutoOccurrenceButton where + btnLabel BtnExamAutoOccurrenceCalculate = i18n MsgBtnExamAutoOccurrenceCalculate + btnLabel BtnExamAutoOccurrenceAccept = i18n MsgBtnExamAutoOccurrenceAccept + btnLabel BtnExamAutoOccurrenceNudgeUp = toWidget iconExamAutoOccurrenceNudgeUp + btnLabel BtnExamAutoOccurrenceNudgeDown = toWidget iconExamAutoOccurrenceNudgeDown + btnLabel BtnExamAutoOccurrenceIgnore = toWidget iconExamAutoOccurrenceIgnore + btnLabel BtnExamAutoOccurrenceReconsider = toWidget iconExamAutoOccurrenceReconsider + btnClasses BtnExamAutoOccurrenceNudgeUp = [BCIsButton] btnClasses BtnExamAutoOccurrenceNudgeDown = [BCIsButton] + btnClasses BtnExamAutoOccurrenceIgnore = [BCIsButton] + btnClasses BtnExamAutoOccurrenceReconsider = [BCIsButton] btnClasses _ = [BCIsButton, BCPrimary] -examAutoOccurrenceCalculateForm :: ExamAutoOccurrenceCalculateForm -> Form ExamAutoOccurrenceCalculateForm -examAutoOccurrenceCalculateForm ExamAutoOccurrenceCalculateForm{ eaofConfig } +examAutoOccurrenceCalculateForm :: Map ExamOccurrenceId ExamOccurrenceCapacity + -> Map UserId (User, Maybe ExamOccurrenceId) + -> ExamAutoOccurrenceCalculateForm + -> Form ExamAutoOccurrenceCalculateForm +examAutoOccurrenceCalculateForm occurrences (fromIntegral . length -> usersCount) ExamAutoOccurrenceCalculateForm { eaofConfig } = identifyForm FIDExamAutoOccurrenceCalculate . renderAForm FormStandard $ ExamAutoOccurrenceCalculateForm <$> eaocForm where eaocForm = - (set _eaocMinimizeRooms <$> apopt checkBoxField (fslI MsgExamAutoOccurrenceMinimizeRooms & setTooltip MsgExamAutoOccurrenceMinimizeRoomsTip) (Just $ eaofConfig ^. _eaocMinimizeRooms)) + (set _eaocIgnoreRooms . automaticIfTrue <$> apopt checkBoxField (fslI MsgExamAutoOccurrenceMinimizeRooms & setTooltip MsgExamAutoOccurrenceMinimizeRoomsTip) (Just . minimizeRooms $ eaofConfig ^. _eaocIgnoreRooms)) <*> pure def + automaticIfTrue :: Bool -> ExamAutoOccurrenceIgnoreRooms + automaticIfTrue True = ExamAutoOccurrenceIgnoreRooms {eaoirIgnored, eaoirSorted=True} + automaticIfTrue False = ExamAutoOccurrenceIgnoreRooms {eaoirIgnored=Set.empty, eaoirSorted=False} + minimizeRooms :: ExamAutoOccurrenceIgnoreRooms -> Bool + minimizeRooms ExamAutoOccurrenceIgnoreRooms {eaoirSorted} = eaoirSorted + eaoirIgnored :: Set ExamOccurrenceId + -- ^ Minimise number of occurrences used + -- + -- Prefer occurrences with higher capacity + -- + -- If a single occurrence can accommodate all participants, pick the one with + -- the least capacity + eaoirIgnored + | Just largeEnoughs <- fromNullable . filter ((>= Restricted usersCount) . view _2) $ Map.toList occurrences + = Set.delete (view _1 $ minimumBy (comparing $ view _2) largeEnoughs) $ Map.keysSet occurrences + | otherwise + = Set.fromList . view _2 . foldl' accF (Restricted 0, []) + . sortOn (Down . view _2) $ Map.toList occurrences + where + accF :: (ExamOccurrenceCapacity, [ExamOccurrenceId]) + -> (ExamOccurrenceId, ExamOccurrenceCapacity) + -> (ExamOccurrenceCapacity, [ExamOccurrenceId]) + accF (accSize, accIgnored) (occId, occSize) + | accSize >= Restricted usersCount + = (accSize, occId:accIgnored) + | otherwise + = (accSize <> occSize, accIgnored) examAutoOccurrenceNudgeForm :: ExamOccurrenceId -> Maybe ExamAutoOccurrenceCalculateForm -> Form ExamAutoOccurrenceCalculateForm examAutoOccurrenceNudgeForm occId protoForm html = do @@ -63,7 +103,7 @@ examAutoOccurrenceNudgeForm occId protoForm html = do oldDataRes <- globalPostParamField PostExamAutoOccurrencePrevious secretJsonField oldDataId <- newIdent - let protoForm' = fromMaybe def $ oldDataRes <|> protoForm + let protoForm' = fromMaybe def $ protoForm <|> oldDataRes genForm btn = protoForm' & _eaofConfig . _eaocNudge %~ Map.insertWith (+) occId n where n = case btn of BtnExamAutoOccurrenceNudgeUp -> 1 @@ -73,16 +113,55 @@ examAutoOccurrenceNudgeForm occId protoForm html = do oldDataView = fieldView (secretJsonField :: Field Handler _) oldDataId (toPathPiece PostExamAutoOccurrencePrevious) [] (Right . fromMaybe protoForm' $ formResult' res) False return (res, wgt <> oldDataView) +examAutoOccurrenceIgnoreRoomsForm :: ExamOccurrenceId + -> Maybe ExamAutoOccurrenceCalculateForm + -> Maybe ExamAutoOccurrenceCalculateForm + -> Form ExamAutoOccurrenceCalculateForm +examAutoOccurrenceIgnoreRoomsForm occId calculateRes protoForm html = do + cID <- encrypt occId + oldDataRes <- globalPostParamField PostExamAutoOccurrencePrevious secretJsonField + oldDataId <- newIdent + + -- create both buttons + (btnResIgnore, wgtIgnore) <- identifyForm (FIDExamAutoOccurrenceIgnoreRoom $ ciphertext cID) (buttonForm' [BtnExamAutoOccurrenceIgnore]) html + (btnResReconsider, wgtReconsider) <- identifyForm (FIDExamAutoOccurrenceIgnoreRoom $ ciphertext cID) (buttonForm' [BtnExamAutoOccurrenceReconsider]) html + + -- choose the relevant button to display + let btnRes = btnResIgnore <|> btnResReconsider + wgt = case btnRes of + (FormSuccess BtnExamAutoOccurrenceIgnore) -> wgtReconsider + (FormSuccess BtnExamAutoOccurrenceReconsider) -> wgtIgnore + _otherwise -> case eaocIgnoreRooms . eaofConfig $ fromMaybe def $ calculateRes <|> oldDataRes of + ExamAutoOccurrenceIgnoreRooms {eaoirIgnored} + | Set.member occId eaoirIgnored + -> wgtReconsider + | otherwise + -> wgtIgnore + + + let protoForm' = fromMaybe def $ calculateRes <|> protoForm <|> oldDataRes + genForm btn = protoForm' & _eaofConfig . _eaocIgnoreRooms . _eaoirIgnored %~ action occId + where + action = case btn of + BtnExamAutoOccurrenceIgnore -> Set.insert + BtnExamAutoOccurrenceReconsider -> Set.delete + _other -> flip const -- i.e. ignore argument + res = genForm <$> btnRes + oldDataView = fieldView (secretJsonField :: Field Handler _) oldDataId (toPathPiece PostExamAutoOccurrencePrevious) [] (Right . fromMaybe protoForm' $ formResult' res) False + return (res, wgt <> oldDataView) + examAutoOccurrenceAcceptForm :: Maybe ExamAutoOccurrenceAcceptForm -> Form ExamAutoOccurrenceAcceptForm examAutoOccurrenceAcceptForm confirmData = identifyForm FIDExamAutoOccurrenceConfirm $ \html -> do (confirmDataRes, confirmDataView) <- mreq secretJsonField "" confirmData - (acceptRes, acceptView) <- buttonForm' [BtnExamAutoOccurrenceAccept] mempty + let fs :: FieldSettings UniWorX + fs = (if maybe False eaofSuccess confirmData then id else set _fsAttrs [("disabled", "")]) "" + (acceptRes, acceptView) <- buttonForm'' [BtnExamAutoOccurrenceAccept] fs mempty return (acceptRes *> confirmDataRes, toWidget html <> fvWidget confirmDataView <> acceptView) examAutoOccurrenceCalculateWidget :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Widget examAutoOccurrenceCalculateWidget tid ssh csh examn = do - (formView, formEncoding) <- liftHandler . generateFormPost $ examAutoOccurrenceCalculateForm def + (formView, formEncoding) <- liftHandler . generateFormPost $ examAutoOccurrenceCalculateForm Map.empty Map.empty def wrapForm' BtnExamAutoOccurrenceCalculate $(i18nWidgetFile "exam-auto-occurrence-calculate") def { formAction = Just . SomeRoute $ CExamR tid ssh csh examn EAutoOccurrenceR @@ -92,29 +171,46 @@ examAutoOccurrenceCalculateWidget tid ssh csh examn = do postEAutoOccurrenceR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html postEAutoOccurrenceR tid ssh csh examn = do - (Entity eId Exam{ examOccurrenceRule }, occurrences) <- runDB $ do + (Entity eId Exam{ examOccurrenceRule }, occurrences, participants) <- runDB $ do exam@(Entity eId _) <- fetchExam tid ssh csh examn occurrences <- selectList [ ExamOccurrenceExam ==. eId ] [ Asc ExamOccurrenceName ] - return (exam, occurrences) - - - ((calculateRes, _), _) <- runFormPost $ examAutoOccurrenceCalculateForm def - - nudgeRes <- sequence . flip Map.fromSet (setOf (folded . _entityKey) occurrences) $ \occId -> - runFormPost $ examAutoOccurrenceNudgeForm occId (formResult' calculateRes) - - let calculateRes' = asum $ calculateRes : nudgeRes ^.. folded . _1 . _1 - - calcResult <- formResultMaybe calculateRes' $ \ExamAutoOccurrenceCalculateForm{..} -> runDB $ do participants <- E.select . E.from $ \(registration `E.InnerJoin` user) -> do E.on $ registration E.^. ExamRegistrationUser E.==. user E.^. UserId E.where_ $ registration E.^. ExamRegistrationExam E.==. E.val eId return (user, registration) - let participants' = Map.fromList $ do - (Entity uid userRec, Entity _ ExamRegistration{..}) <- participants - return (uid, (userRec, examRegistrationOccurrence)) - occurrences' = Map.fromList $ map (\(Entity eoId ExamOccurrence{..}) -> (eoId, fromIntegral examOccurrenceCapacity)) occurrences - (eaofMapping, eaofAssignment) = examAutoOccurrence eId examOccurrenceRule eaofConfig occurrences' participants' + return (exam, occurrences, participants) + + + let participants' = Map.fromList $ do + (Entity uid userRec, Entity _ ExamRegistration{..}) <- participants + return (uid, (userRec, examRegistrationOccurrence)) + occurrences' = Map.fromList $ map (\(Entity eoId ExamOccurrence{..}) -> (eoId, _examOccurrenceCapacityIso # (fromIntegral <$> examOccurrenceCapacity))) occurrences + ((calculateRes, _), _) <- runFormPost $ examAutoOccurrenceCalculateForm occurrences' participants' def + + + (nudgeRes, ignoreRes) <- mdo + nudgeRes <- sequence . flip Map.fromSet (setOf (folded . _entityKey) occurrences) $ \occId -> + runFormPost $ examAutoOccurrenceNudgeForm occId (formResult' . asum $ nudgeRes ^.. ifolded . ifiltered (\occId' _ -> occId' /= occId) . _1 . _1 ++ ignoreRes ^.. folded . _1 . _1) + ignoreRes <- sequence . flip Map.fromSet (setOf (folded . _entityKey) occurrences) $ \occId -> + runFormPost $ examAutoOccurrenceIgnoreRoomsForm occId (formResult' calculateRes) (formResult' . asum $ nudgeRes ^.. folded . _1 . _1 ++ ignoreRes ^.. ifolded . ifiltered (\occId' _ -> occId' /= occId) . _1 . _1) + return (nudgeRes, ignoreRes) + + + let calculateRes' = asum $ calculateRes : nudgeRes ^.. folded . _1 . _1 ++ ignoreRes ^.. folded . _1 . _1 + + calcResult <- formResultMaybe calculateRes' $ \ExamAutoOccurrenceCalculateForm{..} -> do + let autoOccurrenceResult = examAutoOccurrence eId examOccurrenceRule eaofConfig occurrences' participants' + (eaofMapping, eaofAssignment, eaofSuccess) <- case autoOccurrenceResult of + (Left e) -> do + addMessageI Error e + pure ( ExamOccurrenceMapping { + examOccurrenceMappingRule = examOccurrenceRule, + examOccurrenceMappingMapping = Map.empty + } + , Map.map (view _2) participants' + , False + ) + (Right res) -> pure $ uncurry (,,True) res return $ Just ExamAutoOccurrenceAcceptForm{..} ((confirmRes, confirmView), confirmEncoding) <- runFormPost $ examAutoOccurrenceAcceptForm calcResult @@ -126,14 +222,13 @@ postEAutoOccurrenceR tid ssh csh examn = do formResult confirmRes $ \ExamAutoOccurrenceAcceptForm{..} -> do Sum assignedCount <- runDB $ do - let eaofMapping'' :: Maybe (Maybe (ExamOccurrenceMapping ExamOccurrenceName)) - eaofMapping'' = (<$> eaofMapping) . traverseExamOccurrenceMapping $ \eoId -> case filter ((== eoId) . entityKey) occurrences of + let eaofMapping'' :: Maybe (ExamOccurrenceMapping ExamOccurrenceName) + eaofMapping'' = ($ eaofMapping) . traverseExamOccurrenceMapping $ \eoId -> case filter ((== eoId) . entityKey) occurrences of [Entity _ ExamOccurrence{..}] -> Just examOccurrenceName _other -> Nothing eaofMapping' <- case eaofMapping'' of - Nothing -> return Nothing - Just Nothing -> invalidArgsI [MsgExamAutoOccurrenceOccurrencesChangedInFlight] - Just (Just x ) -> return $ Just x + Nothing -> invalidArgsI [MsgExamAutoOccurrenceOccurrencesChangedInFlight] + Just x -> return $ Just x update eId [ ExamExamOccurrenceMapping =. eaofMapping' ] fmap fold . iforM eaofAssignment $ \pid occ -> case occ of Just _ -> Sum <$> updateWhereCount [ ExamRegistrationExam ==. eId, ExamRegistrationUser ==. pid, ExamRegistrationOccurrence ==. Nothing ] [ ExamRegistrationOccurrence =. occ ] @@ -149,6 +244,16 @@ postEAutoOccurrenceR tid ssh csh examn = do , formAttrs = [("class", "buttongroup")] } + let ignoreRoomWgt = ignoreRes <&> \((_, ignoreRoomsView), ignoreRoomsEncoding) -> + wrapForm ignoreRoomsView def + { formAction = Just . SomeRoute $ CExamR tid ssh csh examn EAutoOccurrenceR + , formEncoding = ignoreRoomsEncoding + , formSubmit = FormNoSubmit + , formAttrs = [("class", "buttongroup")] + } + isIgnored :: ExamOccurrenceId -> Bool + isIgnored occId = maybe False (Set.member occId) $ formResult' calculateRes' ^? _Just . _eaofConfig . _eaocIgnoreRooms . _eaoirIgnored + ExamAutoOccurrenceAcceptForm{..} <- maybe (redirect $ CExamR tid ssh csh examn EUsersR) return calcResult let heading = MsgTitleExamAutoOccurrence tid ssh csh examn @@ -158,13 +263,15 @@ postEAutoOccurrenceR tid ssh csh examn = do occLoad = fromMaybe 0 . flip Map.lookup occLoads - occMappingRule = examOccurrenceMappingRule <$> eaofMapping + occMappingRule = examOccurrenceMappingRule eaofMapping loadProp curr max' - | max' /= 0 = MsgProportion (toMessage curr) (toMessage max') (toRational curr / toRational max') - | otherwise = MsgProportionNoRatio (toMessage curr) (toMessage max') + | Just max'' <- assertM (/= 0) max' + = MsgProportion (toMessage curr) (toMessage max'') (toRational curr / toRational max'') + | otherwise + = MsgProportionNoRatio (toMessage curr) $ maybe "∞" toMessage max' - occMapping occId = examOccurrenceMappingDescriptionWidget <$> occMappingRule <*> (Map.lookup occId . examOccurrenceMappingMapping =<< eaofMapping) + occMapping occId = examOccurrenceMappingDescriptionWidget occMappingRule <$> Map.lookup occId (examOccurrenceMappingMapping eaofMapping) in $(widgetFile "widgets/exam-occurrence-mapping") siteLayoutMsg heading $ do diff --git a/src/Handler/Exam/CorrectorInvite.hs b/src/Handler/Exam/CorrectorInvite.hs index 5441a3409..a69ecd850 100644 --- a/src/Handler/Exam/CorrectorInvite.hs +++ b/src/Handler/Exam/CorrectorInvite.hs @@ -11,6 +11,7 @@ module Handler.Exam.CorrectorInvite import Import import Handler.Utils.Invitations import Handler.Utils.Exam +import Handler.Utils.Memcached import Data.Aeson hiding (Result(..)) @@ -71,7 +72,7 @@ examCorrectorInvitationConfig = InvitationConfig{..} return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing invitationRestriction _ _ = return Authorized invitationForm _ _ _ = pure (JunctionExamCorrector, ()) - invitationInsertHook _ _ _ _ _ = id + invitationInsertHook _ _ _ _ _ = (*>) (memcachedByInvalidate AuthCacheExamCorrectorList $ Proxy @(Set UserId)) invitationSuccessMsg (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamCorrectorInvitationAccepted examName invitationUltDest (Entity _ Exam{..}) _ = do Course{..} <- get404 examCourse diff --git a/src/Handler/Exam/Edit.hs b/src/Handler/Exam/Edit.hs index 4208453e1..959b38580 100644 --- a/src/Handler/Exam/Edit.hs +++ b/src/Handler/Exam/Edit.hs @@ -113,6 +113,7 @@ postEEditR tid ssh csh examn = do deleteWhere [ ExamCorrectorExam ==. eId ] insertMany_ $ map (ExamCorrector eId) adds + memcachedByInvalidate AuthCacheExamCorrectorList $ Proxy @(Set UserId) deleteWhere [ InvitationFor ==. invRef @ExamCorrector eId, InvitationEmail /<-. invites ] sinkInvitationsF examCorrectorInvitationConfig $ map (, eId, (InvDBDataExamCorrector, InvTokenDataExamCorrector)) invites diff --git a/src/Handler/Exam/Form.hs b/src/Handler/Exam/Form.hs index efb76f7e6..0e930fc77 100644 --- a/src/Handler/Exam/Form.hs +++ b/src/Handler/Exam/Form.hs @@ -59,7 +59,7 @@ data ExamOccurrenceForm = ExamOccurrenceForm , eofName :: ExamOccurrenceName , eofRoom :: Maybe RoomReference , eofRoomHidden :: Bool - , eofCapacity :: Word64 + , eofCapacity :: Maybe Word64 , eofStart :: UTCTime , eofEnd :: Maybe UTCTime , eofDescription :: Maybe StoredMarkup @@ -232,7 +232,7 @@ examOccurrenceForm prev = wFormToAForm $ do <*> apopt checkBoxField (fslI MsgExamRoomRoomHidden & setTooltip MsgExamRoomRoomHiddenTip & addName (nudge "room-hidden")) (eofRoomHidden <$> mPrev) let eofRoomRes = view _1 <$> eofRoomRes' eofRoomHiddenRes = view _2 <$> eofRoomRes' - (eofCapacityRes, eofCapacityView) <- mpreq (natFieldI MsgExamRoomCapacityNegative) (fslI MsgExamRoomCapacity & addName (nudge "capacity")) (eofCapacity <$> mPrev) + (eofCapacityRes, eofCapacityView) <- mopt (natFieldI MsgExamRoomCapacityNegative) (fslI MsgExamRoomCapacity & addName (nudge "capacity")) (eofCapacity <$> mPrev) (eofStartRes, eofStartView) <- mpreq utcTimeField (fslI MsgExamRoomStart & addName (nudge "start")) (eofStart <$> mPrev) (eofEndRes, eofEndView) <- mopt utcTimeField (fslI MsgExamRoomEnd & addName (nudge "end")) (eofEnd <$> mPrev) (eofDescRes, eofDescView) <- mopt htmlField (fslI MsgExamRoomDescription & addName (nudge "description")) (eofDescription <$> mPrev) @@ -421,7 +421,6 @@ examTemplate cid = runMaybeT $ do validateExam :: forall m. ( MonadHandler m , HandlerSite m ~ UniWorX - , MonadThrow m ) => CourseId -> Maybe (Entity Exam) -> FormValidator ExamForm (SqlPersistT m) () validateExam cId oldExam = do diff --git a/src/Handler/Exam/List.hs b/src/Handler/Exam/List.hs index 79c279ccf..a5af5fe27 100644 --- a/src/Handler/Exam/List.hs +++ b/src/Handler/Exam/List.hs @@ -33,8 +33,8 @@ mkExamTable (Entity cid Course{..}) = do dbtColonnade = dbColonnade . mconcat $ catMaybes [ Just . sortable (Just "name") (i18nCell MsgTableExamName) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> indicatorCell <> anchorCell (CExamR tid ssh csh examName EShowR) examName , (<$ guard mayCreate) . sortable (Just "visible") (i18nCell MsgExamVisibleFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty (dateTimeCellVisible now) examVisibleFrom - , Just . sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom - , Just . sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo + , Just . sortable (Just "register-from") (i18nCell MsgTableExamRegisterFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom + , Just . sortable (Just "register-to") (i18nCell MsgTableExamRegisterTo) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo , Just . sortable (Just "time") (i18nCell MsgTableExamTime) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> maybe mempty (cell . flip (formatTimeRangeW SelFormatDateTime) examEnd) examStart , Just . sortable (Just "registered") (i18nCell MsgTableExamRegistration ) $ \DBRow{ dbrOutput = Entity eId Exam{..} } -> sqlCell $ do mayRegister <- (== Authorized) <$> evalAccessDB (CExamR tid ssh csh examName ERegisterR) True diff --git a/src/Handler/Exam/New.hs b/src/Handler/Exam/New.hs index e982a91be..90d80c17d 100644 --- a/src/Handler/Exam/New.hs +++ b/src/Handler/Exam/New.hs @@ -84,6 +84,7 @@ postCExamNewR tid ssh csh = do , examCorrectorUser <- adds ] sinkInvitationsF examCorrectorInvitationConfig $ map (, examid, (InvDBDataExamCorrector, InvTokenDataExamCorrector)) invites + memcachedByInvalidate AuthCacheExamCorrectorList $ Proxy @(Set UserId) let recordNoShow (Entity _ CourseParticipant{..}) = do didRecord <- is _Just <$> insertUnique ExamResult diff --git a/src/Handler/Exam/Show.hs b/src/Handler/Exam/Show.hs index 59ed1a4c5..be4c41e55 100644 --- a/src/Handler/Exam/Show.hs +++ b/src/Handler/Exam/Show.hs @@ -7,7 +7,7 @@ import Handler.Exam.Register import Handler.Exam.AutoOccurrence (examAutoOccurrenceCalculateWidget) -import Handler.ExamOffice.Exam (examCloseWidget) +import Handler.ExamOffice.Exam (examCloseWidget, examFinishWidget) import Data.Map ((!?)) import qualified Data.Map as Map @@ -106,6 +106,7 @@ getEShowR tid ssh csh examn = do partNumbersShown = lecturerInfoShown examClosedShown = lecturerInfoShown && isn't _ExamCloseOnFinished' schoolExamCloseMode showCloseWidget = lecturerInfoShown + showFinishWidget = lecturerInfoShown && is _Nothing examFinished showAutoOccurrenceCalculateWidget = lecturerInfoShown showRegisteredCount = lecturerInfoShown examFinishedMsg = if lecturerInfoShown then MsgExamFinished else MsgExamFinishedParticipant @@ -191,12 +192,13 @@ getEShowR tid ssh csh examn = do showOccurrenceMappingColumn = examOccurrenceRuleAutomatic examOccurrenceRule && occurrenceAssignmentsShown && is _Just examExamOccurrenceMapping closeWgt <- examCloseWidget (SomeRoute $ CExamR tid ssh csh examn EUsersR) eId + finishWgt <- examFinishWidget (SomeRoute $ CExamR tid ssh csh examn EUsersR) eId let heading = prependCourseTitle tid ssh csh $ CI.original examName notificationDiscouragedExamMode <- runMaybeT $ do guard $ evalExamModeDNF schoolExamDiscouragedModes examExamMode - guardM . hasWriteAccessTo $ CExamR tid ssh csh examn EEditR + guardM . lift . hasWriteAccessTo $ CExamR tid ssh csh examn EEditR return $ notification NotificationBroad =<< messageI Warning MsgExamModeSchoolDiscouraged siteLayoutMsg heading $ do diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index 5b6f62902..cd644f4b7 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -14,7 +14,7 @@ import Handler.Utils.StudyFeatures import Handler.Exam.AutoOccurrence (examAutoOccurrenceCalculateWidget) -import Handler.ExamOffice.Exam (examCloseWidget) +import Handler.ExamOffice.Exam (examCloseWidget, examFinishWidget) import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E @@ -148,19 +148,22 @@ resultStudyFeatures = _dbrOutput . _8 resultAutomaticExamBonus :: Ord epId => Exam -> Map UserId (SheetTypeSummary epId) -> Fold ExamUserTableData Points resultAutomaticExamBonus exam examBonus' = resultUser . _entityKey . folding (\uid -> join $ examResultBonus <$> examBonusRule exam <*> pure (examBonusPossible uid examBonus') <*> pure (examBonusAchieved uid examBonus')) -resultAutomaticExamResult :: Exam -> Map UserId (SheetTypeSummary ExamPartId) -> Fold ExamUserTableData ExamResultPassedGrade -resultAutomaticExamResult exam@Exam{..} examBonus' = folding . runReader $ do +resultAutomaticExamResult :: Exam + -> Map UserId (SheetTypeSummary ExamPartId) + -> Map UserId (SheetTypeSummary ExamPartId) + -> Fold ExamUserTableData ExamResultPassedGrade +resultAutomaticExamResult exam@Exam{..} examBonus' resultSheets = folding . runReader $ do parts' <- asks (itoListOf resultExamParts) >>= mapM (\(epId, (ep, mRes)) -> runMaybeT $ hoistMaybe (mRes ^? _Just . _entityVal . _examPartResultResult) - <|> MaybeT (preview $ resultAutomaticExamPartResult (Entity epId ep) examBonus') + <|> MaybeT (preview $ resultAutomaticExamPartResult (Entity epId ep) resultSheets) ) bonus <- preview $ resultExamBonus . _entityVal . _examBonusBonus <> resultAutomaticExamBonus exam examBonus' let gradeRes = examGrade exam bonus =<< sequence parts' return $ fmap (bool Right (Left . view passingGrade) $ is _ExamGradingPass examGradingMode) <$> gradeRes resultAutomaticExamPartResult :: Entity ExamPart -> Map UserId (SheetTypeSummary ExamPartId) -> Fold ExamUserTableData ExamResultPoints -resultAutomaticExamPartResult epEnt examBonus' = folding . runReader . runMaybeT $ do +resultAutomaticExamPartResult epEnt resultSheets = folding . runReader . runMaybeT $ do uid <- view $ resultUser . _entityKey - summary <- hoistMaybe $ Map.lookup uid examBonus' + summary <- hoistMaybe $ Map.lookup uid resultSheets hoistMaybe $ sheetExamResult summary epEnt @@ -219,7 +222,7 @@ instance ToNamedRecord ExamUserTableCsv where \pNumber pResult -> pure $ (csvExamPartHeader # pNumber) Csv..= pResult instance FromNamedRecord ExamUserTableCsv where - parseNamedRecord csv + parseNamedRecord (lsfHeaderTranslate -> csv) = ExamUserTableCsv <$> csv .:?? "surname" <*> csv .:?? "first-name" @@ -378,12 +381,13 @@ embedRenderMessage ''UniWorX ''ExamUserCsvException id getEUsersR, postEUsersR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html getEUsersR = postEUsersR postEUsersR tid ssh csh examn = do - (((Any computedValues, registrationResult), examUsersTable), Entity eId examVal@Exam{..}, bonus) <- runDB $ do + (((Any computedValues, registrationResult), examUsersTable), Entity eId examVal@Exam{..}, (bonus, resultSheets)) <- runDB $ do exam@(Entity eid examVal@Exam{..}) <- fetchExam tid ssh csh examn Course{..} <- getJust examCourse occurrences <- selectList [ExamOccurrenceExam ==. eid] [Asc ExamOccurrenceName] examParts <- selectList [ExamPartExam ==. eid] [Asc ExamPartName] - bonus <- examBonus exam + bonus <- examRelevantSheets exam True + resultSheets <- examRelevantSheets exam False let allBoni :: SheetGradeSummary @@ -398,7 +402,7 @@ postEUsersR tid ssh csh examn = do resultAutomaticExamBonus' :: Fold ExamUserTableData Points resultAutomaticExamBonus' = resultAutomaticExamBonus examVal bonus resultAutomaticExamResult' :: Fold ExamUserTableData ExamResultPassedGrade - resultAutomaticExamResult' = resultAutomaticExamResult examVal bonus + resultAutomaticExamResult' = resultAutomaticExamResult examVal bonus resultSheets automaticCell :: forall msg m a b r. ( RenderMessage UniWorX msg @@ -420,8 +424,6 @@ postEUsersR tid ssh csh examn = do | otherwise -> i18nCell man & cellAttrs <>~ [("class", "table__td--overriden")] & tellCell (Any True, mempty) - csvName <- getMessageRender <*> pure (MsgExamUserCsvName tid ssh csh examn) - let examUsersDBTable = DBTable{..} where @@ -488,7 +490,7 @@ postEUsersR tid ssh csh examn = do in propCell (getSum achievedPoints) (getSum sumSheetsPoints) , guardOn doBonus $ sortable (Just "bonus") (i18nCell MsgExamBonusAchieved) . automaticCell $ resultExamBonus . _entityVal . _examBonusBonus . to Right <> resultAutomaticExamBonus' . to Left , pure $ mconcat - [ sortable (Just $ fromText [st|part-#{toPathPiece examPartNumber}|]) (i18nCell $ MsgExamPartNumbered examPartNumber) . automaticCell $ resultExamPartResult epId . _Just . _entityVal . _examPartResultResult . to Right <> resultAutomaticExamPartResult epEnt bonus . to Left + [ sortable (Just $ fromText [st|part-#{toPathPiece examPartNumber}|]) (i18nCell $ MsgExamPartNumbered examPartNumber) . automaticCell $ resultExamPartResult epId . _Just . _entityVal . _examPartResultResult . to Right <> resultAutomaticExamPartResult epEnt resultSheets . to Left | epEnt@(Entity epId ExamPart{..}) <- sortOn (examPartNumber . entityVal) examParts ] , pure $ sortable (Just "exam-result") (i18nCell MsgTableExamResult) . automaticCell $ (resultExamResult . _entityVal . _examResultResult . to Right <> resultAutomaticExamResult' . to Left) @@ -590,10 +592,12 @@ postEUsersR tid ssh csh examn = do } dbtIdent :: Text dbtIdent = "exam-users" + dbtCsvName = MsgExamUserCsvName tid ssh csh examn + dbtCsvSheetName = MsgExamUserCsvSheetName tid ssh csh examn dbtCsvEncode = Just DBTCsvEncode { dbtCsvExportForm = pure () , dbtCsvDoEncode = \() -> C.map (doEncode' . view _2) - , dbtCsvName = unpack csvName + , dbtCsvName, dbtCsvSheetName , dbtCsvNoExportData = Just id , dbtCsvHeader = const . return . examUserTableCsvHeader allBoni doBonus $ examParts ^.. folded . _entityVal . _examPartNumber , dbtCsvExampleData = Nothing @@ -615,7 +619,7 @@ postEUsersR tid ssh csh examn = do <*> preview (resultExamResult . _entityVal . _examResultResult <> resultAutomaticExamResult') <*> preview (resultCourseNote . _entityVal . _courseUserNoteNote) encodePartResults = fmap Map.fromList . forM examParts $ \epEnt@(Entity epId ExamPart{..}) -> (examPartNumber, ) <$> - preview (resultExamPartResult epId . _Just . _entityVal . _examPartResultResult <> resultAutomaticExamPartResult epEnt bonus) + preview (resultExamPartResult epId . _Just . _entityVal . _examPartResultResult <> resultAutomaticExamPartResult epEnt resultSheets) dbtCsvDecode = Just DBTCsvDecode { dbtCsvRowKey = \csv -> do uid <- lift $ view _2 <$> guessUser' csv @@ -954,7 +958,7 @@ postEUsersR tid ssh csh examn = do (First (Just act), regMap) <- inp let regMap' = Map.mapMaybe (uncurry guardOn) $ getDBFormResult (False,) regMap return (act, regMap') - (, exam, bonus) . over (_1 . _2) postprocess <$> dbTable examUsersDBTableValidator examUsersDBTable + (, exam, (bonus, resultSheets)) . over (_1 . _2) postprocess <$> dbTable examUsersDBTableValidator examUsersDBTable formResult registrationResult $ \case (ExamUserDeregisterData, Map.elems -> selectedRegistrations) -> do @@ -976,9 +980,9 @@ postEUsersR tid ssh csh examn = do uid <- view $ resultUser . _entityKey hasResult <- asks $ has resultExamResult hasBonus <- asks $ has resultExamBonus - autoResult <- preview $ resultAutomaticExamResult examVal bonus + autoResult <- preview $ resultAutomaticExamResult examVal bonus resultSheets autoBonus <- preview $ resultAutomaticExamBonus examVal bonus - autoParts <- asks (itoListOf resultExamParts) >>= mapM (\(epId, (ep, mRes)) -> fmap (guardOnM (isn't _Just mRes) . fmap (epId, )) . preview $ resultAutomaticExamPartResult (Entity epId ep) bonus) + autoParts <- asks (itoListOf resultExamParts) >>= mapM (\(epId, (ep, mRes)) -> fmap (guardOnM (isn't _Just mRes) . fmap (epId, )) . preview $ resultAutomaticExamPartResult (Entity epId ep) resultSheets) lift $ if | not hasResult , Just examResultResult <- autoResult @@ -1127,6 +1131,7 @@ postEUsersR tid ssh csh examn = do redirect $ CExamR tid ssh csh examn EUsersR closeWgt <- examCloseWidget (SomeRoute $ CExamR tid ssh csh examn EUsersR) eId + finishWgt <- examFinishWidget (SomeRoute $ CExamR tid ssh csh examn EUsersR) eId siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamUsersHeading) $ do setTitleI $ prependCourseTitle tid ssh csh MsgExamUsersHeading diff --git a/src/Handler/ExamOffice/Exam.hs b/src/Handler/ExamOffice/Exam.hs index 0b50e66b7..1f77d04b3 100644 --- a/src/Handler/ExamOffice/Exam.hs +++ b/src/Handler/ExamOffice/Exam.hs @@ -2,7 +2,7 @@ module Handler.ExamOffice.Exam ( getEGradesR, postEGradesR - , examCloseWidget + , examCloseWidget, examFinishWidget ) where import Import @@ -79,6 +79,47 @@ examCloseWidget dest eId = do return $(widgetFile "widgets/exam-close") +data ButtonFinishExam = BtnFinishExam + deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) +instance Universe ButtonFinishExam +instance Finite ButtonFinishExam + +nullaryPathPiece ''ButtonFinishExam $ camelToPathPiece' 1 + +embedRenderMessage ''UniWorX ''ButtonFinishExam id +instance Button UniWorX ButtonFinishExam where + btnClasses BtnFinishExam = [BCIsButton] + + +examFinishWidget :: SomeRoute UniWorX -> ExamId -> Handler Widget +examFinishWidget dest eId = do + Exam{examFinished} <- runDB $ get404 eId + + examFinishedStr <- for examFinished $ formatTime SelFormatDateTime + + ((finishRes, finishView'), finishEnc) <- runFormPost $ identifyForm BtnFinishExam buttonForm + + formResult finishRes $ \case + BtnFinishExam -> do + now <- liftIO getCurrentTime + + unless (is _Nothing examFinished) $ + invalidArgs ["Exam is already finished"] + + runDB $ update eId [ ExamFinished =. Just now ] + addMessageI Success MsgExamDidFinish + redirect dest + + let finishView = wrapForm finishView' def + { formSubmit = FormNoSubmit + , formAction = Just dest + , formEncoding = finishEnc + } + + return $(widgetFile "widgets/exam-finish") + + + type ExamUserTableExpr = ( E.SqlExpr (Entity ExamResult) `E.InnerJoin` E.SqlExpr (Entity User) ) @@ -186,11 +227,10 @@ getEGradesR = postEGradesR postEGradesR tid ssh csh examn = do uid <- requireAuthId now <- liftIO getCurrentTime - ((usersResult, examUsersTable), Entity eId _) <- runDB $ do + ((usersResult, examUsersTable), Entity eId Exam{examFinished}) <- runDB $ do exam@(Entity eid Exam{..}) <- fetchExam tid ssh csh examn Course{..} <- getJust examCourse - csvName <- getMessageRender <*> pure (MsgExamUserCsvNameExamOffice tid ssh csh examn) isLecturer <- hasReadAccessTo $ CExamR tid ssh csh examn EUsersR userFunctions <- selectList [ UserFunctionUser ==. uid, UserFunctionFunction ==. SchoolExamOffice ] [] @@ -377,7 +417,7 @@ postEGradesR tid ssh csh examn = do , pure ExamUserMarkSynchronisedData ) ] - (res, formWgt) <- multiActionM actionMap (fslI MsgAction) Nothing csrf + (res, formWgt) <- multiActionM actionMap (fslI MsgTableAction) Nothing csrf let formRes = (, mempty) . First . Just <$> res return (formRes, formWgt) , dbParamsFormEvaluate = liftHandler . runFormPost @@ -386,6 +426,8 @@ postEGradesR tid ssh csh examn = do } dbtIdent :: Text dbtIdent = "exam-results" + dbtCsvName = MsgExamUserCsvName tid ssh csh examn + dbtCsvSheetName = MsgExamUserCsvSheetName tid ssh csh examn dbtCsvEncode = Just DBTCsvEncode { dbtCsvExportForm = ExamUserCsvExportData <$> apopt checkBoxField (fslI MsgExamOfficeExamUserMarkSynchronisedCsv & setTooltip MsgExamOfficeExamUserMarkSynchronisedCsvTip) (Just False) @@ -399,7 +441,7 @@ postEGradesR tid ssh csh examn = do (row ^. resultStudyFeatures) (row ^? (resultExamOccurrence . _entityVal . _examOccurrenceStart <> like examStart . _Just) . to utcToZonedTime) (row ^. resultExamResult . _entityVal . _examResultResult) - , dbtCsvName = unpack csvName + , dbtCsvName, dbtCsvSheetName , dbtCsvNoExportData = Nothing , dbtCsvHeader = const . return $ Csv.headerOrder (error "headerOrder" :: ExamUserTableCsv) , dbtCsvExampleData = Nothing @@ -430,6 +472,7 @@ postEGradesR tid ssh csh examn = do whenIsJust usersResult join closeWgt <- examCloseWidget (SomeRoute $ CExamR tid ssh csh examn EGradesR) eId + finishWgt <- examFinishWidget (SomeRoute $ CExamR tid ssh csh examn EGradesR) eId hasUsers <- hasReadAccessTo $ CExamR tid ssh csh examn EUsersR siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamOfficeExamUsersHeading) $ do diff --git a/src/Handler/ExternalExam/Correct.hs b/src/Handler/ExternalExam/Correct.hs index 7ce13ccde..c4d359ec6 100644 --- a/src/Handler/ExternalExam/Correct.hs +++ b/src/Handler/ExternalExam/Correct.hs @@ -81,7 +81,7 @@ postEECorrectR tid ssh coursen examn = do , GuessUserSurname (ident :: UserSurname) , GuessUserFirstName (ident :: UserFirstName) ] - in maybe [] (either NonEmpty.toList pure) <$> lift (guessUser pdnf $ Just $ maxCountUserMatches+1) + in maybe [] (either NonEmpty.toList pure) <$> lift (guessUser pdnf . Just $ succ maxCountUserMatches) if | is _Nothing ciqResults, is _Nothing ciqGrade -> do diff --git a/src/Handler/ExternalExam/Edit.hs b/src/Handler/ExternalExam/Edit.hs index 48f4d70a0..05fe04e08 100644 --- a/src/Handler/ExternalExam/Edit.hs +++ b/src/Handler/ExternalExam/Edit.hs @@ -55,6 +55,7 @@ postEEEditR tid ssh coursen examn = do when (is _Nothing replaceRes) $ do audit $ TransactionExternalExamEdit eeId + memcachedByInvalidate AuthCacheExternalExamStaffList $ Proxy @(Set UserId) forM_ (eefStaff `setSymmDiff` staff) $ \change -> if | change `Set.member` eefStaff -> case change of Left invEmail -> do diff --git a/src/Handler/ExternalExam/Form.hs b/src/Handler/ExternalExam/Form.hs index 721f7f611..e62ac2f68 100644 --- a/src/Handler/ExternalExam/Form.hs +++ b/src/Handler/ExternalExam/Form.hs @@ -107,13 +107,13 @@ externalExamForm template = validateForm validateExternalExam $ \html -> do fSettings = fslI MsgExternalExamStaff & setTooltip MsgExternalExamStaffTip fRequired = True -validateExternalExam :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => FormValidator ExternalExamForm m () +validateExternalExam :: (MonadThrow m, MonadAP m) => FormValidator ExternalExamForm m () validateExternalExam = do State.modify $ \eeForm -> eeForm & over _eefOfficeSchools (Set.delete $ eeForm ^. _eefSchool) ExternalExamForm{..} <- State.get - isAdmin <- hasWriteAccessTo $ SchoolR eefSchool SchoolEditR + isAdmin <- lift . hasWriteAccessTo $ SchoolR eefSchool SchoolEditR unless isAdmin $ do uid <- requireAuthId guardValidation MsgExternalExamUserMustBeStaff $ Right uid `Set.member` eefStaff diff --git a/src/Handler/ExternalExam/New.hs b/src/Handler/ExternalExam/New.hs index c509705c3..8b9b65b13 100644 --- a/src/Handler/ExternalExam/New.hs +++ b/src/Handler/ExternalExam/New.hs @@ -42,6 +42,7 @@ postEExamNewR = do forM_ eefOfficeSchools' $ \ExternalExamOfficeSchool{..} -> audit $ TransactionExternalExamOfficeSchoolEdit eeId externalExamOfficeSchoolSchool + memcachedByInvalidate AuthCacheExternalExamStaffList $ Proxy @(Set UserId) let (invites, adds) = partitionEithers $ Set.toList eefStaff eefStaff' = do externalExamStaffUser <- adds diff --git a/src/Handler/Help.hs b/src/Handler/Help.hs index f6070369e..9757fe5f5 100644 --- a/src/Handler/Help.hs +++ b/src/Handler/Help.hs @@ -35,7 +35,7 @@ helpForm mReferer mUid = renderWForm FormStandard $ do let defaultActions = [ ( HIEmail - , Left . Just <$> (Address <$> aopt textField (fslpI MsgName $ mr MsgName) Nothing <*> apreq emailField (fslpI MsgEMail $ mr MsgEMail) Nothing) + , Left . Just <$> (Address <$> aopt textField (fslpI MsgHelpName $ mr MsgHelpName) Nothing <*> apreq emailField (fslpI MsgHelpEmail $ mr MsgEMail) Nothing) ) , ( HIAnonymous , pure $ Left Nothing diff --git a/src/Handler/Info.hs b/src/Handler/Info.hs index 2dc046526..d76a83d7f 100644 --- a/src/Handler/Info.hs +++ b/src/Handler/Info.hs @@ -106,7 +106,7 @@ getGlossaryR = mkI18nWidgetEnum "FAQ" "faq" mkMessageFor ''UniWorX ''FAQItem "messages/faq" "de-de-formal" -faqsWidget :: ( MonadHandler m, HandlerSite m ~ UniWorX +faqsWidget :: ( MonadAP m , MonadThrow m ) => Maybe Natural -> Maybe (Route UniWorX) -> m (Maybe Widget, Bool) @@ -155,7 +155,7 @@ getFaqR = fromMaybe mempty . view _1 =<< faqsWidget Nothing Nothing -showFAQ :: ( MonadHandler m, HandlerSite m ~ UniWorX +showFAQ :: ( MonadAP m , MonadThrow m ) => Route UniWorX -> FAQItem -> m Bool diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index c5255744f..6688ca520 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -63,7 +63,7 @@ makeMaterialForm cid template = identifyForm FIDmaterial $ \html -> do (mfDescription <$> template) <*> aopt utcTimeField (fslI MsgMaterialVisibleFrom & setTooltip visibleToolTip) ((mfVisibleFrom <$> template) <|> pure (Just ctime)) - <*> aopt (multiFileField' . fromMaybe (return ()) $ mfFiles =<< template) + <*> aopt (multiFileField' . maybeVoid $ mfFiles =<< template) (fslI MsgMaterialFiles) (mfFiles <$> template) fetchMaterial :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> DB (Entity Material) @@ -326,7 +326,7 @@ handleMaterialEdit tid ssh csh cid template dbMaterial = do case mbmid of Nothing -> False <$ addMessageI Error (MsgMaterialNameDup tid ssh csh mfName) (Just mid) -> do -- save files in DB - insertMaterialFile' mid $ fromMaybe (return ()) mfFiles + insertMaterialFile' mid $ maybeVoid mfFiles addMessageI Success $ MsgMaterialSaveOk tid ssh csh mfName -- more info/warnings could go here return True diff --git a/src/Handler/News.hs b/src/Handler/News.hs index 82504c37e..d7be7045d 100644 --- a/src/Handler/News.hs +++ b/src/Handler/News.hs @@ -70,7 +70,7 @@ newsSystemMessages = do (messages', Any anyHidden) <- liftHandler . runDB . runConduit . C.runWriterLC $ transPipe lift (selectKeys [] []) - .| C.filterM (hasReadAccessTo . MessageR <=< encrypt) + .| C.filterM (lift . hasReadAccessTo . MessageR <=< encrypt) .| transPipe lift (C.mapMaybeM $ \smId -> fmap (\args@(sm, _) -> (smId, sm, systemMessageToTranslation smId args)) <$> getSystemMessage smId) .| C.filter (\(_, SystemMessage{..}, _) -> NTop systemMessageFrom <= NTop (Just now) && NTop (Just now) < NTop systemMessageTo) .| C.mapMaybeM checkHidden @@ -265,8 +265,8 @@ newsUpcomingExams uid = do let Entity _ Exam{..} = view lensExam dbrOutput Entity _ Course{..} = view lensCourse dbrOutput indicatorCell <> anchorCell (CExamR courseTerm courseSchool courseShorthand examName EShowR) examName - , sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom - , sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo + , sortable (Just "register-from") (i18nCell MsgTableExamRegisterFrom) $ \DBRow { dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom + , sortable (Just "register-to") (i18nCell MsgTableExamRegisterTo) $ \DBRow { dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo , sortable (Just "time") (i18nCell MsgTableExamTime) $ \DBRow{ dbrOutput } -> if | Just (Entity _ ExamOccurrence{..}) <- preview lensOccurrence dbrOutput -> cell $ formatTimeRangeW SelFormatDateTime examOccurrenceStart examOccurrenceEnd diff --git a/src/Handler/Participants.hs b/src/Handler/Participants.hs index 7d2f6ee82..6a27a8375 100644 --- a/src/Handler/Participants.hs +++ b/src/Handler/Participants.hs @@ -67,9 +67,8 @@ getParticipantsListR = do getParticipantsR :: TermId -> SchoolId -> Handler TypedContent getParticipantsR tid ssh = do - csvName <- timestampCsv <*> fmap ((flip addExtension `on` unpack) extensionCsv) (getMessageRender <*> pure (MsgParticipantsCsvName tid ssh)) - setContentDisposition' $ Just csvName - respondDefaultOrderedCsvDB $ E.selectSource partQuery .| C.map toParticipantEntry + setContentDispositionCsv $ MsgParticipantsCsvName tid ssh + respondDefaultOrderedCsvDB (MsgParticipantsCsvSheetName tid ssh) $ E.selectSource partQuery .| C.map toParticipantEntry where partQuery = E.from $ \(course `E.InnerJoin` participant `E.InnerJoin` user) -> do E.on $ user E.^. UserId E.==. participant E.^. CourseParticipantUser diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index f269c7c1d..72ef3402e 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -151,7 +151,7 @@ schoolsForm template = formToAForm $ schoolsFormView =<< renderWForm FormStandar notificationForm :: Maybe NotificationSettings -> AForm Handler NotificationSettings notificationForm template = wFormToAForm $ do mbUid <- liftHandler maybeAuthId - isAdmin <- hasReadAccessTo AdminR + isAdmin <- lift . lift $ hasReadAccessTo AdminR let sectionIsHidden :: NotificationTriggerKind -> DB Bool @@ -565,7 +565,7 @@ mkEnrolledCoursesTable = <*> view _courseSchool , sortable (Just "course") (i18nCell MsgTableCourse) $ courseCell <$> view (_dbrOutput . _1 . _entityVal) - , sortable (Just "time") (i18nCell MsgRegistered) $ do + , sortable (Just "time") (i18nCell MsgProfileRegistered) $ do regTime <- view $ _dbrOutput . _2 return $ dateTimeCell regTime ] diff --git a/src/Handler/Sheet/CorrectorInvite.hs b/src/Handler/Sheet/CorrectorInvite.hs index da23c0b78..ea4e29d83 100644 --- a/src/Handler/Sheet/CorrectorInvite.hs +++ b/src/Handler/Sheet/CorrectorInvite.hs @@ -74,7 +74,7 @@ correctorInvitationConfig = InvitationConfig{..} return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing invitationRestriction _ _ = return Authorized invitationForm _ (InvDBDataSheetCorrector cLoad cState, _) _ = pure (JunctionSheetCorrector cLoad cState, ()) - invitationInsertHook _ _ _ _ _ = id + invitationInsertHook _ _ _ _ _ = (*>) (memcachedByInvalidate AuthCacheCorrectorList $ Proxy @(Set UserId)) invitationSuccessMsg (Entity _ Sheet{..}) _ = return . SomeMessage $ MsgCorrectorInvitationAccepted sheetName invitationUltDest (Entity _ Sheet{..}) _ = do Course{..} <- get404 sheetCourse diff --git a/src/Handler/Sheet/Edit.hs b/src/Handler/Sheet/Edit.hs index 5acf81fc6..5ac173421 100644 --- a/src/Handler/Sheet/Edit.hs +++ b/src/Handler/Sheet/Edit.hs @@ -92,10 +92,10 @@ handleSheetEdit tid ssh csh msId template dbAction = do case mbsid of Nothing -> False <$ addMessageI Error (MsgSheetNameDup tid ssh csh sfName) (Just sid) -> do -- save files in DB: - insertSheetFile' sid SheetExercise $ fromMaybe (return ()) sfSheetF - insertSheetFile' sid SheetHint $ fromMaybe (return ()) sfHintF - insertSheetFile' sid SheetSolution $ fromMaybe (return ()) sfSolutionF - insertSheetFile' sid SheetMarking $ fromMaybe (return ()) sfMarkingF + insertSheetFile' sid SheetExercise $ maybeVoid sfSheetF + insertSheetFile' sid SheetHint $ maybeVoid sfHintF + insertSheetFile' sid SheetSolution $ maybeVoid sfSolutionF + insertSheetFile' sid SheetMarking $ maybeVoid sfMarkingF runConduit $ maybe (return ()) (transPipe liftHandler) (spffFiles =<< sfPersonalF) .| sinkPersonalisedSheetFiles cid sid (maybe False spffFilesKeepExisting sfPersonalF) @@ -120,6 +120,7 @@ handleSheetEdit tid ssh csh msId template dbAction = do deleteWhere [ SheetCorrectorSheet ==. sid ] insertMany_ adds + memcachedByInvalidate AuthCacheCorrectorList (Proxy @(Set UserId)) deleteWhere [InvitationFor ==. invRef @SheetCorrector sid, InvitationEmail /<-. toListOf (folded . _1) invites] sinkInvitationsF correctorInvitationConfig invites diff --git a/src/Handler/Sheet/Form.hs b/src/Handler/Sheet/Form.hs index 98ed7b9e6..375325a06 100644 --- a/src/Handler/Sheet/Form.hs +++ b/src/Handler/Sheet/Form.hs @@ -120,7 +120,7 @@ makeSheetForm cId msId template = identifyForm FIDsheet . validateForm validateS ) ] ) - guardM $ hasReadAccessTo downloadRoute + guardM . lift $ hasReadAccessTo downloadRoute messageIconWidget Info IconFileUser [whamlet| $newline never diff --git a/src/Handler/Sheet/List.hs b/src/Handler/Sheet/List.hs index 6981439d4..339ce954a 100644 --- a/src/Handler/Sheet/List.hs +++ b/src/Handler/Sheet/List.hs @@ -95,7 +95,7 @@ getSheetListR tid ssh csh = do acell = anchorCellM mkRoute $(widgetFile "widgets/rating/rating") tellStats = do r <- mkRoute - showRating <- hasReadAccessTo r + showRating <- lift $ hasReadAccessTo r tell . stats $ bool Nothing submissionRatingPoints showRating in acell & cellContents %~ (<* tellStats) diff --git a/src/Handler/Sheet/PersonalisedFiles.hs b/src/Handler/Sheet/PersonalisedFiles.hs index c69b954ef..5d19b0e51 100644 --- a/src/Handler/Sheet/PersonalisedFiles.hs +++ b/src/Handler/Sheet/PersonalisedFiles.hs @@ -260,7 +260,7 @@ sourcePersonalisedSheetFiles cId mbsid mbuids anonMode restrs = do suf <- lift . lift $ genSuffixes courseParticipantUser _sufCache %= Map.insert courseParticipantUser suf return suf - cID <- either throwM return . (runReaderT ?? cIDKey) $ I.encrypt courseParticipantUser + cID <- throwLeft . (runReaderT ?? cIDKey) $ I.encrypt courseParticipantUser let dirName = unpack . Text.intercalate "_" . map pack $ suffix `snoc` mkPersonalisedFilesDirectory mbIdx cID unlessM (uses _dirCache $ Set.member dirName) $ do yield $ Right File diff --git a/src/Handler/Sheet/Show.hs b/src/Handler/Sheet/Show.hs index a438bfd42..9c69bea90 100644 --- a/src/Handler/Sheet/Show.hs +++ b/src/Handler/Sheet/Show.hs @@ -129,7 +129,7 @@ getSShowR tid ssh csh shn = do mRequiredExamLink <- runMaybeT $ do (etid, essh, ecsh, examn) <- hoistMaybe mRequiredExam let eUrl = CExamR etid essh ecsh examn EShowR - guardM $ hasReadAccessTo eUrl + guardM . lift $ hasReadAccessTo eUrl return eUrl mMissingExamRegistration <- for (guardOnM checkExamRegistration $ sheetRequireExamRegistration sheet) $ \eId -> maybeT (return True) $ do uid <- MaybeT maybeAuthId @@ -148,7 +148,7 @@ getSShowR tid ssh csh shn = do submissionModeNoneWithoutNotGradedWarning <- runMaybeT $ do guard $ classifySubmissionMode (sheetSubmissionMode sheet) == SubmissionModeNone && sheetType sheet /= NotGraded - guardM . hasWriteAccessTo $ CSheetR tid ssh csh shn SEditR + guardM . lift . hasWriteAccessTo $ CSheetR tid ssh csh shn SEditR return $ notification NotificationBroad =<< messageI Warning MsgSheetSubmissionModeNoneWithoutNotGraded sTypeDesc <- runDB $ sheetTypeDescription (sheetCourse sheet) (sheetType sheet) @@ -162,7 +162,7 @@ getSShowR tid ssh csh shn = do sheetTo <- traverse (formatTime SelFormatDateTime) $ sheetActiveTo sheet hintsFrom <- traverse (formatTime SelFormatDateTime) $ sheetHintFrom sheet solutionFrom <- traverse (formatTime SelFormatDateTime) $ sheetSolutionFrom sheet - markingText <- runMaybeT $ assertM_ (Authorized ==) (evalAccessCorrector tid ssh csh) >> hoistMaybe (sheetMarkingText sheet) + markingText <- runMaybeT $ assertM_ (Authorized ==) (lift $ evalAccessCorrector tid ssh csh) >> hoistMaybe (sheetMarkingText sheet) submissionTip <- messageI Info MsgSheetCorrectorSubmissionsTip tr <- getTranslate $(widgetFile "sheetShow") diff --git a/src/Handler/Submission/Correction.hs b/src/Handler/Submission/Correction.hs index 0ff09ad33..fa69877d1 100644 --- a/src/Handler/Submission/Correction.hs +++ b/src/Handler/Submission/Correction.hs @@ -52,8 +52,11 @@ postCorrectionR tid ssh csh shn cid = do ur <- getUrlRenderParams tr <- getTranslate case results of - [(Entity cId Course{}, Entity shId Sheet{..}, Entity _ subm@Submission{..}, corrector, E.Value filesCorrected)] -> do - sheetTypeDesc <- runDB $ sheetTypeDescription cId sheetType + [(Entity cId Course{}, Entity shId Sheet{..}, subEnt@(Entity _ subm@Submission{..}), corrector, E.Value filesCorrected)] -> do + (sheetTypeDesc, invisibleWidget) <- runDB $ do + sheetTypeDesc <- sheetTypeDescription cId sheetType + invisibleWidget <- correctionInvisibleWidget tid ssh csh shn cid subEnt + return (sheetTypeDesc, invisibleWidget) let ratingComment = submissionRatingComment >>= (\c -> c <$ guard (not $ null c)) . Text.strip pointsForm = case sheetType of NotGraded @@ -115,10 +118,6 @@ postCorrectionR tid ssh csh shn cid = do , SubmissionRatingComment =. ratingComment' ] - when (rated && is _Nothing submissionRatingTime) $ do - $logDebugS "CorrectionR" [st|Rated #{tshow sub}|] - queueDBJob . JobQueueNotification $ NotificationSubmissionRated sub - addMessageI Success $ if | rated -> MsgRatingUpdated | is _Nothing ratingComment' @@ -142,7 +141,7 @@ postCorrectionR tid ssh csh shn cid = do headingWgt = [whamlet| $newline never _{heading} - $if not (submissionRatingDone subm) + $if is _Just invisibleWidget || not (submissionRatingDone subm) \ ^{isVisibleWidget False} |] @@ -150,6 +149,7 @@ postCorrectionR tid ssh csh shn cid = do setTitleI heading urlArchive <- toTextUrl . CSubmissionR tid ssh csh shn cid $ SubArchiveR SubmissionCorrected let userCorrection = $(widgetFile "correction-user") + maybeVoid invisibleWidget $(widgetFile "correction") _ -> notFound getCorrectionUserR tid ssh csh shn cid = do diff --git a/src/Handler/Submission/Download.hs b/src/Handler/Submission/Download.hs index 0e0e1d62c..59adad1c1 100644 --- a/src/Handler/Submission/Download.hs +++ b/src/Handler/Submission/Download.hs @@ -17,14 +17,14 @@ import qualified Data.Conduit.Combinators as Conduit subDownloadSource :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> FilePath -> ConduitT () SubmissionFile (YesodDB UniWorX) () -subDownloadSource tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = maybeT (return ()) $ do +subDownloadSource tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = maybeT_ $ do (submissionID, isRating) <- hoist lift $ do submissionID <- lift $ submissionMatchesSheet tid ssh csh shn cID isRating <- lift $ (== Just submissionID) <$> isRatingFile path when (isUpdate || isRating) $ - guardM . hasReadAccessTo $ CSubmissionR tid ssh csh shn cID CorrectionR + guardM . lift . hasReadAccessTo $ CSubmissionR tid ssh csh shn cID CorrectionR return (submissionID, isRating) @@ -57,9 +57,9 @@ getSubDownloadR tid ssh csh shn cID sft@(submissionFileTypeIsUpdate -> isUpdate) subArchiveSource :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> ConduitT () (Either SubmissionFile DBFile) (YesodDB UniWorX) () -subArchiveSource tid ssh csh shn cID sfType = maybeT (return ()) $ do +subArchiveSource tid ssh csh shn cID sfType = maybeT_ $ do when (sfType == SubmissionCorrected) $ - guardM . hasReadAccessTo $ CSubmissionR tid ssh csh shn cID CorrectionR + guardM . lift . lift . hasReadAccessTo $ CSubmissionR tid ssh csh shn cID CorrectionR lift $ do submissionID <- lift $ submissionMatchesSheet tid ssh csh shn cID diff --git a/src/Handler/Submission/Helper.hs b/src/Handler/Submission/Helper.hs index 7ed49a760..7b73b48f7 100644 --- a/src/Handler/Submission/Helper.hs +++ b/src/Handler/Submission/Helper.hs @@ -29,12 +29,21 @@ import Data.Aeson.Lens import Handler.Submission.SubmissionUserInvite +import qualified Data.Conduit.Combinators as C -makeSubmissionForm :: CourseId -> Maybe SubmissionId -> UploadMode -> SheetGroup -> Bool -> Set (Either UserEmail UserId) -> Form (Maybe FileUploads, Set (Either UserEmail UserId)) -makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = identifyForm FIDsubmission . renderAForm FormStandard $ (,) - <$> fileUploadForm (not isLecturer && is _Nothing msmid) (fslI . bool MsgSubmissionFile MsgSubmissionArchive) uploadMode + +makeSubmissionForm :: CourseId -> SheetId -> Maybe SubmissionId -> UploadMode -> SheetGroup -> Maybe FileUploads -> Bool -> Set (Either UserEmail UserId) -> Form (Maybe FileUploads, Set (Either UserEmail UserId)) +makeSubmissionForm cid shid msmid uploadMode grouping mPrev isLecturer prefillUsers = identifyForm FIDsubmission . renderAForm FormStandard $ (,) + <$> uploadForm <*> wFormToAForm submittorsForm' where + uploadForm + | is _NoUpload uploadMode = pure Nothing + | is _Nothing msmid = uploadForm' + | otherwise = join <$> optionalActionNegatedA uploadForm' (fslI MsgSubmissionFilesUnchanged & setTooltip MsgSubmissionFilesUnchangedTip) (Just False) + + uploadForm' = fileUploadForm (not isLecturer) (fslI . bool MsgSubmissionFile MsgSubmissionArchive) uploadMode mPrev + miCell' :: Markup -> Either UserEmail UserId -> Widget miCell' csrf (Left email) = do invWarnMsg <- messageIconI Info IconEmail $ if @@ -42,7 +51,17 @@ makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = ident | otherwise -> MsgEmailInvitationWarningPrevCoSubmittors $(widgetFile "widgets/massinput/submissionUsers/cellInvitation") miCell' csrf (Right uid) = do - User{..} <- liftHandler . runDB $ getJust uid + (User{..}, hasSubmitted) <- liftHandler . runDB $ do + user <- getJust uid + hasSubmitted <- E.selectExists . E.from $ \(submissionUser `E.InnerJoin` submission) -> do + E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId + E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val uid + E.&&. submission E.^. SubmissionSheet E.==. E.val shid + whenIsJust msmid $ \smid -> + E.where_ $ submission E.^. SubmissionId E.!=. E.val smid + return (user, hasSubmitted) + knownWarning <- runMaybeT $ + guardOnM hasSubmitted $ messageIconI Error IconSubmissionUserDuplicate MsgSubmissionUserDuplicateWarning $(widgetFile "widgets/massinput/submissionUsers/cellKnown") miLayout :: ListLength @@ -101,7 +120,7 @@ makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = ident miButtonAction' mCurrent frag = mCurrent <&> \current -> SomeRoute (current :#: frag) submittorsForm' = maybeT submittorsForm $ do - restr <- MaybeT (maybeCurrentBearerRestrictions @Value) >>= hoistMaybe . preview (_Object . ix "submittors" . _Array) + restr <- MaybeT (liftHandler $ maybeCurrentBearerRestrictions @Value) >>= hoistMaybe . preview (_Object . ix "submittors" . _Array) let _Submittor = prism (either toJSON toJSON) $ \x -> first (const x) $ JSON.parseEither (\x' -> fmap Right (parseJSON x') <|> fmap Left (parseJSON x')) x submittors <- fmap (pure @FormResult @[Either UserEmail CryptoUUIDUser]) . forM (toList restr) $ hoistMaybe . preview _Submittor fmap Set.fromList <$> forMOf (traverse . traverse . _Right) submittors decrypt @@ -310,8 +329,9 @@ submissionHelper tid ssh csh shn mcid = do -- @submissionModeUser == Nothing@ below iff we are currently serving a user with elevated rights (lecturer, admin, ...) -- Therefore we do not restrict upload behaviour in any way in that case ((res,formWidget'), formEnctype) <- do - (Entity _ Sheet{..}, buddies, _, _, isLecturer, isOwner, _, _) <- runDB getSheetInfo - runFormPost . makeSubmissionForm sheetCourse msmid (fromMaybe (UploadAny True Nothing True) . submissionModeUser $ sheetSubmissionMode) sheetGrouping isLecturer $ bool id (maybe id (Set.insert . Right) muid) isOwner buddies + (Entity shid Sheet{..}, buddies, _, _, isLecturer, isOwner, _, _) <- runDB getSheetInfo + let mPrevUploads = msmid <&> \smid -> runDBSource $ selectSource [SubmissionFileSubmission ==. smid, SubmissionFileIsUpdate ==. False] [Asc SubmissionFileTitle] .| C.map (view $ _FileReference . _1) + runFormPost . makeSubmissionForm sheetCourse shid msmid (fromMaybe (UploadAny True Nothing True) . submissionModeUser $ sheetSubmissionMode) sheetGrouping mPrevUploads isLecturer $ bool id (maybe id (Set.insert . Right) muid) isOwner buddies let formWidget = wrapForm' BtnHandIn formWidget' def { formAction = Just $ SomeRoute actionUrl , formEncoding = formEnctype @@ -350,6 +370,7 @@ submissionHelper tid ssh csh shn mcid = do (FormFailure failmsgs) -> return $ FormFailure failmsgs (FormSuccess res'@(_, groupMembers)) | groupMembers == subUsersOld -> return $ FormSuccess res' + | isLecturer -> return $ FormSuccess res' | Arbitrary{..} <- sheetGrouping -> do -- Validate AdHoc Group Members let (gEMails, gIds) = partitionEithers $ Set.toList groupMembers prep :: [(E.Value UserEmail, (E.Value UserId, E.Value Bool, E.Value Bool))] -> Map UserEmail (Maybe (UserId, Bool, Bool)) @@ -476,9 +497,13 @@ submissionHelper tid ssh csh shn mcid = do | otherwise -> redirect $ CSheetR tid ssh csh shn SShowR Nothing -> return () - (Entity _ Sheet{..}, _, lastEdits, maySubmit, _, _, msubmission, corrector) <- runDB getSheetInfo + (Entity shid Sheet{..}, _, lastEdits, maySubmit, _, _, msubmission, corrector) <- runDB getSheetInfo - showCorrection <- fmap (fromMaybe False) . for mcid $ \cid -> hasReadAccessTo $ CSubmissionR tid ssh csh shn cid CorrectionR + (showCorrection, correctionInvisible) <- fmap (fromMaybe (False, Nothing)) . for ((,) <$> mcid <*> (Entity <$> msmid <*> msubmission)) $ \(cid, subEnt) -> runDB $ do + showCorrection <- hasReadAccessTo $ CSubmissionR tid ssh csh shn cid CorrectionR + correctionInvisible <- correctionInvisibleWidget tid ssh csh shn cid subEnt + + return (showCorrection, correctionInvisible) -- Maybe construct a table to display uploaded archive files let colonnadeFiles :: _ -> Colonnade Sortable _ (DBCell (HandlerFor UniWorX) ()) @@ -551,13 +576,36 @@ submissionHelper tid ssh csh shn mcid = do sheetTypeDesc <- liftHandler . runDB $ sheetTypeDescription sheetCourse sheetType + multipleSubmissionWarnWidget <- runDB . runMaybeT $ do + subId <- hoistMaybe msmid + cID <- hoistMaybe mcid + guardM . lift $ orM + [ hasWriteAccessTo $ CSubmissionR tid ssh csh shn cID SubDelR + , hasWriteAccessTo $ CSubmissionR tid ssh csh shn cID SubShowR + , hasWriteAccessTo $ CSubmissionR tid ssh csh shn cID CorrectionR + , hasReadAccessTo $ CSheetR tid ssh csh shn SSubsR + ] + guardM . lift . E.selectExists . E.from $ \(submissionUser `E.InnerJoin` (otherSubmissionUser `E.InnerJoin` submission)) -> do + E.on $ otherSubmissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId + E.on $ submissionUser E.^. SubmissionUserSubmission E.!=. otherSubmissionUser E.^. SubmissionUserSubmission + E.&&. submissionUser E.^. SubmissionUserUser E.==. otherSubmissionUser E.^. SubmissionUserUser + E.where_ $ submission E.^. SubmissionSheet E.==. E.val shid + E.&&. submission E.^. SubmissionId E.!=. E.val subId + E.&&. submissionUser E.^. SubmissionUserSubmission E.==. E.val subId + return $ notification NotificationBroad =<< messageIconI Warning IconSubmissionUserDuplicate MsgSubmissionSomeUsersDuplicateWarning + defaultLayout $ do setTitleI $ MsgHeadingSubmissionEditHead tid ssh csh shn (urlArchive, urlOriginal) <- fmap ((,) <$> preview (_Just . _1) <*> preview (_Just . _2)) . for mcid $ \cID -> let mkUrl sft = toTextUrl . CSubmissionR tid ssh csh shn cID $ SubArchiveR sft in liftHandler . runDB $ (,) <$> mkUrl SubmissionCorrected <*> mkUrl SubmissionOriginal tr <- getTranslate - let correctionWdgt = guardOnM (showCorrection && maybe False submissionRatingDone msubmission) ((,) <$> msubmission <*> mcid) <&> \(Submission{..}, cid) -> + let correctionWdgt = guardOnM (showCorrection && maybe False submissionRatingTouched msubmission) ((,) <$> msubmission <*> mcid) <&> \(Submission{..}, cid) -> let ratingComment = assertM (not . null) $ Text.strip <$> submissionRatingComment in $(widgetFile "correction-user") + where submissionRatingTouched sub@Submission{..} = or + [ submissionRatingDone sub + , is _Just submissionRatingPoints, is _Just submissionRatingComment + ] + correctionVisibleWarnWidget = guardOnM (is _Just msubmission && is _Just mcid && showCorrection) correctionInvisible $(widgetFile "submission") diff --git a/src/Handler/Tutorial/Communication.hs b/src/Handler/Tutorial/Communication.hs index c09447ffb..70ca14d52 100644 --- a/src/Handler/Tutorial/Communication.hs +++ b/src/Handler/Tutorial/Communication.hs @@ -21,7 +21,7 @@ postTCommR tid ssh csh tutn = do tuts <- selectList [TutorialCourse ==. cid] [] usertuts <- forMaybeM tuts $ \(Entity tutid Tutorial{..}) -> do cID <- encrypt tutid - guardM . hasReadAccessTo $ CTutorialR tid ssh csh tutorialName TUsersR + guardM . lift . hasReadAccessTo $ CTutorialR tid ssh csh tutorialName TUsersR return ( RGTutorialParticipants cID , E.from $ \(user `E.InnerJoin` participant) -> do E.on $ user E.^. UserId E.==. participant E.^. TutorialParticipantUser diff --git a/src/Handler/Tutorial/Edit.hs b/src/Handler/Tutorial/Edit.hs index 753685c26..c8a9ce789 100644 --- a/src/Handler/Tutorial/Edit.hs +++ b/src/Handler/Tutorial/Edit.hs @@ -78,6 +78,7 @@ postTEditR tid ssh csh tutn = do deleteWhere [ InvitationFor ==. invRef @Tutor tutid, InvitationEmail /<-. invites ] sinkInvitationsF tutorInvitationConfig $ map (, tutid, (InvDBDataTutor, InvTokenDataTutor)) invites + memcachedByInvalidate AuthCacheTutorList $ Proxy @(Set UserId) return insertRes case insertRes of Just _ -> addMessageI Error $ MsgTutorialNameTaken tfName diff --git a/src/Handler/Tutorial/New.hs b/src/Handler/Tutorial/New.hs index 728e264ec..32a88670e 100644 --- a/src/Handler/Tutorial/New.hs +++ b/src/Handler/Tutorial/New.hs @@ -43,6 +43,7 @@ postCTutorialNewR tid ssh csh = do let (invites, adds) = partitionEithers $ Set.toList tfTutors insertMany_ $ map (Tutor tutid) adds + memcachedByInvalidate AuthCacheTutorList $ Proxy @(Set UserId) sinkInvitationsF tutorInvitationConfig $ map (, tutid, (InvDBDataTutor, InvTokenDataTutor)) invites return insertRes case insertRes of diff --git a/src/Handler/Tutorial/TutorInvite.hs b/src/Handler/Tutorial/TutorInvite.hs index 39bb9272a..410f4e5d5 100644 --- a/src/Handler/Tutorial/TutorInvite.hs +++ b/src/Handler/Tutorial/TutorInvite.hs @@ -9,6 +9,7 @@ module Handler.Tutorial.TutorInvite import Import import Handler.Utils.Tutorial import Handler.Utils.Invitations +import Handler.Utils.Memcached import Data.Aeson hiding (Result(..)) @@ -69,8 +70,8 @@ tutorInvitationConfig = InvitationConfig{..} return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing invitationRestriction _ _ = return Authorized invitationForm _ _ _ = pure (JunctionTutor, ()) - invitationInsertHook _ _ _ _ _ = id - invitationSuccessMsg (Entity _ Tutorial{..}) _ = return . SomeMessage $ MsgTutorCorrectorInvitationAccepted tutorialName + invitationInsertHook _ _ _ _ _ = (*>) (memcachedByInvalidate AuthCacheTutorList $ Proxy @(Set UserId)) + invitationSuccessMsg (Entity _ Tutorial{..}) _ = return . SomeMessage $ MsgCorrectorInvitationAccepted tutorialName invitationUltDest (Entity _ Tutorial{..}) _ = do Course{..} <- get404 tutorialCourse return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CTutorialListR diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 08ef33891..be1bc9520 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -84,7 +84,7 @@ postUsersR = do -- , sortable (Just "last-name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM -- (AdminUserR <$> encrypt uid) -- (toWidget . display $ last $ impureNonNull $ words $ userDisplayName) - , sortable (Just "auth-ldap") (i18nCell MsgAuthModeSet) $ \DBRow{ dbrOutput = Entity _ User{..} } -> i18nCell userAuthentication + , sortable (Just "auth-ldap") (i18nCell MsgAuthMode) $ \DBRow{ dbrOutput = Entity _ User{..} } -> i18nCell userAuthentication , sortable (Just "ldap-sync") (i18nCell MsgLdapSynced) $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastLdapSynchronisation , flip foldMap universeF $ \function -> sortable Nothing (i18nCell function) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do @@ -108,7 +108,7 @@ postUsersR = do , formCellLens = id , formCellContents = do cID <- encrypt uid - mayHijack <- (== Authorized) <$> evalAccess (AdminHijackUserR cID) True + mayHijack <- lift . lift $ (== Authorized) <$> evalAccess (AdminHijackUserR cID) True myUid <- liftHandler maybeAuthId if | mayHijack @@ -194,7 +194,7 @@ postUsersR = do [ prismAForm (singletonFilter "user-search") mPrev $ aopt textField (fslI MsgName) -- , prismAForm (singletonFilter "matriculation" ) mPrev $ aopt textField (fslI MsgTableMatrikelNr) , prismAForm (singletonFilter "matriculation") mPrev $ aopt matriculationField (fslI MsgTableMatrikelNr) - , prismAForm (singletonFilter "auth-ldap" . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` selectFieldList [(MsgAuthPWHash "", False), (MsgAuthLDAP, True)]) (fslI MsgAuthModeSet) + , prismAForm (singletonFilter "auth-ldap" . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` selectFieldList [(MsgAuthPWHash "", False), (MsgAuthLDAP, True)]) (fslI MsgAuthMode) , prismAForm (singletonFilter "school") mPrev $ aopt (lift `hoistField` selectFieldList schoolOptions) (fslI MsgCourseSchool) , prismAForm (singletonFilter "ldap-sync" . maybePrism _PathPiece) mPrev $ aopt utcTimeField (fslI MsgLdapSyncedBefore) ] @@ -207,7 +207,7 @@ postUsersR = do , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just - <$> areq (selectField $ optionsF [UserLdapSync]) (fslI MsgAction) Nothing + <$> areq (selectField $ optionsF [UserLdapSync]) (fslI MsgTableAction) Nothing , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormResult = id , dbParamsFormIdent = def @@ -319,7 +319,7 @@ postAdminUserR uuid = do -- above data is needed for both form generation and result evaluation let userRightsForm :: Form (Set (SchoolFunction, SchoolId)) - userRightsForm = identifyForm FIDuserRights $ \csrf -> do + userRightsForm csrf = do boxRights <- sequence . flip Map.fromSet (allFunctions `setProduct` allSchools) $ \(function, sid) -> if | sid `Set.member` adminSchools -> mpopt checkBoxField "" . Just $ (function, sid) `Set.member` functions @@ -339,6 +339,8 @@ postAdminUserR uuid = do if | not $ Set.null updates -> runDBJobs $ do $logInfoS "user-rights-update" $ tshow updates + forM_ (setOf (folded . _1) updates) $ \func -> + memcachedByInvalidate (AuthCacheSchoolFunctionList func) $ Proxy @(Set UserId) forM_ updates $ \(function, sid) -> do $logDebugS "user-rights-update" [st|#{tshow (function, sid)}: #{tshow (Set.member (function, sid) functions)} → #{tshow (Set.member (function,sid) changes)}|] if @@ -394,11 +396,12 @@ postAdminUserR uuid = do let symmDiff = setFromFunc newFuncs `setSymmDiff` setFromFunc systemFunctions if | not $ Set.null symmDiff -> runDBJobs $ do - forM_ symmDiff $ \func -> if - | newFuncs func - -> void $ upsert (UserSystemFunction uid func True False) [ UserSystemFunctionIsOptOut =. False, UserSystemFunctionManual =. True ] - | otherwise - -> void $ upsert (UserSystemFunction uid func True True) [ UserSystemFunctionIsOptOut =. True, UserSystemFunctionManual =. True ] + forM_ symmDiff $ \func -> do + memcachedByInvalidate (AuthCacheSystemFunctionList func) $ Proxy @(Set UserId) + if | newFuncs func + -> void $ upsert (UserSystemFunction uid func True False) [ UserSystemFunctionIsOptOut =. False, UserSystemFunctionManual =. True ] + | otherwise + -> void $ upsert (UserSystemFunction uid func True True) [ UserSystemFunctionIsOptOut =. True, UserSystemFunctionManual =. True ] queueDBJob . JobQueueNotification . NotificationUserSystemFunctionsUpdate uid $ setFromFunc systemFunctions addMessageI Success MsgUserSystemFunctionsSaved | otherwise diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index a44d3a5d1..7ca9e1843 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -22,7 +22,7 @@ import Handler.Utils.I18n as Handler.Utils import Handler.Utils.Widgets as Handler.Utils import Handler.Utils.Database as Handler.Utils import Handler.Utils.Occurrences as Handler.Utils -import Handler.Utils.Memcached as Handler.Utils +import Handler.Utils.Memcached as Handler.Utils hiding (manageMemcachedLocalInvalidations) import Handler.Utils.Files as Handler.Utils import Handler.Utils.Download as Handler.Utils @@ -70,11 +70,12 @@ warnTermDays tid timeNames = do -- | return a value only if the current user ist authorized for a given route -guardAuthorizedFor :: ( HandlerSite h ~ UniWorX, MonadHandler h, MonadThrow h - , MonadTrans m, MonadPlus (m (ReaderT SqlBackend h))) - => Route UniWorX -> a -> m (ReaderT SqlBackend h) a -guardAuthorizedFor link val = - val <$ guardM (lift $ (== Authorized) <$> evalAccessDB link False) +guardAuthorizedFor :: ( MonadThrow m + , MonadTrans t, MonadPlus (t (ReaderT SqlBackend m)) + , MonadAP (ReaderT SqlBackend m) + ) + => Route UniWorX -> a -> t (ReaderT SqlBackend m) a +guardAuthorizedFor link = guardMOn . lift $ hasReadAccessTo link runAppLoggingT :: UniWorX -> LoggingT m a -> m a diff --git a/src/Handler/Utils/Course.hs b/src/Handler/Utils/Course.hs index bc4e3ce48..34b671b7d 100644 --- a/src/Handler/Utils/Course.hs +++ b/src/Handler/Utils/Course.hs @@ -2,6 +2,7 @@ module Handler.Utils.Course where import Import import Handler.Utils.Delete +import Handler.Utils.Memcached import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E @@ -48,8 +49,9 @@ setUsersSubmissionGroup cid uids Nothing = do didDelete <- fmap (> 0) . E.deleteCount . E.from $ \submissionGroupUser -> E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid E.&&. E.subSelectForeign submissionGroupUser SubmissionGroupUserSubmissionGroup (E.^. SubmissionGroupCourse) E.==. E.val cid - when didDelete $ + when didDelete $ do audit $ TransactionSubmissionGroupUnset cid uid + memcachedByInvalidate AuthCacheSubmissionGroupUserList (Proxy @(Set UserId)) return $ bool mempty (Sum 1) didDelete E.delete . E.from $ \submissionGroup -> E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val cid @@ -68,8 +70,9 @@ setUsersSubmissionGroup cid uids (Just grp) = do E.&&. submissionGroup E.^. SubmissionGroupId E.!=. E.val gId fmap getSum . flip foldMapM uids $ \uid -> do didSet <- fmap (is _Just) . insertUnique $ SubmissionGroupUser gId uid - when didSet $ + when didSet $ do audit $ TransactionSubmissionGroupSet cid uid grp + memcachedByInvalidate AuthCacheSubmissionGroupUserList (Proxy @(Set UserId)) return $ bool mempty (Sum 1) didSet showCourseEventRoom :: forall courseEvent courseId. diff --git a/src/Handler/Utils/Csv.hs b/src/Handler/Utils/Csv.hs index cf090e171..813527281 100644 --- a/src/Handler/Utils/Csv.hs +++ b/src/Handler/Utils/Csv.hs @@ -2,17 +2,20 @@ module Handler.Utils.Csv ( decodeCsv, decodeCsvPositional - , timestampCsv - , encodeCsv + , encodeCsv, encodeCsvWith, encodeCsvRendered, encodeCsvRenderedWith + , csvRenderedToTypedContent, csvRenderedToTypedContentWith + , expectedCsvFormat, expectedCsvContentType , encodeDefaultOrderedCsv , respondCsv, respondCsvDB , respondDefaultOrderedCsv, respondDefaultOrderedCsvDB , fileSourceCsv, fileSourceCsvPositional - , partIsAttachmentCsv + , partIsAttachmentCsv, setContentDispositionCsv + , csvOptionsForFormat , CsvParseError(..) , ToNamedRecord(..), FromNamedRecord(..) , DefaultOrdered(..) , ToField(..), FromField(..) + , recodeCsv ) where import Import hiding (Header, mapM_) @@ -21,14 +24,15 @@ import Data.Csv import Data.Csv.Conduit import Handler.Utils.Form (uploadContents) +import Handler.Utils.ContentDisposition (setContentDisposition') import Control.Monad (mapM_) -- import qualified Data.Csv.Util as Csv import qualified Data.Csv.Parser as Csv -import qualified Data.Conduit.List as C -import qualified Data.Conduit.Combinators as C (sourceLazy) +import qualified Data.Conduit.List as C (mapMaybe) +import qualified Data.Conduit.Combinators as C import qualified Data.Map as Map import qualified Data.Vector as Vector @@ -38,13 +42,18 @@ import qualified Data.ByteString.Lazy as LBS import qualified Data.Attoparsec.ByteString.Lazy as A -import Handler.Utils.DateTime import Data.Time.Format (iso8601DateFormat) import qualified Data.Char as Char import Control.Monad.Error.Class (MonadError(..)) +import Data.Time.Clock.POSIX (getPOSIXTime) + +import qualified Data.Time.Format as Time + +-- import qualified Codec.Archive.Zip as Zip + _haltingCsvParseError :: Prism' CsvParseError CsvStreamHaltParseError @@ -79,22 +88,15 @@ decodeCsvPositional :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m, F decodeCsvPositional hdr = decodeCsv' $ \opts -> fromCsvStreamError opts hdr (review _haltingCsvParseError) .| throwIncrementalErrors -decodeCsv' :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => (forall m'. Monad m' => DecodeOptions -> ConduitT ByteString (MaybeEmptyRecord csv) (ExceptT CsvParseError m') ()) -> ConduitT ByteString csv m () +decodeCsv' :: forall csv m. + ( MonadHandler m, HandlerSite m ~ UniWorX + , MonadThrow m + ) + => (forall m'. Monad m' => DecodeOptions -> ConduitT ByteString (MaybeEmptyRecord csv) (ExceptT CsvParseError m') ()) + -> ConduitT ByteString csv m () decodeCsv' fromCsv' = do encOpts <- maybe def (userCsvOptions . entityVal) <$> lift maybeAuth - - let - recode' - | enc == "UTF8" - = id - | otherwise - = \act -> do - inp <- sinkLazy - let inp' = encodeLazyByteString UTF8 $ decodeLazyByteString enc inp - sourceLazy inp' .| act - where enc = encOpts ^. _csvFormat . _csvEncoding - - recode' decodeCsv'' .| C.mapMaybe unMaybeEmptyRecord + recodeCsv encOpts False decodeCsv'' .| C.mapMaybe unMaybeEmptyRecord where decodeCsv'' = transPipe throwExceptT $ do testBuffer <- accumTestBuffer LBS.empty @@ -160,78 +162,201 @@ decodeCsv' fromCsv' = do encodeCsv :: ( ToNamedRecord csv , MonadHandler m , HandlerSite m ~ UniWorX + , RenderMessage UniWorX msg ) - => Header - -> ConduitT csv ByteString m () + => msg -- ^ Sheet name for .xlsx + -> Header + -> ConduitT csv ByteString m CsvFormat -- ^ Encode a stream of records -- -- Currently not streaming -encodeCsv hdr = do - csvOpts <- maybe def (userCsvOptions . entityVal) <$> lift maybeAuth - let recode' - | enc == "UTF8" - = id - | otherwise - = encodeLazyByteString enc . decodeLazyByteString UTF8 - where enc = csvOpts ^. _csvFormat . _csvEncoding - C.foldMap pure >>= (C.sourceLazy . recode') . encodeByNameWith (csvOpts ^. _csvFormat . _CsvEncodeOptions) hdr +encodeCsv sheetName hdr = do + encOpts <- maybe def (userCsvOptions . entityVal) <$> lift maybeAuth + encodeCsvWith encOpts sheetName hdr + +encodeCsvWith :: ( ToNamedRecord csv + , MonadHandler m + , HandlerSite m ~ UniWorX + , RenderMessage UniWorX msg + ) + => CsvOptions + -> msg -- ^ Sheet name for .xlsx + -> Header + -> ConduitT csv ByteString m CsvFormat +-- ^ Encode a stream of records +-- +-- Currently not streaming +encodeCsvWith encOpts sheetName hdr = transPipe liftHandler $ case encOpts ^. _csvFormat of + CsvFormatOptions{} + | Just csvOpts <- encOpts ^? _csvFormat . _CsvEncodeOptions, has (_csvFormat . _CsvFormat . _FormatCsv) encOpts -> do + (C.sourceLazy . encodeByNameWith csvOpts hdr =<< C.foldMap pure) .| recode' + return FormatCsv + | otherwise -> error "encOpts is CsvFormatOptions but cannot be converted via _CsvEncodeOptions or hasn't _FormatCsv" + CsvXlsxFormatOptions{} + | has (_csvFormat . _CsvFormat . _FormatXlsx) encOpts -> do + rendered <- toCsvRendered hdr <$> C.foldMap (pure @Seq) + sheetName' <- ($ sheetName) <$> getMessageRender + pNow <- liftIO getPOSIXTime + C.sourceLazy (fromXlsx pNow $ csvRenderedToXlsx sheetName' rendered) .| recode' + return FormatXlsx + | otherwise -> error "encOpts hasn't _FormatXlsx" + where recode' = recodeCsv encOpts True $ C.map id + +encodeCsvRendered :: ( MonadHandler m + , HandlerSite m ~ UniWorX + , RenderMessage UniWorX msg + ) + => msg -- ^ Sheet name for .xlsx + -> CsvRendered + -> m (CsvFormat, LBS.ByteString) +encodeCsvRendered sheetName CsvRendered{..} = runConduit $ yieldMany csvRenderedData .| (encodeCsv sheetName csvRenderedHeader `fuseBoth` C.sinkLazy) + +encodeCsvRenderedWith :: ( MonadHandler m + , HandlerSite m ~ UniWorX + , RenderMessage UniWorX msg + ) + => CsvOptions + -> msg -- ^ Sheet name for .xlsx + -> CsvRendered + -> m (CsvFormat, LBS.ByteString) +encodeCsvRenderedWith encOpts sheetName CsvRendered{..} = runConduit $ yieldMany csvRenderedData .| (encodeCsvWith encOpts sheetName csvRenderedHeader `fuseBoth` C.sinkLazy) + +csvRenderedToTypedContent :: ( MonadHandler m + , HandlerSite m ~ UniWorX + , RenderMessage UniWorX msg + ) + => msg -- ^ Sheet name for .xlsx + -> CsvRendered + -> m TypedContent +csvRenderedToTypedContent sheetName csvRendered = do + encOpts <- maybe def (userCsvOptions . entityVal) <$> maybeAuth + csvRenderedToTypedContentWith encOpts sheetName csvRendered + +csvRenderedToTypedContentWith :: ( MonadHandler m + , HandlerSite m ~ UniWorX + , RenderMessage UniWorX msg + ) + => CsvOptions + -> msg -- ^ Sheet name for .xlsx + -> CsvRendered + -> m TypedContent +csvRenderedToTypedContentWith encOpts sheetName csvRendered = do + (csvFormat, resp) <- encodeCsvRenderedWith encOpts sheetName csvRendered + let cType = case csvFormat of + FormatCsv -> typeCsv' + FormatXlsx -> typeXlsx + return . TypedContent cType $ toContent resp + timestampCsv :: ( MonadHandler m , HandlerSite m ~ UniWorX ) => m (FilePath -> FilePath) timestampCsv = do - csvOpts <- maybe def (userCsvOptions . entityVal) <$> maybeAuth - if - | csvOpts ^. _csvTimestamp -> do - ts <- formatTime' (iso8601DateFormat $ Just "%H%M") =<< liftIO getCurrentTime - return $ (<>) (unpack ts <> "-") - | otherwise -> return id + csvOpts <- fmap (maybe def $ userCsvOptions . entityVal) maybeAuth + timestampCsv' csvOpts . review _Wrapped =<< languages + -partIsAttachmentCsv :: (Textual t, MonadMail m, HandlerSite m ~ UniWorX) - => t +timestampCsv' :: MonadIO m + => CsvOptions -> Languages -> m (FilePath -> FilePath) +timestampCsv' csvOpts (Languages langs) = liftIO $ if + | csvOpts ^. _csvTimestamp -> do + ts <- getCurrentTime <&> Time.formatTime (getTimeLocale' langs) (iso8601DateFormat $ Just "%H%M") + return $ (<>) (ts <> "-") + | otherwise -> return id + +expectedCsvFormat :: ( MonadHandler m + , HandlerSite m ~ UniWorX + ) + => m CsvFormat +expectedCsvFormat = view (_csvFormat . _CsvFormat) . maybe def (userCsvOptions . entityVal) <$> maybeAuth + +expectedCsvContentType :: ( MonadHandler m + , HandlerSite m ~ UniWorX + ) + => m ContentType +expectedCsvContentType = expectedCsvFormat <&> \case + FormatCsv -> typeCsv' + FormatXlsx -> typeXlsx + +partIsAttachmentCsv :: (RenderMessage UniWorX msg, MonadMail m, HandlerSite m ~ UniWorX) + => msg -> StateT Part m () -partIsAttachmentCsv (repack -> fName) = do - ts <- timestampCsv - partIsAttachment . ts $ fName `addExtension` unpack extensionCsv +partIsAttachmentCsv fName' = do + csvOpts <- lift askMailCsvOptions + langs <- lift askMailLanguages + fName <- ($ fName') <$> lift getMailMessageRender + ts <- timestampCsv' csvOpts langs + let ext = case csvOpts ^. _csvFormat . _CsvFormat of + FormatCsv -> extensionCsv + FormatXlsx -> extensionXlsx + partIsAttachment . ts $ unpack fName `addExtension` unpack ext -encodeDefaultOrderedCsv :: forall csv m. +setContentDispositionCsv :: (RenderMessage UniWorX msg, MonadHandler m, HandlerSite m ~ UniWorX) + => msg + -> m () +setContentDispositionCsv fName' = do + fName <- unpack . ($ fName') <$> getMessageRender + ts <- timestampCsv + fmt <- expectedCsvFormat + let ext = case fmt of + FormatCsv -> extensionCsv + FormatXlsx -> extensionXlsx + setContentDisposition' . Just $ ensureExtension (unpack ext) (ts fName) + +encodeDefaultOrderedCsv :: forall csv m msg. ( ToNamedRecord csv , DefaultOrdered csv , MonadHandler m , HandlerSite m ~ UniWorX + , RenderMessage UniWorX msg ) - => ConduitT csv ByteString m () -encodeDefaultOrderedCsv = encodeCsv $ headerOrder (error "headerOrder" :: csv) + => msg -- ^ Sheet name for .xlsx + -> ConduitT csv ByteString m CsvFormat +encodeDefaultOrderedCsv sheetName = encodeCsv sheetName $ headerOrder (error "headerOrder" :: csv) -respondCsv :: ToNamedRecord csv - => Header +respondCsv :: ( ToNamedRecord csv + , RenderMessage UniWorX msg + ) + => msg -- ^ Sheet name for .xlsx + -> Header -> ConduitT () csv Handler () -> Handler TypedContent -respondCsv hdr src = respondSource typeCsv' $ src .| encodeCsv hdr .| awaitForever sendChunk +respondCsv sheetName hdr src = do + cType <- expectedCsvContentType + respondSource cType $ src .| void (encodeCsv sheetName hdr) .| awaitForever sendChunk -respondDefaultOrderedCsv :: forall csv. +respondDefaultOrderedCsv :: forall csv msg. ( ToNamedRecord csv , DefaultOrdered csv + , RenderMessage UniWorX msg ) - => ConduitT () csv Handler () + => msg -- ^ Sheet name for .xlsx + -> ConduitT () csv Handler () -> Handler TypedContent -respondDefaultOrderedCsv = respondCsv $ headerOrder (error "headerOrder" :: csv) +respondDefaultOrderedCsv sheetName = respondCsv sheetName $ headerOrder (error "headerOrder" :: csv) -respondCsvDB :: ToNamedRecord csv - => Header +respondCsvDB :: ( ToNamedRecord csv + , RenderMessage UniWorX msg + ) + => msg -- ^ Sheet name for .xlsx + -> Header -> ConduitT () csv DB () -> Handler TypedContent -respondCsvDB hdr src = respondSourceDB typeCsv' $ src .| encodeCsv hdr .| awaitForever sendChunk +respondCsvDB sheetName hdr src = do + cType <- expectedCsvContentType + respondSourceDB cType $ src .| void (encodeCsv sheetName hdr) .| awaitForever sendChunk -respondDefaultOrderedCsvDB :: forall csv. +respondDefaultOrderedCsvDB :: forall csv msg. ( ToNamedRecord csv , DefaultOrdered csv + , RenderMessage UniWorX msg ) - => ConduitT () csv DB () + => msg -- ^ Sheet name for .xlsx + -> ConduitT () csv DB () -> Handler TypedContent -respondDefaultOrderedCsvDB = respondCsvDB $ headerOrder (error "headerOrder" :: csv) +respondDefaultOrderedCsvDB sheetName = respondCsvDB sheetName $ headerOrder (error "headerOrder" :: csv) fileSourceCsv :: ( FromNamedRecord csv , MonadThrow m @@ -261,3 +386,15 @@ instance ToWidget UniWorX CsvRendered where ] headers = decodeUtf8 <$> Vector.toList csvRenderedHeader + + +csvOptionsForFormat :: ( MonadHandler m, HandlerSite m ~ UniWorX ) + => CsvFormat + -> m CsvOptions +csvOptionsForFormat fmt = do + csvOpts <- fmap (maybe def $ userCsvOptions . entityVal) maybeAuth + return $ if + | fmt == csvOpts ^. _csvFormat . _CsvFormat + -> csvOpts + | otherwise + -> csvOpts & _csvFormat .~ (csvPreset . _CsvFormatPreset # fmt) diff --git a/src/Handler/Utils/Database.hs b/src/Handler/Utils/Database.hs index b6f82ced0..bd6e81250 100644 --- a/src/Handler/Utils/Database.hs +++ b/src/Handler/Utils/Database.hs @@ -11,7 +11,6 @@ import Data.Map as Map -- import Data.CaseInsensitive (CI) -- import qualified Data.CaseInsensitive as CI - import qualified Database.Esqueleto as E makeSchoolDictionaryDB :: DB (Map.Map SchoolId SchoolName) diff --git a/src/Handler/Utils/Download.hs b/src/Handler/Utils/Download.hs index 03fcbd738..28d723bb8 100644 --- a/src/Handler/Utils/Download.hs +++ b/src/Handler/Utils/Download.hs @@ -121,7 +121,7 @@ ensureApprootUserGeneratedMaybe' ) => Maybe (ConduitT () (Either FileReference DBFile) m ()) -> m () -ensureApprootUserGeneratedMaybe' source = maybeT (return ()) $ do +ensureApprootUserGeneratedMaybe' source = maybeT_ $ do route <- (,) <$> MaybeT getCurrentRoute <*> fmap reqGetParams getRequest $logDebugS "ensureApproot" $ tshow route rApproot <- hoistMaybe <=< lift . runMaybeT $ do diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs index 67d0b310e..4416b7fa6 100644 --- a/src/Handler/Utils/Exam.hs +++ b/src/Handler/Utils/Exam.hs @@ -3,12 +3,14 @@ module Handler.Utils.Exam ( fetchExamAux , fetchExam, fetchExamId, fetchCourseIdExamId, fetchCourseIdExam - , examBonus, examBonusPossible, examBonusAchieved + , examRelevantSheets, examBonusPossible, examBonusAchieved , examResultBonus, examGrade - , getRelevantSheetsUpTo, examBonusGrade + , examBonusGrade , ExamAutoOccurrenceConfig - , eaocMinimizeRooms, eaocFinenessCost, eaocNudge, eaocNudgeSize - , _eaocMinimizeRooms, _eaocFinenessCost, _eaocNudge, _eaocNudgeSize + , eaocIgnoreRooms, eaocFinenessCost, eaocNudge, eaocNudgeSize + , _eaocIgnoreRooms, _eaocFinenessCost, _eaocNudge, _eaocNudgeSize + , ExamAutoOccurrenceIgnoreRooms(..), _eaoirIgnored, _eaoirSorted + , ExamAutoOccurrenceException(..) , examAutoOccurrence , deregisterExamUsersCount, deregisterExamUsers , examAidsPresetWidget, examOnlinePresetWidget, examSynchronicityPresetWidget, examRequiredEquipmentPresetWidget @@ -27,15 +29,15 @@ import Database.Esqueleto.Utils.TH import qualified Data.Conduit.List as C import qualified Data.Map as Map +import qualified Data.Map.Merge.Lazy as Map import qualified Data.Set as Set import qualified Data.Foldable as F import qualified Data.CaseInsensitive as CI -import Control.Monad.Trans.Random.Lazy (evalRand) import System.Random (mkStdGen) -import Control.Monad.Random.Class (weighted) +import System.Random.Shuffle (shuffle') import Control.Monad.ST (ST, runST) import Data.Array (Array) @@ -44,12 +46,13 @@ import qualified Data.Array as Array import Data.Array.ST (STArray, STUArray) import qualified Data.Array.ST as ST +import Data.Foldable (foldMap') import Data.List (findIndex, unfoldr) import qualified Data.List as List -import Data.ExtendedReal +import Data.Either.Combinators (maybeToRight) -import qualified Data.Char as Char +import Data.ExtendedReal import qualified Data.RFC5051 as RFC5051 @@ -91,8 +94,11 @@ fetchCourseIdExam :: MonadHandler m => TermId -> SchoolId -> CourseShorthand -> fetchCourseIdExam tid ssh cid examn = over _1 E.unValue <$> fetchExamAux (\tutorial course -> (course E.^. CourseId, tutorial)) tid ssh cid examn -examBonus :: (MonadHandler m, MonadThrow m) => Entity Exam -> ReaderT SqlBackend m (Map UserId (SheetTypeSummary ExamPartId)) -examBonus (Entity eId Exam{..}) = runConduit $ +examRelevantSheets :: (MonadHandler m, MonadThrow m) + => Entity Exam + -> Bool -- ^ relevant for bonus (restricted to sheet having `sheetActiveTo` before `examOccurrenceStart`)? + -> ReaderT SqlBackend m (Map UserId (SheetTypeSummary ExamPartId)) +examRelevantSheets (Entity eId Exam{..}) forBonus = runConduit $ let rawData = E.selectSource . E.from $ \(((examRegistration `E.LeftOuterJoin` examOccurrence) `E.InnerJoin` sheet) `E.LeftOuterJoin` submission) -> E.distinctOnOrderBy [ E.asc $ examRegistration E.^. ExamRegistrationUser, E.asc $ sheet E.^. SheetId ] $ do E.on $ submission E.?. SubmissionSheet E.==. E.just (sheet E.^. SheetId) @@ -103,16 +109,17 @@ examBonus (Entity eId Exam{..}) = runConduit $ E.on $ examRegistration E.^. ExamRegistrationOccurrence E.==. examOccurrence E.?. ExamOccurrenceId E.where_ $ sheet E.^. SheetCourse E.==. E.val examCourse E.&&. examRegistration E.^. ExamRegistrationExam E.==. E.val eId - E.where_ $ E.case_ - [ E.when_ - ( E.not_ . E.isNothing $ examRegistration E.^. ExamRegistrationOccurrence ) - E.then_ - ( E.maybe E.true ((E.<=. examOccurrence E.?. ExamOccurrenceStart) . E.just) (sheet E.^. SheetActiveTo) - E.&&. sheet E.^. SheetVisibleFrom E.<=. examOccurrence E.?. ExamOccurrenceStart - ) - ] - ( E.else_ . E.not_ . E.isNothing $ sheet E.^. SheetVisibleFrom - ) + when forBonus $ + E.where_ $ E.case_ + [ E.when_ + ( E.isJust $ examRegistration E.^. ExamRegistrationOccurrence ) + E.then_ + ( E.maybe E.true ((E.<=. examOccurrence E.?. ExamOccurrenceStart) . E.just) (sheet E.^. SheetActiveTo) + E.&&. sheet E.^. SheetVisibleFrom E.<=. examOccurrence E.?. ExamOccurrenceStart + ) + ] + ( E.else_ . E.not_ . E.isNothing $ sheet E.^. SheetVisibleFrom + ) return (examRegistration E.^. ExamRegistrationUser, sheet E.^. SheetType, submission, sheet E.^. SheetCourse) accum = C.foldM ?? Map.empty $ \acc (E.Value uid, E.Value sheetType, fmap entityVal -> sub, E.Value cId) -> do sheetType' <- fmap entityKey <$> resolveSheetType cId sheetType @@ -123,29 +130,6 @@ examBonusPossible, examBonusAchieved :: Ord epId => UserId -> Map UserId (SheetT examBonusPossible uid bonusMap = normalSummary $ Map.findWithDefault mempty uid bonusMap examBonusAchieved uid bonusMap = mappend <$> normalSummary <*> bonusSummary $ Map.findWithDefault mempty uid bonusMap -getRelevantSheetsUpTo :: CourseId - -> UserId - -> Maybe UTCTime - -> DB (Map SheetId (SheetType SqlBackendKey, Maybe Points)) -getRelevantSheetsUpTo cid uid mCutoff - = fmap postprocess . E.select . E.from $ \(sheet `E.LeftOuterJoin` submission) -> E.distinctOnOrderBy [ E.asc $ sheet E.^. SheetId ] $ do - E.on $ submission E.?. SubmissionSheet E.==. E.just (sheet E.^. SheetId) - E.&&. E.exists (E.from $ \submissionUser -> E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val uid - E.&&. E.just (submissionUser E.^. SubmissionUserSubmission) E.==. submission E.?. SubmissionId - ) - E.where_ $ sheet E.^. SheetCourse E.==. E.val cid - case mCutoff of - Just cutoff -> E.where_ $ E.maybe E.true (E.<=. E.val cutoff) (sheet E.^. SheetActiveTo) - E.&&. E.maybe E.false (E.<=. E.val cutoff) (sheet E.^. SheetVisibleFrom) - Nothing -> E.where_ . E.not_ . E.isNothing $ sheet E.^. SheetVisibleFrom - return (sheet E.^. SheetId, sheet E.^. SheetType, submission) - where - postprocess :: [(E.Value SheetId, E.Value (SheetType SqlBackendKey), Maybe (Entity Submission))] - -> Map SheetId (SheetType SqlBackendKey, Maybe Points) - postprocess = Map.fromList . map postprocess' - where postprocess' (E.Value sId, E.Value sType, fmap entityVal -> sub) - = (sId, ) . (sType, ) $ assertM submissionRatingDone sub >>= submissionRatingPoints - @@ -235,9 +219,21 @@ examBonusGrade exam@Exam{..} bonusInp = (mBonus, ) . examGrade exam mBonus bonusPossible = normalSummary <$> sheetSummary bonusAchieved = (<>) <$> fmap normalSummary sheetSummary <*> fmap bonusSummary sheetSummary +data ExamAutoOccurrenceIgnoreRooms + = ExamAutoOccurrenceIgnoreRooms {eaoirIgnored :: Set ExamOccurrenceId, eaoirSorted :: Bool} + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +instance Default ExamAutoOccurrenceIgnoreRooms where + def = ExamAutoOccurrenceIgnoreRooms Set.empty False + +makeLenses_ ''ExamAutoOccurrenceIgnoreRooms + +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + } ''ExamAutoOccurrenceIgnoreRooms data ExamAutoOccurrenceConfig = ExamAutoOccurrenceConfig - { eaocMinimizeRooms :: Bool + { eaocIgnoreRooms :: ExamAutoOccurrenceIgnoreRooms , eaocFinenessCost :: Rational -- ^ Cost factor incentivising shorter common prefixes on breaks between rooms , eaocNudge :: Map ExamOccurrenceId Integer , eaocNudgeSize :: Rational @@ -245,7 +241,7 @@ data ExamAutoOccurrenceConfig = ExamAutoOccurrenceConfig instance Default ExamAutoOccurrenceConfig where def = ExamAutoOccurrenceConfig - { eaocMinimizeRooms = False + { eaocIgnoreRooms = def , eaocFinenessCost = 0.2 , eaocNudge = Map.empty , eaocNudgeSize = 0.05 @@ -257,36 +253,139 @@ deriveJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } ''ExamAutoOccurrenceConfig +data ExamAutoOccurrenceException + = ExamAutoOccurrenceExceptionRuleNoOp + | ExamAutoOccurrenceExceptionNotEnoughSpace + | ExamAutoOccurrenceExceptionNoUsers + | ExamAutoOccurrenceExceptionRoomTooSmall + deriving (Show, Eq, Generic, Typeable) + +instance Exception ExamAutoOccurrenceException + +embedRenderMessage ''UniWorX ''ExamAutoOccurrenceException id examAutoOccurrence :: forall seed. Hashable seed => seed -> ExamOccurrenceRule -> ExamAutoOccurrenceConfig - -> Map ExamOccurrenceId Natural + -> Map ExamOccurrenceId ExamOccurrenceCapacity -> Map UserId (User, Maybe ExamOccurrenceId) - -> (Maybe (ExamOccurrenceMapping ExamOccurrenceId), Map UserId (Maybe ExamOccurrenceId)) + -> Either ExamAutoOccurrenceException + (ExamOccurrenceMapping ExamOccurrenceId, Map UserId (Maybe ExamOccurrenceId)) examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences users - | sum occurrences < usersCount - || sum occurrences <= 0 - || Map.null users - = nullResult + | Map.null users' + = Left ExamAutoOccurrenceExceptionNoUsers + | occurrencesSize < Restricted usersCount -- this guarantees occurrencesSize > 0 as well + = Left ExamAutoOccurrenceExceptionNotEnoughSpace | otherwise = case rule of ExamRoomRandom - -> ( Nothing - , flip Map.mapWithKey users $ \uid (_, mOcc) - -> let randomOcc = flip evalRand (mkStdGen $ hashWithSalt seed uid) $ - weighted $ over _2 fromIntegral <$> occurrences' - in Just $ fromMaybe randomOcc mOcc + -> Right ( ExamOccurrenceMapping { + examOccurrenceMappingRule = rule, + examOccurrenceMappingMapping = Map.fromList $ set _2 (Set.singleton ExamOccurrenceMappingRandom) <$> occurrences'' + } + , Map.union (view _2 <$> assignedUsers) randomlyAssignedUsers ) - _ | Just (postprocess -> (resMapping, result)) <- bestOption - -> ( Just $ ExamOccurrenceMapping rule resMapping - , Map.unionWith (<|>) (view _2 <$> users) result - ) - _ -> nullResult + where + assignedUsers,unassignedUsers :: Map UserId (User, Maybe ExamOccurrenceId) + (assignedUsers, unassignedUsers) = Map.partition (has $ _2 . _Just) users + shuffledUsers :: [UserId] + shuffledUsers = shuffle' (Map.keys unassignedUsers) (length unassignedUsers) (mkStdGen seed) + restrictedOccurrences :: Map ExamOccurrenceId Natural + unrestrictedOccurrences :: Set ExamOccurrenceId + (unrestrictedOccurrences, restrictedOccurrences) + = bimap Set.fromList Map.fromList $ partitionRestricted ([], []) occurrences'' + -- reduce available space until to excess space is left while keeping the filling ratio as equal as possible + decreaseBiggestOutlier :: Natural -> Map ExamOccurrenceId Natural -> Map ExamOccurrenceId Natural + decreaseBiggestOutlier 0 currentOccurrences = currentOccurrences + decreaseBiggestOutlier n currentOccurrences + = decreaseBiggestOutlier (pred n) $ Map.update predToPositive biggestOutlier currentOccurrences + where + currentRatios :: Map ExamOccurrenceId Rational + currentRatios = Map.merge Map.dropMissing Map.dropMissing (Map.zipWithMatched calculateRatio) + currentOccurrences restrictedOccurrences + calculateRatio :: ExamOccurrenceId -> Natural -> Natural -> Rational + calculateRatio k c m = fromIntegral c / max 1 (fromIntegral m * sizeModifier) + where + sizeModifier :: Rational + sizeModifier = 1 + eaocNudgeSize * fromIntegral (lineNudges k) + biggestOutlier :: ExamOccurrenceId + biggestOutlier = fst . List.maximumBy (comparing $ view _2) $ Map.toList currentRatios + predToPositive :: Natural -> Maybe Natural + predToPositive 0 = Nothing + predToPositive 1 = Nothing + predToPositive x = Just $ pred x + extraCapacity :: Natural + extraUsers :: Natural + (extraCapacity, extraUsers) + | restrictedSpace > numUnassignedUsers + = (restrictedSpace - numUnassignedUsers, 0) + | otherwise + = (0, numUnassignedUsers - restrictedSpace) + where + restrictedSpace :: Natural + restrictedSpace = sum restrictedOccurrences + numUnassignedUsers :: Natural + numUnassignedUsers = fromIntegral $ length unassignedUsers + finalOccurrences :: [(ExamOccurrenceId, Natural)] + finalOccurrences = Map.toList $ decreaseBiggestOutlier extraCapacity restrictedOccurrences + unrestrictedPositiveNudges :: Map ExamOccurrenceId Natural + unrestrictedNegativeNudges :: Map ExamOccurrenceId Natural + (unrestrictedPositiveNudges, unrestrictedNegativeNudges) + = bimap (Map.map fromIntegral) (Map.map $ fromIntegral . negate) $ Map.partition (> 0) + $ Map.filter (/= 0) $ Map.restrictKeys eaocNudge unrestrictedOccurrences + -- extra entries caused by nudges + nudgedUnrestrictedOccurrences :: [ExamOccurrenceId] + nudgedUnrestrictedOccurrences = nudgedPositiveOccurrences unrestrictedPositiveNudges [] + ++ nudgedNegativeOccurrences unrestrictedNegativeNudges [] + where + replicateMany :: Int -> [a] -> [a] + replicateMany n as = take (n * length as) $ List.cycle as + nudgeEffect :: Int + nudgeEffect = max 1 $ ceiling $ eaocNudgeSize * fromIntegral extraUsers + -- for a positive nudge, add one entry to the front of the list + nudgedPositiveOccurrences :: Map ExamOccurrenceId Natural -> [ExamOccurrenceId] -> [ExamOccurrenceId] + nudgedPositiveOccurrences nudges acc + | null nudges = acc + | otherwise = nudgedPositiveOccurrences (Map.mapMaybe predToPositive nudges) + $ nudgeOccurrences' ++ acc + where + nudgeOccurrences :: [ExamOccurrenceId] + nudgeOccurrences = Set.toList (Set.intersection unrestrictedOccurrences $ Map.keysSet nudges) + nudgeOccurrences' :: [ExamOccurrenceId] + nudgeOccurrences' = replicateMany nudgeEffect nudgeOccurrences + -- for a negative nudge, add one entry for every other unrestricted occurrence to the front of the list + nudgedNegativeOccurrences :: Map ExamOccurrenceId Natural ->[ExamOccurrenceId] -> [ExamOccurrenceId] + nudgedNegativeOccurrences nudges acc + | null nudges = acc + | otherwise = nudgedNegativeOccurrences (Map.mapMaybe predToPositive nudges) + $ nudgeOccurrences' ++ acc + where + nudgeOccurrences :: [ExamOccurrenceId] + nudgeOccurrences = Set.toList (Set.difference unrestrictedOccurrences $ Map.keysSet nudges) + nudgeOccurrences' :: [ExamOccurrenceId] + nudgeOccurrences' = replicateMany nudgeEffect nudgeOccurrences + -- fill in users in a random order + randomlyAssignedUsers :: Map UserId (Maybe ExamOccurrenceId) + randomlyAssignedUsers = Map.fromList $ fillUnrestricted + (nudgedUnrestrictedOccurrences ++ List.cycle (Set.toList unrestrictedOccurrences)) + $ foldl' addUsers ([], shuffledUsers) finalOccurrences + addUsers :: ([(UserId, Maybe ExamOccurrenceId)], [UserId]) + -> (ExamOccurrenceId, Natural) + -> ([(UserId, Maybe ExamOccurrenceId)], [UserId]) + addUsers (acc, userList) (roomId, roomSize) = (map (, Just roomId) newUsers ++ acc, remainingUsers) + where + newUsers, remainingUsers :: [UserId] + (newUsers, remainingUsers) = List.genericSplitAt roomSize userList + -- if there are remaining users, we are guaranteed to have at least one unrestricted room (toplevel check) + fillUnrestricted :: [ExamOccurrenceId] -> ([(UserId, Maybe ExamOccurrenceId)], [UserId]) -> [(UserId, Maybe ExamOccurrenceId)] + fillUnrestricted _unrestrictedRooms (acc, []) = acc + fillUnrestricted [] _ = error "fillUnrestricted should only be called with an infinite list" + fillUnrestricted (nextRoom:followingRooms) (acc, nextUser:remainingUsers) + = fillUnrestricted followingRooms ((nextUser, Just nextRoom) : acc, remainingUsers) + _ -> over _1 (ExamOccurrenceMapping rule) . over _2 (Map.unionWith (<|>) (view _2 <$> users)) . postprocess <$> bestOption where - nullResult = (Nothing, view _2 <$> users) usersCount :: forall a. Num a => a usersCount = getSum $ foldMap (Sum . fromIntegral . Set.size) users' @@ -306,40 +405,43 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences | (uid, (User{..}, Nothing)) <- Map.toList users , matriculation' <- userMatrikelnummer ^.. _Just . filtered (not . null) ] - in Map.mapKeysWith Set.union (take . F.minimum . Set.map length $ Map.keysSet matrUsers) matrUsers - _ -> Map.singleton [] $ Map.keysSet users - - - occurrences' :: [(ExamOccurrenceId, Natural)] - -- ^ Minimise number of occurrences used - -- - -- Prefer occurrences with higher capacity - -- - -- If a single occurrence can accomodate all participants, pick the one with - -- the least capacity - occurrences' - | not eaocMinimizeRooms - = Map.toList occurrences - | Just largeEnoughs <- fromNullable . filter ((>= usersCount) . view _2) $ Map.toList occurrences - = pure $ minimumBy (comparing $ view _2) largeEnoughs - | otherwise - = view _2 . foldl' accF (0, []) . sortOn (Down . view _2) $ Map.toList occurrences + takeEnd n chars = drop (length chars - n) chars + in Map.mapKeysWith Set.union (takeEnd . F.minimum . Set.map length $ Map.keysSet matrUsers) matrUsers + _ | null unassignedUsers -> Map.empty + | otherwise -> Map.singleton [] $ Map.keysSet unassignedUsers where - accF :: (Natural, [(ExamOccurrenceId, Natural)]) - -> (ExamOccurrenceId, Natural) - -> (Natural, [(ExamOccurrenceId, Natural)]) - accF acc@(accSize, accOccs) occ@(_, occSize) - | accSize >= usersCount - = acc - | otherwise - = ( accSize + occSize - , occ : accOccs - ) + unassignedUsers = Map.filter (has $ _2 . _Nothing) users + + occurrencesSize :: ExamOccurrenceCapacity + occurrencesSize = foldMap' (view _2) occurrences'' + + occurrences' :: Map ExamOccurrenceId ExamOccurrenceCapacity + -- ^ reduce room capacity for every pre-assigned user by 1 + -- also remove empty/pre-filled rooms + occurrences' = foldl' (flip $ Map.update predToPositive) (Map.filter (> Restricted 0) occurrences) + $ Map.mapMaybe snd users + where + predToPositive :: ExamOccurrenceCapacity -> Maybe ExamOccurrenceCapacity + predToPositive Unrestricted = Just Unrestricted + predToPositive (Restricted 0) = Nothing + predToPositive (Restricted 1) = Nothing + predToPositive (Restricted n) = Just $ Restricted $ pred n + + occurrences'' :: [(ExamOccurrenceId, ExamOccurrenceCapacity)] + -- ^ Only use non-ignored occurrences + -- Sort by size if specified (here increasing, since it is reversed later) + occurrences'' = case eaocIgnoreRooms of + ExamAutoOccurrenceIgnoreRooms {..} -> (if eaoirSorted then sortOn (view _2) else id) $ Map.toList $ Map.withoutKeys occurrences' eaoirIgnored + + partitionRestricted :: ([a], [(a, Natural)]) -> [(a,ExamOccurrenceCapacity)] -> ([a], [(a, Natural)]) + partitionRestricted acc [] = acc + partitionRestricted acc ((a,Unrestricted):t) = partitionRestricted (over _1 (a:) acc) t + partitionRestricted acc ((a,Restricted n):t) = partitionRestricted (over _2 ((a,n):) acc) t distribute :: forall wordId lineId cost. _ => [(wordId, Natural)] -- ^ Word sizes (in order) - -> [(lineId, Natural)] -- ^ Line sizes (in order) + -> [(lineId, ExamOccurrenceCapacity)] -- ^ Line sizes (in order) -> (lineId -> Integer) -- ^ Nudge -> (wordId -> wordId -> Extended Rational) -- ^ Break cost -> Maybe (cost, [(lineId, [wordId])]) @@ -358,9 +460,25 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences Finite c -> Just (fromInteger $ round c, result) _other -> Nothing where + restrictedLines :: [(lineId, Natural)] + unrestrictedLines :: [lineId] + -- partitionRestricted reverses the order of occurrences + (unrestrictedLines, restrictedLines) = partitionRestricted ([], []) lineLengths + + -- reorder so unrestricted lines are at the end and my be left empty + lineLengths' :: [(lineId, ExamOccurrenceCapacity)] + lineLengths' = (over _2 Restricted <$> restrictedLines) ++ ((, Unrestricted) <$> unrestrictedLines) + + restrictedLengths :: [Natural] + restrictedLengths = view _2 <$> restrictedLines + + restrictedSpace :: Natural + restrictedSpace = sum restrictedLengths + longestLine :: Natural -- ^ For scaling costs - longestLine = maximum . mapNonNull (view _2) $ impureNonNull lineLengths + -- longest restricted line (or 1 if all unrestricted) + longestLine = maybe numUnassignedUsers maximum $ fromNullable restrictedLengths wordMap :: Map wordId Natural wordMap = Map.fromListWith (+) wordLengths @@ -396,23 +514,31 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences minima <- ST.newListArray (0, Map.size wordMap) $ 0 : repeat PosInf :: forall s. ST s (STArray s Int (Extended Rational)) breaks <- ST.newArray (0, Map.size wordMap) 0 :: forall s. ST s (STUArray s Int Int) - forM_ (Array.range (0, Map.size wordMap)) $ \i' -> do - let go i j + -- find current line + let + walkBack 0 = return 0 + walkBack i'' = fmap succ $ walkBack =<< ST.readArray breaks i'' + -- calculate line breaks + forM_ (Array.range (0, Map.size wordMap)) $ \i -> do + let go j | j <= Map.size wordMap = do - let - walkBack 0 = return 0 - walkBack i'' = fmap succ $ walkBack =<< ST.readArray breaks i'' lineIx <- walkBack i + -- identifier and potential width of current line let (l, potWidth) | lineIx >= 0 - , lineIx < length lineLengths - = over _1 Just $ lineLengths List.!! lineIx + , lineIx < length lineLengths' + = over _1 Just $ lineLengths' List.!! lineIx | otherwise - = (Nothing, 0) + = (Nothing, Restricted 0) + -- cumulative width for words [i,j), no whitespace required w = offsets Array.! j - offsets Array.! i prevMin <- ST.readArray minima i let cost = prevMin + widthCost l potWidth w + breakCost' + remainingWords = offsets Array.! Map.size wordMap - offsets Array.! i + remainingLineSpace = foldMap (view _2) $ drop lineIx lineLengths' breakCost' + | Restricted remainingWords > remainingLineSpace + = PosInf | j < Map.size wordMap , j > 0 = breakCost (wordIx # pred j) (wordIx # j) @@ -431,36 +557,56 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences when (cost < minCost) $ do ST.writeArray minima j cost ST.writeArray breaks j i - go i' $ succ j + go $ succ j | otherwise = return () - in go i' $ succ i' + in go $ succ i -- traceM . show . map (fmap (fromRational :: Rational -> Centi)) =<< ST.getElems minima -- traceM . show =<< ST.getElems breaks + usedLines <- walkBack $ Map.size wordMap let accumResult lineIx j (accCost, accMap) = do i <- ST.readArray breaks j accCost' <- (+) accCost <$> ST.readArray minima j -- traceM $ show ((fromRational :: Rational -> Centi) <$> accCost', lineIx, (i, pred j)) let accMap' = (lineIxs List.!! lineIx, map (review wordIx) [i .. pred j]) : accMap - if - | i > 0 -> accumResult (succ lineIx) i (accCost', accMap') - | otherwise -> return (accCost', accMap') - lineIxs = reverse $ map (view _1) lineLengths + if i > 0 + then accumResult (succ lineIx) i (accCost', accMap') + else return (accCost', accMap') + lineIxs = reverse $ map (view _1) $ take usedLines lineLengths' in accumResult 0 (Map.size wordMap) (0, []) + optimumRatio :: Rational + optimumRatio = ((%) `on` fromIntegral . max 1 . sum) (map (view _2) wordLengths) restrictedLengths - widthCost :: Maybe lineId -> Natural -> Natural -> Extended Rational - widthCost l lineWidth w - | lineWidth < w = PosInf - | otherwise = Finite (max 1 . abs $ ((fromIntegral w % fromIntegral lineWidth) - optimumRatio') * fromIntegral longestLine) ^ 2 + numUnassignedUsers :: Natural + numUnassignedUsers = sum $ view _2 <$> wordLengths + + extraUsers :: Natural + extraUsers + | numUnassignedUsers > restrictedSpace = numUnassignedUsers - restrictedSpace + | otherwise = 0 + + widthCost :: Maybe lineId -> ExamOccurrenceCapacity -> Natural -> Extended Rational + widthCost l Unrestricted w + = Finite $ max 1 $ (fromIntegral w - sizeModifier * (fromIntegral extraUsers % List.genericLength unrestrictedLines)) ^ 2 where - optimumRatio = ((%) `on` fromIntegral . sum) (map (view _2) wordLengths) (map (view _2) lineLengths) - optimumRatio' = maybe 0 (fromIntegral . lineNudge) l * eaocNudgeSize + optimumRatio + sizeModifier :: Rational + sizeModifier = 1 + maybe 0 (fromIntegral . lineNudge) l * eaocNudgeSize + widthCost l (Restricted lineWidth) w + | lineWidth < w = PosInf + | otherwise = Finite $ max 1 $ ((fromIntegral w / nudgedWidth - optimumRatio) * fromIntegral longestLine) ^ 2 + where + nudgedWidth :: Rational + nudgedWidth = max 1 $ sizeModifier * fromIntegral lineWidth + sizeModifier :: Rational + sizeModifier = 1 + maybe 0 (fromIntegral . lineNudge) l * eaocNudgeSize charCost :: [CI Char] -> [CI Char] -> Extended Rational charCost pA pB = Finite (max 1 $ List.genericLength (pA `lcp` pB) * eaocFinenessCost * fromIntegral longestLine) ^ 2 where - longestLine = maximum . mapNonNull (view _2) $ impureNonNull occurrences' + longestLine :: Natural + longestLine = maybe (sum $ fromIntegral . length <$> users') maximum $ fromNullable $ catMaybes + $ view (_2 . _examOccurrenceCapacityIso) <$> occurrences'' lcp :: Eq a => [a] -> [a] -> [a] @@ -473,18 +619,18 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences lineNudges = fromMaybe 0 . flip Map.lookup eaocNudge - bestOption :: Maybe [(ExamOccurrenceId, [[CI Char]])] + bestOption :: Either ExamAutoOccurrenceException [(ExamOccurrenceId, [[CI Char]])] bestOption = case rule of - ExamRoomSurname -> do - (_cost, res) <- distribute (sortBy (RFC5051.compareUnicode `on` (pack . toListOf (_1 . folded . to CI.foldedCase))) . Map.toAscList $ fromIntegral . Set.size <$> users') occurrences' lineNudges charCost + ExamRoomSurname -> maybeToRight ExamAutoOccurrenceExceptionRoomTooSmall $ do + (_cost, res) <- distribute (sortBy (RFC5051.compareUnicode `on` (pack . toListOf (_1 . folded . to CI.foldedCase))) . Map.toAscList $ fromIntegral . Set.size <$> users') occurrences'' lineNudges charCost -- traceM $ show cost return res - ExamRoomMatriculation -> do + ExamRoomMatriculation -> maybeToRight ExamAutoOccurrenceExceptionRoomTooSmall $ do let usersFineness n = Map.toAscList $ fromIntegral . Set.size <$> Map.mapKeysWith Set.union (reverse . take (fromIntegral n) . reverse) users' -- finenessCost n = Finite (max 1 $ fromIntegral n * eaocFinenessCost * fromIntegral longestLine) ^ 2 * length occurrences' distributeFine :: Natural -> Maybe (Extended Rational, _) - distributeFine n = distribute (usersFineness n) occurrences' lineNudges charCost + distributeFine n = distribute (usersFineness n) occurrences'' lineNudges charCost maximumFineness = fromIntegral . F.minimum . Set.map length $ Map.keysSet users' @@ -510,7 +656,7 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences (_cost, res) <- fmap (minimumBy . comparing $ view _1) . fromNullable $ genResults 1 return res - _other -> Nothing + _other -> Left ExamAutoOccurrenceExceptionRuleNoOp postprocess :: [(ExamOccurrenceId, [[CI Char]])] -> ( Map ExamOccurrenceId (Set ExamOccurrenceMappingDescription) @@ -518,63 +664,135 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences ) postprocess result = (resultAscList, resultUsers) where - resultAscList = pad . Map.fromListWith Set.union $ accRes (pure <$> Set.lookupMin rangeAlphabet) result - where - accRes _ [] = [] - accRes prevEnd ((occA, nsA) : (occB, nsB) : xs) - | Just minA <- prevEnd <|> preview _head nsA - , Just maxA <- nsA ^? _last - , Just minB <- nsB ^? _head - = let common = maxA `lcp` minB - in if - | Just rmaxA <- nsA ^? to (filter . mayRange . succ $ length common) . _last - , Just rminA <- maybe id (:) prevEnd nsA ^? to (filter . mayRange . succ $ length common) . _head - , Just rminB <- nsB ^? to (filter . mayRange . succ $ length common) . _head - , firstA : _ <- CI.foldedCase <$> drop (length common) rmaxA - , firstB : _ <- CI.foldedCase <$> drop (length common) rminB - -> let break' - | occSize occA > 0 || occSize occB > 0 - = (occSize occA * Char.ord firstA + occSize occB * Char.ord firstB) % (occSize occA + occSize occB) - & floor - & Char.chr - & Char.toUpper - & CI.mk - & pure - & (common ++) - | otherwise = common ++ pure (CI.mk firstA) - succBreak = fmap reverse . go $ reverse break' - where - go [] = Nothing - go (c:cs) - | c' <- CI.map succ c - , c' `Set.member` rangeAlphabet - = Just $ c' : cs - | otherwise - = go cs - commonLength = max 1 . succ . length $ minA `lcp` break' - isBreakSpecialStart c = not (mayRange (length rminA ) c) && length (rminA `lcp` c) >= pred (length rminA ) - isBreakSpecialEnd c = not (mayRange (length break') c) && length (break' `lcp` c) >= pred (length break') - rangeSpecials = Set.map (ExamOccurrenceMappingSpecial . take commonLength) . Set.filter (not . mayRange commonLength) $ Set.fromList nsA - breakSpecialsStart = Set.map (ExamOccurrenceMappingSpecial . take (length rminA)) . Set.filter isBreakSpecialStart $ Set.fromList nsA - breakSpecialsEnd = Set.map (ExamOccurrenceMappingSpecial . take (length break')) . Set.filter isBreakSpecialEnd $ Set.fromList nsA - in (occA, Set.insert (ExamOccurrenceMappingRange rminA break') $ breakSpecialsStart <> breakSpecialsEnd <> rangeSpecials) : accRes succBreak ((occB, nsB) : xs) + maxTagLength :: Int + maxTagLength = maybe 0 maximum $ fromNullable $ concatMap (map length . snd) result + + rangeAlphabet :: [CI Char] + rangeAlphabet = case rule of + ExamRoomSurname -> map CI.mk ['A'..'Z'] + ExamRoomMatriculation-> map CI.mk ['0'..'9'] + _rule -> [] + + resultAscList :: Map ExamOccurrenceId (Set ExamOccurrenceMappingDescription) + resultAscList = case fromNullable rangeAlphabet of + Nothing -> Map.empty + (Just alphabet) -> Map.fromList $ go (singleton $ head alphabet) 1 [] result + where + go :: NonNull [CI Char] + -> Int + -> [(ExamOccurrenceId, Set ExamOccurrenceMappingDescription)] + -> [(ExamOccurrenceId, [[CI Char]])] + -> [(ExamOccurrenceId, Set ExamOccurrenceMappingDescription)] + go _start _borderLength acc [] = acc + -- special case necessary, so ranges always end on last alphabet + go start _borderLength acc [(_occurrenceId, [])] = case acc of + [] -> [] + ((occurrenceId, mappingDescription):t) -> (occurrenceId, Set.map extendEnd mappingDescription) : t + where + extendEnd :: ExamOccurrenceMappingDescription -> ExamOccurrenceMappingDescription + extendEnd ExamOccurrenceMappingRange {eaomrStart} = ExamOccurrenceMappingRange {eaomrStart, eaomrEnd} + extendEnd examOccurrenceMappingSpecial = examOccurrenceMappingSpecial + eaomrEnd :: [CI Char] + eaomrEnd = replicate (length start) $ last alphabet + go start borderLength acc ((_occurrenceId, []):t) = go start borderLength acc t + go start borderLength acc ((occurrenceId, userTags):t) + | matchMappingDescription mappingDescription userTags + && (null t || toNullable nextStart > end) + = go nextStart borderLength ((occurrenceId, mappingDescription) : acc) t + | borderLength < maxTagLength + = go restartStart restartBorderLength [] result | otherwise - -> (occA, Set.map (ExamOccurrenceMappingSpecial . take (max 1 . max (succ $ length common) $ maybe 0 length prevEnd)) $ Set.fromList nsA) : accRes (Just $ take (succ $ length common) minB) ((occB, nsB) : xs) - | null nsA - = accRes prevEnd $ (occB, nsB) : xs - | otherwise -- null nsB - = accRes prevEnd $ (occA, nsA) : xs - accRes prevEnd [(occZ, nsZ)] - | Just minAlpha <- Set.lookupMin rangeAlphabet - , Just maxAlpha <- Set.lookupMax rangeAlphabet - , minZ <- fromMaybe (pure minAlpha) prevEnd - = let commonLength = max 1 . succ . length $ takeWhile (== maxAlpha) minZ - isBreakSpecial c = not (mayRange (length minZ) c) && length (minZ `lcp` c) >= pred (length minZ) - rangeSpecials = Set.map (ExamOccurrenceMappingSpecial . take commonLength) . Set.filter (not . mayRange commonLength) $ Set.fromList nsZ - breakSpecials = Set.map (ExamOccurrenceMappingSpecial . take (length minZ)) . Set.filter isBreakSpecial $ Set.fromList nsZ - in pure (occZ, Set.insert (ExamOccurrenceMappingRange minZ $ replicate commonLength maxAlpha) $ rangeSpecials <> breakSpecials) - | otherwise - = pure (occZ, Set.map (ExamOccurrenceMappingSpecial . take (max 1 $ maybe 0 length prevEnd)) $ Set.fromList nsZ) + = [] -- shouldn't happen, but ensures termination on invalid input (e.g. non-monotonic) + where + restartBorderLength :: Int + restartBorderLength = succ borderLength + + restartStart :: NonNull [CI Char] + restartStart = case rule of + ExamRoomMatriculation -> impureNonNull $ replicate restartBorderLength $ head alphabet + _rule -> singleton $ head alphabet + + mappingDescription :: Set ExamOccurrenceMappingDescription + mappingDescription + -- if start > end, the room only consists of users with a non-ascii tag directly adjacent to the last room + -- therefore, leave out a potentially confusing range description + | toNullable start > end = Set.fromList specialMapping + | otherwise = Set.fromList $ ExamOccurrenceMappingRange (toNullable start) end : specialMapping + + specialMapping :: [ExamOccurrenceMappingDescription] + specialMapping + = [ExamOccurrenceMappingSpecial {eaomrSpecial=tag} + | (transformTag borderLength -> tag) <- userTags + , not $ all (`elem` alphabet) tag] + + -- | pre/suffix of largest user tag + -- special (i.e. non-ascii) tags use the largest smaller ascii-char according to RFC5051.compareUnicode, + -- ending the tag with ..ZZZ-padding + end :: [CI Char] + end = case t of + [] -> replicate borderLength $ last alphabet + _nonEmpty -> withAlphabetChars + $ transformTag borderLength + $ maximumBy (\a b -> RFC5051.compareUnicode (pack $ map CI.foldedCase a) (pack $ map CI.foldedCase b)) + -- userTags is guaranteed non-null + $ impureNonNull userTags + where + withAlphabetChars :: [CI Char] -> [CI Char] + withAlphabetChars [] = [] + withAlphabetChars (c:cs) + | c `elem` alphabet = c : withAlphabetChars cs + | otherwise= case previousAlphabetChar c of + Nothing -> [] + (Just c') -> c' : replicate (length cs) (last alphabet) + previousAlphabetChar :: CI Char -> Maybe (CI Char) + previousAlphabetChar c = fmap last $ fromNullable $ nfilter ((== GT) . compareChars c) alphabet + compareChars :: CI Char -> CI Char -> Ordering + compareChars a b = RFC5051.compareUnicode (pack [CI.foldedCase a]) (pack [CI.foldedCase b]) + nextStart :: NonNull [CI Char] + -- end is guaranteed nonNull, all empty tags are filtered out in users' + nextStart + | length end < borderLength + = impureNonNull $ end <> [head alphabet] + | otherwise + = impureNonNull $ reverse $ increase $ reverse end + alphabetCycle :: [CI Char] + alphabetCycle = List.cycle $ toNullable alphabet + increase :: [CI Char] -> [CI Char] + increase [] = [] + increase (c:cs) + | nextChar == head alphabet, rule == ExamRoomMatriculation + = nextChar : increase cs + | nextChar == head alphabet + = increase cs + | otherwise + = nextChar : cs + where + nextChar :: CI Char + nextChar + | c `elem` alphabet + = dropWhile (/= c) alphabetCycle List.!! 1 + | otherwise -- shouldn't happen, simply use head alphabet as a fallback + = head alphabet + + transformTag :: Int -> [CI Char] -> [CI Char] + transformTag l tag = case rule of + ExamRoomMatriculation -> drop (max 0 $ length tag - l) tag + _rule -> take l tag + + matchMappingDescription :: Set ExamOccurrenceMappingDescription -> [[CI Char]] -> Bool + matchMappingDescription mappingDescription userTags = flip all userTags $ \tag -> flip any mappingDescription $ \case + ExamOccurrenceMappingRange {eaomrStart, eaomrEnd} + -- non-rangeAlphabet-chars get a special mapping, so <= is fine here + -> (eaomrStart <= transformTag (length eaomrStart) tag) && (transformTag (length eaomrEnd) tag <= eaomrEnd) + ExamOccurrenceMappingSpecial {eaomrSpecial} -> checkSpecial eaomrSpecial tag + where + checkSpecial :: [CI Char] -> [CI Char] -> Bool + checkSpecial = case rule of + ExamRoomMatriculation -> isSuffixOf + _rule -> isPrefixOf + ExamOccurrenceMappingRandom -> False -- Something went wrong, throw an error instead? + + resultUsers :: Map UserId (Maybe ExamOccurrenceId) resultUsers = Map.fromList $ do (occId, buckets) <- result let matchWord b b' = case rule of @@ -585,30 +803,6 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences user <- Set.toList $ foldMap (\b -> foldMap snd . filter (\(b', _) -> matchWord b b') $ Map.toList users') buckets return (user, Just occId) - occSize :: Num a => ExamOccurrenceId -> a - occSize occId = fromIntegral . length $ Map.filter (== Just occId) resultUsers - - rangeAlphabet :: Set (CI Char) - rangeAlphabet - | ExamRoomSurname <- rule - = Set.fromList $ map CI.mk ['A'..'Z'] - | ExamRoomMatriculation <- rule - = Set.fromList $ map CI.mk ['0'..'9'] - | otherwise - = mempty - mayRange :: Int -> [CI Char] -> Bool - mayRange l = all (`Set.member` rangeAlphabet) . take l - - pad :: Map ExamOccurrenceId (Set ExamOccurrenceMappingDescription) -> Map ExamOccurrenceId (Set ExamOccurrenceMappingDescription) - pad res - | ExamRoomMatriculation <- rule - , Just minAlpha <- Set.lookupMin rangeAlphabet - = let maxLength' = maybe 0 maximum . fromNullable $ res ^.. folded . folded . (_eaomrStart <> _eaomrEnd <> _eaomrSpecial) . to length - padSuff cs = replicate (maxLength' - length cs) minAlpha ++ cs - in Set.map (appEndo $ foldMap Endo [ over l padSuff | l <- [_eaomrStart, _eaomrEnd, _eaomrSpecial]]) <$> res - | otherwise - = res - deregisterExamUsersCount :: (MonadIO m, HandlerSite m ~ UniWorX, MonadHandler m, MonadCatch m) => ExamId -> [UserId] -> SqlPersistT m Int64 deregisterExamUsersCount eId uids = do diff --git a/src/Handler/Utils/ExamOffice/Exam.hs b/src/Handler/Utils/ExamOffice/Exam.hs index e9f903471..be3ab8fda 100644 --- a/src/Handler/Utils/ExamOffice/Exam.hs +++ b/src/Handler/Utils/ExamOffice/Exam.hs @@ -34,7 +34,7 @@ resultIsSynced authId examResult = (hasSchool E.&&. allSchools) E.||. (E.not_ ha examOfficeExamResultAuth :: E.SqlExpr (E.Value UserId) -- ^ office -> E.SqlExpr (Entity ExamResult) -> E.SqlExpr (E.Value Bool) -examOfficeExamResultAuth authId examResult = authByUser E.||. authByField E.||. authBySchool E.||. authByExtraSchool +examOfficeExamResultAuth authId examResult = ((isOffice E.||. isSystemOffice) E.&&. authByUser) E.||. authByField E.||. authBySchool E.||. authByExtraSchool where cId = E.subSelectForeign examResult ExamResultExam (\exam -> E.subSelectForeign exam ExamCourse (E.^. CourseId)) @@ -61,6 +61,14 @@ examOfficeExamResultAuth authId examResult = authByUser E.||. authByField E.||. E.where_ $ examOfficeUser E.^. ExamOfficeUserOffice E.==. authId E.&&. examOfficeUser E.^. ExamOfficeUserUser E.==. examResult E.^. ExamResultUser + isOffice = E.exists . E.from $ \userFunction -> + E.where_ $ userFunction E.^. UserFunctionUser E.==. authId + E.&&. userFunction E.^. UserFunctionFunction E.==. E.val SchoolExamOffice + isSystemOffice = E.exists . E.from $ \userSystemFunction -> + E.where_ $ userSystemFunction E.^. UserSystemFunctionUser E.==. authId + E.&&. userSystemFunction E.^. UserSystemFunctionFunction E.==. E.val SystemExamOffice + E.&&. E.not_ (userSystemFunction E.^. UserSystemFunctionIsOptOut) + authBySchool = E.exists . E.from $ \(userFunction `E.InnerJoin` course `E.InnerJoin` exam) -> do E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse E.&&. exam E.^. ExamId E.==. examResult E.^. ExamResultExam diff --git a/src/Handler/Utils/ExamOffice/ExternalExam.hs b/src/Handler/Utils/ExamOffice/ExternalExam.hs index ed7be4aba..1c9d74310 100644 --- a/src/Handler/Utils/ExamOffice/ExternalExam.hs +++ b/src/Handler/Utils/ExamOffice/ExternalExam.hs @@ -34,7 +34,7 @@ resultIsSynced authId eexamResult = (hasSchool E.&&. allSchools) E.||. (E.not_ h examOfficeExternalExamResultAuth :: E.SqlExpr (E.Value UserId) -- ^ office -> E.SqlExpr (Entity ExternalExamResult) -> E.SqlExpr (E.Value Bool) -examOfficeExternalExamResultAuth authId eexamResult = authByUser E.||. authByField E.||. authBySchool E.||. authByExtraSchool +examOfficeExternalExamResultAuth authId eexamResult = ((isOffice E.||. isSystemOffice) E.&&. authByUser) E.||. authByField E.||. authBySchool E.||. authByExtraSchool where authByField = E.exists . E.from $ \(examOfficeField `E.InnerJoin` studyFeatures) -> do E.on $ studyFeatures E.^. StudyFeaturesField E.==. examOfficeField E.^. ExamOfficeFieldField @@ -54,6 +54,14 @@ examOfficeExternalExamResultAuth authId eexamResult = authByUser E.||. authByFie E.where_ $ examOfficeUser E.^. ExamOfficeUserOffice E.==. authId E.&&. examOfficeUser E.^. ExamOfficeUserUser E.==. eexamResult E.^. ExternalExamResultUser + isOffice = E.exists . E.from $ \userFunction -> + E.where_ $ userFunction E.^. UserFunctionUser E.==. authId + E.&&. userFunction E.^. UserFunctionFunction E.==. E.val SchoolExamOffice + isSystemOffice = E.exists . E.from $ \userSystemFunction -> + E.where_ $ userSystemFunction E.^. UserSystemFunctionUser E.==. authId + E.&&. userSystemFunction E.^. UserSystemFunctionFunction E.==. E.val SystemExamOffice + E.&&. E.not_ (userSystemFunction E.^. UserSystemFunctionIsOptOut) + authBySchool = E.exists . E.from $ \(userFunction `E.InnerJoin` eexam) -> do E.on $ userFunction E.^. UserFunctionFunction E.==. E.val SchoolExamOffice E.&&. userFunction E.^. UserFunctionSchool E.==. eexam E.^. ExternalExamSchool diff --git a/src/Handler/Utils/ExternalExam/Users.hs b/src/Handler/Utils/ExternalExam/Users.hs index 9fe8909e4..d0c16d9d8 100644 --- a/src/Handler/Utils/ExternalExam/Users.hs +++ b/src/Handler/Utils/ExternalExam/Users.hs @@ -96,7 +96,7 @@ instance DefaultOrdered ExternalExamUserTableCsv where headerOrder = Csv.genericHeaderOrder externalExamUserTableCsvOptions instance FromNamedRecord ExternalExamUserTableCsv where - parseNamedRecord csv + parseNamedRecord (lsfHeaderTranslate -> csv) = ExternalExamUserTableCsv <$> csv .:?? "surname" <*> csv .:?? "first-name" @@ -193,7 +193,6 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do examn = externalExamExamName uid <- requireAuthId - csvName <- getMessageRender <*> pure (MsgExternalExamUserCsvName tid ssh coursen examn) isLecturer <- hasReadAccessTo $ EExamR tid ssh coursen examn EEUsersR currentRoute <- fromMaybe (error "makeExternalExamUsersTable called from 404-handler") <$> getCurrentRoute MsgRenderer mr <- getMsgRenderer @@ -358,6 +357,8 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do , dbParamsFormIdent = def } dbtIdent = mode + dbtCsvName = MsgExternalExamUserCsvName tid ssh coursen examn + dbtCsvSheetName = MsgExternalExamUserCsvSheetName tid ssh coursen examn dbtCsvEncode = case mode of EEUMGrades -> Just DBTCsvEncode { dbtCsvExportForm = ExternalExamUserCsvExportDataGrades @@ -365,13 +366,13 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do , dbtCsvDoEncode = \ExternalExamUserCsvExportDataGrades{..} -> C.mapM $ \(E.Value k, row) -> do when csvEEUserMarkSynchronised $ externalExamResultMarkSynchronised k return $ encodeCsv' row - , dbtCsvName = unpack csvName + , dbtCsvName, dbtCsvSheetName , dbtCsvNoExportData = Nothing , dbtCsvHeader = const . return $ headerOrder (error "headerOrder" :: ExternalExamUserTableCsv) , dbtCsvExampleData = Nothing } EEUMUsers -> - let baseEncode = simpleCsvEncode csvName encodeCsv' + let baseEncode = simpleCsvEncode dbtCsvName dbtCsvSheetName encodeCsv' csvEUserStudyFeatures = mempty in baseEncode <&> \enc -> enc { dbtCsvExampleData = Just diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index fc5b0befa..a9e67ca8f 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -181,6 +181,20 @@ linkButton defWdgt lbl cls url = do -- Interactive fieldset -- -------------------------- +optionalAction'' :: Bool -- ^ negated? + -> (Field Handler Bool -> FieldSettings UniWorX -> Maybe Bool -> MForm Handler (FormResult Bool, FieldView UniWorX)) + -> AForm Handler a + -> FieldSettings UniWorX + -> Maybe Bool + -> (Html -> MForm Handler (FormResult (Maybe a), [FieldView UniWorX])) +optionalAction'' negated minp justAct fs@FieldSettings{..} defActive csrf = do + (doRes, doView) <- minp (bool id (isoField _not) negated checkBoxField) fs defActive + (actionRes, actionViews') <- over _2 ($ []) <$> aFormToForm justAct + + 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 @@ -192,19 +206,19 @@ optionalAction' :: (Field Handler Bool -> FieldSettings UniWorX -> Maybe Bool -> -> FieldSettings UniWorX -> Maybe Bool -> (Html -> MForm Handler (FormResult (Maybe a), [FieldView UniWorX])) -optionalAction' minp justAct fs@FieldSettings{..} defActive csrf = do - (doRes, doView) <- minp checkBoxField fs defActive - (actionRes, actionViews') <- over _2 ($ []) <$> aFormToForm justAct - - 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' = optionalAction'' False optionalActionA :: AForm Handler a -> FieldSettings UniWorX -> Maybe Bool -> AForm Handler (Maybe a) optionalActionA = optionalActionA' mpopt + +optionalActionNegatedA :: AForm Handler a + -> FieldSettings UniWorX + -> Maybe Bool + -> AForm Handler (Maybe a) +optionalActionNegatedA = optionalActionA'' True mpopt optionalActionA' :: (Field Handler Bool -> FieldSettings UniWorX -> Maybe Bool -> MForm Handler (FormResult Bool, FieldView UniWorX)) -> AForm Handler a @@ -213,6 +227,14 @@ optionalActionA' :: (Field Handler Bool -> FieldSettings UniWorX -> Maybe Bool - -> AForm Handler (Maybe a) optionalActionA' minp justAct fs defActive = formToAForm $ optionalAction' minp justAct fs defActive mempty +optionalActionA'' :: Bool + -> (Field Handler Bool -> FieldSettings UniWorX -> Maybe Bool -> MForm Handler (FormResult Bool, FieldView UniWorX)) + -> AForm Handler a + -> FieldSettings UniWorX + -> Maybe Bool + -> AForm Handler (Maybe a) +optionalActionA'' negated minp justAct fs defActive = formToAForm $ optionalAction'' negated minp justAct fs defActive mempty + optionalActionW :: AForm Handler a -> FieldSettings UniWorX -> Maybe Bool @@ -722,7 +744,8 @@ examBonusRuleForm prev = multiActionA actions (fslI MsgUtilExamBonusRule) $ clas ) , ( ExamBonusPoints' , ExamBonusPoints - <$> apreq (checkBool (> 0) MsgExamBonusMaxPointsNonPositive pointsField) (fslI MsgExamBonusMaxPoints & setTooltip MsgExamBonusMaxPointsTip) (preview _bonusMaxPoints =<< prev) + <$ wFormToAForm (pure () <$ (wformMessage =<< messageI Info MsgExamBonusInfoPoints)) + <*> apreq (checkBool (> 0) MsgExamBonusMaxPointsNonPositive pointsField) (fslI MsgExamBonusMaxPoints & setTooltip MsgExamBonusMaxPointsTip) (preview _bonusMaxPoints =<< prev) <*> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamBonusOnlyPassed) (Just <$> preview _bonusOnlyPassed =<< prev)) <*> areq (checkBool (> 0) MsgExamBonusRoundNonPositive pointsField) (fslI MsgExamBonusRound & setTooltip MsgExamBonusRoundTip) (preview _bonusRound =<< prev) ) @@ -920,13 +943,15 @@ genericFileField mkOpts = Field{..} fieldEnctype = Multipart fieldParse :: [Text] -> [FileInfo] -> m (Either (SomeMessage (HandlerSite m)) (Maybe FileUploads)) - fieldParse vals files = runExceptT $ do + fieldParse vals files' = runExceptT $ do + let files = filter (not . null . fileName) files' + opts@FileField{..} <- liftHandler mkOpts mIdent <- fmap getFirst . flip foldMapM vals $ \v -> fmap First . runMaybeT . exceptTMaybe $ encodedSecretBoxOpen v - let uploadedFilenames = fileName <$> bool (take 1) id fieldMultiple files + let uploadedFilenames = fileName <$> files let doUnpack @@ -973,7 +998,7 @@ genericFileField mkOpts = Field{..} .| C.mapMaybe (\fTitle -> fmap (fTitle, ) . assertM (views _3 $ not . fieldOptionForce) $ Map.lookup fTitle permittedFiles) .| C.filter (\(fTitle, _) -> fieldMultiple - || ( bool (\n h -> h == pure n) elem fieldMultiple fTitle (mapMaybe (preview _FileTitle) vals) + || ( fTitle `elem` mapMaybe (preview _FileTitle) vals && null files ) ) @@ -1091,47 +1116,67 @@ singleFileField prev = genericFileField $ do , fieldAllEmptyOk = True } -specificFileField :: UploadSpecificFile -> Field Handler FileUploads -specificFileField UploadSpecificFile{..} = convertField (.| fixupFileTitles) id . genericFileField $ return FileField - { fieldIdent = Nothing - , fieldUnpackZips = FileFieldUserOption True False - , fieldMultiple = False - , fieldRestrictExtensions = fromNullable . maybe Set.empty (Set.singleton . view _2) . Map.lookupMin . Map.fromList . map (length &&& id) $ fileNameExtensions specificFileName - , fieldAdditionalFiles = _FileReferenceFileReferenceTitleMap # Map.empty - , fieldMaxFileSize = specificFileMaxSize - , fieldAllEmptyOk = specificFileEmptyOk - } +specificFileField :: UploadSpecificFile -> Maybe FileUploads -> Field Handler FileUploads +specificFileField UploadSpecificFile{..} mPrev = convertField (.| fixupFileTitles) id . genericFileField $ do + previous <- runConduit $ maybeVoid mPrev .| C.foldMap Set.singleton + return FileField + { fieldIdent = Nothing + , fieldUnpackZips = FileFieldUserOption True False + , fieldMultiple = False + , fieldRestrictExtensions = fromNullable . maybe Set.empty (Set.singleton . view _2) . Map.lookupMin . Map.fromList . map (length &&& id) $ fileNameExtensions specificFileName + , fieldAdditionalFiles = _FileReferenceFileReferenceTitleMap # Map.fromList + [ (fileReferenceTitle, (fileReferenceContent, fileReferenceModified, FileFieldUserOption False True)) + | FileReference{..} <- Set.toList previous + ] + , fieldMaxFileSize = specificFileMaxSize + , fieldAllEmptyOk = specificFileEmptyOk + } where fixupFileTitles = C.map $ set _fileReferenceTitle (unpack specificFileName) zipFileField :: Bool -- ^ Unpack zips? - -> Maybe (NonNull (Set Extension)) -- ^ Restrictions on file extensions - -> Bool -- ^ Empty files ok? - -> Field Handler FileUploads -zipFileField doUnpack permittedExtensions emptyOk = genericFileField $ return FileField - { fieldIdent = Nothing - , fieldUnpackZips = FileFieldUserOption True doUnpack - , fieldMultiple = doUnpack - , fieldRestrictExtensions = permittedExtensions - , fieldAdditionalFiles = _FileReferenceFileReferenceTitleMap # Map.empty - , fieldMaxFileSize = Nothing - , fieldAllEmptyOk = emptyOk - } + -> Maybe (NonNull (Set Extension)) -- ^ Restrictions on file extensions + -> 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? + -> Maybe FileUploads + -> Field Handler FileUploads +zipFileField' doUnpack permittedExtensions emptyOk mPrev = genericFileField $ do + previous <- runConduit $ maybeVoid mPrev .| C.foldMap Set.singleton + return FileField + { fieldIdent = Nothing + , fieldUnpackZips = FileFieldUserOption True doUnpack + , fieldMultiple = doUnpack + , fieldRestrictExtensions = permittedExtensions + , fieldAdditionalFiles = _FileReferenceFileReferenceTitleMap # Map.fromList + [ (fileReferenceTitle, (fileReferenceContent, fileReferenceModified, FileFieldUserOption False True)) + | FileReference{..} <- Set.toList previous + ] + , fieldMaxFileSize = Nothing + , fieldAllEmptyOk = emptyOk + } fileUploadForm :: Bool -- ^ Required? -> (Bool -> FieldSettings UniWorX) -- ^ given @unpackZips@ generate `FieldSettings` in the case of `UploadAny` - -> UploadMode -> AForm Handler (Maybe FileUploads) -fileUploadForm isReq mkFs = \case + -> UploadMode + -> Maybe FileUploads + -> AForm Handler (Maybe FileUploads) +fileUploadForm isReq mkFs uMode mPrev = case uMode of NoUpload -> pure Nothing UploadAny{..} - -> bool aopt (\f fs _ -> Just <$> areq f fs Nothing) isReq (zipFileField uploadUnpackZips uploadExtensionRestriction uploadEmptyOk) (mkFs uploadUnpackZips) Nothing + -> bool (\f fs d -> aopt f fs $ Just <$> d) (\f fs d -> Just <$> apreq f fs d) isReq (zipFileField' uploadUnpackZips uploadExtensionRestriction uploadEmptyOk mPrev) (mkFs uploadUnpackZips) mPrev UploadSpecific{..} -> mergeFileSources <$> traverse specificFileForm (Set.toList $ toNullable uploadSpecificFiles) where specificFileForm :: UploadSpecificFile -> AForm Handler (Maybe FileUploads) specificFileForm spec@UploadSpecificFile{..} - = bool (\f fs d -> aopt f fs $ fmap Just d) (\f fs d -> Just <$> areq f fs d) (specificFileRequired && isReq) (specificFileField spec) (fsl specificFileLabel) Nothing + = bool (\f fs d -> aopt f fs $ Just <$> d) (\f fs d -> Just <$> apreq f fs d) (specificFileRequired && isReq) (specificFileField spec mPrev') (fsl specificFileLabel) mPrev' + where mPrev' = flip (.|) (C.filter . has $ _fileReferenceTitle . only (unpack specificFileName)) <$> mPrev mergeFileSources :: [Maybe FileUploads] -> Maybe FileUploads mergeFileSources (catMaybes -> sources) = case sources of @@ -1199,14 +1244,17 @@ sheetGradingAFormReq fs template = multiActionA selOptions fs (classify' <$> tem sheetTypeAFormReq :: CourseId -> FieldSettings UniWorX -> Maybe (SheetType ExamPartId) -> AForm Handler (SheetType ExamPartId) sheetTypeAFormReq cId fs template = wFormToAForm $ do - examParts'' <- liftHandler . runDB . E.select . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examPart) -> do - E.on $ exam E.^. ExamId E.==. examPart E.^. ExamPartExam - E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse - E.where_ $ exam E.^. ExamCourse E.==. E.val cId - return (exam, course, examPart) + (examParts'', editableExams) <- liftHandler . runDB $ do + examParts'' <- E.select . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examPart) -> do + E.on $ exam E.^. ExamId E.==. examPart E.^. ExamPartExam + E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse + E.where_ $ exam E.^. ExamCourse E.==. E.val cId + return (exam, course, examPart) - 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 + 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) @@ -1454,11 +1502,10 @@ fsUniq mkUnique seed = "" { fsName = Just $ mkUnique seed } optionsPersistCryptoId :: forall backend a msg. ( HasCryptoUUID (Key a) (HandlerFor UniWorX) - , KnownSymbol (CryptoIDNamespace UUID (Key a)) , RenderMessage UniWorX msg , YesodPersistBackend UniWorX ~ backend , PersistRecordBackend a backend - , PathPiece (Key a) + , Binary (Key a), Typeable a ) => [Filter a] -> [SelectOpt a] @@ -1470,11 +1517,10 @@ optionsPersistCryptoId filts ords toDisplay = do optionsCryptoIdE :: forall backend a msg. ( HasCryptoUUID (Key a) (HandlerFor UniWorX) - , KnownSymbol (CryptoIDNamespace UUID (Key a)) , RenderMessage UniWorX msg , YesodPersistBackend UniWorX ~ backend , PersistRecordBackend a backend - , PathPiece (Key a) + , Binary (Key a), Typeable a ) => E.SqlQuery (E.SqlExpr (Entity a)) -> (a -> msg) @@ -1484,12 +1530,11 @@ optionsCryptoIdE query toDisplay = do optionsCryptoIdF ents (return . entityKey) (return . toDisplay . entityVal) optionsCryptoIdF :: forall m mono k msg. - ( HasCryptoUUID k m - , KnownSymbol (CryptoIDNamespace UUID k) + ( HasCryptoUUID k (HandlerFor (HandlerSite m)) , RenderMessage (HandlerSite m) msg , MonoFoldable mono - , MonadHandler m - , PathPiece k + , MonadHandler m, HandlerSite m ~ UniWorX + , Binary k, Typeable k ) => mono -> (Element mono -> m k) @@ -1961,11 +2006,16 @@ csvFormatOptionsForm fs mPrev = hoistAForm liftHandler . multiActionA csvActs fs CsvFormatOptionsPreset' preset -> pure $ csvPreset # preset CsvFormatOptionsCustom' + -> multiActionA csvFormatActs (fslI MsgCsvFormatField) $ view _CsvFormat <$> mPrev + csvFormatActs :: Map CsvFormat (AForm Handler CsvFormatOptions) + csvFormatActs = mapF $ \case + FormatCsv -> CsvFormatOptions - <$> areq (selectField delimiterOpts) (fslI MsgCsvDelimiter) (csvDelimiter <$> mPrev) - <*> areq (selectField lineEndOpts) (fslI MsgCsvUseCrLf) (csvUseCrLf <$> mPrev) - <*> areq (selectField quoteOpts) (fslI MsgCsvQuoting & setTooltip MsgCsvQuotingTip) (csvQuoting <$> mPrev) - <*> areq (selectField encodingOpts) (fslI MsgCsvEncoding & setTooltip MsgCsvEncodingTip) (csvEncoding <$> mPrev) + <$> apreq (selectField delimiterOpts) (fslI MsgCsvDelimiter) (preview _csvDelimiter =<< mPrev) + <*> apreq (selectField lineEndOpts) (fslI MsgCsvUseCrLf) (preview _csvUseCrLf =<< mPrev) + <*> apreq (selectField quoteOpts) (fslI MsgCsvQuoting & setTooltip MsgCsvQuotingTip) (preview _csvQuoting =<< mPrev) + <*> apreq (selectField encodingOpts) (fslI MsgCsvEncoding & setTooltip MsgCsvEncodingTip) (preview _csvEncoding =<< mPrev) + FormatXlsx -> pure CsvXlsxFormatOptions delimiterOpts :: Handler (OptionList Char) delimiterOpts = do diff --git a/src/Handler/Utils/Mail.hs b/src/Handler/Utils/Mail.hs index 18785044c..b4e32ed32 100644 --- a/src/Handler/Utils/Mail.hs +++ b/src/Handler/Utils/Mail.hs @@ -53,6 +53,7 @@ userMailT uid mAct = do , userDateTimeFormat , userDateFormat , userTimeFormat + , userCsvOptions } <- liftHandler . runDB $ getJust uid let ctx = MailContext @@ -61,6 +62,7 @@ userMailT uid mAct = do SelFormatDateTime -> userDateTimeFormat SelFormatDate -> userDateFormat SelFormatTime -> userTimeFormat + , mcCsvOptions = userCsvOptions } mailT ctx $ do _mailTo .= pure (userAddress user) diff --git a/src/Handler/Utils/Memcached.hs b/src/Handler/Utils/Memcached.hs index 140345aff..de06f6103 100644 --- a/src/Handler/Utils/Memcached.hs +++ b/src/Handler/Utils/Memcached.hs @@ -1,9 +1,12 @@ +{-# LANGUAGE DuplicateRecordFields #-} + module Handler.Utils.Memcached ( memcachedAvailable , memcached, memcachedBy , memcachedHere, memcachedByHere , memcachedSet, memcachedGet , memcachedInvalidate, memcachedByInvalidate + , manageMemcachedLocalInvalidations , memcachedByGet, memcachedBySet , memcachedTimeout, memcachedTimeoutBy , memcachedTimeoutHere, memcachedTimeoutByHere @@ -35,9 +38,11 @@ import Crypto.Hash.Algorithms (SHAKE256) import qualified Data.ByteArray as BA +import qualified Data.ByteString.Base64 as Base64 + import Language.Haskell.TH hiding (Type) -import Data.Typeable (typeRep) +import Data.Typeable (typeRep, typeRepFingerprint) import Type.Reflection (typeOf, TypeRep) import qualified Type.Reflection as Refl (typeRep) import Data.Type.Equality (TestEquality(..)) @@ -56,6 +61,14 @@ import qualified Crypto.Saltine.Core.AEAD as AEAD import qualified Control.Monad.State.Class as State +import qualified Data.ByteString.Lazy as Lazy (ByteString) + +import GHC.Fingerprint + +import Utils.Postgresql + +import UnliftIO.Concurrent (threadDelay) + type Expiry = Either UTCTime DiffTime @@ -110,7 +123,7 @@ putMemcachedValue MemcachedValue{..} = do putExpiry mExpiry Binary.putByteString mCiphertext -getMemcachedValue :: Binary.Get MemcachedValue +getMemcachedValue, getMemcachedValueNoExpiry :: Binary.Get MemcachedValue getMemcachedValue = do Binary.lookAhead . Binary.label "length check" $ do void . Binary.getByteString $ Saltine.secretBoxNonce + 4 + Saltine.secretBoxMac @@ -118,8 +131,6 @@ getMemcachedValue = do mExpiry <- getExpiry mCiphertext <- Binary.label "ciphertext" $ toStrict <$> Binary.getRemainingLazyByteString return MemcachedValue{..} - -getMemcachedValueNoExpiry :: Binary.Get MemcachedValue getMemcachedValueNoExpiry = do Binary.lookAhead . Binary.label "length check" $ do void . Binary.getByteString $ Saltine.secretBoxNonce + 4 + Saltine.secretBoxMac @@ -128,7 +139,6 @@ getMemcachedValueNoExpiry = do mCiphertext <- Binary.label "ciphertext" $ toStrict <$> Binary.getRemainingLazyByteString return MemcachedValue{..} - memcachedAvailable :: ( MonadHandler m, HandlerSite m ~ UniWorX ) => m Bool @@ -141,13 +151,9 @@ data MemcachedException = MemcachedException Memcached.MemcachedException deriving anyclass (Exception) -memcachedKey :: ( Typeable a - , Binary k - ) - => AEAD.Key -> Proxy a -> k -> ByteString -memcachedKey (Saltine.encode -> kmacKey) p k = Binary.encode k - & kmaclazy @(SHAKE256 256) (encodeUtf8 . tshow $ typeRep p) kmacKey - & BA.convert +toMemcachedKey :: Typeable a + => AEAD.Key -> Proxy a -> Lazy.ByteString -> ByteString +toMemcachedKey (Saltine.encode -> kmacKey) p = BA.convert . kmaclazy @(SHAKE256 256) (encodeUtf8 . tshow $ typeRep p) kmacKey memcachedAAD :: ByteString -> Maybe POSIXTime -> ByteString memcachedAAD cKey mExpiry = toStrict . Binary.runPut $ do @@ -156,86 +162,173 @@ memcachedAAD cKey mExpiry = toStrict . Binary.runPut $ do memcachedByGet :: forall a k m. ( MonadHandler m, HandlerSite m ~ UniWorX - , Typeable a, Binary a + , Typeable a, Binary a, NFData a , Binary k ) => k -> m (Maybe a) -memcachedByGet k = runMaybeT $ do - (aeadKey, conn) <- MaybeT $ getsYesod appMemcached - let cKey = memcachedKey aeadKey (Proxy @a) k - - encVal <- fmap toStrict . hoist liftIO . catchMaybeT (Proxy @Memcached.MemcachedException) $ Memcached.get_ cKey conn - - $logDebugS "memcached" "Cache hit" - - let withExp doExp = do - MemcachedValue{..} <- hoistMaybe . flip runGetMaybe encVal $ bool getMemcachedValueNoExpiry getMemcachedValue doExp - $logDebugS "memcached" "Decode valid" - for_ mExpiry $ \expiry -> do - now <- liftIO getPOSIXTime - guard $ expiry > now + clockLeniency - $logDebugS "memcached" $ "Expiry valid: " <> tshow mExpiry - let aad = memcachedAAD cKey mExpiry - decrypted <- hoistMaybe $ AEAD.aeadOpen aeadKey mNonce mCiphertext aad - - $logDebugS "memcached" $ "Decryption valid " <> bool "without" "with" doExp <> " expiration" - - hoistMaybe $ runGetMaybe Binary.get decrypted - - withExp True <|> withExp False +memcachedByGet (Binary.encode -> k) = runMaybeT $ arc <|> memcache where - runGetMaybe p (fromStrict -> bs) = case Binary.runGetOrFail p bs of - Right (bs', _, x) | null bs' -> Just x - _other -> Nothing - clockLeniency :: NominalDiffTime - clockLeniency = 2 + arc = do + AppMemcachedLocal{..} <- MaybeT $ getsYesod appMemcachedLocal + res <- hoistMaybe . preview (_1 . _NFDynamic) <=< hoistMaybe <=< cachedARC' memcachedLocalARC (typeRepFingerprint . typeRep $ Proxy @a, k) $ \mPrev -> do + prev@((_, prevExpiry), _) <- hoistMaybe mPrev + $logDebugS "memcached" "Cache hit (local ARC)" + lift . runMaybeT $ do -- To delete from ARC upon expiry + for_ prevExpiry $ \expiry -> do + now <- liftIO getPOSIXTime + guard $ expiry > now + return prev + $logDebugS "memcached" "All valid (local ARC)" + return res + memcache = do + AppMemcached{..} <- MaybeT $ getsYesod appMemcached + localARC <- getsYesod appMemcachedLocal + let cKey = toMemcachedKey memcachedKey (Proxy @a) k + + encVal <- fmap toStrict . hoist liftIO . catchMaybeT (Proxy @Memcached.MemcachedException) $ Memcached.get_ cKey memcachedConn + + $logDebugS "memcached" "Cache hit" + + let withExp doExp = do + MemcachedValue{..} <- hoistMaybe . flip runGetMaybe encVal $ bool getMemcachedValueNoExpiry getMemcachedValue doExp + $logDebugS "memcached" "Decode valid" + for_ mExpiry $ \expiry -> do + now <- liftIO getPOSIXTime + guard $ expiry > now + clockLeniency + $logDebugS "memcached" $ "Expiry valid: " <> tshow mExpiry + let aad = memcachedAAD cKey mExpiry + decrypted <- hoistMaybe $ AEAD.aeadOpen memcachedKey mNonce mCiphertext aad + + $logDebugS "memcached" $ "Decryption valid " <> bool "without" "with" doExp <> " expiration" + + let withCache = case localARC of + Just AppMemcachedLocal{..} -> cachedARC memcachedLocalARC (typeRepFingerprint . typeRep $ Proxy @a, k) + Nothing -> fmap (view _1) . ($ Nothing) + res <- hoistMaybe . preview (_1 . _NFDynamic) <=< withCache $ \case + Nothing -> fmap ((, length decrypted) . (, mExpiry) . review (_NFDynamic @a)) . hoistMaybe $ runGetMaybe Binary.get decrypted + Just p -> return p + + $logDebugS "memcached" "All valid" + + return res + + withExp True <|> withExp False + where + runGetMaybe p (fromStrict -> bs) = case Binary.runGetOrFail p bs of + Right (bs', _, x) | null bs' -> Just x + _other -> Nothing + clockLeniency :: NominalDiffTime + clockLeniency = 2 memcachedBySet :: forall a k m. ( MonadHandler m, HandlerSite m ~ UniWorX , MonadThrow m - , Typeable a, Binary a + , Typeable a, Binary a, NFData a , Binary k ) => Maybe Expiry -> k -> a -> m () -memcachedBySet mExp k v = do +memcachedBySet mExp (Binary.encode -> k) v = do mExp' <- for mExp $ \exp -> maybe (throwM $ MemcachedInvalidExpiry exp) return $ exp ^? _MemcachedExpiry + + let decrypted = toStrict $ Binary.encode v + mExpiry <- for mExp $ \case + Left uTime -> return $ utcTimeToPOSIXSeconds uTime + Right diff -> liftIO $ (+ realToFrac diff) <$> getPOSIXTime + mConn <- getsYesod appMemcached - for_ mConn $ \(aeadKey, conn) -> do + for_ mConn $ \AppMemcached{..} -> do mNonce <- liftIO AEAD.newNonce - mExpiry <- for mExp $ \case - Left uTime -> return $ utcTimeToPOSIXSeconds uTime - Right diff -> liftIO $ (+ realToFrac diff) <$> getPOSIXTime - let cKey = memcachedKey aeadKey (Proxy @a) k + let cKey = toMemcachedKey memcachedKey (Proxy @a) k aad = memcachedAAD cKey mExpiry - mCiphertext = AEAD.aead aeadKey mNonce (toStrict $ Binary.encode v) aad - liftIO $ Memcached.set zeroBits (fromMaybe zeroBits mExp') cKey (Binary.runPut $ putMemcachedValue MemcachedValue{..}) conn + mCiphertext = AEAD.aead memcachedKey mNonce decrypted aad + liftIO $ Memcached.set zeroBits (fromMaybe zeroBits mExp') cKey (Binary.runPut $ putMemcachedValue MemcachedValue{..}) memcachedConn $logDebugS "memcached" $ "Cache store: " <> tshow mExpiry + mLocal <- getsYesod appMemcachedLocal + for_ mLocal $ \AppMemcachedLocal{..} -> do + void . cachedARC memcachedLocalARC (typeRepFingerprint . typeRep $ Proxy @a, k) . const $ return ((_NFDynamic # v, mExpiry), length decrypted) + $logDebugS "memcached" $ "Cache store: " <> tshow mExpiry <> " (local ARC)" + -- DEBUG + let inv = Base64.encode . toStrict $ Binary.encode MemcachedLocalInvalidateMsg{..} + where mLocalInvalidateType = typeRepFingerprint . typeRep $ Proxy @a + mLocalInvalidateKey = k + $logDebugS "memcached" $ "To invalidate remotely: " <> tshow inv + memcachedByInvalidate :: forall a k m p. ( MonadHandler m, HandlerSite m ~ UniWorX , Typeable a , Binary k ) => k -> p a -> m () -memcachedByInvalidate k _ = maybeT_ $ do - (aeadKey, conn) <- MaybeT $ getsYesod appMemcached - let cKey = memcachedKey aeadKey (Proxy @a) k - hoist liftIO . catchIfMaybeT Memcached.isKeyNotFound $ Memcached.delete cKey conn +memcachedByInvalidate (Binary.encode -> k) _ = arc >> memcache + where + memcache = maybeT_ $ do + AppMemcached{..} <- MaybeT $ getsYesod appMemcached + let cKey = toMemcachedKey memcachedKey (Proxy @a) k + hoist liftIO . catchIfMaybeT Memcached.isKeyNotFound $ Memcached.delete cKey memcachedConn + $logDebugS "memcached" "Cache invalidation" + arc = maybeT_ $ do + AppMemcachedLocal{..} <- MaybeT $ getsYesod appMemcachedLocal + let arcKey = (typeRepFingerprint . typeRep $ Proxy @a, k) + atomically $ modifyTVar' memcachedLocalInvalidationQueue (:> arcKey) + void . cachedARC' memcachedLocalARC arcKey . const $ return Nothing + $logDebugS "memcached" "Cache invalidation (local ARC)" + +data MemcachedLocalInvalidateMsg = MemcachedLocalInvalidateMsg + { mLocalInvalidateType :: Fingerprint + , mLocalInvalidateKey :: Lazy.ByteString + } deriving (Eq, Ord, Show, Typeable) + +instance Binary MemcachedLocalInvalidateMsg where + get = Binary.label "MemcachedLocalInvalidateMsg" $ do + mLocalInvalidateType <- Binary.label "mLocalInvalidateType" $ Fingerprint <$> Binary.getWord64le <*> Binary.getWord64le + mLocalInvalidateKey <- Binary.label "mLocalInvalidateKey" Binary.getRemainingLazyByteString + return MemcachedLocalInvalidateMsg{..} + put MemcachedLocalInvalidateMsg{..} = do + let Fingerprint w1 w2 = mLocalInvalidateType + Binary.putWord64le w1 + Binary.putWord64le w2 + Binary.putLazyByteString mLocalInvalidateKey + +manageMemcachedLocalInvalidations :: ( MonadUnliftIO m + , MonadLogger m + ) + => ARCHandle (Fingerprint, Lazy.ByteString) Int (NFDynamic, Maybe POSIXTime) + -> TVar (Seq (Fingerprint, Lazy.ByteString)) + -> PostgresqlChannelManager m () +manageMemcachedLocalInvalidations localARC iQueue = PostgresqlChannelManager + { pgcTerminate = forever $ threadDelay maxBound + , pgcOnInput = Just $ \inpBS -> case Binary.runGetOrFail Binary.get . fromStrict <$> Base64.decode inpBS of + Right (Right (bs', _, MemcachedLocalInvalidateMsg{..})) | null bs' -> + void . cachedARC' localARC (mLocalInvalidateType, mLocalInvalidateKey) $ \mPrev -> do + $logDebugS "memcached" $ "Remote invalidation in local ARC: " <> bool "miss" "hit" (is _Just mPrev) + return Nothing + _other -> $logErrorS "memcached" $ "Received unparseable remote invalidation: " <> tshow inpBS + , pgcGenOutput = atomically $ do + iQueue' <- readTVar iQueue + i <- case iQueue' of + i :< is' -> i <$ writeTVar iQueue is' + _other -> mzero + let (mLocalInvalidateType, mLocalInvalidateKey) = i + return . Base64.encode . toStrict $ Binary.encode MemcachedLocalInvalidateMsg{..} + } newtype MemcachedUnkeyed a = MemcachedUnkeyed { unMemcachedUnkeyed :: a } deriving (Typeable) deriving newtype (Eq, Ord, Show, Binary) +instance NFData a => NFData (MemcachedUnkeyed a) where + rnf = rnf . unMemcachedUnkeyed memcachedGet :: ( MonadHandler m, HandlerSite m ~ UniWorX - , Typeable a, Binary a + , Typeable a, Binary a, NFData a ) => m (Maybe a) memcachedGet = fmap unMemcachedUnkeyed <$> memcachedByGet () memcachedSet :: ( MonadHandler m, HandlerSite m ~ UniWorX , MonadThrow m - , Typeable a, Binary a + , Typeable a, Binary a, NFData a ) => Maybe Expiry -> a -> m () memcachedSet mExp = memcachedBySet mExp () . MemcachedUnkeyed @@ -258,14 +351,14 @@ memcachedWith (doGet, doSet) act = do memcached :: ( MonadHandler m, HandlerSite m ~ UniWorX , MonadThrow m - , Typeable a, Binary a + , Typeable a, Binary a, NFData a ) => Maybe Expiry -> m a -> m a memcached mExp = memcachedWith (memcachedGet, \x -> x <$ memcachedSet mExp x) memcachedBy :: ( MonadHandler m, HandlerSite m ~ UniWorX , MonadThrow m - , Typeable a, Binary a + , Typeable a, Binary a, NFData a , Binary k ) => Maybe Expiry -> k -> m a -> m a @@ -275,6 +368,8 @@ memcachedBy mExp k = memcachedWith (memcachedByGet k, \x -> x <$ memcachedBySet newtype MemcachedUnkeyedLoc a = MemcachedUnkeyedLoc { unMemcachedUnkeyedLoc :: a } deriving (Typeable) deriving newtype (Eq, Ord, Show, Binary) +instance NFData a => NFData (MemcachedUnkeyedLoc a) where + rnf MemcachedUnkeyedLoc{..} = rnf unMemcachedUnkeyedLoc memcachedHere :: Q Exp memcachedHere = do @@ -284,11 +379,21 @@ memcachedHere = do newtype MemcachedKeyedLoc a = MemcachedKeyedLoc { unMemcachedKeyedLoc :: a } deriving (Typeable) deriving newtype (Eq, Ord, Show, Binary) +instance NFData a => NFData (MemcachedKeyedLoc a) where + rnf MemcachedKeyedLoc{..} = rnf unMemcachedKeyedLoc + +withMemcachedKeyedLoc :: Functor f => (f (MemcachedKeyedLoc a) -> f (MemcachedKeyedLoc a)) -> (f a -> f a) +withMemcachedKeyedLoc act = fmap unMemcachedKeyedLoc . act . fmap MemcachedKeyedLoc +{-# INLINE withMemcachedKeyedLoc #-} + +withMemcachedKeyedLoc' :: (Functor f, Functor f') => (f (MemcachedKeyedLoc a) -> f (f' (MemcachedKeyedLoc a))) -> (f a -> f (f' a)) +withMemcachedKeyedLoc' act = fmap (fmap unMemcachedKeyedLoc) . act . fmap MemcachedKeyedLoc +{-# INLINE withMemcachedKeyedLoc' #-} memcachedByHere :: Q Exp memcachedByHere = do loc <- location - [e| \mExp k -> fmap unMemcachedKeyedLoc . memcachedBy mExp (loc, k) . fmap MemcachedKeyedLoc |] + [e| \mExp k -> withMemcachedKeyedLoc (memcachedBy mExp (loc, k)) |] data HashableDynamic = forall a. (Hashable a, Eq a) => HashableDynamic !(TypeRep a) !a @@ -346,7 +451,7 @@ memcachedLimitedWith (doGet, doSet) liftAct (hashableDynamic -> lK) burst rate t memcachedLimited :: forall a m. ( MonadHandler m, HandlerSite m ~ UniWorX , MonadThrow m - , Typeable a, Binary a + , Typeable a, Binary a, NFData a ) => Word64 -- ^ burst-size (tokens) -> Word64 -- ^ avg. inverse rate (usec/token) @@ -359,7 +464,7 @@ memcachedLimited burst rate tokens mExp = memcachedLimitedWith (memcachedGet, me memcachedLimitedKey :: forall a k' m. ( MonadHandler m, HandlerSite m ~ UniWorX , MonadThrow m - , Typeable a, Binary a + , Typeable a, Binary a, NFData a , Typeable k', Hashable k', Eq k' ) => k' @@ -374,7 +479,7 @@ memcachedLimitedKey lK burst rate tokens mExp = memcachedLimitedWith (memcachedG memcachedLimitedBy :: forall a k m. ( MonadHandler m, HandlerSite m ~ UniWorX , MonadThrow m - , Typeable a, Binary a + , Typeable a, Binary a, NFData a , Binary k ) => Word64 -- ^ burst-size (tokens) @@ -389,7 +494,7 @@ memcachedLimitedBy burst rate tokens mExp k = memcachedLimitedWith (memcachedByG memcachedLimitedKeyBy :: forall a k' k m. ( MonadHandler m, HandlerSite m ~ UniWorX , MonadThrow m - , Typeable a, Binary a + , Typeable a, Binary a, NFData a , Typeable k', Hashable k', Eq k' , Binary k ) @@ -416,18 +521,18 @@ memcachedLimitedKeyHere = do memcachedLimitedByHere :: Q Exp memcachedLimitedByHere = do loc <- location - [e| \burst rate tokens mExp k -> fmap (fmap unMemcachedKeyedLoc) . memcachedLimitedBy burst rate tokens mExp (loc, k) . fmap MemcachedKeyedLoc |] + [e| \burst rate tokens mExp k -> withMemcachedKeyedLoc' (memcachedLimitedBy burst rate tokens mExp (loc, k)) |] memcachedLimitedKeyByHere :: Q Exp memcachedLimitedKeyByHere = do loc <- location - [e| \lK burst rate tokens mExp k -> fmap (fmap unMemcachedKeyedLoc) . memcachedLimitedKeyBy lK burst rate tokens mExp (loc, k) . fmap MemcachedKeyedLoc |] + [e| \lK burst rate tokens mExp k -> withMemcachedKeyedLoc' (memcachedLimitedKeyBy lK burst rate tokens mExp (loc, k)) |] memcacheAuth :: forall m k a. ( MonadHandler m, HandlerSite m ~ UniWorX , MonadThrow m - , Typeable a, Binary a + , Typeable a, Binary a, NFData a , Binary k ) => k @@ -448,7 +553,7 @@ memcacheAuth k mx = cachedByBinary k $ do memcacheAuth' :: forall m k a. ( MonadHandler m, HandlerSite m ~ UniWorX , MonadThrow m - , Typeable a, Binary a + , Typeable a, Binary a, NFData a , Binary k ) => Expiry @@ -460,7 +565,7 @@ memcacheAuth' exp k = memcacheAuth k . (<* tell (Just $ Min exp)) . lift memcacheAuthMax :: forall m k a. ( MonadHandler m, HandlerSite m ~ UniWorX , MonadThrow m - , Typeable a, Binary a + , Typeable a, Binary a, NFData a , Binary k ) => Expiry @@ -472,17 +577,17 @@ memcacheAuthMax exp k = memcacheAuth k . (tell (Just $ Min exp) *>) memcacheAuthHere :: Q Exp memcacheAuthHere = do loc <- location - [e| \k -> fmap unMemcachedKeyedLoc . memcacheAuth (loc, k) . fmap MemcachedKeyedLoc |] + [e| \k -> withMemcachedKeyedLoc (memcacheAuth (loc, k)) |] memcacheAuthHere' :: Q Exp memcacheAuthHere' = do loc <- location - [e| \exp k -> fmap unMemcachedKeyedLoc . memcacheAuth' exp (loc, k) . fmap MemcachedKeyedLoc |] + [e| \exp k -> withMemcachedKeyedLoc (memcacheAuth' exp (loc, k)) |] memcacheAuthHereMax :: Q Exp memcacheAuthHereMax = do loc <- location - [e| \exp k -> fmap unMemcachedKeyedLoc . memcacheAuthMax exp (loc, k) . fmap MemcachedKeyedLoc |] + [e| \exp k -> withMemcachedKeyedLoc (memcacheAuthMax exp (loc, k)) |] @@ -574,7 +679,7 @@ memcachedTimeout :: ( MonadHandler m, HandlerSite m ~ UniWorX , MonadThrow m , MonadUnliftIO m , Typeable k'', Hashable k'', Eq k'' - , Typeable a, Binary a + , Typeable a, Binary a, NFData a ) => Maybe Expiry -> DiffTime -> k'' -> m a -> m (Maybe a) memcachedTimeout mExp = memcachedTimeoutWith (memcachedGet, memcachedSet mExp) @@ -583,7 +688,7 @@ memcachedTimeoutBy :: ( MonadHandler m, HandlerSite m ~ UniWorX , MonadThrow m , MonadUnliftIO m , Typeable k'', Hashable k'', Eq k'' - , Typeable a, Binary a + , Typeable a, Binary a, NFData a , Binary k ) => Maybe Expiry -> DiffTime -> k'' -> k -> m a -> m (Maybe a) @@ -604,7 +709,7 @@ memcachedLimitedTimeout :: forall a k'' m. , MonadThrow m , MonadUnliftIO m , Typeable k'', Hashable k'', Eq k'' - , Typeable a, Binary a + , Typeable a, Binary a, NFData a ) => Word64 -- ^ burst-size (tokens) -> Word64 -- ^ avg. inverse rate (usec/token) @@ -621,7 +726,7 @@ memcachedLimitedKeyTimeout :: forall a k' k'' m. , MonadThrow m , MonadUnliftIO m , Typeable k'', Hashable k'', Eq k'' - , Typeable a, Binary a + , Typeable a, Binary a, NFData a , Typeable k', Hashable k', Eq k' ) => k' @@ -640,7 +745,7 @@ memcachedLimitedTimeoutBy :: forall a k'' k m. , MonadThrow m , MonadUnliftIO m , Typeable k'', Hashable k'', Eq k'' - , Typeable a, Binary a + , Typeable a, Binary a, NFData a , Binary k ) => Word64 -- ^ burst-size (tokens) @@ -659,7 +764,7 @@ memcachedLimitedKeyTimeoutBy :: forall a k' k'' k m. , MonadThrow m , MonadUnliftIO m , Typeable k'', Hashable k'', Eq k'' - , Typeable a, Binary a + , Typeable a, Binary a, NFData a , Typeable k', Hashable k', Eq k' , Binary k ) diff --git a/src/Handler/Utils/Minio.hs b/src/Handler/Utils/Minio.hs index 5d85ff633..92fdb0089 100644 --- a/src/Handler/Utils/Minio.hs +++ b/src/Handler/Utils/Minio.hs @@ -17,7 +17,7 @@ runAppMinio :: ( MonadHandler m, HandlerSite m ~ UniWorX => Minio a -> m a runAppMinio act = do conn <- hoistMaybe =<< getsYesod appUploadCache - either throwM return <=< liftIO $ Minio.runMinioWith conn act + throwLeft <=< liftIO $ Minio.runMinioWith conn act minioIsDoesNotExist :: HttpException -> Bool minioIsDoesNotExist (HttpExceptionRequest _ (StatusCodeException resp _)) diff --git a/src/Handler/Utils/Sheet.hs b/src/Handler/Utils/Sheet.hs index 760c15705..780dd4767 100644 --- a/src/Handler/Utils/Sheet.hs +++ b/src/Handler/Utils/Sheet.hs @@ -91,13 +91,12 @@ resolveSheetTypeRating cId dbST = do } sheetTypeDescription :: forall m. - ( MonadThrow m - , MonadHandler m, HandlerSite m ~ UniWorX + ( MonadHandler m, HandlerSite m ~ UniWorX ) => CourseId -> SheetType SqlBackendKey -> ReaderT SqlBackend m (HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)) -sheetTypeDescription cId dbST = do +sheetTypeDescription cId dbST = hoist liftHandler $ do sType' <- resolveSheetType cId dbST sType <- for sType' $ \(Entity _epId ExamPart{..}) -> do Exam{..} <- getJust examPartExam @@ -147,4 +146,8 @@ sheetExamResult SheetTypeSummary{ examSummary = MergeMap examSummary'' } (Entity pointsWeights = getSum $ foldMap (\(sWeight, gradeSummary) -> guardMonoid (sumSheetsPoints gradeSummary - sumSheetsPassPoints gradeSummary > 0) $ Sum sWeight) examSummary' passesWeights = getSum $ foldMap (\(sWeight, gradeSummary) -> guardMonoid (numSheetsPasses gradeSummary > 0) $ Sum sWeight) examSummary' - in ExamAttended . roundToPoints . (* examPartWeight) . (* weightRescale) . getSum . fold $ foldMapM (fmap Sum . toExamPoints) examSummary' + in if | SheetGradeSummary{numMarked} <- foldOf (folded . _2) examSummary' + , numMarked <= 0 + -> ExamNoShow + | otherwise + -> ExamAttended . roundToPoints . (* examPartWeight) . (* weightRescale) . getSum . fold $ foldMapM (fmap Sum . toExamPoints) examSummary' diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 41bc52cdf..f7505e10e 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -10,13 +10,14 @@ module Handler.Utils.Submission , sinkSubmission, sinkMultiSubmission , submissionMatchesSheet , submissionDeleteRoute + , correctionInvisibleWidget ) where import Import hiding (joinPath) import Jobs.Queue import Yesod.Core.Types (HandlerContents(..)) -import Control.Monad.State.Class as State +import qualified Control.Monad.State.Class as State import Control.Monad.Trans.State (execStateT) import Control.Monad.RWS.Lazy (MonadRWS, RWST, execRWST) import qualified Control.Monad.Random as Rand @@ -229,7 +230,7 @@ planSubmissions sid restriction = do targetSubmissions' <- liftIO . unstableSortBy (comparing $ \subId -> Map.null . view _2 $ submissionData ! subId) $ Set.toList targetSubmissions (newSubmissionData, ()) <- (\act -> execRWST act oldSubmissionData targetSubmissionData) . forM_ (zip [1..] targetSubmissions') $ \(i, subId) -> do - tutors <- gets $ view _2 . (! subId) -- :: Map UserId (Sum Natural) + tutors <- State.gets $ view _2 . (! subId) -- :: Map UserId (Sum Natural) let acceptableCorrectors | correctorsByTut <- Map.filter (is _Just . view _byTutorial) $ sheetCorrectors `Map.restrictKeys` Map.keysSet tutors , not $ null correctorsByTut @@ -359,7 +360,7 @@ submissionMultiArchive anonymous (Set.toList -> ids) = do notAnonymized' <- and2M (return $ isn't _SubmissionDownloadAnonymous anonymous) - (or2M (return $ not sheetAnonymous) (hasReadAccessTo $ CourseR tid ssh csh CCorrectionsR)) + (or2M (return $ not sheetAnonymous) (lift . hasReadAccessTo $ CourseR tid ssh csh CCorrectionsR)) submissionDirectory <- bool return withNames notAnonymized' $ dirFrag (cID :: CryptoFileNameSubmission) @@ -395,7 +396,6 @@ submissionMultiArchive anonymous (Set.toList -> ids) = do data SubmissionSinkState = SubmissionSinkState { sinkSeenRating :: Last Rating' , sinkSubmissionTouched :: Any - , sinkSubmissionNotifyRating :: Any , sinkFilenames :: Set FilePath } deriving (Show, Eq, Generic, Typeable) @@ -554,7 +554,7 @@ sinkSubmission userId mExists isUpdate = do sId <$ (guardFileTitles sheetSubmissionMode .| sinkSubmission' sId) where - tellSt = modify . mappend + tellSt = State.modify . mappend guardFileTitles :: MonadThrow m => SubmissionMode -> ConduitT SubmissionContent SubmissionContent m () guardFileTitles SubmissionMode{..} @@ -576,7 +576,7 @@ sinkSubmission userId mExists isUpdate = do Left file@FileReference{..} -> do $logDebugS "sinkSubmission" . tshow $ (submissionId, fileReferenceTitle) - alreadySeen <- gets (Set.member fileReferenceTitle . sinkFilenames) + alreadySeen <- State.gets (Set.member fileReferenceTitle . sinkFilenames) when alreadySeen . throwM $ DuplicateFileTitle fileReferenceTitle tellSt $ mempty{ sinkFilenames = Set.singleton fileReferenceTitle } @@ -632,7 +632,7 @@ sinkSubmission userId mExists isUpdate = do unless (submissionId' == submissionId) $ throwM $ ForeignRating cID - alreadySeen <- gets $ is (_Wrapped . _Just) . sinkSeenRating + alreadySeen <- State.gets $ is (_Wrapped . _Just) . sinkSeenRating when alreadySeen $ throwM DuplicateRating submission <- lift $ getJust submissionId @@ -671,8 +671,6 @@ sinkSubmission userId mExists isUpdate = do mapM_ (throwM . RatingSubmissionException cID . RatingValidityException) $ validateRating sheetType r' - when (submissionRatingDone submission' && not (submissionRatingDone submission)) $ - tellSt mempty { sinkSubmissionNotifyRating = Any True } lift $ replace submissionId submission' sheetId <- lift getSheetId lift $ audit $ TransactionSubmissionEdit submissionId sheetId @@ -697,7 +695,7 @@ sinkSubmission userId mExists isUpdate = do touchSubmission :: StateT SubmissionSinkState (YesodJobDB UniWorX) () touchSubmission = do - alreadyTouched <- gets $ getAny . sinkSubmissionTouched + alreadyTouched <- State.gets $ getAny . sinkSubmissionTouched unless alreadyTouched $ do now <- liftIO getCurrentTime if @@ -769,9 +767,6 @@ sinkSubmission userId mExists isUpdate = do update submissionId [ SubmissionRatingTime =. Nothing, SubmissionRatingPoints =. Nothing, SubmissionRatingComment =. Nothing] sheetId <- getSheetId audit $ TransactionSubmissionEdit submissionId sheetId - | isUpdate - , getAny sinkSubmissionNotifyRating - -> queueDBJob . JobQueueNotification $ NotificationSubmissionRated submissionId | not isUpdate , getAny sinkSubmissionTouched , is _Right mExists @@ -801,7 +796,7 @@ sinkMultiSubmission userId isUpdate = do (YesodJobDB UniWorX) () feed sId val = do - mSink <- gets $ Map.lookup sId + mSink <- State.gets $ Map.lookup sId sink <- case mSink of Just sink -> return sink Nothing -> do @@ -811,12 +806,12 @@ sinkMultiSubmission userId isUpdate = do Submission{..} <- get404 sId Sheet{..} <- get404 submissionSheet Course{..} <- get404 sheetCourse - guardAuthResult =<< evalAccessDB (CSubmissionR courseTerm courseSchool courseShorthand sheetName cID CorrectionR) True + hoist lift $ guardAuthResult =<< evalAccessDB (CSubmissionR courseTerm courseSchool courseShorthand sheetName cID CorrectionR) True return . newResumableSink $ sinkSubmission (Just userId) (Right sId) isUpdate sink' <- lift $ yield val ++$$ sink case sink' of Left _ -> error "sinkSubmission returned prematurely" - Right nSink -> modify $ Map.insert sId nSink + Right nSink -> State.modify $ Map.insert sId nSink (sinks, ignoredFiles) <- execRWSLC () Map.empty . awaitForever $ \case v@(Right (sId, _)) -> do cID <- encrypt sId @@ -930,3 +925,36 @@ submissionDeleteRoute drRecords = DeleteRoute del } + + +data CorrectionInvisibleReason + = CorrectionInvisibleExamUnfinished + | CorrectionInvisibleRatingNotDone + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + deriving anyclass (Universe, Finite) +embedRenderMessage ''UniWorX ''CorrectionInvisibleReason id + +correctionInvisibleWidget :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission + -> Entity Submission + -> DB (Maybe Widget) +correctionInvisibleWidget tid ssh csh shn cID (Entity subId sub) = runMaybeT $ do + submittors <- lift . fmap (Set.fromList . fmap E.unValue) . E.select . E.from $ \submissionUser -> do + E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val subId + return $ submissionUser E.^. SubmissionUserUser + + corrVisible <- lift . allM submittors $ \bId -> is _Authorized <$> evalAccessFor (Just bId) (CSubmissionR tid ssh csh shn cID CorrectionR) False + guard $ not corrVisible + + reasons <- lift . mapReaderT execWriterT $ do + unless (submissionRatingDone sub) $ + tellPoint @(Set _) CorrectionInvisibleRatingNotDone + maybeT_ $ do + Sheet{..} <- MaybeT . get $ submissionSheet sub + epId <- hoistMaybe $ sheetType ^? _examPart . from _SqlKey + ExamPart{examPartExam} <- MaybeT $ get epId + Exam{..} <- MaybeT $ get examPartExam + now <- liftIO getCurrentTime + unless (NTop (Just now) >= NTop examFinished) $ + tellPoint CorrectionInvisibleExamUnfinished + + return $ notification NotificationBroad =<< messageIconWidget Warning IconInvisible $(widgetFile "submission-correction-invisible") diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 02caa48d6..2514f0761 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -53,7 +53,6 @@ import Handler.Utils.Table.Pagination.Types import Handler.Utils.Table.Pagination.CsvColumnExplanations import Handler.Utils.Form import Handler.Utils.Csv -import Handler.Utils.ContentDisposition import Handler.Utils.I18n import Utils import Utils.Lens @@ -581,24 +580,34 @@ singletonFilter key = prism' fromInner (fmap Just . fromOuter) fromOuter = Map.lookup key >=> listToMaybe -data DBTCsvEncode r' k' csv = forall exportData. +data DBTCsvEncode r' k' csv = forall exportData filename sheetName. ( ToNamedRecord csv, CsvColumnsExplained csv , DBTableKey k' , Typeable exportData + , RenderMessage UniWorX filename, RenderMessage UniWorX sheetName ) => DBTCsvEncode { dbtCsvExportForm :: AForm DB exportData , dbtCsvHeader :: Maybe exportData -> DB Csv.Header -- ^ @exportData@ is @Nothing@, if we're reporting an error or exporting example data , dbtCsvExampleData :: Maybe [csv] , dbtCsvDoEncode :: exportData -> ConduitT (k', r') csv DB () - , dbtCsvName :: FilePath + , dbtCsvName :: filename + , dbtCsvSheetName :: sheetName , dbtCsvNoExportData :: Maybe (AnIso' exportData ()) } -data DBTExtraRep r' k' = forall rep. - ( HasContentType rep - , DBTableKey k' - ) => DBTExtraRep - { dbtERepDoEncode :: ConduitT (k', r') Void DB rep - } +data DBTExtraRep r' k' + = forall rep. + ( HasContentType rep + , DBTableKey k' + ) => DBTExtraRep + { dbtERepDoEncode :: ConduitT (k', r') Void DB rep + } + | forall rep. + ( ToContent rep + , DBTableKey k' + ) => DBTExtraRepFor + { dbtERepContentType :: ContentType + , dbtERepDoEncode :: ConduitT (k', r') Void DB rep + } data DBTCsvDecode r' k' csv = forall route csvAction csvActionClass csvException. ( FromNamedRecord csv, ToNamedRecord csv , DBTableKey k' @@ -646,48 +655,61 @@ type DBFilterUI = Maybe (Map FilterKey [Text]) -> AForm DB (Map FilterKey [Text] noCsvEncode :: Maybe (DBTCsvEncode r' k' Void) noCsvEncode = Nothing -simpleCsvEncode :: forall fp r' k' csv. +simpleCsvEncode :: forall filename sheetName r' k' csv. ( ToNamedRecord csv, DefaultOrdered csv, CsvColumnsExplained csv , DBTableKey k' - , Textual fp + , RenderMessage UniWorX filename, RenderMessage UniWorX sheetName ) - => fp -> (r' -> csv) -> Maybe (DBTCsvEncode r' k' csv) -simpleCsvEncode fName f = Just DBTCsvEncode + => filename -> sheetName -> (r' -> csv) -> Maybe (DBTCsvEncode r' k' csv) +simpleCsvEncode fName sName f = Just DBTCsvEncode { dbtCsvExportForm = pure () , dbtCsvDoEncode = \() -> C.map (f . view _2) - , dbtCsvName = unpack fName + , dbtCsvName = fName + , dbtCsvSheetName = sName , dbtCsvNoExportData = Just id , dbtCsvHeader = const . return $ headerOrder (error "headerOrder" :: csv) , dbtCsvExampleData = Nothing } -simpleCsvEncodeM :: forall fp r' k' csv. +simpleCsvEncodeM :: forall filename sheetName r' k' csv. ( ToNamedRecord csv, DefaultOrdered csv, CsvColumnsExplained csv , DBTableKey k' - , Textual fp + , RenderMessage UniWorX filename, RenderMessage UniWorX sheetName ) - => fp -> ReaderT r' DB csv -> Maybe (DBTCsvEncode r' k' csv) -simpleCsvEncodeM fName f = Just DBTCsvEncode + => filename -> sheetName -> ReaderT r' DB csv -> Maybe (DBTCsvEncode r' k' csv) +simpleCsvEncodeM fName sName f = Just DBTCsvEncode { dbtCsvExportForm = pure () , dbtCsvDoEncode = \() -> C.mapM (runReaderT f . view _2) - , dbtCsvName = unpack fName + , dbtCsvName = fName + , dbtCsvSheetName = sName , dbtCsvNoExportData = Just id , dbtCsvHeader = const . return $ headerOrder (error "headerOrder" :: csv) , dbtCsvExampleData = Nothing } -withCsvExtraRep :: forall exportData csv r' k'. - Typeable exportData - => exportData +withCsvExtraRep :: forall exportData csv sheetName r' k'. + ( Typeable exportData + , RenderMessage UniWorX sheetName + ) + => sheetName + -> exportData -> Maybe (DBTCsvEncode r' k' csv) -> [DBTExtraRep r' k'] -> [DBTExtraRep r' k'] -withCsvExtraRep exportData mEncode = maybe id (flip snoc) csvExtraRep - where csvExtraRep = do - DBTCsvEncode{ dbtCsvNoExportData = (_ :: Maybe (AnIso' exportData' ())), .. } <- mEncode - Refl <- eqT @exportData @exportData' - return DBTExtraRep - { dbtERepDoEncode = toCsvRendered <$> lift (dbtCsvHeader $ Just exportData) <*> (dbtCsvDoEncode exportData .| C.foldMap (pure @[])) - } +withCsvExtraRep sheetName exportData mEncode = maybe id (flip snoc) (csvExtraRep FormatCsv) + . maybe id (flip snoc) (csvExtraRep FormatXlsx) + where + csvExtraRep fmt = do + DBTCsvEncode{ dbtCsvNoExportData = (_ :: Maybe (AnIso' exportData' ())), .. } <- mEncode + Refl <- eqT @exportData @exportData' + return DBTExtraRepFor + { dbtERepContentType = case fmt of + FormatCsv -> typeCsv' + FormatXlsx -> typeXlsx + , dbtERepDoEncode = do + csvRendered <- toCsvRendered <$> lift (dbtCsvHeader $ Just exportData) <*> (dbtCsvDoEncode exportData .| C.foldMap (pure @[])) + encOpts <- csvOptionsForFormat fmt + csvRenderedToTypedContentWith encOpts sheetName csvRendered + } class (MonadHandler m, HandlerSite m ~ UniWorX, Monoid' x, Monoid' (DBCell m x), Default (DBParams m x)) => IsDBTable (m :: Type -> Type) (x :: Type) where @@ -1125,14 +1147,14 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db | Just DBTCsvEncode{..} <- dbtCsvEncode , Just exData <- dbtCsvExampleData -> do hdr <- dbtCsvHeader Nothing - sendResponse <=< liftHandler . respondCsv hdr $ C.sourceList exData + setContentDispositionCsv dbtCsvName + sendResponse <=< liftHandler . respondCsv dbtCsvSheetName hdr $ C.sourceList exData DBCsvExport{..} | Just DBTCsvEncode{..} <- dbtCsvEncode , Just exportData <- fromDynamic dbCsvExportData -> do hdr <- dbtCsvHeader $ Just exportData - dbtCsvName' <- timestampCsv <*> pure dbtCsvName - setContentDisposition' . Just $ ensureExtension (unpack extensionCsv) dbtCsvName' - sendResponse <=< liftHandler . respondCsvDB hdr $ C.sourceList (zip currentKeys rows) .| dbtCsvDoEncode exportData >> lift E.transactionSave + setContentDispositionCsv dbtCsvName + sendResponse <=< liftHandler . respondCsvDB dbtCsvSheetName hdr $ C.sourceList (zip currentKeys rows) .| dbtCsvDoEncode exportData >> lift E.transactionSave DBCsvImport{..} | Just DBTCsvEncode{..} <- dbtCsvEncode , Just (DBTCsvDecode{ dbtCsvClassifyAction = dbtCsvClassifyAction :: csvAction -> csvActionClass @@ -1290,15 +1312,16 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db ] _other -> return () - let extraReps = maybe id (flip snoc) csvRep dbtExtraReps - where csvRep = do + let extraReps = maybe id ($) addCSVReps dbtExtraReps + where addCSVReps = do DBTCsvEncode{..} <- dbtCsvEncode noExportData' <- cloneIso <$> dbtCsvNoExportData let exportData = noExportData' # () - return DBTExtraRep - { dbtERepDoEncode = toCsvRendered <$> lift (dbtCsvHeader $ Just exportData) <*> (dbtCsvDoEncode exportData .| C.foldMap (pure @[])) - } - extraReps' = (typeHtml, Nothing) : map ((,) <$> (\DBTExtraRep{..} -> getContentType dbtERepDoEncode) <*> Just) extraReps + return $ withCsvExtraRep dbtCsvSheetName exportData dbtCsvEncode + extraRepContentType = \case + DBTExtraRep{..} -> getContentType dbtERepDoEncode + DBTExtraRepFor{..} -> dbtERepContentType + extraReps' = (typeHtml, Nothing) : map ((,) <$> extraRepContentType <*> Just) extraReps doAltRep = maybe True (== dbtIdent) <$> lookupGlobalGetParam GetSelectTable maybeT (return ()) $ do @@ -1308,7 +1331,9 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db altRep <- hoistMaybe <=< asum $ do mRep <- hoistMaybe . selectRep' extraReps' =<< cts - return . return $ mRep <&> \DBTExtraRep{..} -> fmap toTypedContent . runConduit $ C.sourceList (zip currentKeys rows) .| dbtERepDoEncode + return . return $ mRep <&> \case + DBTExtraRep{..} -> fmap toTypedContent . runConduit $ C.sourceList (zip currentKeys rows) .| dbtERepDoEncode + DBTExtraRepFor{..} -> fmap (TypedContent dbtERepContentType . toContent) . runConduit $ C.sourceList (zip currentKeys rows) .| dbtERepDoEncode lift $ sendResponse =<< altRep diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index cfd159c74..ca64817a8 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -644,7 +644,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do in runConduit $ getExamCorrectors .| C.mapM_ upsertExamCorrector let getQueuedJobs = selectSource [] [] - updateQueuedJob (Entity jId QueuedJob{..}) = maybeT (return ()) $ do + updateQueuedJob (Entity jId QueuedJob{..}) = maybeT_ $ do (content' :: Job) <- hoistMaybe $ JSON.parseMaybe parseJSON queuedJobContent let uContent' = set (typesUsing @JobChildren . filtered (== oldUserId)) newUserId content' guard $ uContent' /= content' diff --git a/src/Handler/Utils/Workflow/EdgeForm.hs b/src/Handler/Utils/Workflow/EdgeForm.hs index d7b932e82..b5ac09b55 100644 --- a/src/Handler/Utils/Workflow/EdgeForm.hs +++ b/src/Handler/Utils/Workflow/EdgeForm.hs @@ -72,7 +72,7 @@ workflowEdgeForm :: ( MonadHandler m , HandlerSite m ~ UniWorX , MonadHandler m' , HandlerSite m' ~ UniWorX - , MonadCatch m' + , MonadUnliftIO m' ) => Either WorkflowInstanceId WorkflowWorkflowId -> Maybe WorkflowEdgeForm diff --git a/src/Handler/Utils/Workflow/Workflow.hs b/src/Handler/Utils/Workflow/Workflow.hs index be615a834..3ab5595b8 100644 --- a/src/Handler/Utils/Workflow/Workflow.hs +++ b/src/Handler/Utils/Workflow/Workflow.hs @@ -85,7 +85,8 @@ sourceWorkflowActionInfos ( MonadHandler m, HandlerSite m ~ UniWorX , BackendCompatible SqlReadBackend backend , MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey - , MonadCatch m + , MonadCatch m, MonadUnliftIO m + , MonadAP (ReaderT backend m) ) => WorkflowWorkflowId -> WorkflowState FileReference UserId diff --git a/src/Handler/Utils/Zip.hs b/src/Handler/Utils/Zip.hs index 3638a98dc..cf3e15faa 100644 --- a/src/Handler/Utils/Zip.hs +++ b/src/Handler/Utils/Zip.hs @@ -212,7 +212,7 @@ decodeZipEntryName :: MonadThrow m => Either Text ByteString -> m FilePath -- Throws 'Data.Encoding.Exception.DecodingException's. decodeZipEntryName = \case Left t -> return $ unpack t - Right cp437 -> either throwM return $ decodeStrictByteStringExplicit CP437 cp437 + Right cp437 -> throwLeft $ decodeStrictByteStringExplicit CP437 cp437 encodeZipEntryName :: FilePath -> Either Text ByteString -- ^ Encode a filename for use in a 'ZipEntry', encodes as diff --git a/src/Handler/Workflow/Instance/Form.hs b/src/Handler/Workflow/Instance/Form.hs index 38aaa494e..e31924820 100644 --- a/src/Handler/Workflow/Instance/Form.hs +++ b/src/Handler/Workflow/Instance/Form.hs @@ -26,7 +26,7 @@ workflowInstanceScopeForm scopeRestr fs mPrev = multiActionA scopeOptions' fs $ , pure WSGlobal ) , ( WSTerm' - , WSTerm <$> apopt termField (fslI MsgTerm) (mPrev ^? _Just . _wisTerm) + , WSTerm <$> apopt termField (fslI MsgTableTerm) (mPrev ^? _Just . _wisTerm) ) , ( WSSchool' , WSSchool <$> apopt schoolField (fslI MsgTableSchool) (mPrev ^? _Just . _wisSchool) diff --git a/src/Handler/Workflow/Instance/Initiate.hs b/src/Handler/Workflow/Instance/Initiate.hs index fda1576d6..361d675c5 100644 --- a/src/Handler/Workflow/Instance/Initiate.hs +++ b/src/Handler/Workflow/Instance/Initiate.hs @@ -56,6 +56,12 @@ workflowInstanceInitiateR rScope win = do } return . Just $ do + memcachedByInvalidate (AuthCacheWorkflowInstanceWorkflowViewers win rScope) $ Proxy @(Set ((DBWorkflowScope, WorkflowWorkflowId), WorkflowRole UserId)) + memcachedByInvalidate (NavCacheHaveWorkflowWorkflowsRoles rScope) $ Proxy @(Set ((WorkflowWorkflowId, CryptoFileNameWorkflowWorkflow), WorkflowRole UserId)) + when (isTopWorkflowScope rScope) $ + memcachedByInvalidate NavCacheHaveTopWorkflowWorkflowsRoles $ Proxy @(Set ((WorkflowWorkflowId, CryptoFileNameWorkflowWorkflow, RouteWorkflowScope), WorkflowRole UserId)) + + addMessageI Success MsgWorkflowInstanceInitiateSuccess cID <- encrypt wwId diff --git a/src/Handler/Workflow/Instance/List.hs b/src/Handler/Workflow/Instance/List.hs index 0f8fb1e8c..73f10af83 100644 --- a/src/Handler/Workflow/Instance/List.hs +++ b/src/Handler/Workflow/Instance/List.hs @@ -151,9 +151,9 @@ workflowInstanceListR rScope = do Entity _ desc@WorkflowInstanceDescription{..} <- descs guard $ workflowInstanceDescriptionLanguage == lang return desc - mayInitiate <- hasWriteAccessTo $ toInitiateRoute workflowInstanceName - mayEdit <- hasReadAccessTo $ toEditRoute workflowInstanceName - mayList <- hasReadAccessTo $ toListRoute workflowInstanceName + mayInitiate <- lift . hasWriteAccessTo $ toInitiateRoute workflowInstanceName + mayEdit <- lift . hasReadAccessTo $ toEditRoute workflowInstanceName + mayList <- lift . hasReadAccessTo $ toListRoute workflowInstanceName guard $ mayInitiate || mayEdit || mayList return (wi, desc) @@ -192,9 +192,9 @@ getTopWorkflowInstanceListR = do Entity _ desc@WorkflowInstanceDescription{..} <- descs guard $ workflowInstanceDescriptionLanguage == lang return desc - mayInitiate <- hasWriteAccessTo $ toInitiateRoute' rScope workflowInstanceName - mayEdit <- hasReadAccessTo $ toEditRoute' rScope workflowInstanceName - mayList <- hasReadAccessTo $ toListRoute' rScope workflowInstanceName + mayInitiate <- lift . hasWriteAccessTo $ toInitiateRoute' rScope workflowInstanceName + mayEdit <- lift . hasReadAccessTo $ toEditRoute' rScope workflowInstanceName + mayList <- lift . hasReadAccessTo $ toListRoute' rScope workflowInstanceName guard $ mayInitiate || mayEdit || mayList return (rScope, [(wi, desc)]) diff --git a/src/Handler/Workflow/Workflow/List.hs b/src/Handler/Workflow/Workflow/List.hs index 97d56fb28..7417af3b2 100644 --- a/src/Handler/Workflow/Workflow/List.hs +++ b/src/Handler/Workflow/Workflow/List.hs @@ -367,10 +367,11 @@ workflowWorkflowList (title, heading) WWListColumns{..} sqlPred = do ( MonadHandler m , HandlerSite m ~ UniWorX , MonadCatch m + , MonadUnliftIO m ) => WorkflowActionInfo FileReference UserId -> WriterT (Maybe (Last (CryptoUUIDWorkflowStateIndex, Maybe WorkflowGraphNodeLabel, Maybe JsonWorkflowUser, UTCTime, Map WorkflowPayloadLabel JsonWorkflowPayload))) (SqlPersistT m) () - go WorkflowActionInfo{ waiIx = stIx, waiHistory = (workflowStateCurrentPayloads -> currentPayload), waiAction = WorkflowAction{..}} = maybeT (return ()) $ do + go WorkflowActionInfo{ waiIx = stIx, waiHistory = (workflowStateCurrentPayloads -> currentPayload), waiAction = WorkflowAction{..}} = maybeT_ $ do stCID <- encryptWorkflowStateIndex wwId stIx rScope <- hoistMaybe $ res ^. resultRouteScope diff --git a/src/Handler/Workflow/Workflow/Workflow.hs b/src/Handler/Workflow/Workflow/Workflow.hs index 430d8aa59..a0b024330 100644 --- a/src/Handler/Workflow/Workflow/Workflow.hs +++ b/src/Handler/Workflow/Workflow/Workflow.hs @@ -91,12 +91,22 @@ workflowR rScope cID = do edgeAct <- formResultMaybe edgeRes $ \edgeRes' -> do nState <- followEdge wGraph edgeRes' . Just $ _DBWorkflowState # workflowWorkflowState - memcachedByInvalidate (AuthCacheWorkflowWorkflowEdgeActors cID) $ Proxy @(WorkflowWorkflowId, Set (WorkflowRole UserId)) - memcachedByInvalidate (AuthCacheWorkflowWorkflowViewers cID) $ Proxy @(WorkflowWorkflowId, Set (WorkflowRole UserId)) + wInstance <- for workflowWorkflowInstance $ \wiId -> do + wInstance@WorkflowInstance{..} <- get404 wiId + wiScope <- maybeT notFound . toRouteWorkflowScope $ _DBWorkflowScope # workflowInstanceScope + return (wiScope, Entity wiId wInstance) update wwId [ WorkflowWorkflowState =. view _DBWorkflowState nState ] return . Just $ do + whenIsJust wInstance $ \(wiScope, Entity _ WorkflowInstance{..}) -> do + memcachedByInvalidate (AuthCacheWorkflowInstanceWorkflowViewers workflowInstanceName wiScope) $ Proxy @(Set ((DBWorkflowScope, WorkflowWorkflowId), WorkflowRole UserId)) + memcachedByInvalidate (NavCacheHaveWorkflowWorkflowsRoles wiScope) $ Proxy @(Set ((WorkflowWorkflowId, CryptoFileNameWorkflowWorkflow), WorkflowRole UserId)) + when (isTopWorkflowScope wiScope) $ + memcachedByInvalidate NavCacheHaveTopWorkflowWorkflowsRoles $ Proxy @(Set ((WorkflowWorkflowId, CryptoFileNameWorkflowWorkflow, RouteWorkflowScope), WorkflowRole UserId)) + memcachedByInvalidate (AuthCacheWorkflowWorkflowEdgeActors cID) $ Proxy @(WorkflowWorkflowId, Set (WorkflowRole UserId)) + memcachedByInvalidate (AuthCacheWorkflowWorkflowViewers cID) $ Proxy @(WorkflowWorkflowId, Set (WorkflowRole UserId)) + addMessageI Success MsgWorkflowWorkflowWorkflowEdgeSuccess redirect canonRoute @@ -107,10 +117,11 @@ workflowR rScope cID = do ( MonadHandler m , HandlerSite m ~ UniWorX , MonadCatch m + , MonadUnliftIO m ) => WorkflowActionInfo FileReference UserId -> RWST () (Maybe (Last WorkflowCurrentState), [WorkflowHistoryItem]) (Map WorkflowPayloadLabel (Set (WorkflowFieldPayloadW FileReference UserId))) (SqlPersistT m) () - go WorkflowActionInfo{ waiIx = stIx, waiFrom = wpFrom, waiHistory = history@(workflowStateCurrentPayloads -> currentPayload), waiAction = WorkflowAction{..} } = maybeT (return ()) $ do + go WorkflowActionInfo{ waiIx = stIx, waiFrom = wpFrom, waiHistory = history@(workflowStateCurrentPayloads -> currentPayload), waiAction = WorkflowAction{..} } = maybeT_ $ do mAuthId <- maybeAuthId stCID <- encryptWorkflowStateIndex wwId stIx diff --git a/src/Import.hs b/src/Import.hs index 3cfcb3057..ac410e50d 100644 --- a/src/Import.hs +++ b/src/Import.hs @@ -11,5 +11,6 @@ import Utils.SystemMessage as Import import Utils.Metrics as Import import Utils.Files as Import import Utils.PersistentTokenBucket as Import +import Utils.Csv.Mail as Import import Jobs.Types as Import (JobHandler(..)) diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index 7ca1dcaaa..c8854d786 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -23,6 +23,7 @@ import ClassyPrelude.Yesod as Import , defaultYesodMiddleware , authorizationCheck , mkMessage, mkMessageFor, mkMessageVariant + , YesodBreadcrumbs(..) ) import UnliftIO.Async.Utils as Import @@ -74,6 +75,9 @@ import Data.Monoid as Import (Last(..), First(..), Any(..), All(..), import Data.Binary as Import (Binary) import Data.Binary.Instances as Import () +import Data.Dynamic as Import (Dynamic) +import Data.Dynamic.Lens as Import + import System.FilePath as Import hiding (joinPath, normalise, isValid, makeValid) import Numeric.Natural as Import (Natural) diff --git a/src/Jobs.hs b/src/Jobs.hs index 02f207bf6..c58b9f444 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -617,7 +617,7 @@ handleJobs' wNum = C.mapM_ $ \jctl -> hoist delimitInternalState . withJobWorker E.where_ $ matchesPrewarmSource eRef jcPrewarmSource return cRef sinkChunkCache lh (cRef, (c, range)) = insertLRUHandle lh (cRef, range) jcTargetTime (c, ByteString.length c) - handleCmd JobCtlInhibitInject{..} = maybeT (return ()) $ do + handleCmd JobCtlInhibitInject{..} = maybeT_ $ do PrewarmCacheConf{..} <- MaybeT . getsYesod $ view _appFileSourcePrewarmConf let inhibitInterval = IntervalMap.ClosedInterval (addUTCTime (-precStart) jcTargetTime) diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs index d96247af0..c6f6abc9a 100644 --- a/src/Jobs/Crontab.hs +++ b/src/Jobs/Crontab.hs @@ -20,6 +20,7 @@ import Handler.Utils.DateTime import qualified Data.Conduit.List as C import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E import Jobs.Handler.Intervals.Utils @@ -62,7 +63,7 @@ determineCrontab = execWriterT $ do let tellPrewarmJobs :: JobCtlPrewarmSource -> UTCTime -> WriterT (Crontab JobCtl) (ReaderT SqlReadBackend (HandlerFor UniWorX)) () - tellPrewarmJobs jcPrewarmSource jcTargetTime = maybeT (return ()) $ do + tellPrewarmJobs jcPrewarmSource jcTargetTime = maybeT_ $ do PrewarmCacheConf{..} <- hoistMaybe appFileSourcePrewarmConf let @@ -89,7 +90,7 @@ determineCrontab = execWriterT $ do | ts' <- iterate (addUTCTime step') $ addUTCTime (subtract precStart . realToFrac $ toRational (precStart - precEnd) * (1 - recip precMaxSpeedup)) jcTargetTime ] - lift . maybeT (return ()) $ do + lift . maybeT_ $ do injectInterval <- fmap abs . MaybeT . getsYesod $ view _appInjectFiles tell $ HashMap.singleton JobCtlInhibitInject{..} @@ -117,7 +118,7 @@ determineCrontab = execWriterT $ do for_ (max <$> sheetVisibleFrom <*> sheetHintFrom) $ \hFrom -> do tellPrewarmJobs (JobCtlPrewarmSheetFile nSheet SheetHint) hFrom - when (isn't _JobsOffload appJobMode) . maybeT (return ()) $ do + when (isn't _JobsOffload appJobMode) . maybeT_ $ do guard $ maybe True (\aFrom -> abs (diffUTCTime aFrom hFrom) > 300) sheetActiveFrom guardM $ or2M (return $ maybe True (\sFrom -> abs (diffUTCTime sFrom hFrom) > 300) sheetSolutionFrom) (fmap not . lift . lift $ exists [SheetFileType ==. SheetSolution, SheetFileSheet ==. nSheet]) @@ -133,7 +134,7 @@ determineCrontab = execWriterT $ do for_ (max <$> sheetVisibleFrom <*> sheetSolutionFrom) $ \sFrom -> do tellPrewarmJobs (JobCtlPrewarmSheetFile nSheet SheetSolution) sFrom - when (isn't _JobsOffload appJobMode) . maybeT (return ()) $ do + when (isn't _JobsOffload appJobMode) . maybeT_ $ do guard $ maybe True (\aFrom -> abs (diffUTCTime aFrom sFrom) > 300) sheetActiveFrom guardM . lift . lift $ exists [SheetFileType ==. SheetSolution, SheetFileSheet ==. nSheet] tell $ HashMap.singleton @@ -386,6 +387,28 @@ determineCrontab = execWriterT $ do ) .| C.fold collateSubmissionsByCorrector Map.empty + submissionRatedNotificationsSince <- lift $ getMigrationTime Migration20210318CrontabSubmissionRatedNotification + whenIsJust submissionRatedNotificationsSince $ \notifySince + -> let submissionsSelect = E.selectSource . E.from $ \(submission `E.InnerJoin` sheet) -> do + E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId + E.where_ $ sqlSubmissionRatingDone submission + E.&&. submission E.^. SubmissionRatingTime E.>=. E.justVal notifySince + return (submission, sheet E.^. SheetType) + submissionJobs (Entity subId Submission{..}, E.Value sType) = maybeT_ $ do + examFinishedTime <- hoist lift . for (sType ^? _examPart . from _SqlKey) $ \epId -> 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 + tell $ HashMap.singleton + (JobCtlQueue . JobQueueNotification $ NotificationSubmissionRated subId) + Cron + { cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ notifyTime + , cronRepeat = CronRepeatNever + , cronRateLimit = appNotificationRateLimit + , cronNotAfter = Left appNotificationExpiration + } + in runConduit $ transPipe lift submissionsSelect .| C.mapM_ submissionJobs let examSelect = E.selectSource . E.from $ \(exam `E.InnerJoin` course `E.InnerJoin` school) -> do diff --git a/src/Jobs/Handler/Files.hs b/src/Jobs/Handler/Files.hs index f4e06a475..ecf6a2924 100644 --- a/src/Jobs/Handler/Files.hs +++ b/src/Jobs/Handler/Files.hs @@ -268,7 +268,7 @@ dispatchJobPruneUnreferencedFiles numIterations epoch iteration = JobHandlerAtom dispatchJobInjectFiles :: JobHandler UniWorX -dispatchJobInjectFiles = JobHandlerException . maybeT (return ()) $ do +dispatchJobInjectFiles = JobHandlerException . maybeT_ $ do uploadBucket <- getsYesod $ view _appUploadCacheBucket interval <- getsYesod $ view _appInjectFiles @@ -338,7 +338,7 @@ dispatchJobInjectFiles = JobHandlerException . maybeT (return ()) $ do Just <$> waitAsync dbAsync let matchesFRef = is _Just $ assertM (== fRef) fRef' if | matchesFRef -> - maybeT (return ()) . runAppMinio . handleIf minioIsDoesNotExist (const $ return ()) $ Minio.removeObject uploadBucket obj + maybeT_ . runAppMinio . handleIf minioIsDoesNotExist (const $ return ()) $ Minio.removeObject uploadBucket obj | otherwise -> $logErrorS "InjectFiles" [st|Minio object “#{obj}”'s content does not match it's name (content hash: #{tshow fRef'} /= name hash: #{tshow fRef})|] return . bool mempty (Sum 1, Sum sz) $ is _Just fRef' diff --git a/src/Jobs/Handler/HelpRequest.hs b/src/Jobs/Handler/HelpRequest.hs index 42ad88d0f..8fe7af509 100644 --- a/src/Jobs/Handler/HelpRequest.hs +++ b/src/Jobs/Handler/HelpRequest.hs @@ -34,14 +34,4 @@ dispatchJobHelpRequest jSender jRequestTime jHelpSubject jHelpRequest jReferer j setDate jRequestTime rtime <- formatTimeMail SelFormatDateTime jRequestTime - errPartName <- for jError $ \_ -> do - objId <- setMailObjectIdRandom - mr <- getMailMessageRender - return . mr $ MsgHelpErrorYamlFilename objId - addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/support.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) - - whenIsJust ((,) <$> jError <*> errPartName) $ \(err, partName) -> addPart' $ do - toMailPart $ toYAML err - _partDisposition .= InlineDisposition partName - diff --git a/src/Jobs/Handler/SendCourseCommunication.hs b/src/Jobs/Handler/SendCourseCommunication.hs index cff458364..712fd4beb 100644 --- a/src/Jobs/Handler/SendCourseCommunication.hs +++ b/src/Jobs/Handler/SendCourseCommunication.hs @@ -38,5 +38,5 @@ dispatchJobSendCourseCommunication jRecipientEmail jAllRecipientAddresses jCours addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/courseCommunication.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) when (jRecipientEmail == Right jSender) $ addPart' $ do - partIsAttachmentCsv $ mr MsgCommAllRecipients - toMailPart (toDefaultOrderedCsvRendered jAllRecipientAddresses, userCsvOptions sender) + partIsAttachmentCsv MsgCommAllRecipients + toMailPart (MsgCommAllRecipientsSheet, toDefaultOrderedCsvRendered jAllRecipientAddresses) diff --git a/src/Jobs/Handler/SendNotification/Allocation.hs b/src/Jobs/Handler/SendNotification/Allocation.hs index 8002e66b2..94b86e4ed 100644 --- a/src/Jobs/Handler/SendNotification/Allocation.hs +++ b/src/Jobs/Handler/SendNotification/Allocation.hs @@ -14,6 +14,8 @@ import Import import Handler.Utils import Jobs.Handler.SendNotification.Utils +import Handler.Info (FAQItem(..)) + import Text.Hamlet import qualified Database.Esqueleto as E @@ -182,7 +184,11 @@ dispatchNotificationAllocationResults nAllocation jRecipient = userMailT jRecipi setSubjectI $ MsgMailSubjectAllocationResults allocationName editNotifications <- mkEditNotifications jRecipient + studentFaqItems <- forM studentFaqItems' $ \faqItem -> (faqItem, ) <$> toTextUrl (FaqR :#: faqItem) + addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/allocationResults.hamlet") + where + studentFaqItems' = [FAQAllocationNoPlaces] dispatchNotificationAllocationNewCourse :: AllocationId -> CourseId -> UserId -> Handler () dispatchNotificationAllocationNewCourse nAllocation nCourse jRecipient = userMailT jRecipient $ do @@ -196,7 +202,7 @@ dispatchNotificationAllocationNewCourse nAllocation nCourse jRecipient = userMai editNotifications <- mkEditNotifications jRecipient cID <- encrypt nCourse - mayApply <- orM + mayApply <- lift $ orM [ is _Authorized <$> evalAccessFor (Just jRecipient) (AllocationR allocationTerm allocationSchool allocationShorthand ARegisterR) True , is _Authorized <$> evalAccessFor (Just jRecipient) (AllocationR allocationTerm allocationSchool allocationShorthand $ AApplyR cID) True ] diff --git a/src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs b/src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs index 13f66127e..2181b44a4 100644 --- a/src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs +++ b/src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs @@ -31,4 +31,4 @@ dispatchNotificationCorrectionsAssigned nUser nSheet jRecipient = do editNotifications <- mkEditNotifications jRecipient - addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/correctionsAssigned.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) + addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/correctionsAssigned.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)) diff --git a/src/Jobs/Handler/SendNotification/CorrectionsNotDistributed.hs b/src/Jobs/Handler/SendNotification/CorrectionsNotDistributed.hs index 50ba2ad51..f4536a175 100644 --- a/src/Jobs/Handler/SendNotification/CorrectionsNotDistributed.hs +++ b/src/Jobs/Handler/SendNotification/CorrectionsNotDistributed.hs @@ -28,4 +28,4 @@ dispatchNotificationCorrectionsNotDistributed nSheet jRecipient = do csh = courseShorthand shn = sheetName - addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/correctionsUndistributed.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) + addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/correctionsUndistributed.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)) diff --git a/src/Jobs/Handler/SendNotification/CourseRegistered.hs b/src/Jobs/Handler/SendNotification/CourseRegistered.hs index 9bfb22ff3..2bb361ae4 100644 --- a/src/Jobs/Handler/SendNotification/CourseRegistered.hs +++ b/src/Jobs/Handler/SendNotification/CourseRegistered.hs @@ -31,4 +31,4 @@ dispatchNotificationCourseRegistered nUser nCourse jRecipient = userMailT jRecip editNotifications <- mkEditNotifications jRecipient - addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/courseRegistered.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) + addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/courseRegistered.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)) diff --git a/src/Jobs/Handler/SendNotification/ExamActive.hs b/src/Jobs/Handler/SendNotification/ExamActive.hs index 90f4aa64f..1d7095993 100644 --- a/src/Jobs/Handler/SendNotification/ExamActive.hs +++ b/src/Jobs/Handler/SendNotification/ExamActive.hs @@ -32,7 +32,7 @@ dispatchNotificationExamRegistrationActive nExam jRecipient = userMailT jRecipie editNotifications <- mkEditNotifications jRecipient - addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/examRegistrationActive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) + addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/examRegistrationActive.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)) dispatchNotificationExamRegistrationSoonInactive :: ExamId -> UserId -> Handler () dispatchNotificationExamRegistrationSoonInactive nExam jRecipient = userMailT jRecipient $ do @@ -52,7 +52,7 @@ dispatchNotificationExamRegistrationSoonInactive nExam jRecipient = userMailT jR editNotifications <- mkEditNotifications jRecipient - addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/examRegistrationSoonInactive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) + addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/examRegistrationSoonInactive.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)) dispatchNotificationExamDeregistrationSoonInactive :: ExamId -> UserId -> Handler () dispatchNotificationExamDeregistrationSoonInactive nExam jRecipient = userMailT jRecipient $ do @@ -72,4 +72,4 @@ dispatchNotificationExamDeregistrationSoonInactive nExam jRecipient = userMailT editNotifications <- mkEditNotifications jRecipient - addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/examDeregistrationSoonInactive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) + addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/examDeregistrationSoonInactive.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)) diff --git a/src/Jobs/Handler/SendNotification/ExamOffice.hs b/src/Jobs/Handler/SendNotification/ExamOffice.hs index 62992478a..aa3420022 100644 --- a/src/Jobs/Handler/SendNotification/ExamOffice.hs +++ b/src/Jobs/Handler/SendNotification/ExamOffice.hs @@ -35,7 +35,7 @@ dispatchNotificationExamOfficeExamResults nExam jRecipient = userMailT jRecipien editNotifications <- mkEditNotifications jRecipient - addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/examOffice/examResults.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) + addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/examOffice/examResults.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)) dispatchNotificationExamOfficeExamResultsChanged :: Set ExamResultId -> UserId -> Handler () dispatchNotificationExamOfficeExamResultsChanged nExamResults jRecipient = do @@ -59,7 +59,7 @@ dispatchNotificationExamOfficeExamResultsChanged nExamResults jRecipient = do editNotifications <- mkEditNotifications jRecipient - addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/examOffice/examResultsChanged.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) + addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/examOffice/examResultsChanged.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)) dispatchNotificationExamOfficeExternalExamResults :: ExternalExamId -> UserId -> Handler () @@ -77,4 +77,4 @@ dispatchNotificationExamOfficeExternalExamResults nExternalExam jRecipient = use editNotifications <- mkEditNotifications jRecipient - addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/examOffice/externalExamResults.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) + addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/examOffice/externalExamResults.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)) diff --git a/src/Jobs/Handler/SendNotification/ExamResult.hs b/src/Jobs/Handler/SendNotification/ExamResult.hs index a509e8b8f..7cacbc1cb 100644 --- a/src/Jobs/Handler/SendNotification/ExamResult.hs +++ b/src/Jobs/Handler/SendNotification/ExamResult.hs @@ -30,4 +30,4 @@ dispatchNotificationExamResult nExam jRecipient = userMailT jRecipient $ do editNotifications <- mkEditNotifications jRecipient - addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/examResult.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) + addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/examResult.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)) diff --git a/src/Jobs/Handler/SendNotification/SheetActive.hs b/src/Jobs/Handler/SendNotification/SheetActive.hs index ff0919a57..a4733d341 100644 --- a/src/Jobs/Handler/SendNotification/SheetActive.hs +++ b/src/Jobs/Handler/SendNotification/SheetActive.hs @@ -32,7 +32,7 @@ dispatchNotificationSheetActive nSheet jRecipient = userMailT jRecipient $ do editNotifications <- mkEditNotifications jRecipient - addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/sheetActive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) + addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/sheetActive.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)) dispatchNotificationSheetHint nSheet jRecipient = userMailT jRecipient $ do (Course{..}, Sheet{..}) <- liftHandler . runDB $ do sheet <- getJust nSheet @@ -50,7 +50,7 @@ dispatchNotificationSheetHint nSheet jRecipient = userMailT jRecipient $ do editNotifications <- mkEditNotifications jRecipient - addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/sheetHint.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) + addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/sheetHint.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)) dispatchNotificationSheetSolution nSheet jRecipient = userMailT jRecipient $ do (Course{..}, Sheet{..}) <- liftHandler . runDB $ do sheet <- getJust nSheet @@ -68,4 +68,4 @@ dispatchNotificationSheetSolution nSheet jRecipient = userMailT jRecipient $ do editNotifications <- mkEditNotifications jRecipient - addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/sheetSolution.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) + addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/sheetSolution.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)) diff --git a/src/Jobs/Handler/SendNotification/SheetInactive.hs b/src/Jobs/Handler/SendNotification/SheetInactive.hs index 0dd325bb2..2e97dfc9a 100644 --- a/src/Jobs/Handler/SendNotification/SheetInactive.hs +++ b/src/Jobs/Handler/SendNotification/SheetInactive.hs @@ -33,7 +33,7 @@ dispatchNotificationSheetSoonInactive nSheet jRecipient = userMailT jRecipient $ editNotifications <- mkEditNotifications jRecipient - addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/sheetSoonInactive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) + addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/sheetSoonInactive.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)) dispatchNotificationSheetInactive :: SheetId -> UserId -> Handler () dispatchNotificationSheetInactive nSheet jRecipient = userMailT jRecipient $ do @@ -61,5 +61,5 @@ dispatchNotificationSheetInactive nSheet jRecipient = userMailT jRecipient $ do editNotifications <- mkEditNotifications jRecipient - addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/sheetInactive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) + addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/sheetInactive.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)) diff --git a/src/Jobs/Handler/SendNotification/SubmissionRated.hs b/src/Jobs/Handler/SendNotification/SubmissionRated.hs index 06e0073c2..493a72e25 100644 --- a/src/Jobs/Handler/SendNotification/SubmissionRated.hs +++ b/src/Jobs/Handler/SendNotification/SubmissionRated.hs @@ -14,29 +14,34 @@ import qualified Data.CaseInsensitive as CI dispatchNotificationSubmissionRated :: SubmissionId -> UserId -> Handler () -dispatchNotificationSubmissionRated nSubmission jRecipient = userMailT jRecipient $ do - (Course{..}, Sheet{..}, Submission{..}, corrector, sheetTypeDesc) <- liftHandler . runDB $ do +dispatchNotificationSubmissionRated nSubmission jRecipient = maybeT_ $ do + (Course{..}, Sheet{..}, Submission{..}, corrector, sheetTypeDesc, hasAccess, csid) <- lift . runDB $ do submission@Submission{submissionRatingBy} <- getJust nSubmission - sheet <- belongsToJust submissionSheet submission - course <- belongsToJust sheetCourse sheet + sheet@Sheet{sheetName} <- belongsToJust submissionSheet submission + course@Course{..} <- belongsToJust sheetCourse sheet corrector <- traverse getJust submissionRatingBy sheetTypeDesc <- sheetTypeDescription (sheetCourse sheet) (sheetType sheet) - return (course, sheet, submission, corrector, sheetTypeDesc) + csid <- encrypt nSubmission - whenIsJust corrector $ \corrector' -> - addMailHeader "Reply-To" . renderAddress $ userAddressFrom corrector' - replaceMailHeader "Auto-Submitted" $ Just "auto-generated" - setSubjectI $ MsgMailSubjectSubmissionRated courseShorthand + hasAccess <- is _Authorized <$> evalAccessForDB (Just jRecipient) (CSubmissionR courseTerm courseSchool courseShorthand sheetName csid CorrectionR) False + return (course, sheet, submission, corrector, sheetTypeDesc, hasAccess, csid) - csid <- encrypt nSubmission - MsgRenderer mr <- getMailMsgRenderer - let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm - submissionRatingTime' <- traverse (formatTimeMail SelFormatDateTime) submissionRatingTime - let tid = courseTerm - ssh = courseSchool - csh = courseShorthand - shn = sheetName + guard hasAccess - editNotifications <- mkEditNotifications jRecipient + lift . userMailT jRecipient $ do + whenIsJust corrector $ \corrector' -> + addMailHeader "Reply-To" . renderAddress $ userAddressFrom corrector' + replaceMailHeader "Auto-Submitted" $ Just "auto-generated" + setSubjectI $ MsgMailSubjectSubmissionRated courseShorthand - addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/submissionRated.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)) + MsgRenderer mr <- getMailMsgRenderer + let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm + submissionRatingTime' <- traverse (formatTimeMail SelFormatDateTime) submissionRatingTime + let tid = courseTerm + ssh = courseSchool + csh = courseShorthand + shn = sheetName + + editNotifications <- mkEditNotifications jRecipient + + addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/submissionRated.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)) diff --git a/src/Jobs/Handler/SendNotification/Utils.hs b/src/Jobs/Handler/SendNotification/Utils.hs index b53180bee..08476d543 100644 --- a/src/Jobs/Handler/SendNotification/Utils.hs +++ b/src/Jobs/Handler/SendNotification/Utils.hs @@ -11,10 +11,10 @@ import qualified Data.HashSet as HashSet import qualified Data.HashMap.Strict as HashMap -ihamletSomeMessage :: HtmlUrlI18n UniWorXMessage route -> HtmlUrlI18n (SomeMessage UniWorX) route +ihamletSomeMessage :: HtmlUrlI18n (SomeMessage UniWorX) route -> HtmlUrlI18n (SomeMessage UniWorX) route ihamletSomeMessage f trans = f $ trans . SomeMessage -mkEditNotifications :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m (HtmlUrlI18n UniWorXMessage (Route UniWorX)) +mkEditNotifications :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m (HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)) mkEditNotifications uid = liftHandler $ do cID <- encrypt uid jwt <- encodeBearer =<< bearerToken (HashSet.singleton $ Right uid) Nothing (HashMap.singleton BearerTokenRouteEval . HashSet.singleton $ UserNotificationR cID) Nothing Nothing Nothing @@ -22,4 +22,5 @@ mkEditNotifications uid = liftHandler $ do editNotificationsUrl :: SomeRoute UniWorX editNotificationsUrl = SomeRoute (UserNotificationR cID, [(toPathPiece GetBearer, toPathPiece jwt)]) editNotificationsUrl' <- toTextUrl editNotificationsUrl - return ($(ihamletFile "templates/mail/editNotifications.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) + return ($(ihamletFile "templates/mail/editNotifications.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)) + \ No newline at end of file diff --git a/src/Jobs/HealthReport.hs b/src/Jobs/HealthReport.hs index a3bfb46b4..83c685700 100644 --- a/src/Jobs/HealthReport.hs +++ b/src/Jobs/HealthReport.hs @@ -60,7 +60,7 @@ dispatchHealthCheckMatchingClusterConfig dbSetting <- clusterSetting @'ClusterId return $ Just ourSetting == dbSetting clusterSettingMatches ClusterMemcachedKey = do - ourSetting <- getsYesod $ fmap fst . appMemcached + ourSetting <- getsYesod $ fmap memcachedKey . appMemcached dbSetting <- clusterSetting @'ClusterMemcachedKey return $ maybe True ((== dbSetting) . Just) ourSetting clusterSettingMatches ClusterVerpSecret = do diff --git a/src/Jobs/Offload.hs b/src/Jobs/Offload.hs index 1176823e9..8eeaf657d 100644 --- a/src/Jobs/Offload.hs +++ b/src/Jobs/Offload.hs @@ -2,23 +2,14 @@ module Jobs.Offload ( mkJobOffloadHandler ) where -import Import hiding (bracket, js) +import Import hiding (js) import Jobs.Types import Jobs.Queue -import qualified Database.PostgreSQL.Simple as PG -import qualified Database.PostgreSQL.Simple.Types as PG -import qualified Database.PostgreSQL.Simple.Notification as PG - -import Database.Persist.Postgresql (PostgresConf, pgConnStr) +import Utils.Postgresql import Data.Text.Encoding (decodeUtf8') -import UnliftIO.Exception (bracket) - - -jobOffloadChannel :: Text -jobOffloadChannel = "job-offload" mkJobOffloadHandler :: forall m. ( MonadResource m @@ -32,39 +23,21 @@ mkJobOffloadHandler dbConf jMode | not shouldListen = Nothing | otherwise = Just $ do jobOffloadOutgoing <- newTVarIO mempty - jobOffloadHandler <- allocateAsync . bracket (liftIO . PG.connectPostgreSQL $ pgConnStr dbConf) (liftIO . PG.close) $ \pgConn -> do - myPid <- liftIO $ PG.getBackendPID pgConn - - when shouldListen $ - void . liftIO $ PG.execute pgConn "LISTEN ?" (PG.Only $ PG.Identifier jobOffloadChannel) - - foreverBreak $ \(($ ()) -> terminate) -> do - UniWorX{appJobState} <- ask - shouldTerminate <- atomically $ readTMVar appJobState >>= fmap not . isEmptyTMVar . jobShutdown - when shouldTerminate terminate - - let - getInput = do - n@PG.Notification{..} <- liftIO $ PG.getNotification pgConn - if | notificationPid == myPid || notificationChannel /= encodeUtf8 jobOffloadChannel -> getInput - | otherwise -> return n - getOutput = atomically $ do - jQueue <- readTVar jobOffloadOutgoing - case jQueue of - j :< js -> j <$ writeTVar jobOffloadOutgoing js - _other -> mzero - - io <- lift $ if - | shouldListen -> getInput `race` getOutput - | otherwise -> Right <$> getOutput - - case io of - Left PG.Notification{..} - | Just jId <- fromPathPiece =<< either (const Nothing) Just (decodeUtf8' notificationData) - -> writeJobCtl $ JobCtlPerform jId - | otherwise - -> $logErrorS "JobOffloadHandler" $ "Could not parse incoming notification data: " <> tshow notificationData - Right jId -> void . liftIO $ PG.execute pgConn "NOTIFY ?, ?" (PG.Identifier jobOffloadChannel, encodeUtf8 $ toPathPiece jId) - + jobOffloadHandler <- allocateAsync $ managePostgresqlChannel dbConf ChannelJobOffload PostgresqlChannelManager + { pgcTerminate = do + UniWorX{appJobState} <- ask + atomically $ do + shouldTerminate <- readTMVar appJobState >>= fmap not . isEmptyTMVar . jobShutdown + guardOn shouldTerminate () + , pgcOnInput = Just $ \inpBS -> case fromPathPiece =<< either (const Nothing) Just (decodeUtf8' inpBS) of + Nothing -> $logErrorS "JobOffloadHandler" $ "Could not parse incoming notification data: " <> tshow inpBS + Just jId -> writeJobCtl $ JobCtlPerform jId + , pgcGenOutput = atomically $ do + jQueue <- readTVar jobOffloadOutgoing + j <- case jQueue of + j :< js -> j <$ writeTVar jobOffloadOutgoing js + _other -> mzero + return . encodeUtf8 $ toPathPiece j + } return JobOffloadHandler{..} where shouldListen = has (_jobsAcceptOffload . only True) jMode diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 7ebb4bf4c..23402d381 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -170,6 +170,7 @@ type family ChildrenJobChildren a where ChildrenJobChildren (Key a) = '[] ChildrenJobChildren (CI a) = '[] ChildrenJobChildren (Set a) = '[] + ChildrenJobChildren MailContext = '[] ChildrenJobChildren a = Children ChGeneric a diff --git a/src/Mail.hs b/src/Mail.hs index 01b062cee..827467b8e 100644 --- a/src/Mail.hs +++ b/src/Mail.hs @@ -41,6 +41,7 @@ import ClassyPrelude.Yesod hiding (snoc, (.=), getMessageRender, derivePersistFi import Data.Kind (Type) import Model.Types.Languages +import Model.Types.Csv import Network.Mail.Mime hiding (addPart, addAttachment) import qualified Network.Mail.Mime as Mime (addPart) @@ -171,6 +172,7 @@ _MailSmtpDataSet = to $ \MailSmtpData{..} -> none id data MailContext = MailContext { mcLanguages :: Languages , mcDateTimeFormat :: SelDateTimeFormat -> DateTimeFormat + , mcCsvOptions :: CsvOptions } deriving (Eq, Ord, Read, Show, Generic, Typeable) deriveJSON defaultOptions @@ -183,6 +185,7 @@ instance Default MailContext where def = MailContext { mcLanguages = def , mcDateTimeFormat = def + , mcCsvOptions = def } makeLenses_ ''MailContext @@ -192,11 +195,13 @@ makeLenses_ ''MailSmtpData class (MonadHandler m, MonadState Mail m) => MonadMail m where askMailLanguages :: m Languages askMailDateTimeFormat :: SelDateTimeFormat -> m DateTimeFormat + askMailCsvOptions :: m CsvOptions tellMailSmtpData :: MailSmtpData -> m () instance MonadHandler m => MonadMail (MailT m) where askMailLanguages = view _mcLanguages askMailDateTimeFormat = (view _mcDateTimeFormat ??) + askMailCsvOptions = view _mcCsvOptions tellMailSmtpData = tell getMailMessageRender :: ( MonadMail m diff --git a/src/Model.hs b/src/Model.hs index b8e4c22d9..750e8dd07 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -33,7 +33,7 @@ type SqlBackendKey = BackendKey SqlBackend -- You can find more information on persistent and how to declare entities -- at: -- http://www.yesodweb.com/book/persistent/ -share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateUniWorX", mkSave "currentModel"] +share [mkPersist sqlSettings{ mpsDeriveInstances = [''NFData] }, mkDeleteCascade sqlSettings, mkMigrate "migrateUniWorX", mkSave "currentModel"] $(persistDirectoryWith lowerCaseSettings "models") @@ -51,8 +51,6 @@ deriving newtype instance FromJSONKey ExamOccurrenceId deriving instance Show (Unique ExamPart) -deriving anyclass instance NFData ExamPart - -- ToMarkup and ToMessage instances for displaying selected database primary keys instance ToMarkup (Key School) where diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index ea88dbbdc..72b13b3ab 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -3,6 +3,7 @@ module Model.Migration ( migrateAll , requiresMigration + , ManualMigration(..), getMigrationTime ) where import Import.NoModel hiding (Max(..), Last(..)) @@ -184,3 +185,11 @@ getMissingMigrations = do E.where_ $ appliedMigration E.^. AppliedMigrationMigration `E.in_` E.valList universeF return $ appliedMigration E.^. AppliedMigrationMigration return $ customMigrations `Map.withoutKeys` Set.fromList appliedMigrations + +getMigrationTime :: ( MonadIO m + , BaseBackend backend ~ SqlBackend + , PersistStoreRead backend + ) + => ManualMigration + -> ReaderT backend m (Maybe UTCTime) +getMigrationTime = fmap (fmap appliedMigrationTime) . get . AppliedMigrationKey diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs index 2fe78d785..c0fb48b78 100644 --- a/src/Model/Migration/Definitions.hs +++ b/src/Model/Migration/Definitions.hs @@ -101,6 +101,7 @@ data ManualMigration | Migration20210115ExamPartsFrom | Migration20210201SharedWorkflowGraphs | Migration20210208StudyFeaturesRelevanceCachedUUIDs + | Migration20210318CrontabSubmissionRatedNotification deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) deriving anyclass (Universe, Finite) @@ -140,6 +141,9 @@ migrateManual = do , ("sent_mail_bounce_secret", "CREATE INDEX sent_mail_bounce_secret ON \"sent_mail\" (bounce_secret) WHERE bounce_secret IS NOT NULL") , ("sent_mail_recipient", "CREATE INDEX sent_mail_recipient ON \"sent_mail\" (recipient) WHERE recipient IS NOT NULL") , ("study_features_relevance_cached", "CREATE INDEX study_features_relevance_cached ON \"study_features\" (relevance_cached)") + , ("submission_rating_by", "CREATE INDEX submission_rating_by ON submission (rating_by) WHERE rating_by IS NOT NULL" ) + , ("exam_corrector_user", "CREATE INDEX exam_corrector_user ON exam_corrector (\"user\")" ) + , ("submission_rating_time", "CREATE INDEX submission_rating_time ON submission (rating_time)" ) ] where addIndex :: Text -> Sql -> Migration @@ -1040,6 +1044,9 @@ customMigrations = mapF $ \case ALTER TABLE "study_features" RENAME COLUMN "relevance_cached_uuid" TO "relevance_cached"; |] + -- Placeholder to inform crontab generation when switchover happened so old submissions don't get notified as corrected + Migration20210318CrontabSubmissionRatedNotification -> return () + tableExists :: MonadIO m => Text -> ReaderT SqlBackend m Bool tableExists table = do diff --git a/src/Model/Tokens/Bearer.hs b/src/Model/Tokens/Bearer.hs index 3185729c4..09849ecb6 100644 --- a/src/Model/Tokens/Bearer.hs +++ b/src/Model/Tokens/Bearer.hs @@ -79,13 +79,12 @@ data BearerToken site = BearerToken , bearerStartsAt :: Maybe UTCTime } deriving (Generic, Typeable) -deriving instance (Eq (AuthId site), Eq (Route site)) => Eq (BearerToken site) -deriving instance (Read (AuthId site), Eq (Route site), Hashable (Route site), Read (Route site), Hashable (AuthId site), Eq (AuthId site)) => Read (BearerToken site) -deriving instance (Show (AuthId site), Show (Route site), Hashable (AuthId site)) => Show (BearerToken site) - -instance (Hashable (AuthId site), Hashable (Route site)) => Hashable (BearerToken site) - -instance (Binary (AuthId site), Binary (Route site), Hashable (Route site), Eq (Route site), Hashable (AuthId site), Eq (AuthId site)) => Binary (BearerToken site) +deriving stock instance (Eq (AuthId site), Eq (Route site)) => Eq (BearerToken site) +deriving stock instance (Ord (AuthId site), Ord (Route site)) => Ord (BearerToken site) +deriving stock instance (Read (AuthId site), Eq (Route site), Hashable (Route site), Read (Route site), Hashable (AuthId site), Eq (AuthId site)) => Read (BearerToken site) +deriving stock instance (Show (AuthId site), Show (Route site), Hashable (AuthId site)) => Show (BearerToken site) +deriving anyclass instance (Hashable (AuthId site), Hashable (Route site)) => Hashable (BearerToken site) +deriving anyclass instance (Binary (AuthId site), Binary (Route site), Hashable (Route site), Eq (Route site), Hashable (AuthId site), Eq (AuthId site)) => Binary (BearerToken site) makeLenses_ ''BearerToken instance HasTokenIdentifier (BearerToken site) TokenId where diff --git a/src/Model/Types.hs b/src/Model/Types.hs index e36765375..9ee14e263 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -21,3 +21,4 @@ import Model.Types.Workflow as Types import Model.Types.Changelog as Types import Model.Types.Markup as Types import Model.Types.Room as Types +import Model.Types.Csv as Types diff --git a/src/Model/Types/Allocation.hs b/src/Model/Types/Allocation.hs index 90b406364..d78d62cae 100644 --- a/src/Model/Types/Allocation.hs +++ b/src/Model/Types/Allocation.hs @@ -32,6 +32,7 @@ data AllocationPriority = AllocationPriorityNumeric { allocationPriorities :: Vector Integer } | AllocationPriorityOrdinal { allocationOrdinal :: Natural } deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (NFData) deriveJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 , constructorTagModifier = camelToPathPiece' 2 @@ -49,7 +50,9 @@ instance Binary AllocationPriority data AllocationPriorityNumericRecord = AllocationPriorityNumericRecord { apmrMatrikelnummer :: UserMatriculation , apmrPriority :: Vector Integer - } deriving (Eq, Ord, Read, Show, Generic, Typeable) + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (NFData) allocationPriorityNumericMap :: Prism' (Map UserMatriculation AllocationPriority) AllocationPriorityNumericRecord allocationPriorityNumericMap = prism' fromPrioRecord toPrioRecord @@ -90,6 +93,7 @@ data AllocationPriorityComparison = AllocationPriorityComparisonNumeric { allocationGradeScale :: Rational } | AllocationPriorityComparisonOrdinal { allocationCloneIndex :: Down Natural, allocationOrdinalScale :: Rational } deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (NFData) type AllocationFingerprint = Digest (SHAKE128 128) diff --git a/src/Model/Types/Changelog.hs b/src/Model/Types/Changelog.hs index bc07b524a..1285782d5 100644 --- a/src/Model/Types/Changelog.hs +++ b/src/Model/Types/Changelog.hs @@ -29,21 +29,22 @@ makePrisms ''ChangelogItemKind classifyChangelogItem :: ChangelogItem -> ChangelogItemKind classifyChangelogItem = \case - ChangelogHaskellCampusLogin -> ChangelogItemBugfix - ChangelogTooltipsWithoutJavascript -> ChangelogItemBugfix - ChangelogButtonsWorkWithoutJavascript -> ChangelogItemBugfix - ChangelogTableFormsWorkAfterAjax -> ChangelogItemBugfix - ChangelogPassingByPointsWorks -> ChangelogItemBugfix - ChangelogErrorMessagesForTableItemVanish -> ChangelogItemBugfix - ChangelogExamAchievementParticipantDuplication -> ChangelogItemBugfix - ChangelogFormsTimesReset -> ChangelogItemBugfix - ChangelogAllocationCourseAcceptSubstitutesFixed -> ChangelogItemBugfix - ChangelogStoredMarkup -> ChangelogItemBugfix - ChangelogFixPersonalisedSheetFilesKeep -> ChangelogItemBugfix - ChangelogHonorRoomHidden -> ChangelogItemBugfix - ChangelogFixSheetBonusRounding -> ChangelogItemBugfix - ChangelogFixExamBonusAllSheetsBonus -> ChangelogItemBugfix - _other -> ChangelogItemFeature + ChangelogHaskellCampusLogin -> ChangelogItemBugfix + ChangelogTooltipsWithoutJavascript -> ChangelogItemBugfix + ChangelogButtonsWorkWithoutJavascript -> ChangelogItemBugfix + ChangelogTableFormsWorkAfterAjax -> ChangelogItemBugfix + ChangelogPassingByPointsWorks -> ChangelogItemBugfix + ChangelogErrorMessagesForTableItemVanish -> ChangelogItemBugfix + ChangelogExamAchievementParticipantDuplication -> ChangelogItemBugfix + ChangelogFormsTimesReset -> ChangelogItemBugfix + ChangelogAllocationCourseAcceptSubstitutesFixed -> ChangelogItemBugfix + ChangelogStoredMarkup -> ChangelogItemBugfix + ChangelogFixPersonalisedSheetFilesKeep -> ChangelogItemBugfix + ChangelogHonorRoomHidden -> ChangelogItemBugfix + ChangelogFixSheetBonusRounding -> ChangelogItemBugfix + ChangelogFixExamBonusAllSheetsBonus -> ChangelogItemBugfix + ChangelogExamAutomaticRoomDistributionRespectSize -> ChangelogItemBugfix + _other -> ChangelogItemFeature changelogItemDays :: Map ChangelogItem Day changelogItemDays = Map.fromListWithKey (\k d1 d2 -> bool (error $ "Duplicate changelog days for " <> show k) d1 $ d1 /= d2) diff --git a/src/Model/Types/Course.hs b/src/Model/Types/Course.hs index e7a991d29..e9779a486 100644 --- a/src/Model/Types/Course.hs +++ b/src/Model/Types/Course.hs @@ -16,9 +16,7 @@ import Utils.Lens.TH data LecturerType = CourseLecturer | CourseAssistant deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) - -instance Universe LecturerType -instance Finite LecturerType + deriving (Universe, Finite, NFData) nullaryPathPiece ''LecturerType $ camelToPathPiece' 1 deriveJSON defaultOptions @@ -33,7 +31,7 @@ data CourseParticipantState = CourseParticipantActive | CourseParticipantInactive { courseParticipantNoShow :: Bool } deriving (Eq, Ord, Read, Show, Generic, Typeable) - deriving anyclass (Hashable) + deriving anyclass (NFData, Hashable) makePrisms ''CourseParticipantState makeLenses_ ''CourseParticipantState diff --git a/src/Model/Types/Csv.hs b/src/Model/Types/Csv.hs new file mode 100644 index 000000000..88f183de9 --- /dev/null +++ b/src/Model/Types/Csv.hs @@ -0,0 +1,191 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Model.Types.Csv + ( Quoting(..) + , CsvOptions(..), _csvFormat, _csvTimestamp + , CsvFormatOptions(..), _csvDelimiter, _csvUseCrLf, _csvQuoting, _csvEncoding + , CsvPreset(..) + , csvPreset + , _CsvEncodeOptions + , CsvFormat(..), _FormatCsv, _FormatXlsx + , _CsvFormat, _CsvFormatPreset + ) where + +import ClassyPrelude + +import Data.Csv (Quoting(..)) +import qualified Data.Csv as Csv + +import Model.Types.TH.JSON +import Utils.PathPiece +import Data.Universe.TH +import Data.Aeson.TH + +import Data.Aeson (FromJSON, ToJSON) +import qualified Data.Aeson as JSON + +import Data.Encoding (DynEncoding) + +import Data.Encoding.Instances () + +import Control.Lens + +import Utils.Lens.TH + +import Data.Default +import Data.Universe + + +deriving stock instance Generic Quoting +deriving stock instance Ord Quoting +deriving stock instance Read Quoting +deriving anyclass instance Hashable Quoting +deriving anyclass instance NFData Quoting +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 1 + } ''Quoting +deriveFinite ''Quoting +nullaryPathPiece ''Quoting $ \q -> if + | q == "QuoteNone" -> "never" + | otherwise -> camelToPathPiece' 1 q + +data CsvOptions + = CsvOptions + { csvFormat :: CsvFormatOptions + , csvTimestamp :: Bool + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (Hashable, NFData) + +data CsvFormatOptions + = CsvFormatOptions + { csvDelimiter :: Char + , csvUseCrLf :: Bool + , csvQuoting :: Csv.Quoting + , csvEncoding :: DynEncoding + } + | CsvXlsxFormatOptions + deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (Hashable, NFData) + +makeLenses_ ''CsvOptions +makeLenses_ ''CsvFormatOptions + +instance Default CsvOptions where + def = CsvOptions + { csvFormat = def + , csvTimestamp = False + } + +instance Default CsvFormatOptions where + def = csvPreset # CsvPresetRFC + +data CsvPreset = CsvPresetRFC + | CsvPresetXlsx + | CsvPresetExcel + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) +instance Universe CsvPreset +instance Finite CsvPreset + +csvPreset :: Prism' CsvFormatOptions CsvPreset +csvPreset = prism' fromPreset toPreset + where + fromPreset :: CsvPreset -> CsvFormatOptions + fromPreset CsvPresetRFC = CsvFormatOptions + { csvDelimiter = ',' + , csvUseCrLf = True + , csvQuoting = QuoteMinimal + , csvEncoding = "UTF8" + } + fromPreset CsvPresetExcel = CsvFormatOptions + { csvDelimiter = ';' + , csvUseCrLf = True + , csvQuoting = QuoteAll + , csvEncoding = "CP1252" + } + fromPreset CsvPresetXlsx = CsvXlsxFormatOptions + + toPreset :: CsvFormatOptions -> Maybe CsvPreset + toPreset opts = case filter (\p -> fromPreset p == opts) universeF of + [p] -> Just p + _other -> Nothing + +_CsvEncodeOptions :: Prism' CsvFormatOptions Csv.EncodeOptions +_CsvEncodeOptions = prism' fromEncode toEncode + where + toEncode CsvFormatOptions{..} = Just $ Csv.defaultEncodeOptions + { Csv.encDelimiter = fromIntegral $ fromEnum csvDelimiter + , Csv.encUseCrLf = csvUseCrLf + , Csv.encQuoting = csvQuoting + , Csv.encIncludeHeader = True + } + toEncode CsvXlsxFormatOptions{} = Nothing + fromEncode encOpts = def + { csvDelimiter = toEnum . fromIntegral $ Csv.encDelimiter encOpts + , csvUseCrLf = Csv.encUseCrLf encOpts + , csvQuoting = Csv.encQuoting encOpts + } + +instance ToJSON CsvOptions where + toJSON CsvOptions{..} = JSON.object + [ "format" JSON..= csvFormat + , "timestamp" JSON..= csvTimestamp + ] + +instance FromJSON CsvOptions where + parseJSON = JSON.withObject "CsvOptions" $ \o -> do + csvFormat <- o JSON..:? "format" JSON..!= csvFormat def + csvTimestamp <- o JSON..:? "timestamp" JSON..!= csvTimestamp def + return CsvOptions{..} + +data CsvFormat = FormatCsv | FormatXlsx + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + deriving anyclass (Universe, Finite) + +nullaryPathPiece ''CsvFormat $ camelToPathPiece' 1 +pathPieceJSON ''CsvFormat +makePrisms ''CsvFormat + +_CsvFormat :: forall r. Getting r CsvFormatOptions CsvFormat +_CsvFormat = to $ \case + CsvFormatOptions{} -> FormatCsv + CsvXlsxFormatOptions{} -> FormatXlsx + +_CsvFormatPreset :: Prism' CsvPreset CsvFormat +_CsvFormatPreset = prism' toPreset fromPreset + where + toPreset = \case + FormatCsv -> CsvPresetRFC + FormatXlsx -> CsvPresetXlsx + fromPreset = \case + CsvPresetRFC -> Just FormatCsv + CsvPresetXlsx -> Just FormatXlsx + _other -> Nothing + +instance ToJSON CsvFormatOptions where + toJSON CsvFormatOptions{..} = JSON.object + [ "format" JSON..= FormatCsv + , "delimiter" JSON..= fromEnum csvDelimiter + , "use-cr-lf" JSON..= csvUseCrLf + , "quoting" JSON..= csvQuoting + , "encoding" JSON..= csvEncoding + ] + toJSON CsvXlsxFormatOptions = JSON.object + [ "format" JSON..= FormatXlsx + ] +instance FromJSON CsvFormatOptions where + parseJSON = JSON.withObject "CsvFormatOptions" $ \o -> do + formatTag <- o JSON..:? "format" JSON..!= FormatCsv + + case formatTag of + FormatCsv -> do + csvDelimiter <- fmap (fmap toEnum) (o JSON..:? "delimiter") JSON..!= csvDelimiter def + csvUseCrLf <- o JSON..:? "use-cr-lf" JSON..!= csvUseCrLf def + csvQuoting <- o JSON..:? "quoting" JSON..!= csvQuoting def + csvEncoding <- o JSON..:? "encoding" JSON..!= csvEncoding def + return CsvFormatOptions{..} + FormatXlsx -> return CsvXlsxFormatOptions + +derivePersistFieldJSON ''CsvOptions + +nullaryPathPiece ''CsvPreset $ camelToPathPiece' 2 diff --git a/src/Model/Types/DateTime.hs b/src/Model/Types/DateTime.hs index 16942e98a..76d427ed9 100644 --- a/src/Model/Types/DateTime.hs +++ b/src/Model/Types/DateTime.hs @@ -153,6 +153,7 @@ data OccurrenceSchedule = ScheduleWeekly , scheduleEnd :: TimeOfDay } deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (NFData) deriveJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 @@ -170,6 +171,7 @@ data OccurrenceException = ExceptOccur { exceptTime :: LocalTime } deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (NFData) deriveJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 @@ -180,7 +182,9 @@ deriveJSON defaultOptions data Occurrences = Occurrences { occurrencesScheduled :: Set OccurrenceSchedule , occurrencesExceptions :: Set OccurrenceException - } deriving (Eq, Ord, Read, Show, Generic, Typeable) + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (NFData) deriveJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 diff --git a/src/Model/Types/Exam.hs b/src/Model/Types/Exam.hs index 1a9cb0ef4..193e319fb 100644 --- a/src/Model/Types/Exam.hs +++ b/src/Model/Types/Exam.hs @@ -19,6 +19,8 @@ module Model.Types.Exam , _examOccurrenceMappingRule , _examOccurrenceMappingMapping , traverseExamOccurrenceMapping + , ExamOccurrenceCapacity(.., Unrestricted, Restricted) + , _examOccurrenceCapacityIso , ExamGrade(..) , numberGrade , ExamGradeDefCenter(..) @@ -76,6 +78,7 @@ data ExamResult' res = ExamAttended { examResult :: res } | ExamNoShow | ExamVoided deriving (Show, Read, Eq, Ord, Functor, Generic, Typeable) + deriving anyclass (NFData) deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1 , fieldLabelModifier = camelToPathPiece' 1 @@ -154,6 +157,7 @@ data ExamBonusRule = ExamBonusManual , bonusRound :: Points } deriving (Show, Read, Eq, Ord, Generic, Typeable) + deriving anyclass (NFData) deriveJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 , constructorTagModifier = camelToPathPiece' 1 @@ -169,7 +173,8 @@ data ExamOccurrenceRule = ExamRoomManual | ExamRoomSurname | ExamRoomMatriculation | ExamRoomRandom - deriving (Show, Read, Eq, Ord, Generic, Typeable) + deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic, Typeable) + deriving anyclass (Universe, Finite, NFData) deriveJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 , constructorTagModifier = camelToPathPiece' 2 @@ -191,7 +196,9 @@ examOccurrenceRuleAutomatic x = any ($ x) data ExamOccurrenceMappingDescription = ExamOccurrenceMappingRange { eaomrStart, eaomrEnd :: [CI Char] } | ExamOccurrenceMappingSpecial { eaomrSpecial :: [CI Char] } + | ExamOccurrenceMappingRandom deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (NFData) deriveJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 , constructorTagModifier = camelToPathPiece' 3 @@ -203,7 +210,9 @@ makePrisms ''ExamOccurrenceMappingDescription data ExamOccurrenceMapping roomId = ExamOccurrenceMapping { examOccurrenceMappingRule :: ExamOccurrenceRule , examOccurrenceMappingMapping :: Map roomId (Set ExamOccurrenceMappingDescription) - } deriving (Eq, Ord, Read, Show, Generic, Typeable) + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (NFData) instance ToJSONKey roomId => ToJSON (ExamOccurrenceMapping roomId) where toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 @@ -224,6 +233,34 @@ traverseExamOccurrenceMapping :: Ord roomId' => Traversal (ExamOccurrenceMapping roomId) (ExamOccurrenceMapping roomId') roomId roomId' traverseExamOccurrenceMapping = _examOccurrenceMappingMapping . iso Map.toList (Map.fromListWith Set.union) . traverse . _1 +-- | Natural extended by representation for Infinity. +-- +-- Maybe doesn't work, because the 'Ord' instance puts 'Nothing' below 0 +-- instead of above every other number. +newtype ExamOccurrenceCapacity = EOCapacity (Maybe Natural) + deriving stock (Show) + deriving (Eq, Ord) via (NTop (Maybe Natural)) + +pattern Unrestricted :: ExamOccurrenceCapacity +pattern Unrestricted = EOCapacity Nothing +pattern Restricted :: Natural -> ExamOccurrenceCapacity +pattern Restricted n = EOCapacity (Just n) + +{-# COMPLETE Unrestricted, Restricted #-} + +-- | Addition monoid with 'Unrestricted' interpreted as infinity. +instance Semigroup ExamOccurrenceCapacity where + (<>) Unrestricted _b = Unrestricted + (<>) _a Unrestricted = Unrestricted + (<>) (Restricted a) (Restricted b) = Restricted $ a + b + +-- | Addition monoid with 'Unrestricted' interpreted as infinity. +instance Monoid ExamOccurrenceCapacity where + mempty = Restricted 0 + +_examOccurrenceCapacityIso :: Iso' ExamOccurrenceCapacity (Maybe Natural) +_examOccurrenceCapacityIso = iso (\case {Unrestricted -> Nothing; Restricted n -> Just n}) + (\case {Nothing -> Unrestricted; Just n -> Restricted n}) data ExamGrade = Grade50 @@ -238,8 +275,7 @@ data ExamGrade | Grade13 | Grade10 deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) -instance Universe ExamGrade -instance Finite ExamGrade + deriving anyclass (Universe, Finite, NFData) numberGrade :: Prism' Rational ExamGrade numberGrade = prism toNumberGrade fromNumberGrade @@ -258,19 +294,21 @@ numberGrade = prism toNumberGrade fromNumberGrade Grade13 -> 1.3 Grade10 -> 1.0 fromNumberGrade :: Rational -> Either Rational ExamGrade - fromNumberGrade = \case - 5.0 -> Right Grade50 - 4.0 -> Right Grade40 - 3.7 -> Right Grade37 - 3.3 -> Right Grade33 - 3.0 -> Right Grade30 - 2.7 -> Right Grade27 - 2.3 -> Right Grade23 - 2.0 -> Right Grade20 - 1.7 -> Right Grade17 - 1.3 -> Right Grade13 - 1.0 -> Right Grade10 - n -> Left n + fromNumberGrade n + | n >= 100 = fromNumberGrade $ n / 100 + | otherwise = case n of + 5.0 -> Right Grade50 + 4.0 -> Right Grade40 + 3.7 -> Right Grade37 + 3.3 -> Right Grade33 + 3.0 -> Right Grade30 + 2.7 -> Right Grade27 + 2.3 -> Right Grade23 + 2.0 -> Right Grade20 + 1.7 -> Right Grade17 + 1.3 -> Right Grade13 + 1.0 -> Right Grade10 + n' -> Left n' instance PathPiece ExamGrade where toPathPiece = toPathPiece . (fromRational :: Rational -> Deci) . review numberGrade @@ -313,6 +351,7 @@ data ExamGradingRule { examGradingKey :: [Points] -- ^ @[n1, n2, n3, ..., n11]@ means @0 <= p < n1 -> p ~= 5@, @n1 <= p < n2 -> p ~ 4@, @n2 <= p < n3 -> p ~ 3.7@, ..., @n10 <= p -> p ~ 1.0@ } deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (NFData) deriveJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 2 , constructorTagModifier = camelToPathPiece' 2 @@ -327,6 +366,7 @@ derivePersistFieldJSON ''ExamGradingRule newtype ExamPassed = ExamPassed { examPassed :: Bool } deriving (Read, Show, Generic, Typeable) deriving newtype (Eq, Ord, Enum, Bounded, PersistField) + deriving anyclass (NFData) instance PersistFieldSql ExamPassed where sqlType _ = sqlType $ Proxy @Bool @@ -372,8 +412,7 @@ data ExamGradingMode | ExamGradingGrades | ExamGradingMixed deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) -instance Universe ExamGradingMode -instance Finite ExamGradingMode + deriving anyclass (Universe, Finite, NFData) nullaryPathPiece ''ExamGradingMode $ camelToPathPiece' 2 pathPieceJSON ''ExamGradingMode @@ -447,12 +486,13 @@ data ExamAids = ExamAidsPreset { examAidsPreset :: ExamAidsPreset } | ExamAidsCustom { examAidsCustom :: StoredMarkup } deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (NFData) data ExamAidsPreset = ExamOpenBook | ExamClosedBook deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) - deriving anyclass (Universe, Finite) + deriving anyclass (Universe, Finite, NFData) deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece' 2 @@ -468,12 +508,13 @@ data ExamOnline = ExamOnlinePreset { examOnlinePreset :: ExamOnlinePreset } | ExamOnlineCustom { examOnlineCustom :: StoredMarkup } deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (NFData) data ExamOnlinePreset = ExamOnline | ExamOffline deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) - deriving anyclass (Universe, Finite) + deriving anyclass (Universe, Finite, NFData) deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece' 2 @@ -489,12 +530,13 @@ data ExamSynchronicity = ExamSynchronicityPreset { examSynchronicityPreset :: ExamSynchronicityPreset } | ExamSynchronicityCustom { examSynchronicityCustom :: StoredMarkup } deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (NFData) data ExamSynchronicityPreset = ExamSynchronous | ExamAsynchronous deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) - deriving anyclass (Universe, Finite) + deriving anyclass (Universe, Finite, NFData) deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece' 2 @@ -510,6 +552,7 @@ data ExamRequiredEquipment = ExamRequiredEquipmentPreset { examRequiredEquipmentPreset :: ExamRequiredEquipmentPreset } | ExamRequiredEquipmentCustom { examRequiredEquipmentCustom :: StoredMarkup } deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (NFData) data ExamRequiredEquipmentPreset = ExamRequiredEquipmentNone @@ -520,7 +563,7 @@ data ExamRequiredEquipmentPreset | ExamRequiredEquipmentWebcamMicrophoneInternet | ExamRequiredEquipmentMicrophoneInternet deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) - deriving anyclass (Universe, Finite) + deriving anyclass (Universe, Finite, NFData) deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece' 2 @@ -539,6 +582,8 @@ data ExamMode = ExamMode , examSynchronicity :: Maybe ExamSynchronicity , examRequiredEquipment :: Maybe ExamRequiredEquipment } + deriving (Generic, Typeable) + deriving anyclass (NFData) deriveJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 , sumEncoding = UntaggedValue @@ -551,6 +596,7 @@ data ExamModePredicate | ExamModePredSynchronicity ExamSynchronicityPreset | ExamModePredRequiredEquipment ExamRequiredEquipmentPreset deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (NFData) deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 , sumEncoding = TaggedObject "setting" "preset" @@ -561,6 +607,7 @@ deriveFinite ''ExamModePredicate newtype ExamModeDNF = ExamModeDNF { examModeDNF :: PredDNF ExamModePredicate } deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving newtype (ToJSON, FromJSON, PathPiece) + deriving anyclass (NFData) derivePersistFieldJSON ''ExamModeDNF @@ -569,7 +616,7 @@ data ExamCloseMode = ExamCloseSeparate | ExamCloseOnFinished { examCloseOnFinishedHidden :: Bool } deriving (Eq, Ord, Read, Show, Generic, Typeable) - deriving anyclass (Binary) + deriving anyclass (Binary, NFData) deriveFinite ''ExamCloseMode finitePathPiece ''ExamCloseMode ["separate", "on-finished", "on-finished-hidden"] derivePersistFieldPathPiece ''ExamCloseMode diff --git a/src/Model/Types/File.hs b/src/Model/Types/File.hs index be8922eff..28c649dfd 100644 --- a/src/Model/Types/File.hs +++ b/src/Model/Types/File.hs @@ -1,4 +1,5 @@ {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE EmptyCase #-} module Model.Types.File ( FileContentChunkReference(..), FileContentReference(..) @@ -156,7 +157,7 @@ data FileReference = FileReference , fileReferenceContent :: Maybe FileContentReference , fileReferenceModified :: UTCTime } deriving (Eq, Ord, Read, Show, Generic, Typeable) - deriving anyclass (Hashable, Binary) + deriving anyclass (Hashable, Binary, NFData) makeLenses_ ''FileReference deriveJSON defaultOptions @@ -169,11 +170,16 @@ class HasFileReference record where _FileReference :: Iso' record (FileReference, FileReferenceResidual record) +instance HasFileReference Void where + data FileReferenceResidual Void + + _FileReference = iso (\case {}) $ views _2 (\case {}) + instance HasFileReference FileReference where data FileReferenceResidual FileReference = FileReferenceResidual deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) - deriving anyclass (Universe, Finite) + deriving anyclass (Universe, Finite, NFData) -- newtype FileReferenceTitleMap FileReference add = FileReferenceFileReferenceTitleMap { unFileReferenceFileReferenceTitleMap :: Map FilePath (FileReferenceTitleMapElem FileReference add) } -- deriving (Eq, Ord, Read, Show, Generic, Typeable) -- deriving newtype (Semigroup, Monoid) @@ -190,6 +196,7 @@ instance HasFileReference PureFile where newtype FileReferenceResidual PureFile = PureFileResidual { unPureFileResidual :: Maybe ByteString } deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving newtype (ToJSON, FromJSON) + deriving anyclass (NFData) _FileReference = iso toFileReference fromFileReference where @@ -207,6 +214,7 @@ instance HasFileReference PureFile where instance (HasFileReference a, HasFileReference b) => HasFileReference (Either a b) where newtype FileReferenceResidual (Either a b) = FileReferenceResidualEither { unFileReferenceResidualEither :: Either (FileReferenceResidual a) (FileReferenceResidual b) } + deriving (Generic, Typeable) _FileReference = iso doSplit doJoin where doSplit (Right r) = over _2 (FileReferenceResidualEither . Right) $ r ^. _FileReference @@ -219,6 +227,7 @@ instance HasFileReference record => HasFileReference (Entity record) where { fileReferenceResidualEntityKey :: Key record , fileReferenceResidualEntityResidual :: FileReferenceResidual record } + deriving (Generic, Typeable) _FileReference = iso doSplit doJoin where doSplit Entity{..} = (fRef, FileReferenceResidualEntity entityKey res) @@ -237,11 +246,14 @@ newtype instance FileReferenceTitleMap FileReference add = FileReferenceFileRefe } deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving newtype (Semigroup, Monoid) + deriving anyclass (NFData) data FileReferenceFileReferenceTitleMapElem add = FileReferenceFileReferenceTitleMapElem { fRefTitleMapContent :: Maybe FileContentReference , fRefTitleMapModified :: UTCTime , fRefTitleMapAdditional :: add - } deriving (Eq, Ord, Read, Show, Generic, Typeable) + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (NFData) makePrisms ''FileReferenceFileReferenceTitleMapElem @@ -259,7 +271,9 @@ instance FileReferenceTitleMapConvertible add FileReference FileReference where data FileFieldUserOption a = FileFieldUserOption { fieldOptionForce :: Bool , fieldOptionDefault :: a - } deriving (Eq, Ord, Read, Show, Generic, Typeable) + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (NFData) deriveJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 2 @@ -273,11 +287,13 @@ data FileField fileid = FileField , fieldMaxFileSize :: Maybe Natural , fieldAdditionalFiles :: FileReferenceTitleMap fileid (FileFieldUserOption Bool) , fieldAllEmptyOk :: Bool - } deriving (Generic, Typeable) + } + deriving (Generic, Typeable) deriving instance Eq (FileReferenceTitleMap fileid (FileFieldUserOption Bool)) => Eq (FileField fileid) deriving instance Ord (FileReferenceTitleMap fileid (FileFieldUserOption Bool)) => Ord (FileField fileid) deriving instance Read (FileReferenceTitleMap fileid (FileFieldUserOption Bool)) => Read (FileField fileid) deriving instance Show (FileReferenceTitleMap fileid (FileFieldUserOption Bool)) => Show (FileField fileid) +deriving anyclass instance NFData (FileReferenceTitleMap fileid (FileFieldUserOption Bool)) => NFData (FileField fileid) instance ToJSON (FileField FileReference) where toJSON FileField{..} = JSON.object $ catMaybes diff --git a/src/Model/Types/Mail.hs b/src/Model/Types/Mail.hs index a6e96ad4f..e3b6cdd93 100644 --- a/src/Model/Types/Mail.hs +++ b/src/Model/Types/Mail.hs @@ -64,11 +64,7 @@ data NotificationTrigger | NTExamOfficeExamResultsChanged | NTCourseRegistered deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) - -instance Universe NotificationTrigger -instance Finite NotificationTrigger - -instance Hashable NotificationTrigger + deriving anyclass (Universe, Finite, Hashable, NFData) nullaryPathPiece ''NotificationTrigger $ camelToPathPiece' 1 pathPieceJSON ''NotificationTrigger @@ -78,6 +74,7 @@ pathPieceJSONKey ''NotificationTrigger newtype NotificationSettings = NotificationSettings { notificationAllowed :: NotificationTrigger -> Bool } deriving (Generic, Typeable) deriving newtype (Eq, Ord, Read, Show) + deriving anyclass (NFData) instance Default NotificationSettings where def = NotificationSettings $ not . flip HashSet.member defaultOff @@ -117,7 +114,7 @@ instance PathPiece BounceSecret where newtype MailContent = MailContent [Alternatives] deriving (Eq, Show, Generic, Typeable) deriving newtype (ToJSON, FromJSON) - deriving anyclass (Binary) + deriving anyclass (Binary, NFData) derivePersistFieldJSON ''MailContent diff --git a/src/Model/Types/Markup.hs b/src/Model/Types/Markup.hs index f60ffb57e..8170de721 100644 --- a/src/Model/Types/Markup.hs +++ b/src/Model/Types/Markup.hs @@ -30,7 +30,7 @@ data MarkupFormat | MarkupHtml | MarkupPlaintext deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) - deriving anyclass (Universe, Finite) + deriving anyclass (Universe, Finite, NFData) nullaryPathPiece ''MarkupFormat $ camelToPathPiece' 1 pathPieceJSON ''MarkupFormat @@ -38,7 +38,9 @@ data StoredMarkup = StoredMarkup { markupInputFormat :: MarkupFormat , markupInput :: LT.Text , markupOutput :: Html - } deriving (Read, Show, Generic, Typeable) + } + deriving (Read, Show, Generic, Typeable) + deriving anyclass (NFData) htmlToStoredMarkup :: Html -> StoredMarkup htmlToStoredMarkup html = StoredMarkup diff --git a/src/Model/Types/Misc.hs b/src/Model/Types/Misc.hs index 108a89a4a..6bfae3fc6 100644 --- a/src/Model/Types/Misc.hs +++ b/src/Model/Types/Misc.hs @@ -1,5 +1,3 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - {-| Module: Model.Types.Misc Description: Additional uncategorized types @@ -7,7 +5,6 @@ Description: Additional uncategorized types module Model.Types.Misc ( module Model.Types.Misc - , Quoting(..) ) where import Import.NoModel @@ -18,23 +15,16 @@ import Data.Maybe (fromJust) import qualified Data.Text as Text import qualified Data.Text.Lens as Text -import qualified Data.ByteString.Lazy as LBS - -import Data.Csv (Quoting(..)) import qualified Data.Csv as Csv -import qualified Data.Aeson as JSON - import Database.Persist.Sql (PersistFieldSql(..)) -import Utils.Lens.TH - import Web.HttpApiData data StudyFieldType = FieldPrimary | FieldSecondary deriving (Eq, Ord, Enum, Show, Read, Bounded, Generic) - deriving anyclass (Universe, Finite) + deriving anyclass (Universe, Finite, NFData) derivePersistField "StudyFieldType" nullaryPathPiece ''StudyFieldType $ camelToPathPiece' 1 @@ -51,14 +41,12 @@ data Theme | ThemeMossGreen | ThemeSkyLove deriving (Eq, Ord, Bounded, Enum, Show, Read, Generic) + deriving anyclass (Universe, Finite, NFData) deriveJSON defaultOptions { constructorTagModifier = fromJust . stripPrefix "Theme" } ''Theme -instance Universe Theme -instance Finite Theme - nullaryPathPiece ''Theme $ camelToPathPiece' 1 $(deriveSimpleWith ''ToMessage 'toMessage (over Text.packed $ Text.intercalate " " . unsafeTail . splitCamel) ''Theme) -- describe theme to user @@ -66,135 +54,6 @@ $(deriveSimpleWith ''ToMessage 'toMessage (over Text.packed $ Text.intercalate " derivePersistField "Theme" -deriving instance Generic Quoting -deriving instance Ord Quoting -deriving instance Read Quoting -deriveJSON defaultOptions - { constructorTagModifier = camelToPathPiece' 1 - } ''Quoting -deriveFinite ''Quoting -nullaryPathPiece ''Quoting $ \q -> if - | q == "QuoteNone" -> "never" - | otherwise -> camelToPathPiece' 1 q - -data CsvOptions - = CsvOptions - { csvFormat :: CsvFormatOptions - , csvTimestamp :: Bool - } - deriving (Eq, Ord, Read, Show, Generic, Typeable) - -data CsvFormatOptions - = CsvFormatOptions - { csvDelimiter :: Char - , csvUseCrLf :: Bool - , csvQuoting :: Csv.Quoting - , csvEncoding :: DynEncoding - } - deriving (Eq, Ord, Read, Show, Generic, Typeable) - -makeLenses_ ''CsvOptions -makeLenses_ ''CsvFormatOptions - -instance Default CsvOptions where - def = CsvOptions - { csvFormat = def - , csvTimestamp = False - } - -instance Default CsvFormatOptions where - def = csvPreset # CsvPresetRFC - -data CsvPreset = CsvPresetRFC - | CsvPresetExcel - deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) -instance Universe CsvPreset -instance Finite CsvPreset - -csvPreset :: Prism' CsvFormatOptions CsvPreset -csvPreset = prism' fromPreset toPreset - where - fromPreset :: CsvPreset -> CsvFormatOptions - fromPreset CsvPresetRFC = CsvFormatOptions - { csvDelimiter = ',' - , csvUseCrLf = True - , csvQuoting = QuoteMinimal - , csvEncoding = "UTF8" - } - fromPreset CsvPresetExcel = CsvFormatOptions - { csvDelimiter = ';' - , csvUseCrLf = True - , csvQuoting = QuoteAll - , csvEncoding = "CP1252" - } - - toPreset :: CsvFormatOptions -> Maybe CsvPreset - toPreset opts = case filter (\p -> fromPreset p == opts) universeF of - [p] -> Just p - _other -> Nothing - -_CsvEncodeOptions :: Iso' CsvFormatOptions Csv.EncodeOptions -_CsvEncodeOptions = iso toEncode fromEncode - where - toEncode CsvFormatOptions{..} = Csv.defaultEncodeOptions - { Csv.encDelimiter = fromIntegral $ fromEnum csvDelimiter - , Csv.encUseCrLf = csvUseCrLf - , Csv.encQuoting = csvQuoting - , Csv.encIncludeHeader = True - } - fromEncode encOpts = def - { csvDelimiter = toEnum . fromIntegral $ Csv.encDelimiter encOpts - , csvUseCrLf = Csv.encUseCrLf encOpts - , csvQuoting = Csv.encQuoting encOpts - } - -instance ToJSON CsvOptions where - toJSON CsvOptions{..} = JSON.object - [ "format" JSON..= csvFormat - , "timestamp" JSON..= csvTimestamp - ] - -instance FromJSON CsvOptions where - parseJSON = JSON.withObject "CsvOptions" $ \o -> do - csvFormat <- o JSON..:? "format" JSON..!= csvFormat def - csvTimestamp <- o JSON..:? "timestamp" JSON..!= csvTimestamp def - return CsvOptions{..} - -instance ToJSON CsvFormatOptions where - toJSON CsvFormatOptions{..} = JSON.object - [ "delimiter" JSON..= fromEnum csvDelimiter - , "use-cr-lf" JSON..= csvUseCrLf - , "quoting" JSON..= csvQuoting - , "encoding" JSON..= csvEncoding - ] -instance FromJSON CsvFormatOptions where - parseJSON = JSON.withObject "CsvFormatOptions" $ \o -> do - csvDelimiter <- fmap (fmap toEnum) (o JSON..:? "delimiter") JSON..!= csvDelimiter def - csvUseCrLf <- o JSON..:? "use-cr-lf" JSON..!= csvUseCrLf def - csvQuoting <- o JSON..:? "quoting" JSON..!= csvQuoting def - csvEncoding <- o JSON..:? "encoding" JSON..!= csvEncoding def - return CsvFormatOptions{..} - -derivePersistFieldJSON ''CsvOptions - -nullaryPathPiece ''CsvPreset $ camelToPathPiece' 2 - -instance YesodMail site => ToMailPart site (CsvRendered, CsvOptions) where - toMailPart (CsvRendered{..}, encOpts) = do - _partType .= decodeUtf8 typeCsv' - _partEncoding .= QuotedPrintableText - _partContent .= PartContent (recode' $ Csv.encodeByNameWith (encOpts ^. _csvFormat . _CsvEncodeOptions) csvRenderedHeader csvRenderedData) - where - recode' :: LBS.ByteString -> LBS.ByteString - recode' - | enc == "UTF8" - = id - | otherwise - = encodeLazyByteString enc . decodeLazyByteString UTF8 - where enc = encOpts ^. _csvFormat . _csvEncoding - -instance YesodMail site => ToMailPart site CsvRendered where - toMailPart = toMailPart . (, def :: CsvOptions) data FavouriteReason @@ -203,22 +62,19 @@ data FavouriteReason | FavouriteManual | FavouriteCurrent deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) -instance Universe FavouriteReason -instance Finite FavouriteReason + deriving anyclass (Universe, Finite, NFData) deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1 } ''FavouriteReason derivePersistFieldJSON ''FavouriteReason - data Sex = SexNotKnown | SexMale | SexFemale | SexNotApplicable deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) -instance Universe Sex -instance Finite Sex + deriving anyclass (Universe, Finite, NFData) deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1 } ''Sex @@ -269,7 +125,7 @@ data TokenBucketIdent = TokenBucketInjectFiles | TokenBucketInjectFilesCount | TokenBucketPruneFiles | TokenBucketRechunkFiles deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) - deriving anyclass (Universe, Finite, Hashable) + deriving anyclass (Universe, Finite, Hashable, NFData) nullaryPathPiece ''TokenBucketIdent $ camelToPathPiece' 2 pathPieceJSON ''TokenBucketIdent diff --git a/src/Model/Types/Room.hs b/src/Model/Types/Room.hs index 54ec3eda9..c30fe818a 100644 --- a/src/Model/Types/Room.hs +++ b/src/Model/Types/Room.hs @@ -16,6 +16,7 @@ data RoomReference , roomRefInstructions :: Maybe StoredMarkup } deriving (Eq, Ord, Show, Generic, Typeable) + deriving anyclass (NFData) deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece' 2 diff --git a/src/Model/Types/School.hs b/src/Model/Types/School.hs index ef695831f..0b9f65634 100644 --- a/src/Model/Types/School.hs +++ b/src/Model/Types/School.hs @@ -10,12 +10,10 @@ data SchoolFunction | SchoolExamOffice | SchoolAllocation deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) -instance Universe SchoolFunction -instance Finite SchoolFunction -instance Hashable SchoolFunction -instance NFData SchoolFunction + deriving anyclass (Universe, Finite, Hashable, NFData) nullaryPathPiece ''SchoolFunction $ camelToPathPiece' 1 pathPieceJSON ''SchoolFunction pathPieceJSONKey ''SchoolFunction derivePersistFieldPathPiece ''SchoolFunction +pathPieceBinary ''SchoolFunction diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs index a7fa4d442..5b83645c3 100644 --- a/src/Model/Types/Security.hs +++ b/src/Model/Types/Security.hs @@ -70,6 +70,7 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä | AuthStaffTime | AuthAllocationTime | AuthCourseTime + | AuthExamTime | AuthMaterials | AuthOwner | AuthPersonalisedSheetFiles @@ -92,7 +93,7 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä | AuthDevelopment | AuthFree deriving (Eq, Ord, Enum, Bounded, Read, Show, Data, Generic, Typeable) - deriving anyclass (Universe, Finite, Hashable) + deriving anyclass (Universe, Finite, Hashable, NFData) nullaryPathPiece ''AuthTag $ camelToPathPiece' 1 pathPieceJSON ''AuthTag @@ -156,7 +157,7 @@ _ReducedActiveAuthTags = iso toReducedActiveAuthTags fromReducedActiveAuthTags data PredLiteral a = PLVariable { plVar :: a } | PLNegated { plVar :: a } deriving (Eq, Ord, Read, Show, Data, Generic, Typeable) - deriving anyclass (Hashable, Binary) + deriving anyclass (Hashable, Binary, NFData) makeLenses_ ''PredLiteral makePrisms ''PredLiteral @@ -177,7 +178,7 @@ instance PathPiece a => PathPiece (PredLiteral a) where newtype PredDNF a = PredDNF { dnfTerms :: Set (NonNull (Set (PredLiteral a))) } deriving (Eq, Ord, Read, Show, Data, Generic, Typeable) - deriving anyclass (Binary, Hashable) + deriving anyclass (Binary, Hashable, NFData) makeLenses_ ''PredDNF @@ -249,7 +250,7 @@ data UserGroupName = UserGroupMetrics | UserGroupCrontab | UserGroupCustom { userGroupCustomName :: CI Text } deriving (Eq, Ord, Read, Show, Generic, Typeable) - deriving anyclass (Hashable) + deriving anyclass (Hashable, NFData) instance PathPiece UserGroupName where toPathPiece UserGroupMetrics = "metrics" diff --git a/src/Model/Types/Sheet.hs b/src/Model/Types/Sheet.hs index 0528cb454..23b1a7f80 100644 --- a/src/Model/Types/Sheet.hs +++ b/src/Model/Types/Sheet.hs @@ -168,7 +168,8 @@ data SheetGroup = Arbitrary { maxParticipants :: Natural } | RegisteredGroups | NoGroups - deriving (Show, Read, Eq, Generic) + deriving (Show, Read, Eq, Generic, Typeable) + deriving anyclass (NFData) deriveJSON defaultOptions ''SheetGroup derivePersistFieldJSON ''SheetGroup @@ -200,7 +201,9 @@ data UploadSpecificFile = UploadSpecificFile , specificFileRequired :: Bool , specificFileEmptyOk :: Bool , specificFileMaxSize :: Maybe Natural - } deriving (Show, Read, Eq, Ord, Generic) + } + deriving (Show, Read, Eq, Ord, Generic, Typeable) + deriving anyclass (NFData) instance ToJSON UploadSpecificFile where toJSON UploadSpecificFile{..} = Aeson.object @@ -229,7 +232,8 @@ data UploadMode = NoUpload | UploadSpecific { uploadSpecificFiles :: NonNull (Set UploadSpecificFile) } - deriving (Show, Read, Eq, Ord, Generic) + deriving (Show, Read, Eq, Ord, Generic, Typeable) + deriving anyclass (NFData) defaultExtensionRestriction :: Maybe (NonNull (Set Extension)) defaultExtensionRestriction = fromNullable $ Set.fromList ["txt", "pdf"] @@ -284,7 +288,8 @@ data SubmissionMode = SubmissionMode { submissionModeCorrector :: Bool , submissionModeUser :: Maybe UploadMode } - deriving (Show, Read, Eq, Ord, Generic) + deriving (Show, Read, Eq, Ord, Generic, Typeable) + deriving anyclass (NFData) deriveJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 2 @@ -319,12 +324,11 @@ data Load -- = ByTutorial { countsToLoad :: Bool } | ByProportion { load :: Rati , byProportion :: Rational -- ^ workload proportion of all submission not assigned to tutorial leaders } deriving (Show, Read, Eq, Ord, Generic) + deriving anyclass (Hashable, NFData) deriveJSON defaultOptions ''Load derivePersistFieldJSON ''Load -instance Hashable Load - instance Semigroup Load where (Load byTut prop) <> (Load byTut' prop') = Load byTut'' (prop + prop') where @@ -346,7 +350,7 @@ instance Monoid Load where data CorrectorState = CorrectorNormal | CorrectorMissing | CorrectorExcused deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic) - deriving anyclass (Universe, Finite, Hashable) + deriving anyclass (Universe, Finite, Hashable, NFData) deriveJSON defaultOptions { constructorTagModifier = fromJust . stripPrefix "Corrector" diff --git a/src/Model/Types/Submission.hs b/src/Model/Types/Submission.hs index 4d52b6939..21fed7e4b 100644 --- a/src/Model/Types/Submission.hs +++ b/src/Model/Types/Submission.hs @@ -56,6 +56,7 @@ newtype Pseudonym = Pseudonym Word24 deriving newtype ( Bounded, Enum, Integral, Num, Real, Ix , PersistField, Random ) + deriving anyclass (NFData) instance PersistFieldSql Pseudonym where sqlType _ = sqlType $ Proxy @Word24 diff --git a/src/Model/Types/User.hs b/src/Model/Types/User.hs index 73745bddb..6e1b966a4 100644 --- a/src/Model/Types/User.hs +++ b/src/Model/Types/User.hs @@ -15,3 +15,4 @@ nullaryPathPiece ''SystemFunction $ camelToPathPiece' 1 pathPieceJSON ''SystemFunction pathPieceJSONKey ''SystemFunction derivePersistFieldPathPiece ''SystemFunction +pathPieceBinary ''SystemFunction diff --git a/src/Model/Types/Workflow.hs b/src/Model/Types/Workflow.hs index 97cee5966..69751dfa7 100644 --- a/src/Model/Types/Workflow.hs +++ b/src/Model/Types/Workflow.hs @@ -78,15 +78,16 @@ newtype WorkflowGraph fileid userid = WorkflowGraph deriving instance (Eq fileid, Eq userid, Typeable fileid, Typeable userid, Eq (FileField fileid)) => Eq (WorkflowGraph fileid userid) deriving instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid, Ord (FileField fileid)) => Ord (WorkflowGraph fileid userid) deriving instance (Show fileid, Show userid, Show (FileField fileid)) => Show (WorkflowGraph fileid userid) +deriving anyclass instance (NFData fileid, NFData userid, NFData (FileField fileid)) => NFData (WorkflowGraph fileid userid) newtype WorkflowGraphReference = WorkflowGraphReference (Digest SHA3_256) deriving (Eq, Ord, Read, Show, Lift, Generic, Typeable) deriving newtype ( PersistField , PathPiece, ToHttpApiData, FromHttpApiData, ToJSON, FromJSON - , Hashable, NFData , ByteArrayAccess , Binary ) + deriving anyclass (Hashable, NFData) instance PersistFieldSql WorkflowGraphReference where sqlType _ = sqlType $ Proxy @(Digest SHA3_256) @@ -96,6 +97,7 @@ instance PersistFieldSql WorkflowGraphReference where newtype WorkflowGraphNodeLabel = WorkflowGraphNodeLabel { unWorkflowGraphNodeLabel :: CI Text } deriving stock (Eq, Ord, Read, Show, Data, Generic, Typeable) deriving newtype (IsString, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PathPiece, PersistField, Binary) + deriving anyclass (NFData) instance PersistFieldSql WorkflowGraphNodeLabel where sqlType _ = sqlType $ Proxy @(CI Text) @@ -112,24 +114,30 @@ data WorkflowGraphNode fileid userid = WGN deriving instance (Eq fileid, Eq userid, Typeable fileid, Typeable userid, Eq (FileField fileid)) => Eq (WorkflowGraphNode fileid userid) deriving instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid, Ord (FileField fileid)) => Ord (WorkflowGraphNode fileid userid) deriving instance (Show fileid, Show userid, Show (FileField fileid)) => Show (WorkflowGraphNode fileid userid) +deriving anyclass instance (NFData fileid, NFData userid, NFData (FileField fileid)) => NFData (WorkflowGraphNode fileid userid) data WorkflowNodeView userid = WorkflowNodeView { wnvViewers :: NonNull (Set (WorkflowRole userid)) , wnvDisplayLabel :: I18nText - } deriving (Eq, Ord, Read, Show, Data, Generic, Typeable) + } + deriving (Eq, Ord, Read, Show, Data, Generic, Typeable) + deriving anyclass (NFData) data WorkflowNodeMessage userid = WorkflowNodeMessage { wnmViewers :: NonNull (Set (WorkflowRole userid)) , wnmRestriction :: Maybe (PredDNF WorkflowGraphRestriction) , wnmStatus :: MessageStatus , wnmContent :: I18nHtml - } deriving (Eq, Ord, Read, Show, Generic, Typeable) + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (NFData) ----- WORKFLOW GRAPH: EDGES ----- newtype WorkflowGraphEdgeLabel = WorkflowGraphEdgeLabel { unWorkflowGraphEdgeLabel :: CI Text } deriving stock (Eq, Ord, Read, Show, Data, Generic, Typeable) deriving newtype (IsString, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PathPiece, PersistField, Binary) + deriving anyclass (NFData) instance PersistFieldSql WorkflowGraphEdgeLabel where sqlType _ = sqlType $ Proxy @(CI Text) @@ -139,6 +147,7 @@ data WorkflowGraphRestriction | WorkflowGraphRestrictionPreviousNode { wgrPreviousNode :: WorkflowGraphNodeLabel } | WorkflowGraphRestrictionInitial deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (NFData) data WorkflowGraphEdge fileid userid = WorkflowGraphEdgeManual @@ -165,13 +174,16 @@ data WorkflowGraphEdge fileid userid deriving instance (Eq fileid, Eq userid, Typeable fileid, Typeable userid, Eq (FileField fileid)) => Eq (WorkflowGraphEdge fileid userid) deriving instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid, Ord (FileField fileid)) => Ord (WorkflowGraphEdge fileid userid) deriving instance (Show fileid, Show userid, Show (FileField fileid)) => Show (WorkflowGraphEdge fileid userid) +deriving anyclass instance (NFData fileid, NFData userid, NFData (FileField fileid)) => NFData (WorkflowGraphEdge fileid userid) data WorkflowEdgeMessage userid = WorkflowEdgeMessage { wemViewers :: NonNull (Set (WorkflowRole userid)) , wemRestriction :: Maybe (PredDNF WorkflowGraphRestriction) , wemStatus :: MessageStatus , wemContent :: I18nHtml - } deriving (Eq, Ord, Read, Show, Generic, Typeable) + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (NFData) -- | A wrapped `Scientific` -- @@ -180,6 +192,7 @@ newtype WorkflowGraphEdgeFormOrder = WorkflowGraphEdgeFormOrder { unWorkflowGrap deriving (Read, Show, Generic, Typeable) deriving (Eq, Ord) via (NTop (Maybe Scientific)) deriving (Semigroup, Monoid) via (Maybe (Min Scientific)) + deriving anyclass (NFData) newtype WorkflowGraphEdgeForm fileid userid = WorkflowGraphEdgeForm @@ -191,11 +204,13 @@ newtype WorkflowGraphEdgeForm fileid userid -- - optional fields are always considered to be filled -- -- since fields can reference other labels this allows arbitrary requirements to be encoded. - } deriving (Generic, Typeable) + } + deriving (Generic, Typeable) deriving instance (Eq fileid, Eq userid, Typeable fileid, Typeable userid, Eq (FileField fileid)) => Eq (WorkflowGraphEdgeForm fileid userid) deriving instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid, Ord (FileField fileid)) => Ord (WorkflowGraphEdgeForm fileid userid) deriving instance (Show fileid, Show userid, Show (FileField fileid)) => Show (WorkflowGraphEdgeForm fileid userid) +deriving anyclass instance (NFData fileid, NFData userid, NFData (FileField fileid)) => NFData (WorkflowGraphEdgeForm fileid userid) ----- WORKFLOW GRAPH: ROLES / ACTORS ----- @@ -205,6 +220,7 @@ data WorkflowRole userid | WorkflowRoleAuthorized { workflowRoleAuthorized :: AuthDNF } | WorkflowRoleInitiator deriving (Eq, Ord, Show, Read, Data, Generic, Typeable) + deriving anyclass (NFData) ----- WORKFLOW GRAPH: PAYLOAD SPECIFICATION ----- @@ -212,16 +228,21 @@ data WorkflowRole userid data WorkflowPayloadView userid = WorkflowPayloadView { wpvViewers :: NonNull (Set (WorkflowRole userid)) , wpvDisplayLabel :: I18nText - } deriving (Eq, Ord, Read, Show, Data, Generic, Typeable) + } + deriving (Eq, Ord, Read, Show, Data, Generic, Typeable) + deriving anyclass (NFData) data WorkflowPayloadSpec fileid userid = forall payload. Typeable payload => WorkflowPayloadSpec (WorkflowPayloadField fileid userid payload) deriving (Typeable) deriving instance (Show fileid, Show userid, Show (FileField fileid)) => Show (WorkflowPayloadSpec fileid userid) +instance (NFData fileid, NFData userid, NFData (FileField fileid)) => NFData (WorkflowPayloadSpec fileid userid) where + rnf (WorkflowPayloadSpec pField) = rnf pField data WorkflowPayloadFieldReference deriving (Typeable) +-- Don't forget to update the NFData instance for every change! data WorkflowPayloadField fileid userid (payload :: Type) where WorkflowPayloadFieldText :: { wpftLabel :: I18nText , wpftPlaceholder :: Maybe I18nText @@ -324,6 +345,18 @@ instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid, Ord (FileFie (WorkflowPayloadFieldReference{}, _) -> LT (WorkflowPayloadFieldMultiple{}, _) -> GT +instance (NFData fileid, NFData userid, NFData (FileField fileid)) => NFData (WorkflowPayloadField fileid userid payload) where + rnf = \case + WorkflowPayloadFieldText{..} -> wpftLabel `deepseq` wpftPlaceholder `deepseq` wpftTooltip `deepseq` wpftDefault `deepseq` wpftLarge `deepseq` wpftOptional `deepseq` () + WorkflowPayloadFieldNumber{..} -> wpfnLabel `deepseq` wpfnPlaceholder `deepseq` wpfnTooltip `deepseq` wpfnDefault `deepseq` wpfnMin `deepseq` wpfnMax `deepseq` wpfnStep `deepseq` wpfnOptional `deepseq` () + WorkflowPayloadFieldBool{..} -> wpfbLabel `deepseq` wpfbTooltip `deepseq` wpfbDefault `deepseq` wpfbOptional `deepseq` () + WorkflowPayloadFieldDay{..} -> wpfdLabel `deepseq` wpfdTooltip `deepseq` wpfdDefault `deepseq` wpfdOptional `deepseq` () + WorkflowPayloadFieldFile{..} -> wpffLabel `deepseq` wpffTooltip `deepseq` wpffConfig `deepseq` wpffOptional `deepseq` () + WorkflowPayloadFieldUser{..} -> wpfuLabel `deepseq` wpfuTooltip `deepseq` wpfuDefault `deepseq` wpfuOptional `deepseq` () + WorkflowPayloadFieldCaptureUser -> () + WorkflowPayloadFieldReference{..} -> wpfrTarget `deepseq` () + WorkflowPayloadFieldMultiple{..} -> wpfmLabel `deepseq` wpfmTooltip `deepseq` wpfmDefault `deepseq` wpfmSub `deepseq` wpfmMin `deepseq` wpfmRange `deepseq` () + _WorkflowPayloadSpec :: forall payload fileid userid. ( Typeable payload, Typeable fileid, Typeable userid ) => Prism' (WorkflowPayloadSpec fileid userid) (WorkflowPayloadField fileid userid payload) @@ -331,7 +364,7 @@ _WorkflowPayloadSpec = prism' WorkflowPayloadSpec $ \(WorkflowPayloadSpec pF) -> data WorkflowPayloadField' = WPFText' | WPFNumber' | WPFBool' | WPFDay' | WPFFile' | WPFUser' | WPFCaptureUser' | WPFReference' | WPFMultiple' deriving (Eq, Ord, Enum, Bounded, Show, Read, Data, Generic, Typeable) - deriving anyclass (Universe, Finite) + deriving anyclass (Universe, Finite, NFData) ----- WORKFLOW INSTANCE ----- @@ -343,11 +376,12 @@ data WorkflowScope termid schoolid courseid | WSTermSchool { wisTerm :: termid, wisSchool :: schoolid } | WSCourse { wisCourse :: courseid } deriving (Eq, Ord, Show, Read, Data, Generic, Typeable) + deriving anyclass (Hashable, NFData) data WorkflowScope' = WSGlobal' | WSTerm' | WSSchool' | WSTermSchool' | WSCourse' deriving (Eq, Ord, Enum, Bounded, Read, Show, Data, Generic, Typeable) - deriving anyclass (Universe, Finite) + deriving anyclass (Universe, Finite, NFData) classifyWorkflowScope :: WorkflowScope termid schoolid courseid -> WorkflowScope' classifyWorkflowScope = \case @@ -362,6 +396,7 @@ classifyWorkflowScope = \case newtype WorkflowPayloadLabel = WorkflowPayloadLabel { unWorkflowPayloadLabel :: CI Text } deriving stock (Eq, Ord, Show, Read, Data, Generic, Typeable) deriving newtype (IsString, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PathPiece, PersistField, Binary) + deriving anyclass (NFData) instance PersistFieldSql WorkflowPayloadLabel where sqlType _ = sqlType $ Proxy @(CI Text) @@ -369,6 +404,7 @@ instance PersistFieldSql WorkflowPayloadLabel where newtype WorkflowStateIndex = WorkflowStateIndex { unWorkflowStateIndex :: Word64 } deriving stock (Eq, Ord, Show, Read, Data, Generic, Typeable) deriving newtype (Num, Real, Integral, Enum, Bounded, ToJSON, FromJSON, PathPiece, Binary) + deriving anyclass (NFData) type WorkflowState fileid userid = NonNull (Seq (WorkflowAction fileid userid)) @@ -392,13 +428,16 @@ data WorkflowAction fileid userid = WorkflowAction , wpTime :: UTCTime } deriving (Eq, Ord, Show, Generic, Typeable) + deriving anyclass (NFData) data WorkflowActionInfo fileid userid = WorkflowActionInfo { waiIx :: WorkflowStateIndex , waiFrom :: Maybe WorkflowGraphNodeLabel , waiHistory :: [WorkflowAction fileid userid] , waiAction :: WorkflowAction fileid userid - } deriving (Eq, Ord, Show, Generic, Typeable) + } + deriving (Eq, Ord, Show, Generic, Typeable) + deriving anyclass (NFData) workflowActionInfos :: WorkflowState fileid userid -> [WorkflowActionInfo fileid userid] workflowActionInfos wState @@ -413,6 +452,9 @@ workflowActionInfos wState data WorkflowFieldPayloadW fileid userid = forall payload. IsWorkflowFieldPayload' fileid userid payload => WorkflowFieldPayloadW (WorkflowFieldPayload fileid userid payload) deriving (Typeable) +instance (NFData fileid, NFData userid) => NFData (WorkflowFieldPayloadW fileid userid) where + rnf (WorkflowFieldPayloadW fPayload) = rnf fPayload + instance (Eq fileid, Eq userid, Typeable fileid, Typeable userid) => Eq (WorkflowFieldPayloadW fileid userid) where (WorkflowFieldPayloadW a) == (WorkflowFieldPayloadW b) = case typeOf a `eqTypeRep` typeOf b of @@ -473,6 +515,7 @@ workflowPayloadSort ordFiles ordUsers (WorkflowFieldPayloadW a) (WorkflowFieldPa instance (Show fileid, Show userid) => Show (WorkflowFieldPayloadW fileid userid) where show (WorkflowFieldPayloadW payload) = show payload +-- Don't forget to update the NFData instance for every change! data WorkflowFieldPayload fileid userid (payload :: Type) where WFPText :: Text -> WorkflowFieldPayload fileid userid Text WFPNumber :: Scientific -> WorkflowFieldPayload fileid userid Scientific @@ -486,6 +529,15 @@ deriving instance (Show fileid, Show userid) => Show (WorkflowFieldPayload filei deriving instance (Typeable fileid, Typeable userid, Eq fileid, Eq userid) => Eq (WorkflowFieldPayload fileid userid payload) deriving instance (Typeable fileid, Typeable userid, Ord fileid, Ord userid) => Ord (WorkflowFieldPayload fileid userid payload) +instance (NFData fileid, NFData userid) => NFData (WorkflowFieldPayload fileid userid payload) where + rnf = \case + WFPText t -> rnf t + WFPNumber n -> rnf n + WFPBool b -> rnf b + WFPDay d -> rnf d + WFPFile f -> rnf f + WFPUser u -> rnf u + _WorkflowFieldPayloadW :: forall payload fileid userid. ( IsWorkflowFieldPayload' fileid userid payload, Typeable fileid, Typeable userid ) => Prism' (WorkflowFieldPayloadW fileid userid) (WorkflowFieldPayload fileid userid payload) @@ -493,7 +545,7 @@ _WorkflowFieldPayloadW = prism' WorkflowFieldPayloadW $ \(WorkflowFieldPayloadW data WorkflowFieldPayload' = WFPText' | WFPNumber' | WFPBool' | WFPDay' | WFPFile' | WFPUser' deriving (Eq, Ord, Enum, Bounded, Show, Read, Data, Generic, Typeable) - deriving anyclass (Universe, Finite) + deriving anyclass (Universe, Finite, NFData) type IsWorkflowFieldPayload' fileid userid payload = IsWorkflowFieldPayload fileid fileid userid userid payload payload diff --git a/src/Network/HTTP/Types/Method/Instances.hs b/src/Network/HTTP/Types/Method/Instances.hs index b71b009ea..bf3931a69 100644 --- a/src/Network/HTTP/Types/Method/Instances.hs +++ b/src/Network/HTTP/Types/Method/Instances.hs @@ -14,8 +14,9 @@ import Utils.PathPiece (pathPieceJSON, pathPieceJSONKey) import Web.PathPieces -deriving instance Generic StdMethod -instance Binary StdMethod +deriving stock instance Generic StdMethod +deriving anyclass instance Binary StdMethod +deriving anyclass instance Hashable StdMethod instance PathPiece Method where toPathPiece = decodeUtf8 diff --git a/src/Network/Mail/Mime/Instances.hs b/src/Network/Mail/Mime/Instances.hs index 841ab9f24..3f36d553a 100644 --- a/src/Network/Mail/Mime/Instances.hs +++ b/src/Network/Mail/Mime/Instances.hs @@ -31,9 +31,7 @@ import Control.Lens deriving instance Read Address deriving instance Ord Address deriving instance Generic Address - -instance Hashable Address -instance NFData Address +deriving anyclass instance Hashable Address deriveToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 @@ -58,6 +56,7 @@ instance Csv.DefaultOrdered Address where newtype MailHeaders = MailHeaders Headers deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (NFData) instance ToJSON MailHeaders where toJSON (MailHeaders hs) = toJSON $ over (traverse . _1) decodeUtf8 hs @@ -76,6 +75,13 @@ instance Binary PartContent instance Binary Part instance Binary Address instance Binary Mail + +deriving anyclass instance NFData Encoding +deriving anyclass instance NFData Disposition +deriving anyclass instance NFData PartContent +deriving anyclass instance NFData Part +deriving anyclass instance NFData Address +deriving anyclass instance NFData Mail deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece diff --git a/src/Settings.hs b/src/Settings.hs index 9006adba0..deac6d484 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -186,6 +186,8 @@ data AppSettings = AppSettings , appCookieSettings :: RegisteredCookie -> CookieSettings , appMemcachedConf :: Maybe MemcachedConf + , appMemcacheAuth :: Bool + , appMemcachedLocalConf :: Maybe (ARCConf Int) , appUploadCacheConf :: Maybe Minio.ConnectInfo , appUploadCacheBucket, appUploadTmpBucket :: Minio.Bucket @@ -215,8 +217,6 @@ data AppSettings = AppSettings , appStudyFeaturesRecacheRelevanceWithin :: Maybe NominalDiffTime , appStudyFeaturesRecacheRelevanceInterval :: NominalDiffTime - , appMemcacheAuth :: Bool - , appFileSourceARCConf :: Maybe (ARCConf Int) , appFileSourcePrewarmConf :: Maybe PrewarmCacheConf @@ -533,12 +533,15 @@ instance FromJSON AppSettings where ] appWidgetMemcachedConf <- assertM validWidgetMemcachedConf <$> o .:? "widget-memcached" appSessionMemcachedConf <- assertM validMemcachedConf <$> o .:? "session-memcached" - appMemcachedConf <- assertM validMemcachedConf <$> o .:? "memcached" appRoot <- o .:? "approot" .!= const Nothing appHost <- fromString <$> o .: "host" appPort <- o .: "port" appIpFromHeader <- o .: "ip-from-header" + appMemcachedConf <- assertM validMemcachedConf <$> o .:? "memcached" + appMemcacheAuth <- o .:? "memcache-auth" .!= False + appMemcachedLocalConf <- assertM isValidARCConf <$> o .:? "memcached-local" + appMailFrom <- o .: "mail-from" appMailEnvelopeFrom <- o .:? "mail-envelope-from" .!= addressEmail appMailFrom appMailSender <- o .:? "mail-sender" .!= appMailFrom @@ -654,14 +657,11 @@ instance FromJSON AppSettings where appDownloadTokenExpire <- o .: "download-token-expire" - appMemcacheAuth <- o .:? "memcache-auth" .!= False - appJobMode <- o .:? "job-mode" .!= JobsLocal True appStudyFeaturesRecacheRelevanceWithin <- o .:? "study-features-recache-relevance-within" appStudyFeaturesRecacheRelevanceInterval <- o .: "study-features-recache-relevance-interval" - let isValidARCConf ARCConf{..} = arccMaximumWeight > 0 appFileSourceARCConf <- assertM isValidARCConf <$> o .:? "file-source-arc" let isValidPrewarmConf PrewarmCacheConf{..} = and @@ -676,6 +676,7 @@ instance FromJSON AppSettings where appBotMitigations <- o .:? "bot-mitigations" .!= Set.empty return AppSettings{..} + where isValidARCConf ARCConf{..} = arccMaximumWeight > 0 makeClassy_ ''AppSettings diff --git a/src/Settings/Cluster.hs b/src/Settings/Cluster.hs index c13ef8c28..faa409b08 100644 --- a/src/Settings/Cluster.hs +++ b/src/Settings/Cluster.hs @@ -7,7 +7,6 @@ module Settings.Cluster ) where import ClassyPrelude.Yesod -import Web.HttpApiData import Data.Kind (Type) @@ -51,21 +50,15 @@ data ClusterSettingsKey | ClusterMemcachedKey | ClusterVerpSecret | ClusterAuthKey - deriving (Eq, Ord, Enum, Bounded, Show, Read) - -instance Universe ClusterSettingsKey -instance Finite ClusterSettingsKey + deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, Typeable) + deriving anyclass (Universe, Finite, NFData) nullaryPathPiece ''ClusterSettingsKey $ camelToPathPiece' 1 pathPieceJSON ''ClusterSettingsKey pathPieceJSONKey ''ClusterSettingsKey +pathPieceHttpApiData ''ClusterSettingsKey derivePersistFieldPathPiece ''ClusterSettingsKey -instance ToHttpApiData ClusterSettingsKey where - toUrlPiece = toPathPiece -instance FromHttpApiData ClusterSettingsKey where - parseUrlPiece = maybe (Left "Could not parse url piece") Right . fromPathPiece - class (ToJSON (ClusterSettingValue key), FromJSON (ClusterSettingValue key)) => ClusterSetting (key :: ClusterSettingsKey) where type ClusterSettingValue key :: Type diff --git a/src/Utils.hs b/src/Utils.hs index b76a9b669..ed364adc1 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -8,7 +8,7 @@ import ClassyPrelude.Yesod hiding (foldlM, Proxy, handle, catch, bracket) -- import Data.Double.Conversion.Text -- faster implementation for textPercent? import qualified Data.Foldable as Fold import Data.Foldable as Utils (foldlM, foldrM) -import Data.Monoid (First, Sum(..)) +import Data.Monoid (First, Sum(..), Endo) import Data.Proxy import Control.Arrow (Kleisli(..)) import Control.Arrow.Instances () @@ -217,6 +217,9 @@ instance ToTypedContent YamlValue where instance HasContentType YamlValue where getContentType _ = "text/vnd.yaml" +instance ToMarkup YamlValue where + toMarkup = toMarkup . decodeUtf8 . Yaml.encode + toYAML :: ToJSON a => a -> YamlValue toYAML = YamlValue . toJSON @@ -700,6 +703,9 @@ hoistMaybe = maybe mzero return hoistMaybeM :: MonadPlus m => m (Maybe a) -> m a hoistMaybeM = (=<<) hoistMaybe +maybeVoid :: Monad m => Maybe (m a) -> m () +maybeVoid = maybe (return ()) void + catchIfMaybeT :: (MonadCatch m, Exception e) => (e -> Bool) -> m a -> MaybeT m a catchIfMaybeT p act = catchIf p (lift act) (const mzero) @@ -774,6 +780,8 @@ whenIsRight :: Monad m => Either a b -> (b -> m ()) -> m () whenIsRight (Right x) f = f x whenIsRight (Left _) _ = return () +throwLeft :: (MonadThrow m, Exception exc) => Either exc a -> m a +throwLeft = either throwM return --------------- -- Exception -- @@ -889,6 +897,10 @@ allM, anyM :: (MonoFoldable mono, Monad m) => mono -> (Element mono -> m Bool) - allM xs f = andM . fmap f $ otoList xs anyM xs f = orM . fmap f $ otoList xs +allMOf, anyMOf :: Monad m => Getting (Endo [a]) s a -> s -> (a -> m Bool) -> m Bool +allMOf l x = allM $ x ^.. l +anyMOf l x = anyM $ x ^.. l + ofoldr1M, ofoldl1M :: (MonoFoldable mono, Monad m) => (Element mono -> Element mono -> m (Element mono)) -> NonNull mono -> m (Element mono) ofoldr1M f (otoList -> x:xs) = foldrM f x xs ofoldr1M _ _ = error "otoList of NonNull is empty" @@ -957,6 +969,12 @@ foreverBreak :: Monad m foreverBreak cont = evalContT . callCC $ forever . cont +sortOnM :: (Ord b, Monad m) + => (a -> m b) + -> [a] + -> m [a] +sortOnM f = fmap (map snd . sortBy (comparing fst)) . mapM (\x -> (\y -> y `seq` (y, x)) <$> f x) + -------------- -- Foldable -- -------------- @@ -987,7 +1005,7 @@ maxLength l = not . minLength (succ l) tellM :: (MonadTrans t, MonadWriter x (t m), Monad m) => m x -> t m () tellM = tell <=< lift -tellPoint :: (MonadWriter mono m, MonoPointed mono) => Element mono -> m () +tellPoint :: forall mono m. (MonadWriter mono m, MonoPointed mono) => Element mono -> m () tellPoint = tell . opoint tellMPoint :: (MonadTrans t, MonadWriter mono (t m), Monad m, MonoPointed mono) => m (Element mono) -> t m () diff --git a/src/Utils/ARC.hs b/src/Utils/ARC.hs index 0f1b94ee5..1545ebf08 100644 --- a/src/Utils/ARC.hs +++ b/src/Utils/ARC.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE BangPatterns #-} + module Utils.ARC ( ARCTick , ARC, initARC @@ -8,19 +10,44 @@ module Utils.ARC , arcRecentSize, arcFrequentSize, arcGhostRecentSize, arcGhostFrequentSize , getARCRecentWeight, getARCFrequentWeight , describeARC + , NFDynamic(..), _NFDynamic, DynARC, DynARCHandle ) where import ClassyPrelude -import Data.OrdPSQ (OrdPSQ) -import qualified Data.OrdPSQ as OrdPSQ +import Data.HashPSQ (HashPSQ) +import qualified Data.HashPSQ as HashPSQ import Control.Lens +import Type.Reflection +import Text.Show (showString, shows) + +import Data.Hashable (Hashed, hashed) + -- https://web.archive.org/web/20210115184012/https://dbs.uni-leipzig.de/file/ARC.pdf -- https://jaspervdj.be/posts/2015-02-24-lru-cache.html +data NFDynamic where + NFDynamic :: forall a. NFData a => TypeRep a -> a -> NFDynamic + +_NFDynamic :: forall a. (Typeable a, NFData a) => Prism' NFDynamic a +_NFDynamic = prism' toNFDyn fromNFDynamic + where + toNFDyn v = NFDynamic typeRep v + fromNFDynamic (NFDynamic t v) + | Just HRefl <- t `eqTypeRep` rep = Just v + | otherwise = Nothing + where rep = typeRep :: TypeRep a + +instance NFData NFDynamic where + rnf (NFDynamic t v) = rnfTypeRep t `seq` rnf v + +instance Show NFDynamic where + showsPrec _ (NFDynamic t _) = showString "<<" . shows t . showString ">>" + + newtype ARCTick = ARCTick { _getARCTick :: Word64 } deriving (Eq, Ord, Show, Typeable) deriving newtype (NFData) @@ -28,13 +55,15 @@ newtype ARCTick = ARCTick { _getARCTick :: Word64 } makeLenses ''ARCTick data ARC k w v = ARC - { arcRecent, arcFrequent :: !(OrdPSQ k ARCTick (v, w)) - , arcGhostRecent, arcGhostFrequent :: !(OrdPSQ k ARCTick ()) + { arcRecent, arcFrequent :: !(HashPSQ (Hashed k) ARCTick (v, w)) + , arcGhostRecent, arcGhostFrequent :: !(HashPSQ (Hashed k) ARCTick ()) , arcRecentWeight, arcFrequentWeight :: !w , arcTargetRecent, arcMaximumWeight :: !w , arcMaximumGhost :: !Int } +type DynARC k w = ARC (SomeTypeRep, k) w NFDynamic + instance (NFData k, NFData w, NFData v) => NFData (ARC k w v) where rnf ARC{..} = rnf arcRecent `seq` rnf arcFrequent @@ -50,10 +79,10 @@ describeARC :: Show w => ARC k w v -> String describeARC ARC{..} = intercalate ", " - [ "arcRecent: " <> show (OrdPSQ.size arcRecent) - , "arcFrequent: " <> show (OrdPSQ.size arcFrequent) - , "arcGhostRecent: " <> show (OrdPSQ.size arcGhostRecent) - , "arcGhostFrequent: " <> show (OrdPSQ.size arcGhostFrequent) + [ "arcRecent: " <> show (HashPSQ.size arcRecent) + , "arcFrequent: " <> show (HashPSQ.size arcFrequent) + , "arcGhostRecent: " <> show (HashPSQ.size arcGhostRecent) + , "arcGhostFrequent: " <> show (HashPSQ.size arcGhostFrequent) , "arcRecentWeight: " <> show arcRecentWeight , "arcFrequentWeight: " <> show arcFrequentWeight , "arcTargetRecent: " <> show arcTargetRecent @@ -62,10 +91,10 @@ describeARC ARC{..} = intercalate ", " ] arcRecentSize, arcFrequentSize, arcGhostRecentSize, arcGhostFrequentSize :: ARC k w v -> Int -arcRecentSize = OrdPSQ.size . arcRecent -arcFrequentSize = OrdPSQ.size . arcFrequent -arcGhostRecentSize = OrdPSQ.size . arcGhostRecent -arcGhostFrequentSize = OrdPSQ.size . arcGhostFrequent +arcRecentSize = HashPSQ.size . arcRecent +arcFrequentSize = HashPSQ.size . arcFrequent +arcGhostRecentSize = HashPSQ.size . arcGhostRecent +arcGhostFrequentSize = HashPSQ.size . arcGhostFrequent getARCRecentWeight, getARCFrequentWeight :: ARC k w v -> w getARCRecentWeight = arcRecentWeight @@ -83,10 +112,10 @@ initARC arcMaximumGhost arcMaximumWeight | arcMaximumWeight < 0 = error "initARC given negative maximum weight" | arcMaximumGhost < 0 = error "initARC given negative maximum ghost size" | otherwise = (, initialARCTick) ARC - { arcRecent = OrdPSQ.empty - , arcFrequent = OrdPSQ.empty - , arcGhostRecent = OrdPSQ.empty - , arcGhostFrequent = OrdPSQ.empty + { arcRecent = HashPSQ.empty + , arcFrequent = HashPSQ.empty + , arcGhostRecent = HashPSQ.empty + , arcGhostFrequent = HashPSQ.empty , arcRecentWeight = 0 , arcFrequentWeight = 0 , arcMaximumWeight @@ -103,66 +132,67 @@ infixl 6 |- arcAlterF :: forall f k w v. - ( Ord k + ( Ord k, Hashable k , Functor f , Integral w + , NFData k, NFData w, NFData v ) => k -> (Maybe (v, w) -> f (Maybe (v, w))) -> ARC k w v -> ARCTick -> f (ARC k w v, ARCTick) -- | Unchecked precondition: item weights are always less than `arcMaximumWeight` -arcAlterF k f oldARC@ARC{..} now - | later <= initialARCTick = uncurry (arcAlterF k f) $ initARC arcMaximumGhost arcMaximumWeight +arcAlterF !(force -> unhashedK@(hashed -> k)) f oldARC@ARC{..} now + | later <= initialARCTick = uncurry (arcAlterF unhashedK f) $ initARC arcMaximumGhost arcMaximumWeight | otherwise = (, later) <$> if - | Just (_p, x@(_, w), arcFrequent') <- OrdPSQ.deleteView k arcFrequent - -> f (Just x) <&> \(fromMaybe x -> x'@(_, w')) + | Just (_p, x@(_, w), arcFrequent') <- HashPSQ.deleteView k arcFrequent + -> f (Just x) <&> \(fromMaybe x -> !(force -> x'@(_, w'))) -> let (arcFrequent'', arcFrequentWeight'', arcGhostFrequent') = evictToSize (arcMaximumWeight |- arcTargetRecent |- w') arcFrequent' (arcFrequentWeight - w) arcGhostFrequent in oldARC - { arcFrequent = OrdPSQ.insert k now x' arcFrequent'' + { arcFrequent = HashPSQ.insert k now x' arcFrequent'' , arcFrequentWeight = arcFrequentWeight'' + w' , arcGhostFrequent = arcGhostFrequent' } - | Just (_p, x@(_, w), arcRecent') <- OrdPSQ.deleteView k arcRecent - -> f (Just x) <&> \(fromMaybe x -> x'@(_, w')) + | Just (_p, x@(_, w), arcRecent') <- HashPSQ.deleteView k arcRecent + -> f (Just x) <&> \(fromMaybe x -> !(force -> x'@(_, w'))) -> let (arcFrequent', arcFrequentWeight', arcGhostFrequent') = evictToSize (arcMaximumWeight |- arcTargetRecent |- w') arcFrequent arcFrequentWeight arcGhostFrequent in oldARC { arcRecent = arcRecent' , arcRecentWeight = arcRecentWeight - w - , arcFrequent = OrdPSQ.insert k now x' arcFrequent' + , arcFrequent = HashPSQ.insert k now x' arcFrequent' , arcFrequentWeight = arcFrequentWeight' + w' , arcGhostFrequent = arcGhostFrequent' } - | Just (_p, (), arcGhostRecent') <- OrdPSQ.deleteView k arcGhostRecent + | Just (_p, (), arcGhostRecent') <- HashPSQ.deleteView k arcGhostRecent -> f Nothing <&> \case Nothing -> oldARC - { arcGhostRecent = OrdPSQ.insert k now () arcGhostRecent' + { arcGhostRecent = HashPSQ.insert k now () arcGhostRecent' } - Just x@(_, w) - -> let arcTargetRecent' = min arcMaximumWeight $ arcTargetRecent + max avgWeight (round $ toRational (OrdPSQ.size arcGhostFrequent) / toRational (OrdPSQ.size arcGhostRecent) * toRational avgWeight) + Just !(force -> x@(_, w)) + -> let arcTargetRecent' = min arcMaximumWeight $ arcTargetRecent + max avgWeight (round $ toRational (HashPSQ.size arcGhostFrequent) / toRational (HashPSQ.size arcGhostRecent) * toRational avgWeight) (arcFrequent', arcFrequentWeight', arcGhostFrequent') = evictToSize (arcMaximumWeight |- arcTargetRecent' |- w) arcFrequent arcFrequentWeight arcGhostFrequent (arcRecent', arcRecentWeight', arcGhostRecent'') = evictToSize (max arcTargetRecent' $ arcMaximumWeight |- arcFrequentWeight' |- w) arcRecent arcRecentWeight arcGhostRecent' in oldARC { arcRecent = arcRecent' - , arcFrequent = OrdPSQ.insert k now x arcFrequent' + , arcFrequent = HashPSQ.insert k now x arcFrequent' , arcGhostRecent = arcGhostRecent'' , arcGhostFrequent = arcGhostFrequent' , arcRecentWeight = arcRecentWeight' , arcFrequentWeight = arcFrequentWeight' + w , arcTargetRecent = arcTargetRecent' } - | Just (_p, (), arcGhostFrequent') <- OrdPSQ.deleteView k arcGhostFrequent + | Just (_p, (), arcGhostFrequent') <- HashPSQ.deleteView k arcGhostFrequent -> f Nothing <&> \case Nothing -> oldARC - { arcGhostFrequent = OrdPSQ.insert k now () arcGhostFrequent' + { arcGhostFrequent = HashPSQ.insert k now () arcGhostFrequent' } - Just x@(_, w) - -> let arcTargetRecent' = arcTargetRecent |- max avgWeight (round $ toRational (OrdPSQ.size arcGhostRecent) / toRational (OrdPSQ.size arcGhostFrequent) * toRational avgWeight) + Just !(force -> x@(_, w)) + -> let arcTargetRecent' = arcTargetRecent |- max avgWeight (round $ toRational (HashPSQ.size arcGhostRecent) / toRational (HashPSQ.size arcGhostFrequent) * toRational avgWeight) (arcFrequent', arcFrequentWeight', arcGhostFrequent'') = evictToSize (arcMaximumWeight |- arcTargetRecent' |- w) arcFrequent arcFrequentWeight arcGhostFrequent' (arcRecent', arcRecentWeight', arcGhostRecent') = evictToSize (max arcTargetRecent' $ arcMaximumWeight |- arcFrequentWeight' |- w) arcRecent arcRecentWeight arcGhostRecent in oldARC { arcRecent = arcRecent' - , arcFrequent = OrdPSQ.insert k now x arcFrequent' + , arcFrequent = HashPSQ.insert k now x arcFrequent' , arcGhostRecent = arcGhostRecent' , arcGhostFrequent = arcGhostFrequent'' , arcRecentWeight = arcRecentWeight' @@ -171,36 +201,37 @@ arcAlterF k f oldARC@ARC{..} now } | otherwise -> f Nothing <&> \case Nothing -> oldARC - { arcGhostRecent = OrdPSQ.insert k now () $ evictGhostToCount arcGhostRecent + { arcGhostRecent = HashPSQ.insert k now () $ evictGhostToCount arcGhostRecent } - Just x@(_, w) + Just !(force -> x@(_, w)) -> let (arcRecent', arcRecentWeight', arcGhostRecent') = evictToSize (max arcTargetRecent (arcMaximumWeight |- arcFrequentWeight) |- w) arcRecent arcRecentWeight arcGhostRecent in oldARC - { arcRecent = OrdPSQ.insert k now x arcRecent' + { arcRecent = HashPSQ.insert k now x arcRecent' , arcRecentWeight = arcRecentWeight' + w , arcGhostRecent = arcGhostRecent' } where - avgWeight = round $ toRational (arcRecentWeight + arcFrequentWeight) / toRational (OrdPSQ.size arcFrequent + OrdPSQ.size arcRecent) + avgWeight = round $ toRational (arcRecentWeight + arcFrequentWeight) / toRational (HashPSQ.size arcFrequent + HashPSQ.size arcRecent) later :: ARCTick later = over getARCTick succ now - evictToSize :: w -> OrdPSQ k ARCTick (v, w) -> w -> OrdPSQ k ARCTick () -> (OrdPSQ k ARCTick (v, w), w, OrdPSQ k ARCTick ()) + evictToSize :: w -> HashPSQ (Hashed k) ARCTick (v, w) -> w -> HashPSQ (Hashed k) ARCTick () -> (HashPSQ (Hashed k) ARCTick (v, w), w, HashPSQ (Hashed k) ARCTick ()) evictToSize tSize c cSize ghostC | cSize <= tSize = (c, cSize, ghostC) - | Just (k', p', (_, w'), c') <- OrdPSQ.minView c = evictToSize tSize c' (cSize - w') . evictGhostToCount $ OrdPSQ.insert k' p' () ghostC + | Just (k', p', (_, w'), c') <- HashPSQ.minView c = evictToSize tSize c' (cSize - w') . evictGhostToCount $ HashPSQ.insert k' p' () ghostC | otherwise = error "evictToSize: cannot reach required size through eviction" - evictGhostToCount :: OrdPSQ k ARCTick () -> OrdPSQ k ARCTick () + evictGhostToCount :: HashPSQ (Hashed k) ARCTick () -> HashPSQ (Hashed k) ARCTick () evictGhostToCount c - | OrdPSQ.size c <= arcMaximumGhost = c - | Just (_, _, _, c') <- OrdPSQ.minView c = evictGhostToCount c' + | HashPSQ.size c <= arcMaximumGhost = c + | Just (_, _, _, c') <- HashPSQ.minView c = evictGhostToCount c' | otherwise = error "evictGhostToCount: cannot reach required count through eviction" lookupARC :: forall k w v. - ( Ord k + ( Ord k, Hashable k , Integral w + , NFData k, NFData w, NFData v ) => k -> (ARC k w v, ARCTick) @@ -208,8 +239,9 @@ lookupARC :: forall k w v. lookupARC k = getConst . uncurry (arcAlterF k Const) insertARC :: forall k w v. - ( Ord k + ( Ord k, Hashable k , Integral w + , NFData k, NFData w, NFData v ) => k -> Maybe (v, w) @@ -221,6 +253,8 @@ insertARC k newVal = (runIdentity .) . arcAlterF k (const $ pure newVal) newtype ARCHandle k w v = ARCHandle { _getARCHandle :: IORef (ARC k w v, ARCTick) } deriving (Eq, Typeable) +type DynARCHandle k w = ARCHandle (SomeTypeRep, k) w NFDynamic + initARCHandle :: forall k w v m. ( MonadIO m , Integral w @@ -232,7 +266,7 @@ initARCHandle maxGhost maxWeight = fmap ARCHandle . newIORef $ initARC maxGhost cachedARC' :: forall k w v m. ( MonadIO m - , Ord k + , Ord k, Hashable k , Integral w , NFData k, NFData w, NFData v ) @@ -243,7 +277,7 @@ cachedARC' :: forall k w v m. cachedARC' (ARCHandle arcVar) k f = do oldVal <- lookupARC k <$> readIORef arcVar newVal <- f oldVal - modifyIORef' arcVar $ force . uncurry (insertARC k newVal) + modifyIORef' arcVar $ uncurry (insertARC k newVal) -- Using `modifyIORef'` instead of `atomicModifyIORef'` might very -- well drop newer values computed during the update. -- @@ -261,7 +295,7 @@ cachedARC' (ARCHandle arcVar) k f = do cachedARC :: forall k w v m. ( MonadIO m - , Ord k + , Ord k, Hashable k , Integral w , NFData k, NFData w, NFData v ) @@ -273,8 +307,9 @@ cachedARC h k f = fromMaybe (error "cachedARC: cachedARC' returned Nothing") <$> lookupARCHandle :: forall k w v m. ( MonadIO m - , Ord k + , Ord k, Hashable k , Integral w + , NFData k, NFData w, NFData v ) => ARCHandle k w v -> k diff --git a/src/Utils/Csv.hs b/src/Utils/Csv.hs index c2fc930fa..7070720b1 100644 --- a/src/Utils/Csv.hs +++ b/src/Utils/Csv.hs @@ -2,11 +2,14 @@ module Utils.Csv ( typeCsv, typeCsv', extensionCsv + , typeXlsx, extensionXlsx , pathPieceCsv , (.:??) + , lsfHeaderTranslate , CsvRendered(..) , toCsvRendered , toDefaultOrderedCsvRendered + , csvRenderedToXlsx, Xlsx, Xlsx.fromXlsx ) where import ClassyPrelude hiding (lookup) @@ -14,7 +17,6 @@ import Settings.Mime import Data.Csv hiding (Name) import Data.Csv.Conduit (CsvParseError) -import qualified Data.Csv.Incremental as Incremental import Language.Haskell.TH (Name) import Language.Haskell.TH.Lib @@ -22,6 +24,20 @@ import Language.Haskell.TH.Lib import Yesod.Core.Content import qualified Data.Map as Map +import qualified Data.HashMap.Strict as HashMap + +import Codec.Xlsx (Xlsx) +import qualified Codec.Xlsx as Xlsx + +import Data.Monoid (Endo(..)) + +import Control.Lens + +import Data.Default + +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified Data.CaseInsensitive as CI deriving instance Typeable CsvParseError @@ -30,10 +46,14 @@ instance Exception CsvParseError typeCsv, typeCsv' :: ContentType typeCsv = simpleContentType typeCsv' -typeCsv' = "text/csv; charset=UTF-8; header=present" +typeCsv' = "text/csv; header=present" -extensionCsv :: Extension +typeXlsx :: ContentType +typeXlsx = "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet" + +extensionCsv, extensionXlsx :: Extension extensionCsv = fromMaybe "csv" $ listToMaybe [ ext | (ext, mime) <- Map.toList mimeMap, mime == typeCsv ] +extensionXlsx = fromMaybe "xlsx" $ listToMaybe [ ext | (ext, mime) <- Map.toList mimeMap, mime == typeXlsx ] pathPieceCsv :: Name -> DecsQ @@ -50,22 +70,23 @@ pathPieceCsv (conT -> t) = m .:?? name = lookup m name <|> return Nothing +lsfHeaderTranslate :: NamedRecord -> NamedRecord +lsfHeaderTranslate = HashMap.fromList . over (traverse . _1) lsfHeaderTranslate' . HashMap.toList + where + lsfHeaderTranslate' k = case CI.mk . Text.strip <$> Text.decodeUtf8' k of + Right k' + | k' == "mtknr" -> "matriculation" + | k' == "nachname" -> "surname" + | k' == "vorname" -> "first-name" + | k' == "bewertung" -> "exam-result" + _other -> k + + data CsvRendered = CsvRendered { csvRenderedHeader :: Header , csvRenderedData :: [NamedRecord] } deriving (Eq, Read, Show, Generic, Typeable) -instance ToContent CsvRendered where - toContent CsvRendered{..} = toContent . Incremental.encodeByName csvRenderedHeader $ foldr ((<>) . Incremental.encodeNamedRecord) mempty csvRenderedData - -instance ToTypedContent CsvRendered where - toTypedContent = TypedContent - <$> getContentType . Identity - <*> toContent - -instance HasContentType CsvRendered where - getContentType _ = typeCsv' - toCsvRendered :: forall mono. ( ToNamedRecord (Element mono) , MonoFoldable mono @@ -83,3 +104,13 @@ toDefaultOrderedCsvRendered :: forall mono. ) => mono -> CsvRendered toDefaultOrderedCsvRendered = toCsvRendered $ headerOrder (error "headerOrder" :: Element mono) + + +csvRenderedToXlsx :: Text -- ^ Name of worksheet + -> CsvRendered -> Xlsx +csvRenderedToXlsx sheetName CsvRendered{..} = def & Xlsx.atSheet sheetName ?~ (def & appEndo (addHeader <> addValues)) + where + addHeader = flip foldMap (zip [1..] $ toList csvRenderedHeader) $ \(c, bs) -> Endo $ Xlsx.cellValueAtRC (1, c) ?~ Xlsx.CellText (decodeUtf8 bs) + addValues = flip foldMap (zip [2..] csvRenderedData) $ \(r, nr) -> flip foldMap (zip [1..] $ toList csvRenderedHeader) $ \(c, hBS) -> case HashMap.lookup hBS nr of + Nothing -> mempty + Just vBS -> Endo $ Xlsx.cellValueAtRC (r, c) ?~ Xlsx.CellText (decodeUtf8 vBS) diff --git a/src/Utils/Csv/Mail.hs b/src/Utils/Csv/Mail.hs new file mode 100644 index 000000000..d79c77331 --- /dev/null +++ b/src/Utils/Csv/Mail.hs @@ -0,0 +1,69 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Utils.Csv.Mail + ( recodeCsv + ) where + +import Import.NoModel +import Model.Types.Csv + +import qualified Data.Csv as Csv + +import Data.Time.Clock.POSIX (getPOSIXTime) + +import qualified Data.Conduit.Combinators as C + +import Data.Encoding (encodeLazyByteStringExplicit, decodeLazyByteStringExplicit) + + +instance (RenderMessage site msg, YesodMail site) => ToMailPart site (msg, CsvRendered) where + toMailPart (sheetName, csvRendered@CsvRendered{..}) = do + encOpts <- lift askMailCsvOptions + + case encOpts ^. _csvFormat of + CsvFormatOptions{} + | Just csvOpts <- encOpts ^? _csvFormat . _CsvEncodeOptions -> do + _partType .= decodeUtf8 typeCsv' + _partEncoding .= QuotedPrintableText + _partContent <~ fmap PartContent (liftHandler . runConduit $ C.sourceLazy (Csv.encodeByNameWith csvOpts csvRenderedHeader csvRenderedData) .| recodeCsv encOpts True C.sinkLazy) + | otherwise -> error "encOpts is CsvFormatOptions but cannot be converted via _CsvEncodeOptions" + CsvXlsxFormatOptions{} -> do + pNow <- liftIO getPOSIXTime + sheetName' <- lift $ ($ sheetName) <$> getMailMessageRender + _partType .= decodeUtf8 typeXlsx + _partEncoding .= Base64 + _partContent .= PartContent (fromXlsx pNow $ csvRenderedToXlsx sheetName' csvRendered) + +recodeCsv :: MonadThrow m + => CsvOptions + -> Bool -- ^ recode from (internal) utf8 to user chosen coding? + -> ConduitT ByteString o m a -> ConduitT ByteString o m a +recodeCsv encOpts toUser act = fromMaybe act $ do + enc <- encOpts ^? _csvFormat . _csvEncoding + + let + recode + | toUser = either throwM return . encodeLazyByteStringExplicit enc <=< either throwM return . decodeLazyByteStringExplicit UTF8 + | otherwise = either throwM return . encodeLazyByteStringExplicit UTF8 <=< either throwM return . decodeLazyByteStringExplicit enc + + return $ if + | enc == "UTF8" -> act + | FormatCsv <- fmt -> do + inp <- C.sinkLazy + inp' <- recode inp + sourceLazy inp' .| act + -- | FormatXlsx <- fmt -> do + -- inp <- C.sinkLazy + -- archive <- throwLeft $ Zip.toArchiveOrFail inp + -- archive' <- traverseOf (_zEntries . traverse . _Entrty . _3) recode archive + -- sourceLazy (Zip.fromArchive inp') .| act + | otherwise -> act + where + + fmt = encOpts ^. _csvFormat . _CsvFormat + + -- _zEntries :: Lens' Zip.Archive [Zip.Entry] + -- _zEntries = lens (\Zip.Archive{..} -> zEntries) (\archive entries -> archive { zEntries = entries }) + + -- _Entry :: Lens' Zip.Entry (FilePath, Integer, Lazy.ByteString) + -- _Entry = lens (\entry@Zip.Entry{..} -> (eRelativePath, eLastModified, Zip.fromEntry entry)) (uncurry3 Zip.toEntry) diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs index bd8fc160e..6c6e15c7b 100644 --- a/src/Utils/DB.hs +++ b/src/Utils/DB.hs @@ -12,7 +12,7 @@ import Utils import Control.Lens import Control.Lens.Extras (is) -import Control.Monad.Catch +import Control.Monad.Catch hiding (bracket) import qualified Utils.Pool as Custom @@ -20,6 +20,11 @@ import Database.Persist.Sql (runSqlConn) import GHC.Stack (HasCallStack, CallStack, callStack) +-- import Control.Monad.Fix (MonadFix) +-- import Control.Monad.Fail (MonadFail) + +-- import Control.Monad.Trans.Reader (withReaderT) + emptyOrIn :: PersistField typ => E.SqlExpr (E.Value typ) -> Set typ -> E.SqlExpr (E.Value Bool) @@ -175,3 +180,64 @@ customRunSqlPool' :: (MonadUnliftIO m, BackendCompatible SqlBackend backend) -> CallStack -> m a customRunSqlPool' act p label = Custom.withResource' p label $ runSqlConn act + + +class WithRunDB backend m' m | m -> backend m' where + useRunDB :: ReaderT backend m' a -> m a + +instance WithRunDB backend m (ReaderT backend m) where + useRunDB = id + +-- newtype DBRunner' backend m = DBRunner' { runDBRunner' :: forall b. ReaderT backend m b -> m b } + +-- _DBRunner' :: Iso' (DBRunner site) (DBRunner' (YesodPersistBackend site) (HandlerFor site)) +-- _DBRunner' = iso fromDBRunner' toDBRunner +-- where +-- fromDBRunner' :: forall site. +-- DBRunner site +-- -> DBRunner' (YesodPersistBackend site) (HandlerFor site) +-- fromDBRunner' DBRunner{..} = DBRunner' runDBRunner + +-- toDBRunner :: forall site. +-- DBRunner' (YesodPersistBackend site) (HandlerFor site) +-- -> DBRunner site +-- toDBRunner DBRunner'{..} = DBRunner runDBRunner' + +-- fromDBRunner :: BackendCompatible backend (YesodPersistBackend site) => DBRunner site -> DBRunner' backend (HandlerFor site) +-- fromDBRunner DBRunner{..} = DBRunner' (runDBRunner . withReaderT projectBackend) + +-- newtype CachedDBRunner backend m a = CachedDBRunner { runCachedDBRunnerUsing :: m (DBRunner' backend m) -> m a } +-- deriving (Functor, Applicative, Monad, MonadFix, MonadFail, Contravariant, MonadIO, Alternative, MonadPlus, MonadUnliftIO, MonadResource, MonadLogger, MonadThrow, MonadCatch, MonadMask) via (ReaderT (m (DBRunner' backend m)) m) + +-- instance MonadTrans (CachedDBRunner backend) where +-- lift act = CachedDBRunner (const act) + +-- instance MonadHandler m => MonadHandler (CachedDBRunner backend m) where +-- type HandlerSite (CachedDBRunner backend m) = HandlerSite m +-- type SubHandlerSite (CachedDBRunner backend m) = SubHandlerSite m + +-- liftHandler = lift . liftHandler +-- liftSubHandler = lift . liftSubHandler + +-- instance Monad m => WithRunDB backend m (CachedDBRunner backend m) where +-- useRunDB act = CachedDBRunner (\getRunner -> getRunner >>= \DBRunner'{..} -> runDBRunner' act) + +-- runCachedDBRunnerSTM :: MonadUnliftIO m +-- => m (DBRunner' backend m) +-- -> CachedDBRunner backend m a +-- -> m a +-- runCachedDBRunnerSTM doAcquire act = do +-- doAcquireLock <- newTMVarIO () +-- runnerTMVar <- newEmptyTMVarIO + +-- let getRunner = bracket (atomically $ takeTMVar doAcquireLock) (void . atomically . tryPutTMVar doAcquireLock) . const $ do +-- cachedRunner <- atomically $ tryReadTMVar runnerTMVar +-- case cachedRunner of +-- Just cachedRunner' -> return cachedRunner' +-- Nothing -> do +-- runner <- doAcquire +-- void . atomically $ tryPutTMVar runnerTMVar runner +-- return runner +-- getRunnerNoLock = maybe getRunner return =<< atomically (tryReadTMVar runnerTMVar) + +-- runCachedDBRunnerUsing act getRunnerNoLock diff --git a/src/Utils/DateTime.hs b/src/Utils/DateTime.hs index de3f76087..a5c013b4a 100644 --- a/src/Utils/DateTime.hs +++ b/src/Utils/DateTime.hs @@ -100,6 +100,7 @@ instance HasLocalTime TimeOfDay where newtype DateTimeFormat = DateTimeFormat { unDateTimeFormat :: String } deriving (Eq, Ord, Read, Show, Data, Generic, Typeable) deriving newtype (ToJSON, FromJSON, PersistField, IsString) + deriving anyclass (NFData) instance PersistFieldSql DateTimeFormat where sqlType _ = sqlType $ Proxy @String @@ -108,10 +109,7 @@ instance Hashable DateTimeFormat data SelDateTimeFormat = SelFormatDate | SelFormatTime | SelFormatDateTime deriving (Eq, Ord, Read, Show, Enum, Bounded, Data, Generic, Typeable) - -instance Universe SelDateTimeFormat -instance Finite SelDateTimeFormat -instance Hashable SelDateTimeFormat + deriving anyclass (Universe, Finite, Hashable, NFData) nullaryPathPiece ''SelDateTimeFormat $ camelToPathPiece' 2 pathPieceJSON ''SelDateTimeFormat diff --git a/src/Utils/Exam/Correct.hs b/src/Utils/Exam/Correct.hs index eec2fc30a..a96d5364f 100644 --- a/src/Utils/Exam/Correct.hs +++ b/src/Utils/Exam/Correct.hs @@ -22,7 +22,7 @@ deriveJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } ''CorrectInterfaceUser -userToResponse :: (MonadHandler m, MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey) => Entity User -> m CorrectInterfaceUser +userToResponse :: (MonadHandler m, MonadCrypto (HandlerFor (HandlerSite m)), MonadCryptoKey (HandlerFor (HandlerSite m)) ~ CryptoIDKey) => Entity User -> m CorrectInterfaceUser userToResponse (Entity uid User{..}) = do uuid <- encrypt uid return CorrectInterfaceUser diff --git a/src/Utils/Files.hs b/src/Utils/Files.hs index fb8c340dc..1e3ebb620 100644 --- a/src/Utils/Files.hs +++ b/src/Utils/Files.hs @@ -216,7 +216,7 @@ replaceFileReferences' mkFilter residual = do = modify $ Map.mapMaybe (assertM' (not . Set.null) . (\\ sfIds)) | otherwise = do let fRef' = _FileReference # (fRef, residual) - forM_ (persistUniqueKeys fRef') $ \u -> maybeT (return ()) $ do + forM_ (persistUniqueKeys fRef') $ \u -> maybeT_ $ do Entity cKey cVal <- MaybeT . lift $ getBy u deleted <- lift . lift . deleteWhereCount $ resFilter <> [ persistIdField ==. cKey ] unless (deleted == 1) $ diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 3913263cd..4f28d482d 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -229,7 +229,7 @@ data FormIdentifier | FIDUserAuthMode | FIDUserAssimilate | FIDUserRights | FIDUserAuthentication | FIDAllUsersAction | FIDLanguage - | FIDExamAutoOccurrenceCalculate | FIDExamAutoOccurrenceConfirm | FIDExamAutoOccurrenceNudge UUID + | FIDExamAutoOccurrenceCalculate | FIDExamAutoOccurrenceConfirm | FIDExamAutoOccurrenceNudge UUID | FIDExamAutoOccurrenceIgnoreRoom UUID | FIDAllocationAccept | FIDTestDownload | FIDAllocationRegister @@ -415,8 +415,12 @@ buttonForm = buttonForm' universeF -- | like `buttonForm`, but for a given list of buttons, i.e. a subset or for buttons outside the Finite typeclass buttonForm' :: (MonadHandler m, Button (HandlerSite m) a) => [a] -> Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()) -buttonForm' btns csrf = do - (res, ($ []) -> fViews) <- aFormToForm . disambiguateButtons $ combinedButtonField btns "" +buttonForm' btns = buttonForm'' btns "" + +-- | like `buttonForm'`, but for a given list of FieldSettings +buttonForm'' :: (MonadHandler m, Button (HandlerSite m) a) => [a] -> FieldSettings (HandlerSite m) -> Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()) +buttonForm'' btns settings csrf = do + (res, ($ []) -> fViews) <- aFormToForm . disambiguateButtons $ combinedButtonField btns settings return (res, [whamlet| $newline never #{csrf} diff --git a/src/Utils/I18n.hs b/src/Utils/I18n.hs index 08595630d..9f71d05dc 100644 --- a/src/Utils/I18n.hs +++ b/src/Utils/I18n.hs @@ -57,7 +57,7 @@ data I18n a = I18n , i18nFallbackLang :: Maybe Lang , i18nTranslations :: Map Lang a } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Data, Generic, Typeable) - deriving anyclass (MonoFunctor, MonoFoldable, MonoTraversable, Binary) + deriving anyclass (MonoFunctor, MonoFoldable, MonoTraversable, Binary, NFData) type instance Element (I18n a) = a type I18nText = I18n Text diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index 36904d962..cf553465f 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -44,6 +44,10 @@ data Icon | IconExam | IconExamRegisterTrue | IconExamRegisterFalse + | IconExamAutoOccurrenceNudgeUp + | IconExamAutoOccurrenceNudgeDown + | IconExamAutoOccurrenceIgnore + | IconExamAutoOccurrenceReconsider | IconCommentTrue | IconCommentFalse | IconLink @@ -92,7 +96,9 @@ data Icon | IconPersonalIdentification | IconMenuWorkflows | IconVideo + | IconSubmissionUserDuplicate deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, Typeable) + deriving anyclass (Universe, Finite, NFData) iconText :: Icon -> Text iconText = \case @@ -111,6 +117,10 @@ iconText = \case IconExam -> "poll-h" IconExamRegisterTrue -> "calendar-check" IconExamRegisterFalse -> "calendar-times" + IconExamAutoOccurrenceNudgeUp -> "user-plus" + IconExamAutoOccurrenceNudgeDown -> "user-minus" + IconExamAutoOccurrenceIgnore -> "users-slash" + IconExamAutoOccurrenceReconsider -> "users" IconCommentTrue -> "comment-alt" IconCommentFalse -> "comment-alt-slash" IconLink -> "link" @@ -164,9 +174,8 @@ iconText = \case IconPersonalIdentification -> "id-card" IconMenuWorkflows -> "project-diagram" IconVideo -> "video" + IconSubmissionUserDuplicate -> "copy" -instance Universe Icon -instance Finite Icon nullaryPathPiece ''Icon $ camelToPathPiece' 1 deriveLift ''Icon diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index b1e194d7d..7605d1e0e 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -82,6 +82,8 @@ _SqlKey = _SqlKey' . _Unwrapped _Integral :: (Integral a, Integral b) => Iso' a b _Integral = iso fromIntegral fromIntegral +_not :: Iso' Bool Bool +_not = iso not not ----------------------------------- -- Lens Definitions for our Types diff --git a/src/Utils/Message.hs b/src/Utils/Message.hs index 168c3e132..27ccafe41 100644 --- a/src/Utils/Message.hs +++ b/src/Utils/Message.hs @@ -31,7 +31,7 @@ import Text.HTML.SanitizeXSS (sanitizeBalance) data MessageStatus = Error | Warning | Info | Success deriving (Eq, Ord, Enum, Bounded, Show, Read, Lift, Generic, Typeable) - deriving anyclass (Universe, Finite) + deriving anyclass (Universe, Finite, NFData) instance Default MessageStatus where def = Info diff --git a/src/Utils/Metrics.hs b/src/Utils/Metrics.hs index 9bc78cdd5..b4a7fe5c3 100644 --- a/src/Utils/Metrics.hs +++ b/src/Utils/Metrics.hs @@ -24,6 +24,8 @@ module Utils.Metrics , poolMetrics , observeDatabaseConnectionOpened, observeDatabaseConnectionClosed , onUseDBConn, onReleaseDBConn, DBConnUseState, DBConnLabel + , AuthTagEvalOutcome(..), observeAuthTagEvaluation + , observeFavouritesSkippedDueToDBLoad ) where import Import.NoModel hiding (Vector, Info) @@ -258,13 +260,19 @@ missingFiles = unsafeRegister . vector "ref" $ gauge info where info = Info "uni2work_missing_files_count" "Number of files referenced from within database that are missing" +{-# NOINLINE favouritesSkippedDueToDBLoad #-} +favouritesSkippedDueToDBLoad :: Counter +favouritesSkippedDueToDBLoad = unsafeRegister $ counter info + where info = Info "uni2work_favourites_skipped_due_to_db_load_count" + "Number of times this Uni2work-instance skipped generating FavouriteQuickActions due to database pressure" + relabel :: Text -> Text -> SampleGroup -> SampleGroup relabel l s (SampleGroup i t ss) = SampleGroup i t . flip map ss $ \(Sample k lbls v) -> Sample k ((l, s) : filter (views _1 $ (/=) l) lbls) v data ARCMetrics = ARCMetrics -data ARCLabel = ARCFileSource +data ARCLabel = ARCFileSource | ARCMemcachedLocal deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) deriving anyclass (Universe, Finite) @@ -416,6 +424,19 @@ onReleaseDBConn DBConnUseState{..} _ = liftIO $ do [] -> "unlabeled" (_, SrcLoc{..}) : _ -> pack srcLocModule withLabel databaseConnDuration lbl $ flip observe diff + +data AuthTagEvalOutcome = OutcomeAuthorized | OutcomeUnauthorized | OutcomeAuthenticationRequired | OutcomeException + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + deriving (Universe, Finite) +nullaryPathPiece ''AuthTagEvalOutcome $ camelToPathPiece' 1 + +{-# NOINLINE authTagEvaluationDuration #-} +authTagEvaluationDuration :: Vector Label3 Histogram +authTagEvaluationDuration = unsafeRegister . vector ("tag", "outcome", "handler") $ histogram info buckets + where + info = Info "uni2work_auth_tag_evaluation_duration_seconds" + "Duration of auth tag evaluations" + buckets = histogramBuckets 5e-6 1 withHealthReportMetrics :: MonadIO m => m HealthReport -> m HealthReport @@ -486,7 +507,7 @@ withJobWorkerStateLbls newLbls act = do liftIO . withLabel jobWorkerStateDuration newLbls . flip observe . realToFrac $ end - start - either throwM return res + throwLeft res observeYesodCacheSize :: MonadHandler m => m () observeYesodCacheSize = do @@ -504,7 +525,7 @@ observeFavouritesQuickActionsDuration act = do liftIO . observe favouritesQuickActionsDuration . realToFrac $ end - start - either throwM return res + throwLeft res data LoginOutcome = LoginSuccessful @@ -564,3 +585,20 @@ observeMissingFiles refIdent = liftIO . withLabel missingFiles refIdent . flip s observeDatabaseConnectionOpened, observeDatabaseConnectionClosed :: MonadIO m => m () observeDatabaseConnectionOpened = liftIO $ incCounter databaseConnectionsOpened observeDatabaseConnectionClosed = liftIO $ incCounter databaseConnectionsClosed + +observeAuthTagEvaluation :: MonadUnliftIO m => AuthTag -> String -> m (a, AuthTagEvalOutcome) -> m a +observeAuthTagEvaluation aTag handler act = do + start <- liftIO $ getTime Monotonic + res <- tryAny act + end <- liftIO $ getTime Monotonic + + let outcome = case res of + Right (_, outcome') -> outcome' + Left _ -> OutcomeException + + liftIO . withLabel authTagEvaluationDuration (toPathPiece aTag, toPathPiece outcome, pack handler) . flip observe . realToFrac $ end - start + + either throwIO (views _1 return) res + +observeFavouritesSkippedDueToDBLoad :: MonadIO m => m () +observeFavouritesSkippedDueToDBLoad = liftIO $ incCounter favouritesSkippedDueToDBLoad diff --git a/src/Utils/Pool.hs b/src/Utils/Pool.hs index e2031d89f..54b17a678 100644 --- a/src/Utils/Pool.hs +++ b/src/Utils/Pool.hs @@ -5,6 +5,7 @@ module Utils.Pool , PoolResourceIdent' , Pool, PoolResourceIdent , getPoolAvailableCount, getPoolInUseCount, getPoolUsesCount + , getPoolIdleTime, getPoolMaxAvailable , createPool, createPool' , purgePool , withResource, withResource' @@ -24,6 +25,7 @@ import UnliftIO.Concurrent (forkIO) import Data.Fixed import System.Clock +import Data.Time.Clock (DiffTime) import Control.Concurrent.STM.Delay import Control.Concurrent.STM.TVar (stateTVar) @@ -78,6 +80,10 @@ getPoolAvailableCount Pool{..} = availableCount <$> readTVar resources getPoolInUseCount Pool{..} = inUseCount <$> readTVar resources getPoolUsesCount Pool{..} = inUseTick <$> readTVar resources +getPoolIdleTime :: Pool' m c' c a -> Maybe DiffTime +getPoolIdleTime = fmap realToFrac . maxAvailable +getPoolMaxAvailable :: Pool' m c' c a -> Maybe Int +getPoolMaxAvailable = maxAvailable toSecond :: TimeSpec -> Int toSecond = fromIntegral . sec diff --git a/src/Utils/Postgresql.hs b/src/Utils/Postgresql.hs new file mode 100644 index 000000000..b9c19efbc --- /dev/null +++ b/src/Utils/Postgresql.hs @@ -0,0 +1,67 @@ +module Utils.Postgresql + ( PostgresqlChannel(..) + , PostgresqlChannelManager(..) + , managePostgresqlChannel + , PostgresConf + ) where + +import Import.NoFoundation hiding (bracket) + +import qualified Database.PostgreSQL.Simple as PG +import qualified Database.PostgreSQL.Simple.Types as PG +import qualified Database.PostgreSQL.Simple.Notification as PG + +import Database.Persist.Postgresql (PostgresConf, pgConnStr) + +import UnliftIO.Exception (bracket) + + +data PostgresqlChannel + = ChannelJobOffload + | ChannelMemcachedLocalInvalidation + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + deriving anyclass (Universe, Finite) + +nullaryPathPiece ''PostgresqlChannel $ camelToPathPiece' 1 + + +data PostgresqlChannelManager m a = PostgresqlChannelManager + { pgcTerminate :: m a -- ^ Expected to block; used within `race` + , pgcOnInput :: Maybe (ByteString -> m ()) + , pgcGenOutput :: m ByteString -- ^ Expected to block; used within `race` + } + +managePostgresqlChannel :: forall m a. + ( MonadUnliftIO m + , MonadLogger m + ) + => PostgresConf + -> PostgresqlChannel + -> PostgresqlChannelManager m a + -> m a +managePostgresqlChannel dbConf (toPathPiece -> chan) PostgresqlChannelManager{..} = bracket (liftIO . PG.connectPostgreSQL $ pgConnStr dbConf) (liftIO . PG.close) $ \pgConn -> do + myPid <- liftIO $ PG.getBackendPID pgConn + when (is _Just pgcOnInput) $ + void . liftIO . PG.execute pgConn "LISTEN ?" . PG.Only $ PG.Identifier chan + + let + getInput = do + n@PG.Notification{..} <- liftIO $ PG.getNotification pgConn + if | notificationPid == myPid || notificationChannel /= encodeUtf8 chan -> getInput + | otherwise -> return n + + foreverBreak $ \terminate -> do + io <- lift . (pgcTerminate `race`) $ if + | is _Just pgcOnInput -> getInput `race` pgcGenOutput + | otherwise -> Right <$> pgcGenOutput + + case io of + Right (Left notif@PG.Notification{..}) -> do + $logDebugS "PGChannel" $ "Got input: " <> tshow notif + lift $ maybe (return ()) ($ notificationData) pgcOnInput + Right (Right o) -> do + void . liftIO $ PG.execute pgConn "NOTIFY ?, ?" (PG.Identifier chan, o) + $logDebugS "PGChannel" $ "Sent output: " <> tshow o + Left t -> do + $logDebugS "PGChannel" "Terminating..." + terminate t diff --git a/src/Utils/TH.hs b/src/Utils/TH.hs index 4e62ba2bc..989f781c0 100644 --- a/src/Utils/TH.hs +++ b/src/Utils/TH.hs @@ -224,6 +224,7 @@ mkI18nWidgetEnum (splitCamel -> namebase) basename = do , derivClause (Just AnyclassStrategy) [ conT ''Universe , conT ''Finite + , conT ''NFData ] ] , instanceD (cxt []) (conT ''PathPiece `appT` conT dataName) diff --git a/src/Utils/Tokens.hs b/src/Utils/Tokens.hs index 51d56e2f5..d26f22ec0 100644 --- a/src/Utils/Tokens.hs +++ b/src/Utils/Tokens.hs @@ -94,7 +94,7 @@ encodeBearer token = do payload <- Jose.Claims . toStrict . JSON.encode <$> bearerToJSON token JwkSet jwks <- getsYesod $ view jsonWebKeySet jwtEncoding <- getsYesod $ view _appBearerEncoding - either throwM return =<< liftIO (Jose.encode jwks jwtEncoding payload) + throwLeft =<< liftIO (Jose.encode jwks jwtEncoding payload) data BearerTokenException diff --git a/src/Web/ServerSession/Frontend/Yesod/Jwt.hs b/src/Web/ServerSession/Frontend/Yesod/Jwt.hs index b25814e90..0dc2f1109 100644 --- a/src/Web/ServerSession/Frontend/Yesod/Jwt.hs +++ b/src/Web/ServerSession/Frontend/Yesod/Jwt.hs @@ -160,7 +160,7 @@ encodeSession :: MonadIO m -> SessionToken sess -> m Jwt encodeSession ServerSessionJwtConfig{..} token = liftIO $ - either throwM return =<< Jose.encode (Jose.keys sJwtJwkSet) sJwtEncoding payload + throwLeft =<< Jose.encode (Jose.keys sJwtJwkSet) sJwtEncoding payload where payload = Jose.Claims . toStrict $ JSON.encode token diff --git a/src/Yesod/Core/Types/Instances.hs b/src/Yesod/Core/Types/Instances.hs index 744e62256..ba60b6680 100644 --- a/src/Yesod/Core/Types/Instances.hs +++ b/src/Yesod/Core/Types/Instances.hs @@ -81,3 +81,4 @@ instance site ~ site' => ToWidget site (SomeMessage site') where deriving instance Generic AuthResult instance Binary AuthResult +instance NFData AuthResult diff --git a/stack.yaml b/stack.yaml index 4bdc468ee..d76cd4465 100644 --- a/stack.yaml +++ b/stack.yaml @@ -62,6 +62,24 @@ extra-deps: - git: git@gitlab2.rz.ifi.lmu.de:uni2work/zip-stream.git commit: 843683d024f767de236f74d24a3348f69181a720 + - git: git@gitlab2.rz.ifi.lmu.de:uni2work/yesod.git + commit: 85cbc004191087fae0eb59e18370f79df5f0afc0 + subdirs: + - yesod-core + - yesod-static + - yesod-persistent + - yesod-newsfeed + - yesod-form + - yesod-form-multi + - yesod-auth + - yesod-auth-oauth + - yesod-sitemap + - yesod-test + - yesod-bin + - yesod + - yesod-eventsource + - yesod-websockets + - classy-prelude-yesod-1.5.0@sha256:8f7e183bdfd6d2ea9674284c4f285294ab086aff60d9be4e5d7d2f3c1a2b05b7,1330 - acid-state-0.16.0.1@sha256:d43f6ee0b23338758156c500290c4405d769abefeb98e9bc112780dae09ece6f,6207 - commonmark-0.1.1.2@sha256:c06ab05f0f224ab7982502a96e17952823a9b6dae8505fb35194b0baa9e2a975,3278 @@ -81,5 +99,5 @@ extra-deps: - network-arbitrary-0.6.0.0@sha256:a7034d63295dfc41cf559ee705fc95cac9a9a01b4715300f590eaa237b5ffd48,2506 resolver: nightly-2021-01-11 -compiler: ghc-8.10.3 +compiler: ghc-8.10.4 allow-newer: true diff --git a/stack.yaml.lock b/stack.yaml.lock index 12d6fa671..742fb3c1e 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -233,6 +233,188 @@ packages: original: git: git@gitlab2.rz.ifi.lmu.de:uni2work/zip-stream.git commit: 843683d024f767de236f74d24a3348f69181a720 +- completed: + subdir: yesod-core + name: yesod-core + version: 1.6.18.8 + git: git@gitlab2.rz.ifi.lmu.de:uni2work/yesod.git + pantry-tree: + size: 5881 + sha256: 1dca5efa7c916fb2d40e74448b497c6c21a4fef6b0e42b993f79d9d9da5002ef + commit: 85cbc004191087fae0eb59e18370f79df5f0afc0 + original: + subdir: yesod-core + git: git@gitlab2.rz.ifi.lmu.de:uni2work/yesod.git + commit: 85cbc004191087fae0eb59e18370f79df5f0afc0 +- completed: + subdir: yesod-static + name: yesod-static + version: 1.6.1.0 + git: git@gitlab2.rz.ifi.lmu.de:uni2work/yesod.git + pantry-tree: + size: 2949 + sha256: 32c1608243a5309005ce11e2aa379ac1d6f8c380c529785eb510770118f3da06 + commit: 85cbc004191087fae0eb59e18370f79df5f0afc0 + original: + subdir: yesod-static + git: git@gitlab2.rz.ifi.lmu.de:uni2work/yesod.git + commit: 85cbc004191087fae0eb59e18370f79df5f0afc0 +- completed: + subdir: yesod-persistent + name: yesod-persistent + version: 1.6.0.5 + git: git@gitlab2.rz.ifi.lmu.de:uni2work/yesod.git + pantry-tree: + size: 496 + sha256: 3e86a3edcaa43e1b86decf8e594db0c9b8d7bce0039a293636d7a1228237bf67 + commit: 85cbc004191087fae0eb59e18370f79df5f0afc0 + original: + subdir: yesod-persistent + git: git@gitlab2.rz.ifi.lmu.de:uni2work/yesod.git + commit: 85cbc004191087fae0eb59e18370f79df5f0afc0 +- completed: + subdir: yesod-newsfeed + name: yesod-newsfeed + version: 1.7.0.0 + git: git@gitlab2.rz.ifi.lmu.de:uni2work/yesod.git + pantry-tree: + size: 488 + sha256: 53ebad62655863a657dcf749ffd3de46f6af90dd71f55bc4d50805ac48ddb099 + commit: 85cbc004191087fae0eb59e18370f79df5f0afc0 + original: + subdir: yesod-newsfeed + git: git@gitlab2.rz.ifi.lmu.de:uni2work/yesod.git + commit: 85cbc004191087fae0eb59e18370f79df5f0afc0 +- completed: + subdir: yesod-form + name: yesod-form + version: 1.6.7 + git: git@gitlab2.rz.ifi.lmu.de:uni2work/yesod.git + pantry-tree: + size: 1914 + sha256: 3db609d2099335c8ddb4ce3dc9ced3f248cf83178f21125eb873ffc452df58fd + commit: 85cbc004191087fae0eb59e18370f79df5f0afc0 + original: + subdir: yesod-form + git: git@gitlab2.rz.ifi.lmu.de:uni2work/yesod.git + commit: 85cbc004191087fae0eb59e18370f79df5f0afc0 +- completed: + subdir: yesod-form-multi + name: yesod-form-multi + version: 1.7.0.1 + git: git@gitlab2.rz.ifi.lmu.de:uni2work/yesod.git + pantry-tree: + size: 328 + sha256: abcab34bcee606574d7ec0410484fa8f73b8c3b88685e7c495455ac946b4f8fd + commit: 85cbc004191087fae0eb59e18370f79df5f0afc0 + original: + subdir: yesod-form-multi + git: git@gitlab2.rz.ifi.lmu.de:uni2work/yesod.git + commit: 85cbc004191087fae0eb59e18370f79df5f0afc0 +- completed: + subdir: yesod-auth + name: yesod-auth + version: 1.6.10.1 + git: git@gitlab2.rz.ifi.lmu.de:uni2work/yesod.git + pantry-tree: + size: 1212 + sha256: e22fa161a42354b6bac03f05295eb494582029a6790119b6ad125af2ad5340ab + commit: 85cbc004191087fae0eb59e18370f79df5f0afc0 + original: + subdir: yesod-auth + git: git@gitlab2.rz.ifi.lmu.de:uni2work/yesod.git + commit: 85cbc004191087fae0eb59e18370f79df5f0afc0 +- completed: + subdir: yesod-auth-oauth + name: yesod-auth-oauth + version: 1.6.0.2 + git: git@gitlab2.rz.ifi.lmu.de:uni2work/yesod.git + pantry-tree: + size: 321 + sha256: 26fb876de747465888b7c5a955659f12199cb8db3292016108aa8c28ea21c39f + commit: 85cbc004191087fae0eb59e18370f79df5f0afc0 + original: + subdir: yesod-auth-oauth + git: git@gitlab2.rz.ifi.lmu.de:uni2work/yesod.git + commit: 85cbc004191087fae0eb59e18370f79df5f0afc0 +- completed: + subdir: yesod-sitemap + name: yesod-sitemap + version: 1.6.0 + git: git@gitlab2.rz.ifi.lmu.de:uni2work/yesod.git + pantry-tree: + size: 314 + sha256: 971f48af7011ff7816872d067e5de9cadafdd371bdf209170b77df36001abd27 + commit: 85cbc004191087fae0eb59e18370f79df5f0afc0 + original: + subdir: yesod-sitemap + git: git@gitlab2.rz.ifi.lmu.de:uni2work/yesod.git + commit: 85cbc004191087fae0eb59e18370f79df5f0afc0 +- completed: + subdir: yesod-test + name: yesod-test + version: 1.6.12 + git: git@gitlab2.rz.ifi.lmu.de:uni2work/yesod.git + pantry-tree: + size: 563 + sha256: 3d5022e8e3f8e77abcf075c42cf49efaa26f4951159bbb5ab50b69fdfeacb7c1 + commit: 85cbc004191087fae0eb59e18370f79df5f0afc0 + original: + subdir: yesod-test + git: git@gitlab2.rz.ifi.lmu.de:uni2work/yesod.git + commit: 85cbc004191087fae0eb59e18370f79df5f0afc0 +- completed: + subdir: yesod-bin + name: yesod-bin + version: 1.6.1 + git: git@gitlab2.rz.ifi.lmu.de:uni2work/yesod.git + pantry-tree: + size: 1295 + sha256: 422d7816965b79826c6c24582d76dadbacd1bfb3e9a8f31208867cd788f2a5b8 + commit: 85cbc004191087fae0eb59e18370f79df5f0afc0 + original: + subdir: yesod-bin + git: git@gitlab2.rz.ifi.lmu.de:uni2work/yesod.git + commit: 85cbc004191087fae0eb59e18370f79df5f0afc0 +- completed: + subdir: yesod + name: yesod + version: 1.6.1.0 + git: git@gitlab2.rz.ifi.lmu.de:uni2work/yesod.git + pantry-tree: + size: 666 + sha256: bada746e25e07b871f00c34bd0b4a583f117085e05f71c74459a5552295f71df + commit: 85cbc004191087fae0eb59e18370f79df5f0afc0 + original: + subdir: yesod + git: git@gitlab2.rz.ifi.lmu.de:uni2work/yesod.git + commit: 85cbc004191087fae0eb59e18370f79df5f0afc0 +- completed: + subdir: yesod-eventsource + name: yesod-eventsource + version: 1.6.0.1 + git: git@gitlab2.rz.ifi.lmu.de:uni2work/yesod.git + pantry-tree: + size: 324 + sha256: 6d393201852cd024e377159ba836398e24d191563e08165430113d3c1384aff2 + commit: 85cbc004191087fae0eb59e18370f79df5f0afc0 + original: + subdir: yesod-eventsource + git: git@gitlab2.rz.ifi.lmu.de:uni2work/yesod.git + commit: 85cbc004191087fae0eb59e18370f79df5f0afc0 +- completed: + subdir: yesod-websockets + name: yesod-websockets + version: 0.3.0.3 + git: git@gitlab2.rz.ifi.lmu.de:uni2work/yesod.git + pantry-tree: + size: 485 + sha256: 1e9af58d6508f4c518f7cecd1c7875e93772eeaae3495b0d93d79a33221272c9 + commit: 85cbc004191087fae0eb59e18370f79df5f0afc0 + original: + subdir: yesod-websockets + git: git@gitlab2.rz.ifi.lmu.de:uni2work/yesod.git + commit: 85cbc004191087fae0eb59e18370f79df5f0afc0 - completed: hackage: classy-prelude-yesod-1.5.0@sha256:8f7e183bdfd6d2ea9674284c4f285294ab086aff60d9be4e5d7d2f3c1a2b05b7,1330 pantry-tree: diff --git a/templates/exam-office/exam-results.hamlet b/templates/exam-office/exam-results.hamlet index 5b077e6d8..329a53cdf 100644 --- a/templates/exam-office/exam-results.hamlet +++ b/templates/exam-office/exam-results.hamlet @@ -1,6 +1,13 @@ $newline never -
- ^{closeWgt} +$if is _Nothing examFinished +
+
+ ^{closeWgt} +
+ ^{finishWgt} +$else +
+ ^{closeWgt}
$if hasUsers ^{examGradesExplanation} diff --git a/templates/exam-show.hamlet b/templates/exam-show.hamlet index 8ed0b0af6..2e780fd04 100644 --- a/templates/exam-show.hamlet +++ b/templates/exam-show.hamlet @@ -33,10 +33,10 @@ $maybe desc <- examDescription _{MsgExamNever} \ ^{isVisible False} $maybe regFrom <- examRegisterFrom -
_{MsgExamRegisterFrom} +
_{MsgTableExamRegisterFrom}
^{formatTimeW SelFormatDateTime regFrom} $maybe regTo <- examRegisterTo -
_{MsgExamRegisterTo} +
_{MsgTableExamRegisterTo}
^{formatTimeW SelFormatDateTime regTo} $maybe deregUntil <- examDeregisterUntil
_{MsgExamDeregisterUntil} @@ -140,12 +140,31 @@ $maybe desc <- examDescription $if is _Nothing (examRequiredEquipment examExamMode) ^{notificationPersonalIdentification} -$if showCloseWidget && is _Nothing examClosed -
-

- _{MsgExamCloseHeading} - \ ^{isVisible False} - ^{closeWgt} +$if (showCloseWidget && is _Nothing examClosed) && (showFinishWidget && is _Nothing examFinished) +
+
+

+ _{MsgExamCloseHeading} + \ ^{isVisible False} + ^{closeWgt} +
+

+ _{MsgExamFinishHeading} + \ ^{isVisible False} + ^{finishWgt} +$else + $if showCloseWidget && is _Nothing examClosed +
+

+ _{MsgExamCloseHeading} + \ ^{isVisible False} + ^{closeWgt} + $if showFinishWidget && is _Nothing examFinished +
+

+ _{MsgExamFinishHeading} + \ ^{isVisible False} + ^{finishWgt} $if examOccurrenceRuleAutomatic examOccurrenceRule && showAutoOccurrenceCalculateWidget

@@ -194,6 +213,11 @@ $if not (null occurrences) _{MsgExamRoomMappingMatriculation} $if not occurrenceAssignmentsVisible \ ^{isVisible False} + $of Just ExamRoomRandom + + _{MsgExamRoomMappingRandom} + $if not occurrenceAssignmentsVisible + \ ^{isVisible False} $of _ $if not occurrenceAssignmentsVisible @@ -318,6 +342,8 @@ $if (gradingShown || partsShown) && not (null examParts) $if partNumbersShown + $if showPartSheets + #{showFixed True sumMaxPoints} @@ -327,6 +353,8 @@ $if (gradingShown || partsShown) && not (null examParts) _{MsgExamBonusAchieved} + $if showPartSheets + $if showMaxPoints $if showAchievedPoints @@ -336,6 +364,8 @@ $if (gradingShown || partsShown) && not (null examParts) $if partNumbersShown + $if showPartSheets + $if showMaxPoints $if showAchievedPoints @@ -349,6 +379,8 @@ $if (gradingShown || partsShown) && not (null examParts) $if partNumbersShown + $if showPartSheets + $if showMaxPoints #{showFixed True sumMaxPoints} diff --git a/templates/exam-users.hamlet b/templates/exam-users.hamlet index 9e85b0605..8c49ddc23 100644 --- a/templates/exam-users.hamlet +++ b/templates/exam-users.hamlet @@ -1,8 +1,17 @@ $newline never -
- $if is _Nothing examClosed -

_{MsgExamCloseHeading} - ^{closeWgt} +$if is _Nothing examFinished +
+
+

_{MsgExamCloseHeading} + ^{closeWgt} +
+

_{MsgExamFinishHeading} + ^{finishWgt} +$else +
+ $if is _Nothing examClosed +

_{MsgExamCloseHeading} + ^{closeWgt} $if examOccurrenceRuleAutomatic examOccurrenceRule

_{MsgExamAutoOccurrenceHeading} diff --git a/templates/i18n/changelog/exam-automatic-room-distribution-respect-size.de-de-formal.hamlet b/templates/i18n/changelog/exam-automatic-room-distribution-respect-size.de-de-formal.hamlet new file mode 100644 index 000000000..41a2fd613 --- /dev/null +++ b/templates/i18n/changelog/exam-automatic-room-distribution-respect-size.de-de-formal.hamlet @@ -0,0 +1,2 @@ +$newline never +Diverse Verbesserungen an der automatischen Zuteilung von Klausurteilnehmern auf Termine/Räume diff --git a/templates/i18n/changelog/exam-automatic-room-distribution-respect-size.en-eu.hamlet b/templates/i18n/changelog/exam-automatic-room-distribution-respect-size.en-eu.hamlet new file mode 100644 index 000000000..a9b07c71d --- /dev/null +++ b/templates/i18n/changelog/exam-automatic-room-distribution-respect-size.en-eu.hamlet @@ -0,0 +1,2 @@ +$newline never +Several improvements for the automated distribution of exam participants to occurrences/rooms diff --git a/templates/i18n/changelog/exam-automatic-room-distribution-unrestricted-rooms.de-de-formal.hamlet b/templates/i18n/changelog/exam-automatic-room-distribution-unrestricted-rooms.de-de-formal.hamlet new file mode 100644 index 000000000..890bac4a2 --- /dev/null +++ b/templates/i18n/changelog/exam-automatic-room-distribution-unrestricted-rooms.de-de-formal.hamlet @@ -0,0 +1,3 @@ +$newline never +Erlaube unbeschränkte Räume bei der # +automatischen Verteilung von Klausurteilnehmern diff --git a/templates/i18n/changelog/exam-automatic-room-distribution-unrestricted-rooms.en-eu.hamlet b/templates/i18n/changelog/exam-automatic-room-distribution-unrestricted-rooms.en-eu.hamlet new file mode 100644 index 000000000..090c5ec6b --- /dev/null +++ b/templates/i18n/changelog/exam-automatic-room-distribution-unrestricted-rooms.en-eu.hamlet @@ -0,0 +1,3 @@ +$newline never +Allow unrestricted rooms in the automated # +distribution of exam participants diff --git a/templates/i18n/changelog/xlsx.de-de-formal.hamlet b/templates/i18n/changelog/xlsx.de-de-formal.hamlet new file mode 100644 index 000000000..48172e006 --- /dev/null +++ b/templates/i18n/changelog/xlsx.de-de-formal.hamlet @@ -0,0 +1,2 @@ +$newline never +Tabellen können nun auch als .xlsx exportiert werden diff --git a/templates/i18n/changelog/xlsx.en-eu.hamlet b/templates/i18n/changelog/xlsx.en-eu.hamlet new file mode 100644 index 000000000..2d604387b --- /dev/null +++ b/templates/i18n/changelog/xlsx.en-eu.hamlet @@ -0,0 +1,2 @@ +$newline never +Tables can now also be exported as .xlsx diff --git a/templates/i18n/exam-auto-occurrence-calculate/de-de-formal.hamlet b/templates/i18n/exam-auto-occurrence-calculate/de-de-formal.hamlet index ef8c4e35b..7db981398 100644 --- a/templates/i18n/exam-auto-occurrence-calculate/de-de-formal.hamlet +++ b/templates/i18n/exam-auto-occurrence-calculate/de-de-formal.hamlet @@ -1,12 +1,11 @@ $newline never

- Bei der Berechnung der Verteilung werden stets alle # - Klausurteilnehmer berücksichtigt, unabhängig davon, ob ihnen bereits # - ein Raum/Termin zugewiesen ist, oder nicht. + Bei der Berechnung der Verteilung werden nur neu zugewiesene # + Klausurteilnehmer berücksichtigt.
- Es werden dennoch nur Klausurteilnehmer anhand der neu berechneten # + Es werden nur Klausurteilnehmer anhand der neu berechneten # Verteilung zugewiesen, die aktuell keinen zugewiesenen Raum/Termin # haben. diff --git a/templates/i18n/exam-auto-occurrence-calculate/en-eu.hamlet b/templates/i18n/exam-auto-occurrence-calculate/en-eu.hamlet index a6b938066..8161a3680 100644 --- a/templates/i18n/exam-auto-occurrence-calculate/en-eu.hamlet +++ b/templates/i18n/exam-auto-occurrence-calculate/en-eu.hamlet @@ -1,18 +1,17 @@ $newline never

- When assignment rules are calculated all exam participants are # - considered, regardless of whether they are already assigned to an # - occurrence/room. + When assignment rules are calculated only newly assigned # + exam participants are considered.
- Nonetheless only exam participants, who are not already assigned to # + Only exam participants, who are not already assigned to # an occurrence/room, will be assigned according to the newly # calculated assignment rules.
- Thus calculating new assignment rules multiple times may lead to a # + Thus, calculating new assignment rules multiple times may lead to a # situation in which the occurrence/room assignments of most # participants do not match the newest assignment rules. diff --git a/templates/i18n/faq/allocation-no-places.de-de-formal.hamlet b/templates/i18n/faq/allocation-no-places.de-de-formal.hamlet index 55c53c6e5..850d54104 100644 --- a/templates/i18n/faq/allocation-no-places.de-de-formal.hamlet +++ b/templates/i18n/faq/allocation-no-places.de-de-formal.hamlet @@ -19,14 +19,28 @@ $newline never

  • - Studienfortschritt (gemessen am Prozentsatz der für den Abschluss # - erforderlichen Veranstaltungen, die bereits bestanden wurden), # - nicht jedoch das Fach- oder Hochschulsemester + Die sog. „zentrale Dringlichkeit“
    - Den aus dem Studienfortschritt errechnet Parameter nennt Uni2work # - die „zentrale Dringlichkeit“. + Als Berechnungsgrundlage wird der Studienfortschritt (gemessen am # + Prozentsatz der für den Abschluss erforderlichen Veranstaltungen, # + die bereits bestanden wurden), nicht jedoch das Fach- oder # + Hochschulsemester herangezogen. # + + So wird z.B. für das Bachelorseminar als Grundqualifikation # + angenommen, dass bereits mindestens 90 ECTS erbracht wurden. + +
    + + An dieser Stelle werden auch einige weitere Faktoren # + berücksichtigt, sodass die zentrale Dringlichkeit die # + „Notwendigkeit“ einen Platz zu erhalten möglichst gut modelliert. # + + Insbesondere wird die Dringlichkeit reduziert, wenn die zum # + Abschluss des Studiums notwendige Anzahl an Kursen der # + entsprechenden Art (also Seminare/Praktika) bereits bestanden # + wurden.
  • diff --git a/templates/i18n/faq/allocation-no-places.en-eu.hamlet b/templates/i18n/faq/allocation-no-places.en-eu.hamlet index d3572f43c..9fa4bfd77 100644 --- a/templates/i18n/faq/allocation-no-places.en-eu.hamlet +++ b/templates/i18n/faq/allocation-no-places.en-eu.hamlet @@ -17,14 +17,26 @@ $newline never not compared between applicants.
  • - Study progress (measured by the number ECTS credits achieved as a # - percentage of those required for graduation) but not (university) # - semesters + The so called “central priority”
    - The parameter calculated from study progress is referred to within # - Uni2work as “central priority”. + Study progress (measured by the number ECTS credits achieved as a # + percentage of those required for graduation) but not (university) # + semesters is used as a basis for the calculation. # + + As an example, bachelor students are expected to have already # + achieved 90 ECTS points to be assigned a seminar. + +
    + + At this point a number of other factors are also considered, such # + that the central priority models the “need” for a place as # + accurately as possible. # + + In particular the priority will be reduced if the requisite number # + of courses of the appropriate type (seminar/practical course) were # + already passed.
  • Ratings of applications by course administrators diff --git a/templates/i18n/implementation/de-de-formal.hamlet b/templates/i18n/implementation/de-de-formal.hamlet index 23876d482..03418198d 100644 --- a/templates/i18n/implementation/de-de-formal.hamlet +++ b/templates/i18n/implementation/de-de-formal.hamlet @@ -29,3 +29,4 @@ $newline never
  • Steffen Jost
  • Gregor Kleen
  • Sarah Vaupel +
  • Wolfgang Witt diff --git a/templates/i18n/implementation/en-eu.hamlet b/templates/i18n/implementation/en-eu.hamlet index ead3e0dbd..ca7ddead0 100644 --- a/templates/i18n/implementation/en-eu.hamlet +++ b/templates/i18n/implementation/en-eu.hamlet @@ -28,3 +28,4 @@ $newline never
  • Steffen Jost
  • Gregor Kleen
  • Sarah Vaupel +
  • Wolfgang Witt diff --git a/templates/mail/allocationResults.hamlet b/templates/mail/allocationResults.hamlet index 8b9039215..72b7fa12d 100644 --- a/templates/mail/allocationResults.hamlet +++ b/templates/mail/allocationResults.hamlet @@ -35,6 +35,13 @@ $newline never $maybe pResults <- participantResults

    _{SomeMessage MsgAllocationResultsStudentTip} + $if not (null studentFaqItems) +

    + _{SomeMessage (MsgAllocationResultsStudentConsultFaq (length studentFaqItems))} +