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

Merge branch 'master' into 476-interface-fur-klausurkorrekturen

Browse Source
This commit is contained in:
Sarah Vaupel 2020-02-04 09:52:33 +01:00
commit 6f2b58c002
51 changed files with 1107 additions and 79 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
.gitlab-ci.yml
View File

@ -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

45
CHANGELOG.md
View File

@ -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)

9
frontend/src/app.sass
View File

@ -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],

2
ghci.sh
View File

@ -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}

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

@ -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

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

@ -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

8
missing-translations.sh
View File

@ -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

1
models/exams.model
View File

@ -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

4
nixpkgs.nix
View File

@ -4,6 +4,6 @@
import ((nixpkgs {}).fetchFromGitHub {
owner = "NixOS";
repo = "nixpkgs";
rev = "10e61bf5be57736035ec7a804cb0bf3d083bf2cf";
sha256 = "0fplfm2zx4vk7gs8bdcxnvzkdmpx2w0llqwf8475z9dz9cl132rm";
rev = "0d97ef510bdc9d66f1023f970be58fdab2eb87fa";
sha256 = "00lnna6097wzrlmwqk8bqayh4qd2gz61zcd4yh7amirqflz3z2ll";
})

2
package-lock.json generated
View File

@ -1,6 +1,6 @@
{
"name": "uni2work",
"version": "10.4.1",
"version": "10.6.0",
"lockfileVersion": 1,
"requires": true,
"dependencies": {

5
package.json
View File

@ -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"

6
package.yaml
View File

@ -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

1
routes
View File

@ -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:

2
shell.nix
View File

@ -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}"

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

@ -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)

1
src/Foundation.hs
View File

@ -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

4
src/Handler/Corrections.hs
View File

@ -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

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

@ -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)

1
src/Handler/Exam.hs
View File

@ -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

172
src/Handler/Exam/AutoOccurrence.hs Normal file
View File

@ -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")

1
src/Handler/Exam/Edit.hs
View File

@ -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

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

@ -32,6 +32,7 @@ postCExamNewR tid ssh csh = do
, examGradingRule = efGradingRule
, examBonusRule = efBonusRule
, examOccurrenceRule = efOccurrenceRule
, examExamOccurrenceMapping = Nothing
, examVisibleFrom = efVisibleFrom
, examRegisterFrom = efRegisterFrom
, examRegisterTo = efRegisterTo

20
src/Handler/Exam/Show.hs
View File

@ -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")

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

@ -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

402
src/Handler/Utils/Exam.hs
View File

@ -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 <https://xxyxyz.org/line-breaking/> 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

13
src/Handler/Utils/Widgets.hs
View File

@ -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

6
src/Model.hs
View File

@ -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

57
src/Model/Types/Exam.hs
View File

@ -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

1
src/Utils/Form.hs
View File

@ -229,6 +229,7 @@ data FormIdentifier
| FIDUserAuthMode
| FIDAllUsersAction
| FIDLanguage
| FIDExamAutoOccurrenceCalculate | FIDExamAutoOccurrenceConfirm | FIDExamAutoOccurrenceNudge UUID
deriving (Eq, Ord, Read, Show)
instance PathPiece FormIdentifier where

1
src/Utils/Parameters.hs
View File

@ -57,6 +57,7 @@ data GlobalPostParam = PostFormIdentifier
| PostBearer
| PostDBCsvImportAction
| PostLoginDummy
| PostExamAutoOccurrencePrevious
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
instance Universe GlobalPostParam

2
stack.yaml
View File

@ -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

7
stack.yaml.lock
View File

@ -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

4
start.sh
View File

@ -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 $@

48
templates/exam-show.hamlet
View File

@ -47,6 +47,9 @@ $maybe desc <- examDescription
$maybe publishAssignments <- examPublishOccurrenceAssignments
<dt .deflist__dt>_{MsgExamPublishOccurrenceAssignmentsParticipant}
<dd .deflist__dd>^{formatTimeW SelFormatDateTime publishAssignments}
$maybe room <- examRoom
<dt .deflist__dt>_{MsgExamRoom}
<dd .deflist__dd>#{room}
$if examTimes
<dt .deflist__dt>_{MsgExamTime}
<dd .deflist__dd>
@ -88,14 +91,29 @@ $maybe desc <- examDescription
<dt .deflist__dt>_{MsgExamRegistration}
<dd .deflist__dd>^{registerWdgt}
$if showCloseWidget && is _Nothing examClosed
<section>
<h2>
_{MsgExamCloseHeading}
\ ^{isVisible False}
^{closeWgt}
$if examOccurrenceRuleAutomatic examOccurrenceRule && showAutoOccurrenceCalculateWidget
<section>
<h2>
_{MsgExamAutoOccurrenceHeading}
\ ^{isVisible False}
^{examAutoOccurrenceCalculateWidget tid ssh csh examn}
$if not (null occurrences)
<section>
<h2>
$if examTimes
_{MsgExamOccurrences}
$else
_{MsgExamRooms}
$elseif is _Just examRoom
_{MsgExamTimes}
$else
_{MsgExamOccurrences}
<table .table .table--striped .table--hover>
<thead>
<tr .table__row .table__row--head>
@ -103,7 +121,8 @@ $if not (null occurrences)
<th .table__th>
_{MsgExamRoomName}
\ ^{isVisible False}
<th .table__th>_{MsgExamRoom}
$if is _Nothing examRoom
<th .table__th>_{MsgExamRoom}
$if not examTimes
<th .table__th>_{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
<th .table__th>
_{MsgExamRoomMappingSurname}
$if not occurrenceAssignmentsVisible
\ ^{isVisible False}
$of Just ExamRoomMatriculation
<th .table__th>
_{MsgExamRoomMappingMatriculation}
$if not occurrenceAssignmentsVisible
\ ^{isVisible False}
$of _
<th .table__td>
$if not occurrenceAssignmentsVisible
^{isVisible False}
<th .table__th>_{MsgExamRoomDescription}
<tbody>
$forall (occurrence, registered) <- occurrences
@ -122,7 +157,8 @@ $if not (null occurrences)
<tr .table__row :markUnregisteredOccurrences (Just occurrence) && not registered:.occurrence--not-registered>
$if occurrenceNamesShown
<td .table__td #exam-occurrence__#{examOccurrenceName}>#{examOccurrenceName}
<td .table__td>#{examOccurrenceRoom}
$if is _Nothing examRoom
<td .table__td>#{examOccurrenceRoom}
$if not examTimes
<td .table__td>
^{formatTimeRangeW SelFormatDateTime examOccurrenceStart examOccurrenceEnd}
@ -133,6 +169,10 @@ $if not (null occurrences)
$nothing
$if registered
#{iconOK}
$if showOccurrenceMappingColumn
<td .table__td>
$maybe mappingWgt <- occurrenceMapping examOccurrenceName
^{mappingWgt}
<td .table__td>
$maybe desc <- examOccurrenceDescription
#{desc}

6
templates/exam-users.hamlet
View File

@ -1,6 +1,12 @@
$newline never
<section>
$if is _Nothing examClosed
<h2>_{MsgExamCloseHeading}
^{closeWgt}
$if examOccurrenceRuleAutomatic examOccurrenceRule
<section>
<h2>_{MsgExamAutoOccurrenceHeading}
^{examAutoOccurrenceCalculateWidget tid ssh csh examn}
<section>
$if computedValues
^{computedValuesTip}

3
templates/exam/auto-occurrence-confirm.hamlet Normal file
View File

@ -0,0 +1,3 @@
$newline never
^{mappingWgt}
^{confirmWidget}

19
templates/i18n/changelog/de-de-formal.hamlet
View File

@ -1,5 +1,24 @@
$newline never
<dl .deflist>
<dt .deflist__dt>
^{formatGregorianW 2020 01 30}
<dd .deflist__dd>
<ul>
<li>
Verbesserung bei der Darstellung von Zuteilungsregeln nach der #
automatischen Verteilung von Klausurteilnehmern
<li>
Warnungen beim anlegen von Kursen, die auf mehrere zur Auswahl #
stehende Semester/Institute hinweisen
<dt .deflist__dt>
^{formatGregorianW 2020 01 29}
<dd .deflist__dd>
<ul>
<li>
Automatische Verteilung von Klausurteilnehmern auf #
Termine/Räume
<dt .deflist__dt>
^{formatGregorianW 2020 01 17}
<dd .deflist__dd>

19
templates/i18n/changelog/en-eu.hamlet
View File

@ -1,5 +1,24 @@
$newline never
<dl .deflist>
<dt .deflist__dt>
^{formatGregorianW 2020 01 30}
<dd .deflist__dd>
<ul>
<li>
Improvements in display of assignment rules after automated #
distribution of exam participants
<li>
Display of a warning if multiple semesters/departments are #
available when creating a course
<dt .deflist__dt>
^{formatGregorianW 2020 01 29}
<dd .deflist__dd>
<ul>
<li>
Automated distribution of exam participants over configured #
occurrences/rooms
<dt .deflist__dt>
^{formatGregorianW 2020 01 17}
<dd .deflist__dd>

4
templates/i18n/data-protection/de-de-formal.hamlet
View File

@ -1,10 +1,10 @@
$newline never
<i>Zuletzt geändert: 23.12.2019
<i>Zuletzt geändert: ^{formatGregorianW 2019 12 23}
<p>
Die folgende Datenschutzerklärung erweitert die #
<a href="https://www.rz.ifi.lmu.de/datenschutz_de.html">Datenschutzerklärung der Rechnerbetriebsgruppe (RBG) der LMU</a> #
der Version 0.91 vom 22.05.2018.<br>
der Version 0.91 vom ^{formatGregorianW 2018 05 22}.<br>
Sollte obenstehender Link auf eine Datenschutzerklärung mit höherer Versionsnummer verweisen, #
so ist im Falle widersprüchlicher Informationen die Fassung der RBG vorzuziehen.
<p>

4
templates/i18n/data-protection/en.hamlet
View File

@ -1,10 +1,10 @@
$newline never
<i>Last changed: 23.12.2019
<i>Last changed: ^{formatGregorianW 2019 12 23}
<p>
The following data protection statement extends the #
<a href="https://www.rz.ifi.lmu.de/datenschutz_en.html">Data Protection Statement of the Rechnerbetriebsgruppe (RBG) of the LMU</a> #
, Version 0.91 from 22.05.2018.<br>
, Version 0.91 from ^{formatGregorianW 2018 05 22}.<br>
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.

19
templates/i18n/exam-auto-occurrence-calculate/de-de-formal.hamlet Normal file
View File

@ -0,0 +1,19 @@
$newline never
<p>
Bei der Berechnung der Verteilung werden stets alle #
Klausurteilnehmer berücksichtigt, unabhängig davon, ob ihnen bereits #
ein Raum/Termin zugewiesen ist, oder nicht.
<br />
Es werden dennoch nur Klausurteilnehmer anhand der neu berechneten #
Verteilung zugewiesen, die aktuell keinen zugewiesenen Raum/Termin #
haben.
<br />
Dies kann bei mehrfacher Berechnung neuer Verteilungen dazu führen, #
dass die Zuteilung der meisten Klausurteilnehmer nicht mit der #
aktuellen Verteilung übereinstimmt.
^{formView}

19
templates/i18n/exam-auto-occurrence-calculate/en-eu.hamlet Normal file
View File

@ -0,0 +1,19 @@
$newline never
<p>
When assignment rules are calculated all exam participants are #
considered, regardless of whether they are already assigned to an #
occurrence/room.
<br />
Nonetheless only exam participants, who are not already assigned to #
an occurrence/room, will be assigned according to the newly #
calculated assignment rules.
<br />
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}

9
templates/i18n/knownBugs/de-de-formal.hamlet
View File

@ -1,10 +1,15 @@
$newline never
<p>
Stand: Oktober 2019
Stand: ^{formatGregorianW 2020 01 30}
<ul>
<li>
Format von Bewertungsdateien ist noch provisorisch
<li>
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)
<li>
Feste (registrierte) Abgabegruppen sind noch nicht implementiert
<li>
Minimierung der Anzahl verwendeter Termine bei der automatischen #
Verteilung von Klausurteilnehmern produziert suboptimale #
Ergebnisse

11
templates/i18n/knownBugs/en-eu.hamlet
View File

@ -1,10 +1,15 @@
$newline never
<p>
Last updated: October 2019
Last updated: ^{formatGregorianW 2020 01 30}
<ul>
<li>
Format of rating files is provisional
<li>
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)
<li>
Fixed (registered) groups for exercise sheet submission not yet implemented
Fixed (registered) groups for exercise sheet submission not yet #
implemented
<li>
Minimisation of number of rooms used when automatically #
distributing exam participants does not produce optimal results

2
templates/i18n/terms-of-use/de-de-formal.hamlet
View File

@ -1,5 +1,5 @@
$newline never
<i>Zuletzt geändert: 18.12.2019
<i>Zuletzt geändert: ^{formatGregorianW 2019 12 18}
<p>
Die im Folgenden geführten Nutzungsbedingungen beziehen sich auf die unter der URL<br>

2
templates/i18n/terms-of-use/en.hamlet
View File

@ -1,5 +1,5 @@
$newline never
<i>Last changed: 18.12.2019
<i>Last changed: ^{formatGregorianW 2019 12 18}
<p>
The following Terms of Use apply to the contents reachable via<br>

15
templates/widgets/exam-occurrence-mapping-description.hamlet Normal file
View File

@ -0,0 +1,15 @@
$newline never
<ul .list--inline .list--comma-separated>
$forall desc <- descriptions
<li>
$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}

44
templates/widgets/exam-occurrence-mapping.hamlet Normal file
View File

@ -0,0 +1,44 @@
$newline never
<table .table .table--striped .table--hover>
<thead>
<tr .table__row .table__row--head>
<th .table__th>
_{MsgExamRoomName}
<th .table__th colspan=2>
_{MsgExamRoomLoad}
$maybe rule <- occMappingRule
$case rule
$of ExamRoomSurname
<th .table__th>
_{MsgExamRoomMappingSurname}
$of ExamRoomMatriculation
<th .table__th>
_{MsgExamRoomMappingMatriculation}
$of _
<th .table__td>
<th .table__th>
_{MsgExamRoom}
<th .table__th>
_{MsgExamRoomTime}
<th .table__th>
_{MsgExamRoomDescription}
<tbody>
$forall Entity occId ExamOccurrence{ examOccurrenceName, examOccurrenceRoom, examOccurrenceStart, examOccurrenceEnd, examOccurrenceDescription, examOccurrenceCapacity } <- occurrences
<tr .table__row>
<td .table__td>
_{examOccurrenceName}
<td .table__td>
_{loadProp (occLoad occId) examOccurrenceCapacity}
<td .table__td>
$maybe nudgeWgt' <- Map.lookup occId nudgeWgt
^{nudgeWgt'}
<td .table__td>
$maybe mappingWgt <- occMapping occId
^{mappingWgt}
<td .table__td>
#{examOccurrenceRoom}
<td .table__td>
^{formatTimeRangeW SelFormatDateTime examOccurrenceStart examOccurrenceEnd}
<td .table__td>
$maybe desc <- examOccurrenceDescription
#{desc}

1
test/Database.hs
View File

@ -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

34
test/TestImport.hs
View File

@ -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))

44
test/User.hs Normal file
View File

@ -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