diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 9780156a1..97f40010b 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -49,6 +49,7 @@ npm install: name: "${CI_JOB_NAME}" expire_in: "1 day" retry: 2 + interruptible: true frontend:build: stage: frontend:build @@ -67,6 +68,7 @@ frontend:build: dependencies: - npm install retry: 2 + interruptible: true frontend:lint: stage: lint @@ -78,6 +80,7 @@ frontend:lint: dependencies: - npm install retry: 2 + interruptible: true yesod:build:dev: stage: yesod:build @@ -105,6 +108,7 @@ yesod:build:dev: variables: - $CI_COMMIT_REF_NAME !~ /^v[0-9].*/ retry: 2 + interruptible: true yesod:build: stage: yesod:build @@ -131,6 +135,8 @@ yesod:build: variables: - $CI_COMMIT_REF_NAME =~ /^v[0-9].*/ retry: 2 + interruptible: true + resource_group: ram frontend:test: stage: test @@ -149,6 +155,7 @@ frontend:test: dependencies: - npm install retry: 2 + interruptible: true hlint:dev: stage: lint @@ -168,6 +175,7 @@ hlint:dev: variables: - $CI_COMMIT_REF_NAME !~ /^v[0-9].*/ retry: 2 + interruptible: true yesod:test:dev: services: @@ -191,6 +199,7 @@ yesod:test:dev: variables: - $CI_COMMIT_REF_NAME !~ /^v[0-9].*/ retry: 2 + interruptible: true hlint: stage: lint @@ -210,6 +219,8 @@ hlint: variables: - $CI_COMMIT_REF_NAME =~ /^v[0-9].*/ retry: 2 + interruptible: true + resource_group: ram yesod:test: services: @@ -233,6 +244,8 @@ yesod:test: variables: - $CI_COMMIT_REF_NAME =~ /^v[0-9].*/ retry: 2 + interruptible: true + resource_group: ram deploy:uniworx3: stage: deploy @@ -254,3 +267,4 @@ deploy:uniworx3: only: variables: - $CI_COMMIT_REF_NAME =~ /^v[0-9].*/ + resource_group: uniworx3 diff --git a/CHANGELOG.md b/CHANGELOG.md index e7395aaf2..c8dd6fa28 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,51 @@ 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. +## [10.6.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v10.5.0...v10.6.0) (2020-01-30) + + +### Bug Fixes + +* date formatting ([0af3b87](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/0af3b87)) +* **exams:** exam-auto-occurrence introduced spurious MappingSpecial ([a1d5479](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a1d5479)) +* exam auto-occurrence by matriculation ([3ef10d9](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3ef10d9)) +* non-exhaustive patterns ([5bff34e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/5bff34e)) + + +### Features + +* exam auto-occurrence nudging ([a91fd7f](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a91fd7f)) +* warnings about multiple terms/schools ([91e1bf9](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/91e1bf9)) + + + +## [10.5.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v10.4.1...v10.5.0) (2020-01-29) + + +### Bug Fixes + +* submission user notification recipients for pseudonym subs ([a7b7bdb](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a7b7bdb)) +* typo ([ad5494e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ad5494e)) + + +### Features + +* **exams:** add warning about multiple automatic distributions ([7fc9fef](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/7fc9fef)) +* **exams:** improve occurrence display ([2b56f26](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/2b56f26)) +* additional exam functions on show page ([214e895](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/214e895)) +* bump changelog ([3bd7520](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3bd7520)) +* **exam:** start work on automatic exam-occurrence assignment ([282df86](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/282df86)) +* **exam:** working prototype of automatic occurrence assignment ([f89545f](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f89545f)) +* **exams:** automatic exam occurrence assignment ([e994faf](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/e994faf)) + + +### Tests + +* fix fakeUser ([62e8c89](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/62e8c89)) +* fix imports ([1626d6b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/1626d6b)) + + + ### [10.4.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v10.4.0...v10.4.1) (2020-01-17) diff --git a/frontend/src/app.sass b/frontend/src/app.sass index 9b842f8a2..2568a5dbb 100644 --- a/frontend/src/app.sass +++ b/frontend/src/app.sass @@ -164,7 +164,7 @@ h4 margin-top: var(--current-header-height) margin-left: 0 - :target::before + :target:not(table :target)::before content: "" display: block height: var(--current-header-height) @@ -249,6 +249,13 @@ button, box-shadow: 0 0 0 0.25rem rgba(50, 115, 220, 0.25) outline: 0 + .buttongroup > & + min-width: 0 + +.buttongroup + display: grid + grid: min-content / auto-flow 1fr + input[type="submit"][disabled], input[type="button"][disabled], button[disabled], diff --git a/ghci.sh b/ghci.sh index 8fbb7aa1e..750d384b8 100755 --- a/ghci.sh +++ b/ghci.sh @@ -20,4 +20,4 @@ if [[ -d .stack-work-ghci ]]; then trap move-back EXIT fi -stack ghci --flag uniworx:dev --flag uniworx:library-only ${@:-uniworx:lib} --ghci-options -fobject-code +stack ghci --flag uniworx:dev --flag uniworx:library-only --ghci-options -fobject-code ${@:-uniworx:lib} diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index ff6ea9383..121137bf3 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -142,9 +142,11 @@ CourseDescriptionTip: Beliebiges Html-Markup ist gestattet CourseHomepageExternal: Externe Homepage CourseShorthand: Kürzel CourseShorthandUnique: Muss nur innerhalb Institut und Semester eindeutig sein. Wird verbatim in die Url der Kursseite übernommen. +CourseSemesterMultipleTip: Es stehen für Sie aktuell mehrere Semester zur Auswahl. Stellen Sie bitte sicher, dass Sie das für den Kurs korrekte Semester wählen. CourseSemester: Semester CourseSchool: Institut CourseSchoolShort: Institut +CourseSchoolMultipleTip: Es stehen für Sie mehrere Institute zur Auswahl. Stellen Sie bitte sicher, dass Sie das für den Kurs korrekte Institut wählen. CourseSecretTip: Anmeldung zum Kurs erfordert Eingabe des Passworts, sofern gesetzt CourseSecretFormat: beliebige Zeichenkette CourseRegisterFromTip: Ohne Datum ist keine eigenständige Anmeldung von Studierenden erlaubt. @@ -1270,7 +1272,11 @@ BreadcrumbExternalExamGrades: Prüfungsleistungen BreadcrumbExternalExamStaffInvite: Einladung zum Prüfer BreadcrumbParticipantsList: Kursteilnehmerlisten BreadcrumbParticipants: Kursteilnehmerliste +<<<<<<< HEAD BreadcrumbStorageKey: Lokalen Schlüssel generieren +======= +BreadcrumbExamAutoOccurrence: Automatische Termin-/Raumverteilung +>>>>>>> master ExternalExamEdit coursen@CourseName examn@ExamName: Bearbeiten: #{coursen}, #{examn} ExternalExamGrades coursen@CourseName examn@ExamName: Prüfungsleistungen: #{coursen}, #{examn} @@ -1534,6 +1540,7 @@ ExamParticipantsRegisterHeading: Prüfungsteilnehmer hinzufügen ExamParticipantsInvited n@Int: #{n} #{pluralDE n "Einladung" "Einladungen"} per E-Mail verschickt ExamName: Name +ExamRoom: Raum ExamTime: Termin ExamsHeading: Prüfungen ExamNameTip: Muss innerhalb der Veranstaltung eindeutig sein @@ -1593,7 +1600,7 @@ ExamBonusRoundNonPositive: Vielfaches, auf das gerundet werden soll, muss positi ExamBonusRoundTip: Bonuspunkte werden kaufmännisch auf ein Vielfaches der angegeben Zahl gerundet. ExamAutomaticOccurrenceAssignment: Termin- bzw. Raumzuteilung -ExamAutomaticOccurrenceAssignmentTip: Sollen Prüfungsteilnehmer automatisch auf die zur Verfügung stehenden Räume bzw. Termine verteilt werden, sich selbstständig einen Raum bzw. Termin aussuchen dürfen oder manuell durch Kursverwalter zugeteilt werden? Manuelle Umverteilung bzw. vorheriges Festlegen von Zuteilungen einzelner Teilnehmer ist trotzdem möglich. +ExamAutomaticOccurrenceAssignmentTip: Sollen Prüfungsteilnehmer automatisch auf die zur Verfügung stehenden Räume bzw. Termine verteilt werden, sich selbstständig einen Raum bzw. Termin aussuchen dürfen oder manuell durch Kursverwalter zugeteilt werden? Die automatische Verteilung muss von einem Kursverwalter ausgelöst werden und geschieht nicht mit Ablauf einer Frist o.Ä.. Manuelle Umverteilung bzw. vorheriges Festlegen von Zuteilungen einzelner Teilnehmer ist somit immer möglich. ExamOccurrenceRule: Verfahren ExamOccurrenceRuleParticipant: Termin- bzw. Raumzuteilungsverfahren ExamRoomManual': Keine automatische bzw. selbstständige Zuteilung @@ -1605,11 +1612,11 @@ ExamRoomFifo': Auswahl durch Teilnehmer bei Anmeldung ExamOccurrence: Termin/Raum ExamNoOccurrence: Kein Termin/Raum ExamNoSuchOccurrence: Termin/Raum existiert nicht (mehr) -ExamOccurrences: Prüfungen +ExamOccurrences: Termine ExamRooms: Räume +ExamTimes: Termine ExamRoomAlreadyExists: Prüfung ist bereits eingetragen ExamRoomName: Interne Bezeichnung -ExamRoom: Raum ExamRoomCapacity: Kapazität ExamRoomCapacityNegative: Kapazität darf nicht negativ sein ExamRoomTime: Termin @@ -2065,6 +2072,7 @@ MailTitleChangeUserDisplayEmail displayName@Text: #{displayName} möchte diese E ExamOfficeOptOutsChanged: Zuständige Prüfungsbeauftragte erfolgreich angepasst +ExamCloseHeading: Klausur abschließen BtnCloseExam: Klausur abschließen ExamCloseTip: Wenn eine Klausur abgeschlossen wird, werden Prüfungsbeauftragte, die im System Noten einsehen, benachrichtigt und danach bei Änderungen informiert. ExamCloseReminder: Bitte schließen Sie die Klausur frühstmöglich, sobald die Prüfungsleistungen sich voraussichtlich nicht mehr ändern werden. Z.B. direkt nach der Klausureinsicht. @@ -2291,3 +2299,17 @@ ExternalExamCourseExists: Der angegebene Kurs existiert im System. Prüfungen so ExternalExamExists coursen@CourseName examn@ExamName: Prüfung „#{examn}“ für Kurs „#{coursen}“ existiert bereits. ExternalExamCreated coursen@CourseName examn@ExamName: Prüfung „#{examn}“ für Kurs „#{coursen}“ erfolgreich angelegt. ExternalExamEdited coursen@CourseName examn@ExamName: Prüfung „#{examn}“ für Kurs „#{coursen}“ erfolgreich bearbeitet. + +ExamAutoOccurrenceHeading: Automatische Raum-/Terminverteilung +ExamAutoOccurrenceMinimizeRooms: Verwendete Räume/Termine minimieren +ExamAutoOccurrenceMinimizeRoomsTip: Soll, für die Aufteilung, die Liste an Räumen/Terminen zunächst reduziert werden, sodass nur so wenige Räume verwendet werden, wie nötig (größte zuerst)? +ExamAutoOccurrenceOccurrencesChangedInFlight: Raumliste wurde verändert +ExamAutoOccurrenceParticipantsAssigned num@Int64: Verteilungstabelle erfolgreich gespeichert und #{num} Teilnehmer zugewiesen +TitleExamAutoOccurrence tid@TermId ssh@SchoolId csh@CourseShorthand examn@ExamName: #{tid} - #{ssh} - #{csh} #{examn}: Automatische Raum-/Terminverteilung +BtnExamAutoOccurrenceCalculate: Verteilungstabelle berechnen +BtnExamAutoOccurrenceAccept: Verteilung akzeptieren +BtnExamAutoOccurrenceNudgeUp: + +BtnExamAutoOccurrenceNudgeDown: - +ExamRoomMappingSurname: Nachnamen beginnend mit +ExamRoomMappingMatriculation: Matrikelnummern endend in +ExamRoomLoad: Auslastung diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 8482e8153..c9c87345a 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -142,9 +142,11 @@ CourseDescriptionTip: You may use arbitrary Html-Markup CourseHomepageExternal: External homepage CourseShorthand: Shorthand CourseShorthandUnique: Needs to be unique within school and semester. Will be used verbatim within the url of the course page. +CourseSemesterMultipleTip: You are currently allowed to select from among multiple semesters. Please ensure that you select the appropriate semester for your course. CourseSemester: Semester CourseSchool: Department CourseSchoolShort: Department +CourseSchoolMultipleTip: You may select from among multiple departments. Please ensure that you select the appropriate department for your course. CourseSecretTip: Enrollment for this course will require the password, if set CourseSecretFormat: Arbitrary string CourseRegisterFromTip: When left empty students will not be able to enrol themselves @@ -1270,6 +1272,7 @@ BreadcrumbExternalExamStaffInvite: Invitation BreadcrumbParticipantsList: Lists of course participants BreadcrumbParticipants: Course participants BreadcrumbStorageKey: Generate storage key +BreadcrumbExamAutoOccurrence: Automatic occurrence/room distribution ExternalExamEdit coursen examn: Edit: #{coursen}, #{examn} ExternalExamGrades coursen examn: Exam achievements: #{coursen}, #{examn} @@ -1532,6 +1535,7 @@ ExamParticipantsRegisterHeading: Add exam participants ExamParticipantsInvited n: #{n} #{pluralEN n "invitation" "invitations"} sent via email ExamName: Name +ExamRoom: Room ExamTime: Time ExamsHeading: Exams ExamNameTip: Needs to be unique within the course @@ -1591,7 +1595,7 @@ ExamBonusRoundNonPositive: Rounding multiple must be positive and greater than z ExamBonusRoundTip: Bonus points are rounded commercially to a multiple of the given number ExamAutomaticOccurrenceAssignment: Selection of occurrences/rooms for/by participants -ExamAutomaticOccurrenceAssignmentTip: Should exam participants be distributed automatically among the configured occurrences/rooms, should they instead be permitted to autonomously choose an occurrence/a room, or should they be assigned to occurrences/rooms manually by course administrators? Manipulation of the distribution and manually assigning participants remains possible. +ExamAutomaticOccurrenceAssignmentTip: Should exam participants be distributed automatically among the configured occurrences/rooms, should they instead be permitted to autonomously choose an occurrence/room, or should they be assigned to occurrences/rooms manually by course administrators? Automatic distribution needs to be triggered by a course administrator. It is not done automatically at a predefined time. Thus manipulation of the distribution and manually assigning participants remains possible. ExamOccurrenceRule: Procedure ExamOccurrenceRuleParticipant: Occurrence/room assignment procedure ExamRoomManual': No automatic or autonomous assignment @@ -1605,9 +1609,9 @@ ExamNoOccurrence: No occurrence/room ExamNoSuchOccurrence: Occurrence/Room does not exist (anymore) ExamOccurrences: Exams ExamRooms: Rooms +ExamTimes: Times ExamRoomAlreadyExists: Occurrence already configured ExamRoomName: Internal name -ExamRoom: Room ExamRoomCapacity: Capacity ExamRoomCapacityNegative: Capacity may not be negative ExamRoomTime: Time @@ -2063,6 +2067,7 @@ MailTitleChangeUserDisplayEmail displayName: #{displayName} wants to publish thi ExamOfficeOptOutsChanged: Successfully adjusted relevant exam offices +ExamCloseHeading: Close exam BtnCloseExam: Close exam ExamCloseTip: When an exam is closed all relevant exam offices, which pull exam achievements from Uni2work, are informed and kept up to date with changes. ExamCloseReminder: Please close the exam as soon as possible, when exam achievements are no longer expected to change e.g. after inspection of the exam has concluced. @@ -2289,3 +2294,17 @@ ExternalExamCourseExists: This course already exists with uni2work. Exams for co ExternalExamExists coursen@CourseName examn@ExamName: Exam “#{examn}” already exists for course “#{coursen}”. ExternalExamCreated coursen@CourseName examn@ExamName: Succesfully created exam “#{examn}” for course “#{coursen}”. ExternalExamEdited coursen@CourseName examn@ExamName: Succesfully edited exam “#{examn}” for course “#{coursen}”. + +ExamAutoOccurrenceHeading: Automatic occurrence/room distribution +ExamAutoOccurrenceMinimizeRooms: Minimize number of occurrences used +ExamAutoOccurrenceMinimizeRoomsTip: Should the list of occurrences/rooms be reduced prior to distribution? Only as many occurrence/rooms as necessary would be used (starting with the biggest). +ExamAutoOccurrenceOccurrencesChangedInFlight: Occurrences/rooms changed +ExamAutoOccurrenceParticipantsAssigned num: Occurrence/room assignment rule saved successfully. Also assigned occurence/room to #{num} #{pluralEN num "participant" "participants"} +TitleExamAutoOccurrence tid ssh csh examn: #{tid} - #{ssh} - #{csh} #{examn}: Automatic occurrence/room distribution +BtnExamAutoOccurrenceCalculate: Calculate assignment rules +BtnExamAutoOccurrenceAccept: Accept assignments +BtnExamAutoOccurrenceNudgeUp: + +BtnExamAutoOccurrenceNudgeDown: - +ExamRoomMappingSurname: Surnames starting with +ExamRoomMappingMatriculation: Matriculation numbers ending in +ExamRoomLoad: Utilisation diff --git a/missing-translations.sh b/missing-translations.sh index 6cfa7daef..080a38620 100755 --- a/missing-translations.sh +++ b/missing-translations.sh @@ -20,6 +20,8 @@ for msgFile (${msgFiles}); do fi done +difference=0 + for msgDirectory (${msgDirectories}); do typeset -a dirMsgFiles dirMsgFiles=() @@ -48,5 +50,9 @@ for msgDirectory (${msgDirectories}); do printf ">>> %s\n" ${msgDirectory} diff --suppress-common-lines -wB ${diffArgs} - ) + ) || difference=1 done + +if [[ $difference -ne 0 ]]; then + exit 1 +fi diff --git a/models/exams.model b/models/exams.model index 5baa6e711..2bdc42cda 100644 --- a/models/exams.model +++ b/models/exams.model @@ -4,6 +4,7 @@ Exam gradingRule ExamGradingRule Maybe bonusRule ExamBonusRule Maybe occurrenceRule ExamOccurrenceRule + examOccurrenceMapping (ExamOccurrenceMapping ExamOccurrenceName) Maybe visibleFrom UTCTime Maybe registerFrom UTCTime Maybe registerTo UTCTime Maybe diff --git a/nixpkgs.nix b/nixpkgs.nix index 783ede000..1d0131f12 100644 --- a/nixpkgs.nix +++ b/nixpkgs.nix @@ -4,6 +4,6 @@ import ((nixpkgs {}).fetchFromGitHub { owner = "NixOS"; repo = "nixpkgs"; - rev = "10e61bf5be57736035ec7a804cb0bf3d083bf2cf"; - sha256 = "0fplfm2zx4vk7gs8bdcxnvzkdmpx2w0llqwf8475z9dz9cl132rm"; + rev = "0d97ef510bdc9d66f1023f970be58fdab2eb87fa"; + sha256 = "00lnna6097wzrlmwqk8bqayh4qd2gz61zcd4yh7amirqflz3z2ll"; }) diff --git a/package-lock.json b/package-lock.json index 951ac6c94..2af106ef1 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "10.4.1", + "version": "10.6.0", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 2c9a90a5c..43d4d1d47 100644 --- a/package.json +++ b/package.json @@ -1,13 +1,13 @@ { "name": "uni2work", - "version": "10.4.1", + "version": "10.6.0", "description": "", "keywords": [], "author": "", "license": "ISC", "scripts": { "start": "npm-run-all frontend:build --parallel \"frontend:build:watch\" \"yesod:start\"", - "test": "run-s frontend:test yesod:test", + "test": "run-s frontend:test yesod:test i18n:test", "lint": "run-s frontend:lint yesod:lint", "build": "run-s frontend:build yesod:build", "cbt": "./cbt.sh", @@ -23,6 +23,7 @@ "frontend:test:watch": "karma start --conf karma.conf.js --single-run false", "frontend:build": "webpack --progress", "frontend:build:watch": "webpack --watch --progress", + "i18n:test": "./missing-translations.sh", "prerelease": "./is-clean.sh && npm run test", "release": "standard-version -a", "postrelease": "git push --follow-tags origin master" diff --git a/package.yaml b/package.yaml index e2e15ec82..c7001df09 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 10.4.1 +version: 10.6.0 dependencies: - base @@ -137,6 +137,8 @@ dependencies: - prometheus-client - prometheus-metrics-ghc - wai-middleware-prometheus + - extended-reals + - rfc5051 other-extensions: - GeneralizedNewtypeDeriving @@ -181,6 +183,8 @@ default-extensions: - DeriveGeneric - DeriveLift - DeriveFunctor + - DeriveFoldable + - DeriveTraversable - DerivingStrategies - DerivingVia - DataKinds diff --git a/routes b/routes index 6019ae09a..9f7a5b92f 100644 --- a/routes +++ b/routes @@ -190,6 +190,7 @@ /register/#ExamOccurrenceName ERegisterOccR POST !exam-occurrence-registrationANDtimeANDcapacityANDcourse-registeredAND¬exam-occurrence-registered !exam-occurrence-registrationANDtimeANDexam-occurrence-registeredAND¬exam-result /grades EGradesR GET POST !exam-office /correct ECorrectR GET POST !exam-correctorANDtime + /assign-occurrences EAutoOccurrenceR POST /apps CApplicationsR GET POST !/apps/files CAppsFilesR GET /apps/#CryptoFileNameCourseApplication CourseApplicationR: diff --git a/shell.nix b/shell.nix index 08c6dde7c..9a3306edc 100644 --- a/shell.nix +++ b/shell.nix @@ -19,7 +19,7 @@ let ''; override = oldAttrs: { - nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ nodejs-13_x postgresql openldap google-chrome exiftool ]) ++ (with haskellPackages; [ stack yesod-bin hlint cabal-install weeder ]); + nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ nodejs-13_x postgresql openldap google-chrome exiftool ]) ++ (with pkgs.haskellPackages; [ stack yesod-bin hlint cabal-install weeder ]); shellHook = '' export PROMPT_INFO="${oldAttrs.name}" diff --git a/src/Database/Persist/Class/Instances.hs b/src/Database/Persist/Class/Instances.hs index 8fc9eb20b..193ea1f16 100644 --- a/src/Database/Persist/Class/Instances.hs +++ b/src/Database/Persist/Class/Instances.hs @@ -1,5 +1,5 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableInstances, GeneralizedNewtypeDeriving #-} module Database.Persist.Class.Instances ( @@ -10,12 +10,15 @@ import ClassyPrelude import Database.Persist.Class import Database.Persist.Types (HaskellName, DBName, PersistValue) import Database.Persist.Types.Instances () +import Database.Persist.Sql import Data.Binary (Binary) import qualified Data.Binary as Binary import qualified Data.Map as Map +import Data.Aeson (ToJSONKey, FromJSONKey) + instance PersistEntity record => Hashable (Key record) where hashWithSalt s = hashWithSalt s . toPersistValue @@ -34,3 +37,7 @@ uniqueToMap = fmap Map.fromList $ zip <$> persistUniqueToFieldNames <*> persistU instance PersistEntity record => Eq (Unique record) where (==) = (==) `on` uniqueToMap + + +deriving newtype instance ToJSONKey (BackendKey SqlBackend) +deriving newtype instance FromJSONKey (BackendKey SqlBackend) diff --git a/src/Foundation.hs b/src/Foundation.hs index eb7c1cca2..7c8878a40 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1942,6 +1942,7 @@ instance YesodBreadcrumbs UniWorX where ERegisterR -> i18nCrumb MsgBreadcrumbExamRegister . Just $ CExamR tid ssh csh examn EShowR ECorrectR -> i18nCrumb MsgBreadcrumbExamCorrect . 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 breadcrumb (CourseR tid ssh csh (TutorialR tutn sRoute)) = case sRoute of TUsersR -> maybeT (i18nCrumb MsgBreadcrumbTutorial . Just $ CourseR tid ssh csh CTutorialListR) $ do diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index df5aad3eb..9fb3215e8 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -953,7 +953,7 @@ postCorrectionsCreateR = do , submissionUserSubmission = subId } forM_ spGroup $ \SheetPseudonym{sheetPseudonymUser} -> do - hoist (hoist lift) . queueDBJob . JobQueueNotification $ NotificationSubmissionUserCreated uid subId + hoist (hoist lift) . queueDBJob . JobQueueNotification $ NotificationSubmissionUserCreated sheetPseudonymUser subId audit $ TransactionSubmissionUserEdit subId sheetPseudonymUser when (genericLength spGroup > maxSize) $ addMessageI Warning $ MsgSheetGroupTooLarge sheetGroupDesc @@ -998,7 +998,7 @@ postCorrectionsCreateR = do , submissionUserSubmission = subId } forM_ spGroup $ \SheetPseudonym{sheetPseudonymUser} -> do - hoist (hoist lift) . queueDBJob . JobQueueNotification $ NotificationSubmissionUserCreated uid subId + hoist (hoist lift) . queueDBJob . JobQueueNotification $ NotificationSubmissionUserCreated sheetPseudonymUser subId audit $ TransactionSubmissionUserEdit subId sheetPseudonymUser when (length spGroup > 1) $ addMessageI Warning $ MsgSheetNoGroupSubmission sheetGroupDesc diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index 9f5bc8c7f..2b1b2fa7e 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -115,16 +115,18 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB return (lecturerSchools, adminSchools, oldSchool) let userSchools = nub . maybe id (:) oldSchool $ lecturerSchools ++ adminSchools - termsField <- case template of - -- Change of term is only allowed if user may delete the course (i.e. no participants) or admin - (Just cform) | (Just cid) <- cfCourseId cform -> liftHandler $ do -- edit existing course - _courseOld@Course{..} <- runDB $ get404 cid - mayEditTerm <- isAuthorized TermEditR True - mayDelete <- isAuthorized (CourseR courseTerm courseSchool courseShorthand CDeleteR) True - return $ if - | (mayEditTerm == Authorized) || (mayDelete == Authorized) -> termsAllowedField - | otherwise -> termsSetField [cfTerm cform] - _allOtherCases -> return termsAllowedField + (termsField, userTerms) <- liftHandler $ case template of + -- Change of term is only allowed if user may delete the course (i.e. no participants) or admin + (Just cform) | (Just cid) <- cfCourseId cform -> do -- edit existing course + _courseOld@Course{..} <- runDB $ get404 cid + mayEditTerm <- isAuthorized TermEditR True + mayDelete <- isAuthorized (CourseR courseTerm courseSchool courseShorthand CDeleteR) True + if + | (mayEditTerm == Authorized) || (mayDelete == Authorized) + -> (termsAllowedField, ) <$> runDB (selectKeysList [TermActive ==. True] []) + | otherwise + -> return (termsSetField [cfTerm cform], [cfTerm cform]) + _allOtherCases -> (termsAllowedField, ) <$> runDB (selectKeysList [TermActive ==. True] []) let miAdd :: ListPosition -> Natural -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId)))) miAdd _ _ nudge btn = Just $ \csrf -> do @@ -258,13 +260,18 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB -- let autoUnzipInfo = [|Entpackt hochgeladene Zip-Dateien (*.zip) automatisch und fügt den Inhalt dem Stamm-Verzeichnis der Abgabe hinzu. TODO|] + multipleSchoolsMsg <- messageI Warning MsgCourseSchoolMultipleTip + multipleTermsMsg <- messageI Warning MsgCourseSemesterMultipleTip + (result, widget) <- flip (renderAForm FormStandard) html $ CourseForm <$> pure (cfCourseId =<< template) <*> areq (textField & cfStrip & cfCI) (fslI MsgCourseName) (cfName <$> template) <*> areq (textField & cfStrip & cfCI) (fslpI MsgCourseShorthand "ProMo, LinAlg1, AlgoDat, Ana2, EiP, …" -- & addAttr "disabled" "disabled" & setTooltip MsgCourseShorthandUnique) (cfShort <$> template) + <* bool (pure ()) (aformMessage multipleSchoolsMsg) (length userSchools > 1) <*> areq (schoolFieldFor userSchools) (fslI MsgCourseSchool) (cfSchool <$> template) + <* bool (pure ()) (aformMessage multipleTermsMsg) (length userTerms > 1) <*> areq termsField (fslI MsgCourseSemester) (cfTerm <$> template) <*> aopt htmlField (fslpI MsgCourseDescription (mr MsgCourseDescriptionPlaceholder) & setTooltip MsgCourseDescriptionTip) (cfDesc <$> template) diff --git a/src/Handler/Exam.hs b/src/Handler/Exam.hs index c48854461..ef54cc1ef 100644 --- a/src/Handler/Exam.hs +++ b/src/Handler/Exam.hs @@ -12,3 +12,4 @@ import Handler.Exam.Show as Handler.Exam import Handler.Exam.Users as Handler.Exam import Handler.Exam.AddUser as Handler.Exam import Handler.Exam.Correct as Handler.Exam +import Handler.Exam.AutoOccurrence as Handler.Exam diff --git a/src/Handler/Exam/AutoOccurrence.hs b/src/Handler/Exam/AutoOccurrence.hs new file mode 100644 index 000000000..6354b2dcd --- /dev/null +++ b/src/Handler/Exam/AutoOccurrence.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Handler.Exam.AutoOccurrence + ( examAutoOccurrenceCalculateWidget + , postEAutoOccurrenceR + ) where + +import Import +import Handler.Utils +import Handler.Utils.Exam + +import qualified Data.Map as Map + +import qualified Database.Esqueleto as E +import Database.Persist.Sql (updateWhereCount) + + +newtype ExamAutoOccurrenceCalculateForm = ExamAutoOccurrenceCalculateForm + { eaofConfig :: ExamAutoOccurrenceConfig + } deriving stock (Eq, Ord, Read, Show, Generic, Typeable) + deriving newtype (Default, FromJSON, ToJSON) + +makeLenses_ ''ExamAutoOccurrenceCalculateForm + +data ExamAutoOccurrenceAcceptForm = ExamAutoOccurrenceAcceptForm + { eaofMapping :: Maybe (ExamOccurrenceMapping ExamOccurrenceId) + , eaofAssignment :: Map UserId (Maybe ExamOccurrenceId) + } deriving (Eq, Ord, Read, Show, Generic, Typeable) + +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + } ''ExamAutoOccurrenceAcceptForm + +data ExamAutoOccurrenceButton + = BtnExamAutoOccurrenceCalculate + | BtnExamAutoOccurrenceAccept + | BtnExamAutoOccurrenceNudgeUp | BtnExamAutoOccurrenceNudgeDown + 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 + btnClasses BtnExamAutoOccurrenceNudgeUp = [BCIsButton] + btnClasses BtnExamAutoOccurrenceNudgeDown = [BCIsButton] + btnClasses _ = [BCIsButton, BCPrimary] + + +examAutoOccurrenceCalculateForm :: ExamAutoOccurrenceCalculateForm -> Form ExamAutoOccurrenceCalculateForm +examAutoOccurrenceCalculateForm ExamAutoOccurrenceCalculateForm{ eaofConfig } + = identifyForm FIDExamAutoOccurrenceCalculate . renderAForm FormStandard $ ExamAutoOccurrenceCalculateForm <$> eaocForm + where + eaocForm = + (set _eaocMinimizeRooms <$> apopt checkBoxField (fslI MsgExamAutoOccurrenceMinimizeRooms & setTooltip MsgExamAutoOccurrenceMinimizeRoomsTip) (Just $ eaofConfig ^. _eaocMinimizeRooms)) + <*> pure def + +examAutoOccurrenceNudgeForm :: ExamOccurrenceId -> Maybe ExamAutoOccurrenceCalculateForm -> Form ExamAutoOccurrenceCalculateForm +examAutoOccurrenceNudgeForm occId protoForm html = do + cID <- encrypt occId + (btnRes, wgt) <- identifyForm (FIDExamAutoOccurrenceNudge $ ciphertext cID) (buttonForm' [BtnExamAutoOccurrenceNudgeUp, BtnExamAutoOccurrenceNudgeDown]) html + oldDataRes <- globalPostParamField PostExamAutoOccurrencePrevious secretJsonField + oldDataId <- newIdent + + let protoForm' = fromMaybe def $ oldDataRes <|> protoForm + genForm btn = protoForm' & _eaofConfig . _eaocNudge %~ Map.insertWith (+) occId n + where n = case btn of + BtnExamAutoOccurrenceNudgeUp -> 1 + BtnExamAutoOccurrenceNudgeDown -> -1 + _other -> 0 + 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 + return (acceptRes *> confirmDataRes, toWidget html <> fvInput confirmDataView <> acceptView) + + +examAutoOccurrenceCalculateWidget :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Widget +examAutoOccurrenceCalculateWidget tid ssh csh examn = do + (formView, formEncoding) <- liftHandler . generateFormPost $ examAutoOccurrenceCalculateForm def + + wrapForm' BtnExamAutoOccurrenceCalculate $(i18nWidgetFile "exam-auto-occurrence-calculate") def + { formAction = Just . SomeRoute $ CExamR tid ssh csh examn EAutoOccurrenceR + , formEncoding + } + + +postEAutoOccurrenceR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html +postEAutoOccurrenceR tid ssh csh examn = do + (Entity eId Exam{ examOccurrenceRule }, occurrences) <- 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, examOccurrenceCapacity)) occurrences + (eaofMapping, eaofAssignment) = examAutoOccurrence eId examOccurrenceRule eaofConfig occurrences' participants' + return $ Just ExamAutoOccurrenceAcceptForm{..} + + ((confirmRes, confirmView), confirmEncoding) <- runFormPost $ examAutoOccurrenceAcceptForm calcResult + let confirmWidget = wrapForm confirmView def + { formAction = Just . SomeRoute $ CExamR tid ssh csh examn EAutoOccurrenceR + , formEncoding = confirmEncoding + , formSubmit = FormNoSubmit + } + + formResult confirmRes $ \ExamAutoOccurrenceAcceptForm{..} -> do + Sum assignedCount <- runDB $ do + let eaofMapping'' :: Maybe (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 + update eId [ ExamExamOccurrenceMapping =. eaofMapping' ] + fmap fold . iforM eaofAssignment $ \pid occ -> case occ of + Just _ -> Sum <$> updateWhereCount [ ExamRegistrationExam ==. eId, ExamRegistrationUser ==. pid, ExamRegistrationOccurrence ==. Nothing ] [ ExamRegistrationOccurrence =. occ ] + Nothing -> return mempty + addMessageI Success $ MsgExamAutoOccurrenceParticipantsAssigned assignedCount + redirect $ CExamR tid ssh csh examn EUsersR + + let nudgeWgt = nudgeRes <&> \((_, nudgeView), nudgeEncoding) -> + wrapForm nudgeView def + { formAction = Just . SomeRoute $ CExamR tid ssh csh examn EAutoOccurrenceR + , formEncoding = nudgeEncoding + , formSubmit = FormNoSubmit + , formAttrs = [("class", "buttongroup")] + } + + ExamAutoOccurrenceAcceptForm{..} <- maybe (redirect $ CExamR tid ssh csh examn EUsersR) return calcResult + + let heading = MsgTitleExamAutoOccurrence tid ssh csh examn + mappingWgt + = let occLoads :: Map ExamOccurrenceId Natural + occLoads = Map.fromListWith (+) . mapMaybe (\(_, mOcc) -> (, 1) <$> mOcc) $ Map.toList eaofAssignment + + occLoad = fromMaybe 0 . flip Map.lookup occLoads + + occMappingRule = examOccurrenceMappingRule <$> eaofMapping + + loadProp curr max' + | max' /= 0 = MsgProportion (toMessage curr) (toMessage max') (toRational curr / toRational max') + | otherwise = MsgProportionNoRatio (toMessage curr) (toMessage max') + + occMapping occId = examOccurrenceMappingDescriptionWidget <$> occMappingRule <*> (Map.lookup occId . examOccurrenceMappingMapping =<< eaofMapping) + in $(widgetFile "widgets/exam-occurrence-mapping") + + siteLayoutMsg heading $ do + setTitleI heading + $(widgetFile "exam/auto-occurrence-confirm") diff --git a/src/Handler/Exam/Edit.hs b/src/Handler/Exam/Edit.hs index 52d90559f..ae40a86c3 100644 --- a/src/Handler/Exam/Edit.hs +++ b/src/Handler/Exam/Edit.hs @@ -35,6 +35,7 @@ postEEditR tid ssh csh examn = do , examGradingRule = efGradingRule , examBonusRule = efBonusRule , examOccurrenceRule = efOccurrenceRule + , examExamOccurrenceMapping = examExamOccurrenceMapping oldExam , examVisibleFrom = efVisibleFrom , examRegisterFrom = efRegisterFrom , examRegisterTo = efRegisterTo diff --git a/src/Handler/Exam/New.hs b/src/Handler/Exam/New.hs index d4e6582a7..7cbfdb32d 100644 --- a/src/Handler/Exam/New.hs +++ b/src/Handler/Exam/New.hs @@ -32,6 +32,7 @@ postCExamNewR tid ssh csh = do , examGradingRule = efGradingRule , examBonusRule = efBonusRule , examOccurrenceRule = efOccurrenceRule + , examExamOccurrenceMapping = Nothing , examVisibleFrom = efVisibleFrom , examRegisterFrom = efRegisterFrom , examRegisterTo = efRegisterTo diff --git a/src/Handler/Exam/Show.hs b/src/Handler/Exam/Show.hs index e072b9e71..e1bec059e 100644 --- a/src/Handler/Exam/Show.hs +++ b/src/Handler/Exam/Show.hs @@ -5,6 +5,10 @@ module Handler.Exam.Show import Import import Handler.Exam.Register +import Handler.Exam.AutoOccurrence (examAutoOccurrenceCalculateWidget) + +import Handler.ExamOffice.Exam (examCloseWidget) + import Data.Map ((!?)) import qualified Data.Map as Map @@ -22,7 +26,7 @@ getEShowR tid ssh csh examn = do cTime <- liftIO getCurrentTime mUid <- maybeAuthId - (Entity _ Exam{..}, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, bonus, occurrences, (registered, mayRegister), lecturerInfoShown) <- runDB $ do + (Entity eId Exam{..}, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, bonus, occurrences, (registered, mayRegister), lecturerInfoShown) <- runDB $ do exam@(Entity eId Exam{..}) <- fetchExam tid ssh csh examn let examVisible = NTop (Just cTime) >= NTop examVisibleFrom @@ -76,8 +80,10 @@ getEShowR tid ssh csh examn = do let occurrenceNamesShown = lecturerInfoShown partNumbersShown = lecturerInfoShown examClosedShown = lecturerInfoShown + showCloseWidget = lecturerInfoShown + showAutoOccurrenceCalculateWidget = lecturerInfoShown - sumMaxPoints = sum [ fromRational examPartWeight * mPoints | Entity _ ExamPart{..} <- examParts, let Just mPoints = examPartMaxPoints ] + sumMaxPoints = sum [ fromRational examPartWeight * mPoints | Entity _ ExamPart{..} <- examParts, mPoints <- examPartMaxPoints ^.. _Just ] noBonus = fromMaybe False $ do guardM $ bonusOnlyPassed <$> examBonusRule @@ -97,6 +103,10 @@ getEShowR tid ssh csh examn = do fmap (Just occId, ) . hasWriteAccessTo . CExamR tid ssh csh examName $ ERegisterOccR examOccurrenceName let examTimes = all (\(Entity _ ExamOccurrence{..}, _) -> Just examOccurrenceStart == examStart && examOccurrenceEnd == examEnd) occurrences + examRoom = do + Entity _ primeOcc <- occurrences ^? _head . _1 + guard $ all (\(Entity _ occ, _) -> examOccurrenceRoom occ == examOccurrenceRoom primeOcc) occurrences + return $ examOccurrenceRoom primeOcc registerWidget mOcc | isRegistered <- is _Just $ join registered , examOccurrenceRule /= ExamRoomFifo || (isRegistered && not (any snd occurrences)) @@ -145,6 +155,9 @@ getEShowR tid ssh csh examn = do showAchievedPoints = not $ null results showOccurrenceRegisterColumn = occurrenceAssignmentsShown || (mayRegister && examOccurrenceRule == ExamRoomFifo) markUnregisteredOccurrences mOcc = occurrenceAssignmentsShown && hasRegistration && isn't _Just (registerWidget mOcc) + showOccurrenceMappingColumn = examOccurrenceRuleAutomatic examOccurrenceRule && occurrenceAssignmentsShown && is _Just examExamOccurrenceMapping + + closeWgt <- examCloseWidget (SomeRoute $ CExamR tid ssh csh examn EUsersR) eId let heading = prependCourseTitle tid ssh csh $ CI.original examName @@ -161,4 +174,7 @@ getEShowR tid ssh csh examn = do examBonusW :: ExamBonusRule -> Widget examBonusW bonusRule = $(widgetFile "widgets/bonusRule") + + occurrenceMapping :: ExamOccurrenceName -> Maybe Widget + occurrenceMapping occName = examOccurrenceMappingDescriptionWidget <$> fmap examOccurrenceMappingRule examExamOccurrenceMapping <*> (fmap examOccurrenceMappingMapping examExamOccurrenceMapping >>= Map.lookup occName) $(widgetFile "exam-show") diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index 39624ab04..eee9a53b0 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -11,6 +11,8 @@ import Handler.Utils.Exam import Handler.Utils.Users import Handler.Utils.Csv +import Handler.Exam.AutoOccurrence (examAutoOccurrenceCalculateWidget) + import Handler.ExamOffice.Exam (examCloseWidget) import qualified Database.Esqueleto as E @@ -390,7 +392,7 @@ 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, bonus) <- runDB $ do + (((Any computedValues, registrationResult), examUsersTable), Entity eId examVal@Exam{..}, bonus) <- runDB $ do exam@(Entity eid examVal@Exam{..}) <- fetchExam tid ssh csh examn examParts <- selectList [ExamPartExam ==. eid] [Asc ExamPartName] bonus <- examBonus exam diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs index dd9742e39..129d11b7e 100644 --- a/src/Handler/Utils/Exam.hs +++ b/src/Handler/Utils/Exam.hs @@ -1,8 +1,14 @@ +{-# OPTIONS_GHC -fno-warn-deprecations #-} + module Handler.Utils.Exam ( fetchExamAux , fetchExam, fetchExamId, fetchCourseIdExamId, fetchCourseIdExam , examBonus, examBonusPossible, examBonusAchieved , examResultBonus, examGrade + , ExamAutoOccurrenceConfig + , eaocMinimizeRooms, eaocFinenessCost, eaocNudge, eaocNudgeSize + , _eaocMinimizeRooms, _eaocFinenessCost, _eaocNudge, _eaocNudgeSize + , examAutoOccurrence ) where import Import.NoFoundation @@ -16,8 +22,32 @@ import Database.Esqueleto.Utils.TH import qualified Data.Conduit.List as C import qualified Data.Map as Map +import qualified Data.Set as Set import Data.Fixed (Fixed(..)) +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 Control.Monad.ST (ST, runST) + +import Data.Array (Array) +import qualified Data.Array as Array + +import Data.Array.ST (STArray, STUArray) +import qualified Data.Array.ST as ST + +import Data.List (findIndex, unfoldr) +import qualified Data.List as List + +import Data.ExtendedReal + +import qualified Data.Char as Char + +import qualified Data.RFC5051 as RFC5051 fetchExamAux :: ( SqlBackendCanRead backend @@ -160,4 +190,376 @@ examGrade Exam{..} mBonus (otoList -> results) where lowerBounds :: [(ExamGrade, Points)] lowerBounds = zip [Grade40, Grade37 ..] examGradingKey' + +data ExamAutoOccurrenceConfig = ExamAutoOccurrenceConfig + { eaocMinimizeRooms :: Bool + , eaocFinenessCost :: Rational -- ^ Cost factor incentivising shorter common prefixes on breaks between rooms + , eaocNudge :: Map ExamOccurrenceId Integer + , eaocNudgeSize :: Rational + } deriving (Eq, Ord, Read, Show, Generic, Typeable) + +instance Default ExamAutoOccurrenceConfig where + def = ExamAutoOccurrenceConfig + { eaocMinimizeRooms = False + , eaocFinenessCost = 0.2 + , eaocNudge = Map.empty + , eaocNudgeSize = 0.05 + } + +makeLenses_ ''ExamAutoOccurrenceConfig + +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + } ''ExamAutoOccurrenceConfig + +examAutoOccurrence :: forall seed. + Hashable seed + => seed + -> ExamOccurrenceRule + -> ExamAutoOccurrenceConfig + -> Map ExamOccurrenceId Natural + -> Map UserId (User, Maybe ExamOccurrenceId) + -> (Maybe (ExamOccurrenceMapping ExamOccurrenceId), Map UserId (Maybe ExamOccurrenceId)) +examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences users + | sum occurrences < usersCount + || sum occurrences <= 0 + || Map.null users + = nullResult + | 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 + ) + _ | Just (postprocess -> (resMapping, result)) <- bestOption + -> ( Just $ ExamOccurrenceMapping rule resMapping + , Map.unionWith (<|>) (view _2 <$> users) result + ) + _ -> nullResult + where + nullResult = (Nothing, view _2 <$> users) + usersCount :: forall a. Num a => a + usersCount = getSum $ foldMap (Sum . fromIntegral . Set.size) users' + + users' :: Map [CI Char] (Set UserId) + -- ^ Finest partition of users + users' = case rule of + ExamRoomSurname + -> Map.fromListWith Set.union + [ (map CI.mk $ unpack userSurname, Set.singleton uid) + | (uid, (User{..}, Nothing)) <- Map.toList users + , not $ null userSurname + ] + ExamRoomMatriculation + -> let matrUsers + = Map.fromListWith Set.union + [ (map CI.mk $ unpack matriculation', Set.singleton uid) + | (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 + where + accF :: (Natural, [(ExamOccurrenceId, Natural)]) + -> (ExamOccurrenceId, Natural) + -> (Natural, [(ExamOccurrenceId, Natural)]) + accF acc@(accSize, accOccs) occ@(_, occSize) + | accSize >= usersCount + = acc + | otherwise + = ( accSize + occSize + , occ : accOccs + ) + + distribute :: forall wordId lineId cost. + _ + => [(wordId, Natural)] -- ^ Word sizes (in order) + -> [(lineId, Natural)] -- ^ Line sizes (in order) + -> (lineId -> Integer) -- ^ Nudge + -> (wordId -> wordId -> Extended Rational) -- ^ Break cost + -> Maybe (cost, [(lineId, [wordId])]) + -- ^ Distribute the given items (@wordId@s) with associated size in + -- contiguous blocks into the given buckets (@lineId@s) such that they are + -- filled as evenly as possible (proportionally) + -- + -- Return a cost scaled to item-size squared + -- + -- See under \"Shortest Path\" + distribute wordLengths lineLengths lineNudge breakCost + | null wordLengths = Just (0, [ (l, []) | (l, _) <- lineLengths ]) + | null lineLengths = Nothing + | otherwise = let (cost, result) = distribute' + in case cost of + Finite c -> Just (fromInteger $ round c, result) + _other -> Nothing + where + longestLine :: Natural + -- ^ For scaling costs + longestLine = maximum . mapNonNull (view _2) $ impureNonNull lineLengths + + wordMap :: Map wordId Natural + wordMap = Map.fromListWith (+) wordLengths + + wordIx :: Iso' wordId Int + wordIx = iso (\wId -> let Just ix' = findIndex (== wId) $ Array.elems collapsedWords + in ix' + ) + (collapsedWords Array.!) + + collapsedWords :: Array Int wordId + collapsedWords = Array.array + (0, pred $ Map.size wordMap) + [ (ix', wId) + | wId <- Map.keys wordMap + , let Just ix' = findIndex ((== wId) . view _1) wordLengths + ] + + offsets :: Array Int Natural + offsets = Array.listArray bounds $ unfoldr (uncurry accOffsets) (0, 0) + where + accOffsets :: Natural -> Int -> Maybe (Natural, (Natural, Int)) + accOffsets accSize ix' + | ix' <= 0 = Just (0, (0, 1)) + | Array.inRange bounds ix' = let newSize = accSize + wordMap Map.! (wordIx # pred ix') + in Just (newSize, (newSize, succ ix')) + | otherwise = Nothing + + bounds = (0, Map.size wordMap) + + distribute' :: (Extended Rational, [(lineId, [wordId])]) + distribute' = runST $ do + 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 + | j <= Map.size wordMap = do + let + walkBack 0 = return 0 + walkBack i'' = fmap succ $ walkBack =<< ST.readArray breaks i'' + lineIx <- walkBack i + let (l, potWidth) + | lineIx >= 0 + , lineIx < length lineLengths + = over _1 Just $ lineLengths List.!! lineIx + | otherwise + = (Nothing, 0) + w = offsets Array.! j - offsets Array.! i + prevMin <- ST.readArray minima i + let cost = prevMin + widthCost l potWidth w + breakCost' + breakCost' + | j < Map.size wordMap + , j > 0 + = breakCost (wordIx # pred j) (wordIx # j) + | otherwise + = 0 + -- traceM $ show ( i + -- , j + -- , potWidth + -- , w + -- , (fromRational :: Rational -> Centi) <$> prevMin + -- , (fromRational :: Rational -> Centi) <$> widthCost potWidth w + -- , (fromRational :: Rational -> Centi) <$> breakCost' + -- ) + when (isFinite cost) $ do + minCost <- ST.readArray minima j + when (cost < minCost) $ do + ST.writeArray minima j cost + ST.writeArray breaks j i + go i' $ succ j + | otherwise = return () + in go i' $ succ i' + -- traceM . show . map (fmap (fromRational :: Rational -> Centi)) =<< ST.getElems minima + -- traceM . show =<< ST.getElems breaks + + 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 + in accumResult 0 (Map.size wordMap) (0, []) + + + 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 + where + optimumRatio = ((%) `on` fromIntegral . sum) (map (view _2) wordLengths) (map (view _2) lineLengths) + optimumRatio' = maybe 0 (fromIntegral . lineNudge) l * eaocNudgeSize + optimumRatio + + 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' + + + lcp :: Eq a => [a] -> [a] -> [a] + -- ^ Longest common prefix + lcp [] _ = [] + lcp _ [] = [] + lcp (a:as) (b:bs) + | a == b = a:lcp as bs + | otherwise = [] + + lineNudges = fromMaybe 0 . flip Map.lookup eaocNudge + + bestOption :: Maybe [(ExamOccurrenceId, [[CI Char]])] + bestOption = case rule of + ExamRoomSurname -> do + (_cost, res) <- distribute (sortBy (RFC5051.compareUnicode `on` toListOf (_1 . folded . to CI.foldedCase)) . Map.toAscList $ fromIntegral . Set.size <$> users') occurrences' lineNudges charCost + -- traceM $ show cost + return res + ExamRoomMatriculation -> 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 + + maximumFineness = fromIntegral . F.minimum . Set.map length $ Map.keysSet users' + + resultFineness :: [(ExamOccurrenceId, [[CI Char]])] -> Natural + resultFineness (map (view _2) -> res) + | Just res' <- fromNullable res + = maybe 0 maximum . fromNullable $ zipWith transFineness res (tail res') + | otherwise = 0 + where + transFineness :: [[CI Char]] -> [[CI Char]] -> Natural + transFineness nsA nsB + | Just maxA <- nsA ^? _last + , Just minB <- nsB ^? _head + = succ . List.genericLength $ maxA `lcp` minB + | otherwise + = 0 + + genResults f + | f > maximumFineness = [] + | otherwise = + let mRes = distributeFine f + in (mRes ^.. _Just) ++ bool [] (genResults $ succ f) (maybe True (>= f) $ mRes ^? _Just . _2 . to resultFineness) + + (_cost, res) <- fmap (minimumBy . comparing $ view _1) . fromNullable $ genResults 1 + return res + _other -> Nothing + + postprocess :: [(ExamOccurrenceId, [[CI Char]])] + -> ( Map ExamOccurrenceId (Set ExamOccurrenceMappingDescription) + , Map UserId (Maybe ExamOccurrenceId) + ) + postprocess result = (resultAscList, resultUsers) + where + resultAscList = pad . Map.fromListWith Set.union . accRes (pure <$> Set.lookupMin rangeAlphabet) $ (\r -> traceShow (over (traverse . _2 . traverse . traverse) CI.original r) r) 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) + | 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) + resultUsers = Map.fromList $ do + (occId, buckets) <- result + let matchWord b b' = case rule of + ExamRoomMatriculation + -> b `isSuffixOf` b' + _other + -> b == b' + 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 diff --git a/src/Handler/Utils/Widgets.hs b/src/Handler/Utils/Widgets.hs index 994fe893d..be3e0424d 100644 --- a/src/Handler/Utils/Widgets.hs +++ b/src/Handler/Utils/Widgets.hs @@ -8,6 +8,8 @@ import Text.Hamlet (shamletFile) import Handler.Utils.DateTime +import qualified Data.Char as Char + --------- -- Simple utilities for consistent display @@ -102,3 +104,14 @@ i18n :: forall m msg. , RenderMessage (HandlerSite m) msg ) => msg -> m () i18n = toWidget . (SomeMessage :: msg -> SomeMessage (HandlerSite m)) + + +examOccurrenceMappingDescriptionWidget :: ExamOccurrenceRule -> Set ExamOccurrenceMappingDescription -> Widget +examOccurrenceMappingDescriptionWidget rule descriptions = $(widgetFile "widgets/exam-occurrence-mapping-description") + where + titleCase = over _head Char.toUpper . map CI.foldedCase + doPrefix + | ExamRoomMatriculation <- rule + = False + | otherwise + = True diff --git a/src/Model.hs b/src/Model.hs index f59815c79..3821126b6 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -37,6 +37,12 @@ share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll submissionRatingDone :: Submission -> Bool submissionRatingDone Submission{..} = isJust submissionRatingTime + +deriving newtype instance ToJSONKey UserId +deriving newtype instance FromJSONKey UserId +deriving newtype instance ToJSONKey ExamOccurrenceId +deriving newtype instance FromJSONKey ExamOccurrenceId + -- ToMarkup and ToMessage instances for displaying selected database primary keys instance ToMarkup (Key School) where diff --git a/src/Model/Types/Exam.hs b/src/Model/Types/Exam.hs index 4fa1817ac..47482c498 100644 --- a/src/Model/Types/Exam.hs +++ b/src/Model/Types/Exam.hs @@ -11,6 +11,14 @@ module Model.Types.Exam , _examResult , ExamBonusRule(..) , ExamOccurrenceRule(..) + , examOccurrenceRuleAutomatic + , ExamOccurrenceMappingDescription(..) + , _eaomrStart, _eaomrEnd, _eaomrSpecial + , _ExamOccurrenceMappingRange, _ExamOccurrenceMappingSpecial + , ExamOccurrenceMapping(..) + , _examOccurrenceMappingRule + , _examOccurrenceMappingMapping + , traverseExamOccurrenceMapping , ExamGrade(..) , numberGrade , ExamGradeDefCenter(..) @@ -27,6 +35,8 @@ import Import.NoModel import Model.Types.Common import qualified Data.Text as Text +import qualified Data.Map as Map +import qualified Data.Set as Set import Utils.Lens.TH @@ -43,6 +53,8 @@ import Text.Blaze (ToMarkup(..)) import qualified Data.Foldable +import Data.Aeson (genericToJSON, genericParseJSON) + data ExamResult' res = ExamAttended { examResult :: res } | ExamNoShow @@ -151,6 +163,51 @@ deriveJSON defaultOptions , tagSingleConstructors = True } ''ExamOccurrenceRule derivePersistFieldJSON ''ExamOccurrenceRule +makePrisms ''ExamOccurrenceRule + +examOccurrenceRuleAutomatic :: ExamOccurrenceRule -> Bool +examOccurrenceRuleAutomatic x = or $ map ($ x) + [ is _ExamRoomSurname + , is _ExamRoomMatriculation + , is _ExamRoomRandom + ] + +data ExamOccurrenceMappingDescription + = ExamOccurrenceMappingRange { eaomrStart, eaomrEnd :: [CI Char] } + | ExamOccurrenceMappingSpecial { eaomrSpecial :: [CI Char] } + deriving (Eq, Ord, Read, Show, Generic, Typeable) +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + , constructorTagModifier = camelToPathPiece' 3 + } ''ExamOccurrenceMappingDescription + +makeLenses_ ''ExamOccurrenceMappingDescription +makePrisms ''ExamOccurrenceMappingDescription + +data ExamOccurrenceMapping roomId = ExamOccurrenceMapping + { examOccurrenceMappingRule :: ExamOccurrenceRule + , examOccurrenceMappingMapping :: Map roomId (Set ExamOccurrenceMappingDescription) + } deriving (Eq, Ord, Read, Show, Generic, Typeable) +instance ToJSONKey roomId => ToJSON (ExamOccurrenceMapping roomId) where + toJSON = genericToJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 3 + , constructorTagModifier = camelToPathPiece' 1 + , tagSingleConstructors = False + } +instance (FromJSONKey roomId, Ord roomId) => FromJSON (ExamOccurrenceMapping roomId) where + parseJSON = genericParseJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 3 + , constructorTagModifier = camelToPathPiece' 1 + , tagSingleConstructors = False + } +derivePersistFieldJSON ''ExamOccurrenceMapping + +makeLenses_ ''ExamOccurrenceMapping + +traverseExamOccurrenceMapping :: Ord roomId' + => Traversal (ExamOccurrenceMapping roomId) (ExamOccurrenceMapping roomId') roomId roomId' +traverseExamOccurrenceMapping = _examOccurrenceMappingMapping . iso Map.toList (Map.fromListWith Set.union) . traverse . _1 + data ExamGrade = Grade50 diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 52024081d..78af6cfaf 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -229,6 +229,7 @@ data FormIdentifier | FIDUserAuthMode | FIDAllUsersAction | FIDLanguage + | FIDExamAutoOccurrenceCalculate | FIDExamAutoOccurrenceConfirm | FIDExamAutoOccurrenceNudge UUID deriving (Eq, Ord, Read, Show) instance PathPiece FormIdentifier where diff --git a/src/Utils/Parameters.hs b/src/Utils/Parameters.hs index 96fe65fd9..f78926740 100644 --- a/src/Utils/Parameters.hs +++ b/src/Utils/Parameters.hs @@ -57,6 +57,7 @@ data GlobalPostParam = PostFormIdentifier | PostBearer | PostDBCsvImportAction | PostLoginDummy + | PostExamAutoOccurrencePrevious deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) instance Universe GlobalPostParam diff --git a/stack.yaml b/stack.yaml index 2764abce4..d0852e051 100644 --- a/stack.yaml +++ b/stack.yaml @@ -67,5 +67,7 @@ extra-deps: - prometheus-metrics-ghc-1.0.0 - wai-middleware-prometheus-1.0.0 + - extended-reals-0.2.3.0 + resolver: lts-13.21 allow-newer: true diff --git a/stack.yaml.lock b/stack.yaml.lock index e67cca322..8e2842628 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -277,6 +277,13 @@ packages: sha256: 6d64803c639ed4c7204ea6fab0536b97d3ee16cdecb9b4a883cd8e56d3c61402 original: hackage: wai-middleware-prometheus-1.0.0 +- completed: + hackage: extended-reals-0.2.3.0@sha256:78a498d703fffcecfba8e66cfb3e64c4307b2c126a442f6d28cfdd997829f1bf,1563 + pantry-tree: + size: 398 + sha256: 29629bb0ac41c49671b7f792e540165ee091eb24ffd0eaff229a2f40cc03f3af + original: + hackage: extended-reals-0.2.3.0 snapshots: - completed: size: 498180 diff --git a/start.sh b/start.sh index 49f9e79f3..07cf5940a 100755 --- a/start.sh +++ b/start.sh @@ -25,4 +25,6 @@ if [[ -d .stack-work-run ]]; then trap move-back EXIT fi -stack exec -- yesod devel $@ +# stack exec -- yesod devel $@ + +yesod devel $@ diff --git a/templates/exam-show.hamlet b/templates/exam-show.hamlet index 3652474ef..48754437c 100644 --- a/templates/exam-show.hamlet +++ b/templates/exam-show.hamlet @@ -47,6 +47,9 @@ $maybe desc <- examDescription $maybe publishAssignments <- examPublishOccurrenceAssignments
_{MsgExamPublishOccurrenceAssignmentsParticipant}
^{formatTimeW SelFormatDateTime publishAssignments} + $maybe room <- examRoom +
_{MsgExamRoom} +
#{room} $if examTimes
_{MsgExamTime}
@@ -88,14 +91,29 @@ $maybe desc <- examDescription
_{MsgExamRegistration}
^{registerWdgt} +$if showCloseWidget && is _Nothing examClosed +
+

+ _{MsgExamCloseHeading} + \ ^{isVisible False} + ^{closeWgt} +$if examOccurrenceRuleAutomatic examOccurrenceRule && showAutoOccurrenceCalculateWidget +
+

+ _{MsgExamAutoOccurrenceHeading} + \ ^{isVisible False} + ^{examAutoOccurrenceCalculateWidget tid ssh csh examn} + $if not (null occurrences)

$if examTimes - _{MsgExamOccurrences} - $else _{MsgExamRooms} + $elseif is _Just examRoom + _{MsgExamTimes} + $else + _{MsgExamOccurrences} @@ -103,7 +121,8 @@ $if not (null occurrences) $forall (occurrence, registered) <- occurrences @@ -122,7 +157,8 @@ $if not (null occurrences) $if occurrenceNamesShown
_{MsgExamRoomName} \ ^{isVisible False} - _{MsgExamRoom} + $if is _Nothing examRoom + _{MsgExamRoom} $if not examTimes _{MsgExamRoomTime} $if showOccurrenceRegisterColumn @@ -114,6 +133,22 @@ $if not (null occurrences) _{MsgExamRoomAssigned} $if not occurrenceAssignmentsVisible \ ^{isVisible False} + $if showOccurrenceMappingColumn + $case fmap examOccurrenceMappingRule examExamOccurrenceMapping + $of Just ExamRoomSurname + + _{MsgExamRoomMappingSurname} + $if not occurrenceAssignmentsVisible + \ ^{isVisible False} + $of Just ExamRoomMatriculation + + _{MsgExamRoomMappingMatriculation} + $if not occurrenceAssignmentsVisible + \ ^{isVisible False} + $of _ + + $if not occurrenceAssignmentsVisible + ^{isVisible False} _{MsgExamRoomDescription}
#{examOccurrenceName} - #{examOccurrenceRoom} + $if is _Nothing examRoom + #{examOccurrenceRoom} $if not examTimes ^{formatTimeRangeW SelFormatDateTime examOccurrenceStart examOccurrenceEnd} @@ -133,6 +169,10 @@ $if not (null occurrences) $nothing $if registered #{iconOK} + $if showOccurrenceMappingColumn + + $maybe mappingWgt <- occurrenceMapping examOccurrenceName + ^{mappingWgt} $maybe desc <- examOccurrenceDescription #{desc} diff --git a/templates/exam-users.hamlet b/templates/exam-users.hamlet index 06e3e489f..9e85b0605 100644 --- a/templates/exam-users.hamlet +++ b/templates/exam-users.hamlet @@ -1,6 +1,12 @@ $newline never
+ $if is _Nothing examClosed +

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

_{MsgExamAutoOccurrenceHeading} + ^{examAutoOccurrenceCalculateWidget tid ssh csh examn}
$if computedValues ^{computedValuesTip} diff --git a/templates/exam/auto-occurrence-confirm.hamlet b/templates/exam/auto-occurrence-confirm.hamlet new file mode 100644 index 000000000..0e94455e7 --- /dev/null +++ b/templates/exam/auto-occurrence-confirm.hamlet @@ -0,0 +1,3 @@ +$newline never +^{mappingWgt} +^{confirmWidget} diff --git a/templates/i18n/changelog/de-de-formal.hamlet b/templates/i18n/changelog/de-de-formal.hamlet index 3da252aaa..470fb8e55 100644 --- a/templates/i18n/changelog/de-de-formal.hamlet +++ b/templates/i18n/changelog/de-de-formal.hamlet @@ -1,5 +1,24 @@ $newline never
+
+ ^{formatGregorianW 2020 01 30} +
+
    +
  • + Verbesserung bei der Darstellung von Zuteilungsregeln nach der # + automatischen Verteilung von Klausurteilnehmern +
  • + Warnungen beim anlegen von Kursen, die auf mehrere zur Auswahl # + stehende Semester/Institute hinweisen + +
    + ^{formatGregorianW 2020 01 29} +
    +
      +
    • + Automatische Verteilung von Klausurteilnehmern auf # + Termine/Räume +
      ^{formatGregorianW 2020 01 17}
      diff --git a/templates/i18n/changelog/en-eu.hamlet b/templates/i18n/changelog/en-eu.hamlet index bb0c941cb..85999caea 100644 --- a/templates/i18n/changelog/en-eu.hamlet +++ b/templates/i18n/changelog/en-eu.hamlet @@ -1,5 +1,24 @@ $newline never
      +
      + ^{formatGregorianW 2020 01 30} +
      +
        +
      • + Improvements in display of assignment rules after automated # + distribution of exam participants +
      • + Display of a warning if multiple semesters/departments are # + available when creating a course + +
        + ^{formatGregorianW 2020 01 29} +
        +
          +
        • + Automated distribution of exam participants over configured # + occurrences/rooms +
          ^{formatGregorianW 2020 01 17}
          diff --git a/templates/i18n/data-protection/de-de-formal.hamlet b/templates/i18n/data-protection/de-de-formal.hamlet index 8607f7d7b..b8fb7ea06 100644 --- a/templates/i18n/data-protection/de-de-formal.hamlet +++ b/templates/i18n/data-protection/de-de-formal.hamlet @@ -1,10 +1,10 @@ $newline never -Zuletzt geändert: 23.12.2019 +Zuletzt geändert: ^{formatGregorianW 2019 12 23}

          Die folgende Datenschutzerklärung erweitert die # Datenschutzerklärung der Rechnerbetriebsgruppe (RBG) der LMU # - der Version 0.91 vom 22.05.2018.
          + der Version 0.91 vom ^{formatGregorianW 2018 05 22}.
          Sollte obenstehender Link auf eine Datenschutzerklärung mit höherer Versionsnummer verweisen, # so ist im Falle widersprüchlicher Informationen die Fassung der RBG vorzuziehen.

          diff --git a/templates/i18n/data-protection/en.hamlet b/templates/i18n/data-protection/en.hamlet index c9e77cec5..85fa15fe9 100644 --- a/templates/i18n/data-protection/en.hamlet +++ b/templates/i18n/data-protection/en.hamlet @@ -1,10 +1,10 @@ $newline never -Last changed: 23.12.2019 +Last changed: ^{formatGregorianW 2019 12 23}

          The following data protection statement extends the # Data Protection Statement of the Rechnerbetriebsgruppe (RBG) of the LMU # - , Version 0.91 from 22.05.2018.
          + , Version 0.91 from ^{formatGregorianW 2018 05 22}.
          Should the Data Protection Statement linked above be newer than the Statement on this page, # the version of the RBG has higher priority than this version in case of conflicting information. diff --git a/templates/i18n/exam-auto-occurrence-calculate/de-de-formal.hamlet b/templates/i18n/exam-auto-occurrence-calculate/de-de-formal.hamlet new file mode 100644 index 000000000..ef8c4e35b --- /dev/null +++ b/templates/i18n/exam-auto-occurrence-calculate/de-de-formal.hamlet @@ -0,0 +1,19 @@ +$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. + +
          + + Es werden dennoch nur Klausurteilnehmer anhand der neu berechneten # + Verteilung zugewiesen, die aktuell keinen zugewiesenen Raum/Termin # + haben. + +
          + + Dies kann bei mehrfacher Berechnung neuer Verteilungen dazu führen, # + dass die Zuteilung der meisten Klausurteilnehmer nicht mit der # + aktuellen Verteilung übereinstimmt. + +^{formView} diff --git a/templates/i18n/exam-auto-occurrence-calculate/en-eu.hamlet b/templates/i18n/exam-auto-occurrence-calculate/en-eu.hamlet new file mode 100644 index 000000000..a6b938066 --- /dev/null +++ b/templates/i18n/exam-auto-occurrence-calculate/en-eu.hamlet @@ -0,0 +1,19 @@ +$newline never +

          + When assignment rules are calculated all exam participants are # + considered, regardless of whether they are already assigned to an # + occurrence/room. + +
          + + Nonetheless 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 # + situation in which the occurrence/room assignments of most # + participants do not match the newest assignment rules. + +^{formView} diff --git a/templates/i18n/knownBugs/de-de-formal.hamlet b/templates/i18n/knownBugs/de-de-formal.hamlet index 6c3d7168d..45b074fc4 100644 --- a/templates/i18n/knownBugs/de-de-formal.hamlet +++ b/templates/i18n/knownBugs/de-de-formal.hamlet @@ -1,10 +1,15 @@ $newline never

          - Stand: Oktober 2019 + Stand: ^{formatGregorianW 2020 01 30}

          • Format von Bewertungsdateien ist noch provisorisch
          • - Zahlen und Prüfungsergebnisse werden nicht internationalisiert (betrifft auch CSV-Import und Export) + Zahlen und Prüfungsergebnisse werden nicht internationalisiert # + (betrifft auch CSV-Import und Export)
          • Feste (registrierte) Abgabegruppen sind noch nicht implementiert +
          • + Minimierung der Anzahl verwendeter Termine bei der automatischen # + Verteilung von Klausurteilnehmern produziert suboptimale # + Ergebnisse diff --git a/templates/i18n/knownBugs/en-eu.hamlet b/templates/i18n/knownBugs/en-eu.hamlet index 98d8fa483..ede33f3c0 100644 --- a/templates/i18n/knownBugs/en-eu.hamlet +++ b/templates/i18n/knownBugs/en-eu.hamlet @@ -1,10 +1,15 @@ $newline never

            - Last updated: October 2019 + Last updated: ^{formatGregorianW 2020 01 30}

            • Format of rating files is provisional
            • - Numbers and exam results are not internationalised (also affects csv-import and export) + Numbers and exam results are not internationalised (also affects # + csv-import and export)
            • - Fixed (registered) groups for exercise sheet submission not yet implemented + Fixed (registered) groups for exercise sheet submission not yet # + implemented +
            • + Minimisation of number of rooms used when automatically # + distributing exam participants does not produce optimal results diff --git a/templates/i18n/terms-of-use/de-de-formal.hamlet b/templates/i18n/terms-of-use/de-de-formal.hamlet index 0cf2861f4..73eef10b9 100644 --- a/templates/i18n/terms-of-use/de-de-formal.hamlet +++ b/templates/i18n/terms-of-use/de-de-formal.hamlet @@ -1,5 +1,5 @@ $newline never -Zuletzt geändert: 18.12.2019 +Zuletzt geändert: ^{formatGregorianW 2019 12 18}

              Die im Folgenden geführten Nutzungsbedingungen beziehen sich auf die unter der URL
              diff --git a/templates/i18n/terms-of-use/en.hamlet b/templates/i18n/terms-of-use/en.hamlet index 5a285bc8b..e7c4070f7 100644 --- a/templates/i18n/terms-of-use/en.hamlet +++ b/templates/i18n/terms-of-use/en.hamlet @@ -1,5 +1,5 @@ $newline never -Last changed: 18.12.2019 +Last changed: ^{formatGregorianW 2019 12 18}

              The following Terms of Use apply to the contents reachable via
              diff --git a/templates/widgets/exam-occurrence-mapping-description.hamlet b/templates/widgets/exam-occurrence-mapping-description.hamlet new file mode 100644 index 000000000..356911383 --- /dev/null +++ b/templates/widgets/exam-occurrence-mapping-description.hamlet @@ -0,0 +1,15 @@ +$newline never +

                + $forall desc <- descriptions +
              • + $case desc + $of ExamOccurrenceMappingRange minChars maxChars + $if doPrefix + #{titleCase minChars}… – #{titleCase maxChars}… + $else + …#{titleCase minChars} – …#{titleCase maxChars} + $of ExamOccurrenceMappingSpecial special + $if doPrefix + #{titleCase special}… + $else + …#{titleCase special} diff --git a/templates/widgets/exam-occurrence-mapping.hamlet b/templates/widgets/exam-occurrence-mapping.hamlet new file mode 100644 index 000000000..a3c8b8ef0 --- /dev/null +++ b/templates/widgets/exam-occurrence-mapping.hamlet @@ -0,0 +1,44 @@ +$newline never + + + + + $forall Entity occId ExamOccurrence{ examOccurrenceName, examOccurrenceRoom, examOccurrenceStart, examOccurrenceEnd, examOccurrenceDescription, examOccurrenceCapacity } <- occurrences + +
                + _{MsgExamRoomName} + + _{MsgExamRoomLoad} + $maybe rule <- occMappingRule + $case rule + $of ExamRoomSurname + + _{MsgExamRoomMappingSurname} + $of ExamRoomMatriculation + + _{MsgExamRoomMappingMatriculation} + $of _ + + + _{MsgExamRoom} + + _{MsgExamRoomTime} + + _{MsgExamRoomDescription} +
                + _{examOccurrenceName} + + _{loadProp (occLoad occId) examOccurrenceCapacity} + + $maybe nudgeWgt' <- Map.lookup occId nudgeWgt + ^{nudgeWgt'} + + $maybe mappingWgt <- occMapping occId + ^{mappingWgt} + + #{examOccurrenceRoom} + + ^{formatTimeRangeW SelFormatDateTime examOccurrenceStart examOccurrenceEnd} + + $maybe desc <- examOccurrenceDescription + #{desc} diff --git a/test/Database.hs b/test/Database.hs index 8335ef6ac..9038f14cb 100755 --- a/test/Database.hs +++ b/test/Database.hs @@ -505,6 +505,7 @@ fillDb = do , examGradingRule = Nothing , examBonusRule = Nothing , examOccurrenceRule = ExamRoomManual + , examExamOccurrenceMapping = Nothing , examVisibleFrom = Just now , examRegisterFrom = Just now , examRegisterTo = Just $ addUTCTime (14 * nominalDay) now diff --git a/test/TestImport.hs b/test/TestImport.hs index 2b13743ab..3c9b42427 100644 --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -47,12 +47,12 @@ import Net.IP as X (IP) import Database (truncateDb) import Database as X (fillDb) +import User as X (fakeUser) import Control.Monad.Catch as X hiding (Handler(..)) import Control.Monad.Trans.Resource (runResourceT) -import Settings import Settings.WellKnownFiles as X import Data.CaseInsensitive as X (CI) @@ -118,37 +118,7 @@ authenticateAs (Entity _ User{..}) = do -- | Create a user. The dummy email entry helps to confirm that foreign-key -- checking is switched off in wipeDB for those database backends which need it. createUser :: (User -> User) -> YesodExample UniWorX (Entity User) -createUser adjUser = do - UserDefaultConf{..} <- appUserDefaults . view appSettings <$> getTestYesod - now <- liftIO getCurrentTime - let - userMatrikelnummer = Nothing - userAuthentication = AuthLDAP - userLastAuthentication = Nothing - userTokensIssuedAfter = Nothing - userIdent = "dummy@example.invalid" - userEmail = "dummy@example.invalid" - userDisplayEmail = "dummy@example.invalid" - userDisplayName = "Dummy Example" - userSurname = "Example" - userFirstName = "Dummy" - userTitle = Nothing - userTheme = userDefaultTheme - userMaxFavourites = userDefaultMaxFavourites - userMaxFavouriteTerms = userDefaultMaxFavouriteTerms - userDateTimeFormat = userDefaultDateTimeFormat - userDateFormat = userDefaultDateFormat - userTimeFormat = userDefaultTimeFormat - userDownloadFiles = userDefaultDownloadFiles - userWarningDays = userDefaultWarningDays - userShowSex = userDefaultShowSex - userLanguages = Nothing - userNotificationSettings = def - userCreated = now - userLastLdapSynchronisation = Nothing - userCsvOptions = def - userSex = Nothing - runDB . insertEntity $ adjUser User{..} +createUser = runDB . insertEntity . fakeUser lawsCheckHspec :: Typeable a => Proxy a -> [Proxy a -> Laws] -> Spec lawsCheckHspec p = parallel . describe (show $ typeRep p) . mapM_ (checkHspec . ($ p)) diff --git a/test/User.hs b/test/User.hs new file mode 100644 index 000000000..919ca7019 --- /dev/null +++ b/test/User.hs @@ -0,0 +1,44 @@ +module User + ( fakeUser + ) where + +import ClassyPrelude + +import Settings +import Model + +import Data.Default +import System.IO.Unsafe + + +fakeUser :: (User -> User) -> User +fakeUser adjUser = adjUser User{..} + where + UserDefaultConf{..} = appUserDefaults compileTimeAppSettings + + userMatrikelnummer = Nothing + userAuthentication = AuthLDAP + userLastAuthentication = Nothing + userTokensIssuedAfter = Nothing + userIdent = "dummy@example.invalid" + userEmail = "dummy@example.invalid" + userDisplayEmail = "dummy@example.invalid" + userDisplayName = "Dummy Example" + userSurname = "Example" + userFirstName = "Dummy" + userTitle = Nothing + userTheme = userDefaultTheme + userMaxFavourites = userDefaultMaxFavourites + userMaxFavouriteTerms = userDefaultMaxFavouriteTerms + userDateTimeFormat = userDefaultDateTimeFormat + userDateFormat = userDefaultDateFormat + userTimeFormat = userDefaultTimeFormat + userDownloadFiles = userDefaultDownloadFiles + userLanguages = Nothing + userWarningDays = userDefaultWarningDays + userCsvOptions = def + userSex = Nothing + userShowSex = userDefaultShowSex + userNotificationSettings = def + userCreated = unsafePerformIO getCurrentTime + userLastLdapSynchronisation = Nothing