diff --git a/CHANGELOG.md b/CHANGELOG.md index c38052ada..70a4feb39 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,49 @@ 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. +## [7.0.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v6.11.1...v7.0.0) (2019-09-25) + + +### Bug Fixes + +* fix startup on unix-socket ([39f1295](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/39f1295)) +* improve async behaviour ([cc7a528](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/cc7a528)) +* make migration idempotent again ([9778404](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/9778404)) +* restore behaviour of waiting asynchronously for job-management ([5ebcd89](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/5ebcd89)) +* **communication:** make communication form more intuitive ([7a2b972](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/7a2b972)), closes [#387](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/issues/387) +* fix migration ([d2478a3](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/d2478a3)) +* fix migration & tests ([e05ea8e](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/e05ea8e)) +* migration ([4383eb1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/4383eb1)) +* syntax ([7afd569](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/7afd569)) +* **migration:** drop more tables in w.a. for inconsistent 21→22 ([d79dca6](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/d79dca6)) +* typo ([fb1e42d](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/fb1e42d)) + + +### chore + +* bump versions ([67e3b38](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/67e3b38)) + + +### Features + +* **course:** additional crosslinking ([5eaba78](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/5eaba78)) +* **exam-users:** document part-* family of columns ([fe07a22](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/fe07a22)) +* **exams:** accept/reset computed results ([72342f1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/72342f1)) +* **exams:** automatically compute examResults ([ea5a398](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/ea5a398)) +* **exams:** better display exam-result-information ([0ebda4d](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/0ebda4d)) +* **exams:** csv-import of ExamPartResults ([29f4e28](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/29f4e28)) +* **exams:** implement rounding of exambonus ([e97cd56](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/e97cd56)) +* **exams:** refine exam form ([014a17a](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/014a17a)) + + +### BREAKING CHANGES + +* yesod >=1.6 +* **exams:** examPartName no longer required +* **exams:** Introduces ExamPartNumbers + + + ### [6.11.1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v6.11.0...v6.11.1) (2019-09-17) diff --git a/README.md b/README.md index f61775faa..685041baa 100644 --- a/README.md +++ b/README.md @@ -5,6 +5,14 @@ The following description applies to Ubuntu and similar debian based Linux distr ## Prerequisites These are the things you need to do/install before you can get started working on Uni2work. +### Install german locale +You will need to install the german locale at compile time. + +Install: + +- Edit `/etc/locale.gen` as root and uncomment/add the line `de_DE.UTF-8 UTF-8` +- Save the file and run `sudo locale-gen` + ### Clone repository Clone this repository and navigate into it ```sh @@ -41,7 +49,7 @@ You'll get a prompt: ```sh Enter name of role to add: uniworx -Shall the new role be a superuser? (y/n) [not exactly sure. Guess not?] +Shall the new role be a superuser? (y/n) y [user must be superuser to create extensions] Password: uniworx ... ``` @@ -89,18 +97,6 @@ $ sudo apt-get install pkg-config $ sudo apt-get install libsodium-dev ``` -Build the app: -```sh -$ stack build -``` - -This might take a few minutes... if not hours... be prepared. - -install yesod: -```sh -$ stack install yesod-bin --install-ghc -``` - ### `Node` & `npm` Node and Npm are needed to compile the frontend. @@ -110,6 +106,18 @@ $ curl -sL https://deb.nodesource.com/setup_12.x | sudo -E bash - $ sudo apt-get install -y nodejs ``` +Build the app: +```sh +$ npm run build +``` + +This might take a few minutes... if not hours... be prepared. + +install yesod: +```sh +$ stack install yesod-bin --install-ghc +``` + ### Add dummy data to the database After building the app you can prepare the database and add some dummy data: ```sh @@ -118,7 +126,7 @@ $ ./db.sh -f ## Run Uni2work ```sh -$ npm start +$ npm run start ``` This will compile both frontend and backend and will start Uni2work in development mode (might take a few minutes the first time). It will keep running and will watch any file changes to automatically re-compile the application if necessary. diff --git a/app/DevelMain.hs b/app/DevelMain.hs index 0a7a89562..b850b33b2 100644 --- a/app/DevelMain.hs +++ b/app/DevelMain.hs @@ -67,7 +67,7 @@ update = do restartAppInNewThread tidStore = modifyStoredIORef tidStore $ \tid -> do killThread tid withStore doneStore takeMVar - readStore doneStore >>= start + withStore doneStore start -- | Start the server in a separate thread. @@ -77,10 +77,7 @@ update = do (port, site, app) <- getApplicationRepl resourceForkIO $ do finally (liftIO $ runSettings (setPort port defaultSettings) app) - -- Note that this implies concurrency - -- between shutdownApp and the next app that is starting. - -- Normally this should be fine - (liftIO $ putMVar done () >> shutdownApp site) + (liftIO $ shutdownApp site `finally` putMVar done ()) -- | kill the server shutdown :: IO () diff --git a/clean.sh b/clean.sh index 2b9f5bfc7..02487e8b2 100755 --- a/clean.sh +++ b/clean.sh @@ -10,6 +10,8 @@ case $1 in ;; *) target=".stack-work-${1}" + shift + if [[ ! -d "${target}" ]]; then printf "%s does not exist or is no directory\n" "${target}" >&2 exit 1 @@ -20,7 +22,11 @@ case $1 in fi move-back() { - mv -v .stack-work "${target}" + if [[ -d .stack-work ]]; then + mv -v .stack-work "${target}" + else + mkdir -v "${target}" + fi [[ -d .stack-work-clean ]] && mv -v .stack-work-clean .stack-work } @@ -28,6 +34,9 @@ case $1 in mv -v "${target}" .stack-work trap move-back EXIT - stack clean + ( + set -ex + stack clean $@ + ) ;; esac diff --git a/config/test-settings.yml b/config/test-settings.yml index 23f59aed5..5fb61bedf 100644 --- a/config/test-settings.yml +++ b/config/test-settings.yml @@ -8,3 +8,5 @@ log-settings: destination: "test.log" auth-dummy-login: true + +job-workers: 1 diff --git a/frontend/src/utils/inputs/inputs.scss b/frontend/src/utils/inputs/inputs.scss index c4cb63373..2d8fb8db5 100644 --- a/frontend/src/utils/inputs/inputs.scss +++ b/frontend/src/utils/inputs/inputs.scss @@ -33,11 +33,14 @@ margin: 7px 0; } -.form-section-title__hint { - margin-top: 7px; +.form-group__hint, .form-section-title__hint { color: var(--color-fontsec); font-size: 0.9rem; font-weight: 600; +} + +.form-section-title__hint { + margin-top: 7px; + .form-group { margin-top: 11px; @@ -58,6 +61,7 @@ .form-group--required .form-group-label__caption::after, .form-group__required-marker::before { content: ' *'; color: var(--color-error); + font-weight: 600; } .form-group--optional { diff --git a/haddock.sh b/haddock.sh index 13bb626e0..00308065f 100755 --- a/haddock.sh +++ b/haddock.sh @@ -15,4 +15,4 @@ if [[ -d .stack-work-doc ]]; then trap move-back EXIT fi -stack build --fast --flag uniworx:library-only --flag uniworx:dev --haddock --haddock-hyperlink-source --haddock-deps --haddock-internal +stack build --fast --flag uniworx:library-only --flag uniworx:dev --haddock --haddock-hyperlink-source --haddock-deps --haddock-internal ${@} diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index babad5c46..bee90fb85 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -1135,8 +1135,10 @@ NavigationFavourites: Favoriten CommSubject: Betreff CommBody: Nachricht +CommBodyTip: Das Eingabefeld akzeptiert derzeit ausschließlich Html. U.A. Zeilumbrüche werden dementsprechend ignoriert und müssen manuell mit
eingefügt werden. CommRecipients: Empfänger CommRecipientsTip: Sie selbst erhalten immer eine Kopie der Nachricht +CommRecipientsList: Die an Sie selbst verschickte Kopie der Nachricht wird, zu Archivierungszwecken, eine vollständige Liste aller Empfänger enthalten. Die Empfängerliste wird im CSV-Format and die E-Mail angehängt. Andere Empfänger erhalten die Liste nicht. Bitte entfernen Sie dementsprechend den Anhang bevor Sie die E-Mail weiterleiten oder anderweitig mit Dritten teilen. CommDuplicateRecipients n@Int: #{n} #{pluralDE n "doppelter" "doppelte"} Empfänger ignoriert CommSuccess n@Int: Nachricht wurde an #{n} Empfänger versandt @@ -1329,28 +1331,40 @@ ExamClosedTip: Prüfungsämter, die im System Noten einsehen, werden zu diesem Z ExamShowGrades: Klausur ist benotet ExamShowGradesTip: Sollen genaue Noten angezeigt werden, oder sollen Teilnehmer und Prüfungsämter nur informiert werden, ob die Klausur bestanden wurde? ExamPublicStatistics: Statistik veröffentlichen -ExamPublicStatisticsTip: Soll die statistische Auswertung auch den Teilnehmern angezeigt werden, sobald diese ihre Noten einsehen können? +ExamPublicStatisticsTip: Soll die automatisch berechnete statistische Auswertung auch den Teilnehmern angezeigt werden, sobald diese ihre Noten einsehen können? +ExamAutomaticGrading: Automatische Notenberechnung +ExamAutomaticGradingTip: Sollen die Gesamtleistungen der Teilnehmer automatisch aus den in den einzelnen Teilprüfungen erreichten Leistungen berechnet werden? Etwaige Bonuspunkte werden dabei berücksichtigt. Manuelles Überschreiben der Gesamtleistung ist dennoch möglich. ExamGradingRule: Notenberechnung ExamGradingManual': Keine automatische Berechnung ExamGradingKey': Nach Schlüssel ExamGradingKey: Notenschlüssel -ExamGradingKeyTip: Die Grenzen beziehen sich auf die effektive Maximalpunktzahl, nachdem etwaige Bonuspunkte aus dem Übungsbetrieb angerechnet und die Ergebnise der Teilaufgaben mit ihrem Gewicht multipliziert wurden +ExamGradingKeyTip: Die Grenzen beziehen sich auf die effektive Maximalpunktzahl, nachdem etwaige Bonuspunkte aus dem Übungsbetrieb angerechnet und die Ergebnise der Teilprüfungen mit ihrem Gewicht multipliziert wurden Points: Punkte PointsMustBeNonNegative: Punktegrenzen dürfen nicht negativ sein PointsMustBeMonotonic: Punktegrenzen müssen aufsteigend sein GradingFrom: Ab ExamNew: Neue Prüfung +ExamBonus: Bonuspunkte-System ExamBonusRule: Prüfungsbonus aus Übungsbetrieb ExamNoBonus': Kein automatischer Bonus ExamBonusPoints': Umrechnung von Übungspunkten +ExamBonusManual': Manuelle Berechnung + +ExamBonusAchieved: Bonuspunkte ExamEditHeading examn@ExamName: #{examn} bearbeiten ExamBonusMaxPoints: Maximal erreichbare Prüfungs-Bonuspunkte +ExamBonusMaxPointsTip: Bonuspunkte werden, anhand der erreichten Übungspunkte bzw. der Anzahl von bestandenen Übungsblättern, linear zwischen null und der angegebenen Schranke interpoliert. ExamBonusMaxPointsNonPositive: Maximaler Prüfungsbonus muss positiv und größer null sein ExamBonusOnlyPassed: Bonus nur nach Bestehen anrechnen +ExamBonusRound: Bonus runden auf +ExamBonusRoundNonPositive: Vielfaches, auf das gerundet werden soll, muss positiv und größer null sein +ExamBonusRoundTip: Bonuspunkte werden kaufmännisch auf ein Vielfaches der angegeben Zahl gerundet. -ExamOccurrenceRule: Automatische Termin- bzw. Raumzuteilung +ExamAutomaticOccurrenceAssignment: Automatische Termin- bzw. Raumzuteilung +ExamAutomaticOccurrenceAssignmentTip: Sollen Prüfungsteilnehmer zum Zeitpunkt der Bekanntgabe der Raum- bzw. Terminzuteilung automatisch auf die zur Verfügung stehenden Räume bzw. Termine verteilt werden? Manuelle Umverteilung bzw. vorheriges Festlegen von Zuteilungen einzelner Teilnehmer ist trotzdem möglich. +ExamOccurrenceRule: Verfahren ExamOccurrenceRuleParticipant: Termin- bzw. Raumzuteilungsverfahren ExamRoomManual': Keine automatische Zuteilung ExamRoomSurname': Nach Nachname @@ -1384,12 +1398,17 @@ ExamFormParts: Teile ExamCorrectors: Korrektoren ExamCorrectorAlreadyAdded: Ein Korrektor mit dieser E-Mail ist bereits für diese Prüfung eingetragen -ExamParts: Teilaufgaben -ExamPartWeightNegative: Gewicht aller Teilaufgaben muss größer oder gleich Null sein -ExamPartAlreadyExists: Teilaufgabe mit diesem Namen existiert bereits -ExamPartName: Name +ExamParts: Teilprüfungen/Aufgaben +ExamPartWeightNegative: Gewicht aller Teilprüfungen muss größer oder gleich Null sein +ExamPartAlreadyExists: Teilprüfung mit diesem Namen existiert bereits +ExamPartNumber: Nummer +ExamPartNumbered examPartNumber@ExamPartNumber: Teil #{view _ExamPartNumber examPartNumber} +ExamPartNumberTip: Wird als interne Bezeichnung z.B. bei CSV-Export verwendet +ExamPartName: Titel +ExamPartNameTip: Wird den Studierenden angezeigt ExamPartMaxPoints: Maximalpunktzahl ExamPartWeight: Gewichtung +ExamPartWeightTip: Wird vor Anzeige oder Notenberechnung mit der erreichten Punktzahl und der Maximalpunktzahl multipliziert; Änderungen hier passen auch bestehende Korrekturergebnisse an ExamPartResultPoints: Erreichte Punkte ExamNameTaken exam@ExamName: Es existiert bereits eine Prüfung mit Namen #{exam} @@ -1399,6 +1418,7 @@ ExamEdited exam@ExamName: #{exam} erfolgreich bearbeitet ExamNoShow: Nicht erschienen ExamVoided: Entwertet +ExamBonusManualParticipants: Von den Kursverwaltern manuell berechnet ExamBonusPoints possible@Points: Maximal #{showFixed True possible} Prüfungspunkte ExamBonusPointsPassed possible@Points: Maximal #{showFixed True possible} Prüfungspunkte, falls die Prüfung auch ohne Bonus bereits bestanden ist @@ -1437,8 +1457,13 @@ ExamSynchronised: Synchronisiert ExamUsersHeading: Prüfungsteilnehmer ExamUserDeregister: Teilnehmer von Prüfung abmelden ExamUserAssignOccurrence: Termin/Raum zuweisen +ExamUserAcceptComputedResult: Berechnetes Prüfungsergebnis übernehmen +ExamUserResetToComputedResult: Prüfungsergebnis zurücksetzen +ExamUserResetBonus: Auch Bonuspunkte zurücksetzen ExamUsersDeregistered count@Int64: #{show count} Teilnehmer von der Prüfung abgemeldet ExamUsersOccurrenceUpdated count@Int64: Termin/Raum für #{show count} Teilnehmer gesetzt +ExamUsersResultsAccepted count@Int64: Prüfungsergebnis für #{show count} Teilnehmer übernommen +ExamUsersResultsReset count@Int64: Prüfungsergebnis für #{show count} Teilnehmer zurückgesetzt ExamUserSynchronised: Synchronisiert ExamUserSyncOfficeName: Name @@ -1487,6 +1512,8 @@ CsvColumnExamUserExercisePoints: Anzahl von Punkten, die der Teilnehmer im Übun CsvColumnExamUserExercisePointsMax: Maximale Anzahl von Punkten, die der Teilnehmer im Übungsbetrieb bis zu seinem Prüfungstermin erreichen hätte können CsvColumnExamUserExercisePasses: Anzahl von Übungsblättern, die der Teilnehmer bestanden hat CsvColumnExamUserExercisePassesMax: Maximale Anzahl von Übungsblättern, die der Teilnehmer bis zu seinem Prüfungstermin bestehen hätte können +CsvColumnExamUserBonus: Anzurechnende Bonuspunkte +CsvColumnExamUserParts: Erreichte Punktezahlen in den Teilprüfungen, sofern vorhanden; eine Spalte pro Teilprüfung CsvColumnExamUserResult: Erreichte Prüfungsleistung; "passed", "failed", "no-show", "voided", oder eine Note ("1.0", "1.3", "1.7", ..., "4.0", "5.0") CsvColumnExamUserCourseNote: Notizen zum Teilnehmer @@ -1518,8 +1545,13 @@ ExamUserCsvRegister: Kursteilnehmer zur Prüfung anmelden ExamUserCsvAssignOccurrence: Teilnehmern einen anderen Termin/Raum zuweisen ExamUserCsvDeregister: Teilnehmer von der Prüfung abmelden ExamUserCsvSetCourseField: Kurs-assoziiertes Studienfach ändern +ExamUserCsvOverrideBonus: Bonuspunkte entgegen Bonusregelung überschreiben +ExamUserCsvOverrideResult: Ergebnis entgegen automatischer Notenberechnung überschreiben +ExamUserCsvSetBonus: Bonuspunkte eintragen ExamUserCsvSetResult: Ergebnis eintragen +ExamUserCsvSetPartResult: Ergebnis einer Teilprüfung eintragen ExamUserCsvSetCourseNote: Teilnehmer-Notizen anpassen +ExamBonusNone: Keine Bonuspunkte ExamUserCsvCourseNoteDeleted: Notiz wird gelöscht diff --git a/models/courses b/models/courses index 206a6879e..260c4254f 100644 --- a/models/courses +++ b/models/courses @@ -17,11 +17,11 @@ Course -- Information about a single course; contained info is always visible deregisterUntil UTCTime Maybe -- unenrolement may be prohibited from a given date onwards registerSecret Text Maybe -- enrolement maybe protected by a simple common passphrase materialFree Bool -- False: only enrolled users may see course materials not stored in this table - applicationsRequired Bool + applicationsRequired Bool default=false applicationsInstructions Html Maybe - applicationsText Bool - applicationsFiles UploadMode - applicationsRatingsVisible Bool + applicationsText Bool default=false + applicationsFiles UploadMode "default='{\"mode\": \"no-upload\"}'::jsonb" + applicationsRatingsVisible Bool default=false TermSchoolCourseShort term school shorthand -- shorthand must be unique within school and semester TermSchoolCourseName term school name -- name must be unique within school and semester deriving Generic diff --git a/models/exams b/models/exams index 694f1a9bc..7eff47789 100644 --- a/models/exams +++ b/models/exams @@ -1,9 +1,9 @@ Exam course CourseId name ExamName - gradingRule ExamGradingRule - bonusRule ExamBonusRule - occurrenceRule ExamOccurrenceRule + gradingRule ExamGradingRule Maybe + bonusRule ExamBonusRule Maybe + occurrenceRule ExamOccurrenceRule Maybe visibleFrom UTCTime Maybe registerFrom UTCTime Maybe registerTo UTCTime Maybe @@ -19,10 +19,12 @@ Exam UniqueExam course name ExamPart exam ExamId - name (CI Text) + number ExamPartNumber + name ExamPartName Maybe maxPoints Points Maybe weight Rational - UniqueExamPart exam name + UniqueExamPartNumber exam number + UniqueExamPartName exam name !force ExamOccurrence exam ExamId name ExamOccurrenceName @@ -42,7 +44,14 @@ ExamPartResult examPart ExamPartId user UserId result ExamResultPoints + lastChanged UTCTime default=now() UniqueExamPartResult examPart user +ExamBonus + exam ExamId + user UserId + bonus Points + lastChanged UTCTime default=now() + UniqueExamBonus exam user ExamResult exam ExamId user UserId diff --git a/nixpkgs.nix b/nixpkgs.nix index f21a81350..783ede000 100644 --- a/nixpkgs.nix +++ b/nixpkgs.nix @@ -4,6 +4,6 @@ import ((nixpkgs {}).fetchFromGitHub { owner = "NixOS"; repo = "nixpkgs"; - rev = "19.03"; - sha256 = "0q2m2qhyga9yq29yz90ywgjbn9hdahs7i8wwlq7b55rdbyiwa5dy"; + rev = "10e61bf5be57736035ec7a804cb0bf3d083bf2cf"; + sha256 = "0fplfm2zx4vk7gs8bdcxnvzkdmpx2w0llqwf8475z9dz9cl132rm"; }) diff --git a/package-lock.json b/package-lock.json index 785fdc8b6..5854e7166 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "6.11.1", + "version": "7.0.0", "lockfileVersion": 1, "requires": true, "dependencies": { @@ -7702,9 +7702,9 @@ "dev": true }, "handlebars": { - "version": "4.1.2", - "resolved": "https://registry.npmjs.org/handlebars/-/handlebars-4.1.2.tgz", - "integrity": "sha512-nvfrjqvt9xQ8Z/w0ijewdD/vvWDTOweBUm96NTr66Wfvo1mJenBLwcYmPs3TIBP5ruzYGD7Hx/DaM9RmhroGPw==", + "version": "4.3.1", + "resolved": "https://registry.npmjs.org/handlebars/-/handlebars-4.3.1.tgz", + "integrity": "sha512-c0HoNHzDiHpBt4Kqe99N8tdLPKAnGCQ73gYMPWtAYM4PwGnf7xl8PBUHJqh9ijlzt2uQKaSRxbXRt+rZ7M2/kA==", "dev": true, "requires": { "neo-async": "^2.6.0", @@ -15623,9 +15623,9 @@ "dev": true }, "uglify-js": { - "version": "3.5.15", - "resolved": "https://registry.npmjs.org/uglify-js/-/uglify-js-3.5.15.tgz", - "integrity": "sha512-fe7aYFotptIddkwcm6YuA0HmknBZ52ZzOsUxZEdhhkSsz7RfjHDX2QDxwKTiv4JQ5t5NhfmpgAK+J7LiDhKSqg==", + "version": "3.6.0", + "resolved": "https://registry.npmjs.org/uglify-js/-/uglify-js-3.6.0.tgz", + "integrity": "sha512-W+jrUHJr3DXKhrsS7NUVxn3zqMOFn0hL/Ei6v0anCIMoKC93TjcflTagwIHLW7SfMFfiQuktQyFVCFHGUE0+yg==", "dev": true, "optional": true, "requires": { diff --git a/package.json b/package.json index a598d4013..242dc4284 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "6.11.1", + "version": "7.0.0", "description": "", "keywords": [], "author": "", @@ -14,7 +14,9 @@ "yesod:start": "./start.sh", "yesod:lint": "./hlint.sh", "yesod:test": "./test.sh", + "yesod:test:watch": "./test.sh --file-watch", "yesod:build": "./build.sh", + "yesod:build:watch": "./build.sh --file-watch", "frontend:lint": "eslint frontend/src", "frontend:test": "karma start --conf karma.conf.js", "frontend:test:watch": "karma start --conf karma.conf.js --single-run false", diff --git a/package.yaml b/package.yaml index 067fce361..1d3882e41 100644 --- a/package.yaml +++ b/package.yaml @@ -1,41 +1,39 @@ name: uniworx -version: 6.11.1 +version: 7.0.0 dependencies: - # Due to a bug in GHC 8.0.1, we block its usage - # See: https://ghc.haskell.org/trac/ghc/ticket/12130 - - base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5 - # version 1.0 had a bug in reexporting Handler, causing trouble - - classy-prelude-yesod >=0.10.2 && <1.0 || >=1.1 - - foreign-store - - yesod >=1.4.3 && <1.5 - - yesod-core >=1.4.30 && <1.5 - - yesod-auth >=1.4.0 && <1.5 - - yesod-static >=1.4.0.3 && <1.6 - - yesod-form >=1.4.0 && <1.5 - - classy-prelude >=0.10.2 - - classy-prelude-conduit >=0.10.2 - - bytestring >=0.9 && <0.11 + - base >=4.9.1.0 && <5 + - yesod >=1.6 && <1.7 + - yesod-core >=1.6 && <1.7 + - yesod-auth >=1.6 && <1.7 + - yesod-static >=1.6 && <1.7 + - yesod-form >=1.6 && <1.7 + - classy-prelude >=1.5 && <1.6 + - classy-prelude-conduit >=1.5 && <1.6 + - classy-prelude-yesod >=1.5 && <1.6 + - bytestring >=0.10 && <0.11 - text >=0.11 && <2.0 - - persistent >=2.7.2 && <2.8 - - persistent-postgresql >=2.1.1 && <2.8 - - persistent-template >=2.0 && <2.8 + - persistent >=2.9 && <2.10 + - persistent-postgresql >=2.9 && <2.10 + - persistent-template >=2.5 && <2.9 + - persistent-qq >=2.9 && <2.10 - template-haskell - shakespeare >=2.0 && <2.1 - hjsmin >=0.1 && <0.3 - monad-control >=0.3 && <1.1 - wai-extra >=3.0 && <3.1 - - yaml >=0.8 && <0.9 - - http-conduit >=2.1 && <2.3 + - yaml >=0.11 && <0.12 + - http-conduit >=2.3 && <2.4 - directory >=1.1 && <1.4 - warp >=3.0 && <3.3 - data-default - - aeson >=0.6 && <1.3 + - aeson >=1.4 && <1.5 - conduit >=1.0 && <2.0 - conduit-combinators - monad-logger >=0.3 && <0.4 - fast-logger >=2.2 && <2.5 - wai-logger >=2.2 && <2.4 + - foreign-store - file-embed - safe - unordered-containers @@ -52,11 +50,12 @@ dependencies: - http-api-data - profunctors - colonnade >=1.1.1 - - yesod-colonnade >=1.1.0 - blaze-markup - zip-stream + - encoding - filepath - transformers + - transformers-base - wl-pprint-text - uuid-types - path-pieces @@ -100,8 +99,10 @@ dependencies: - th-abstraction - HaskellNet - HaskellNet-SSL - - network - - resource-pool + - network >=3 + - network-bsd + - unliftio + - unliftio-pool - mime-mail - hashable - aeson-pretty @@ -116,7 +117,6 @@ dependencies: - pkcs7 - memcached-binary - directory-tree - - lifted-base - lattices - hsass - semigroupoids @@ -126,7 +126,6 @@ dependencies: - mono-traversable - lens-aeson - systemd - - lifted-async - streaming-commons - hourglass - unix @@ -138,6 +137,7 @@ dependencies: - pqueue - deepseq - multiset + - retry other-extensions: - GeneralizedNewtypeDeriving @@ -183,6 +183,7 @@ default-extensions: - DeriveLift - DeriveFunctor - DerivingStrategies + - DerivingVia - DataKinds - BinaryLiterals - PolyKinds @@ -190,9 +191,12 @@ default-extensions: - TypeApplications - RecursiveDo - TypeFamilyDependencies + - QuantifiedConstraints ghc-options: - -Wall + - -Wmissing-home-modules + - -Wredundant-constraints - -fno-warn-type-defaults - -fno-warn-unrecognised-pragmas - -fno-warn-partial-type-signatures diff --git a/shell.nix b/shell.nix index d65bb65a3..1a285b264 100644 --- a/shell.nix +++ b/shell.nix @@ -19,7 +19,7 @@ let ''; override = oldAttrs: { - nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ nodejs-8_x postgresql pgadmin openldap ]) ++ (with haskellPackages; [ stack yesod-bin hlint cabal-install ]); + nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ nodejs-12_x postgresql openldap ]) ++ (with haskellPackages; [ stack yesod-bin hlint cabal-install ]); shellHook = '' export PROMPT_INFO="${oldAttrs.name}" @@ -47,6 +47,12 @@ let set +xe fi + if [ -n "$ZSH_VERSION" ]; then + autoload -U +X compinit && compinit + autoload -U +X bashcompinit && bashcompinit + fi + eval "$(stack --bash-completion-script stack)" + ${oldAttrs.shellHook} ''; }; diff --git a/src/Application.hs b/src/Application.hs index 7d5fa3c39..294e1a206 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -24,7 +24,7 @@ import Language.Haskell.TH.Syntax (qLocation) import Network.Wai (Middleware) import Network.Wai.Handler.Warp (Settings, defaultSettings, defaultShouldDisplayException, - runSettingsSocket, setHost, + runSettings, runSettingsSocket, setHost, setBeforeMainLoop, setOnException, setPort, getPort) import Data.Streaming.Network (bindPortTCP) @@ -54,7 +54,9 @@ import qualified Data.ByteString.Lazy as LBS import Network.HaskellNet.SSL hiding (Settings) import Network.HaskellNet.SMTP.SSL as SMTP hiding (Settings) -import Data.Pool + +import UnliftIO.Concurrent +import UnliftIO.Pool import Control.Monad.Trans.Resource @@ -70,17 +72,17 @@ import System.Exit import qualified Database.Memcached.Binary.IO as Memcached import qualified System.Systemd.Daemon as Systemd -import Control.Concurrent.Async.Lifted.Safe import System.Environment (lookupEnv) import System.Posix.Process (getProcessID) -import System.Posix.Signals (SignalInfo(..), installHandler, sigTERM) +import System.Posix.Signals (SignalInfo(..), installHandler, sigTERM, sigINT) import qualified System.Posix.Signals as Signals (Handler(..)) -import Network (socketPort) +import Network.Socket (socketPort, Socket, PortNumber) import qualified Network.Socket as Socket (close) import Control.Concurrent.STM.Delay import Control.Monad.STM (retry) +import Control.Monad.Trans.Cont (runContT, callCC) import qualified Data.Set as Set @@ -120,7 +122,7 @@ mkYesodDispatch "UniWorX" resourcesUniWorX -- performs initialization and returns a foundation datatype value. This is also -- the place to put your migrate statements to have automatic database -- migrations handled by Yesod. -makeFoundation :: (MonadResource m, MonadBaseControl IO m) => AppSettings -> m UniWorX +makeFoundation :: (MonadResource m, MonadUnliftIO m) => AppSettings -> m UniWorX makeFoundation appSettings'@AppSettings{..} = do -- Some basic initializations: HTTP connection manager, logger, and static -- subsite. @@ -146,7 +148,7 @@ makeFoundation appSettings'@AppSettings{..} = do oldLogger <- atomically . swapTVar tVar =<< mkLogger newSettings rmLoggerSet $ loggerSet oldLogger updateLogger newSettings - (tVar, ) <$> fork (updateLogger initialSettings) + (tVar, ) <$> forkIO (updateLogger initialSettings) appLogger <- over _2 fst <$> allocate mkLogger' (\(tVar, tId) -> killThread tId >> (readTVarIO tVar >>= rmLoggerSet . loggerSet)) let appStatic = embeddedStatic @@ -250,7 +252,7 @@ readInstanceIDFile idFile = liftIO . handle generateInstead $ LBS.readFile idFil instanceId <- UUID.nextRandom LBS.writeFile idFile $ UUID.toByteString instanceId return instanceId - | otherwise = throw e + | otherwise = throwIO e createSmtpPool :: MonadLoggerIO m => SmtpConf -> m SMTPPool createSmtpPool SmtpConf{ smtpPool = ResourcePoolConf{..}, .. } = do @@ -327,7 +329,7 @@ warpSettings foundation = defaultSettings void $ liftIO Systemd.notifyReady if | foundation ^. _appHealthCheckDelayNotify - -> void . fork $ do + -> void . forkIO $ do let activeChecks = Set.fromList universeF & Set.filter (is _Just . (foundation ^. _appHealthCheckInterval)) atomically $ do @@ -365,11 +367,20 @@ develMain = runResourceT $ do wsettings <- liftIO . getDevSettings $ warpSettings foundation app <- makeApplication foundation + let + awaitTermination :: IO () + awaitTermination + = flip runContT return . forever $ do + lift $ threadDelay 100e3 + whenM (lift $ doesFileExist "yesod-devel/devel-terminate") $ + callCC ($ ()) + + void . liftIO $ installHandler sigINT (Signals.Catch $ return ()) Nothing runAppLoggingT foundation $ handleJobs foundation - liftIO . develMainHelper $ return (wsettings, app) + void . liftIO $ awaitTermination `race` runSettings wsettings app -- | The @main@ function for an executable running this site. -appMain :: MonadResourceBase m => m () +appMain :: forall m. MonadUnliftIO m => m () appMain = runResourceT $ do settings <- getAppSettings @@ -397,7 +408,7 @@ appMain = runResourceT $ do $logInfoS "bind" [st|Listening on #{tshow host} port #{tshow port} as per configuration|] liftIO $ pure <$> bindPortTCP port host - $logDebugS "bind" . tshow =<< mapM (liftIO . socketPort) sockets + $logDebugS "bind" . tshow =<< mapM (liftIO . try . socketPort :: Socket -> _ (Either SomeException PortNumber)) sockets mainThreadId <- myThreadId liftIO . void . flip (installHandler sigTERM) Nothing . Signals.CatchInfo $ \SignalInfo{..} -> runAppLoggingT foundation $ do @@ -445,7 +456,7 @@ appMain = runResourceT $ do _other -> return () go status - in void $ allocate (async notifyWatchdog >>= \a -> a <$ link a) cancel + in void $ allocateLinkedAsync notifyWatchdog _other -> return () let runWarp socket = runSettingsSocket (warpSettings foundation) socket app @@ -461,7 +472,7 @@ appMain = runResourceT $ do foundationStoreNum :: Word32 foundationStoreNum = 2 -getApplicationRepl :: (MonadResource m, MonadBaseControl IO m) => m (Int, UniWorX, Application) +getApplicationRepl :: (MonadResource m, MonadUnliftIO m) => m (Int, UniWorX, Application) getApplicationRepl = do settings <- getAppDevSettings foundation <- makeFoundation settings @@ -475,7 +486,7 @@ getApplicationRepl = do return (getPort wsettings, foundation, app1) -shutdownApp :: (MonadIO m, MonadBaseControl IO m) => UniWorX -> m () +shutdownApp :: (MonadIO m, MonadUnliftIO m) => UniWorX -> m () shutdownApp app = do stopJobCtl app liftIO $ do @@ -494,7 +505,7 @@ handler :: Handler a -> IO a handler h = runResourceT $ getAppDevSettings >>= makeFoundation >>= liftIO . flip unsafeHandler h -- | Run DB queries -db :: ReaderT SqlBackend (HandlerT UniWorX IO) a -> IO a +db :: DB a -> IO a db = handler . runDB addPWEntry :: User diff --git a/src/Audit.hs b/src/Audit.hs index 06d3d8767..0b7890b8c 100644 --- a/src/Audit.hs +++ b/src/Audit.hs @@ -22,7 +22,7 @@ import qualified Network.Socket as Wai import qualified Net.IP as IP import qualified Net.IPv6 as IPv6 -import Control.Exception (ErrorCall(..), evaluate) +import Control.Exception (ErrorCall(..)) {-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-} @@ -79,7 +79,6 @@ instance Exception AuditException audit :: ( AuthId (HandlerSite m) ~ Key User - , AuthEntity (HandlerSite m) ~ User , IsSqlBackend (YesodPersistBackend (HandlerSite m)) , SqlBackendCanWrite (YesodPersistBackend (HandlerSite m)) , HasInstanceID (HandlerSite m) InstanceId @@ -99,7 +98,7 @@ audit (toJSON -> transactionLogInfo) = do transactionLogTime <- liftIO getCurrentTime transactionLogInstance <- getsYesod $ view instanceID - transactionLogInitiator <- liftHandlerT maybeAuthId + transactionLogInitiator <- liftHandler maybeAuthId transactionLogRemote <- handle (throwM . AuditRemoteException) $ Just <$> getRemote insert_ TransactionLog{..} diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs index 4d1e77356..5b835a722 100644 --- a/src/Audit/Types.hs +++ b/src/Audit/Types.hs @@ -23,6 +23,24 @@ data Transaction { transactionExam :: ExamId , transactionUser :: UserId } + + | TransactionExamPartResultEdit + { transactionExamPart :: ExamPartId + , transactionUser :: UserId + } + | TransactionExamPartResultDeleted + { transactionExamPart :: ExamPartId + , transactionUser :: UserId + } + + | TransactionExamBonusEdit + { transactionExam :: ExamId + , transactionUser :: UserId + } + | TransactionExamBonusDeleted + { transactionExam :: ExamId + , transactionUser :: UserId + } | TransactionExamResultEdit { transactionExam :: ExamId diff --git a/src/Auth/Dummy.hs b/src/Auth/Dummy.hs index 53a10acde..4bfc09d01 100644 --- a/src/Auth/Dummy.hs +++ b/src/Auth/Dummy.hs @@ -17,41 +17,47 @@ data DummyMessage = MsgDummyIdent deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) -dummyForm :: ( RenderMessage site FormMessage - , RenderMessage site DummyMessage - , YesodPersist site - , SqlBackendCanRead (YesodPersistBackend site) - , Button site ButtonSubmit - ) => AForm (HandlerT site IO) (CI Text) +dummyForm :: ( RenderMessage (HandlerSite m) FormMessage + , RenderMessage (HandlerSite m) DummyMessage + , YesodPersist (HandlerSite m) + , SqlBackendCanRead (YesodPersistBackend (HandlerSite m)) + , Button (HandlerSite m) ButtonSubmit + , MonadHandler m + ) => AForm m (CI Text) dummyForm = areq (ciField & addDatalist userList) (fslI MsgDummyIdent & noAutocomplete) Nothing where - userList = fmap mkOptionList . runDB $ map toOption <$> selectList [] [Asc UserIdent] + userList = fmap mkOptionList . runDB $ withReaderT projectBackend (map toOption <$> selectList [] [Asc UserIdent] :: ReaderT SqlBackend _ [Option UserIdent]) toOption (Entity _ User{..}) = Option userDisplayName userIdent (CI.original userIdent) -dummyLogin :: ( YesodAuth site +dummyLogin :: forall site. + ( YesodAuth site , YesodPersist site , SqlBackendCanRead (YesodPersistBackend site) - , RenderMessage site FormMessage , RenderMessage site AFormMessage , RenderMessage site DummyMessage , Button site ButtonSubmit ) => AuthPlugin site dummyLogin = AuthPlugin{..} where + apName :: Text apName = "dummy" - -- apDispatch :: Text -> [Text] -> HandlerT Auth (HandlerT site IO) TypedContent - apDispatch "POST" [] = do - ((loginRes, _), _) <- lift . runFormPost $ renderAForm FormStandard dummyForm + + apDispatch :: forall m. MonadAuthHandler site m => Text -> [Text] -> m TypedContent + apDispatch "POST" [] = liftSubHandler $ do + ((loginRes, _), _) <- runFormPost $ renderAForm FormStandard dummyForm + tp <- getRouteToParent case loginRes of FormFailure errs -> do - lift . forM_ errs $ addMessage Error . toHtml - redirect LoginR + forM_ errs $ addMessage Error . toHtml + redirect $ tp LoginR FormMissing -> do - lift $ addMessageI Warning MsgDummyNoFormData - redirect LoginR + addMessageI Warning MsgDummyNoFormData + redirect $ tp LoginR FormSuccess ident -> - lift . setCredsRedirect $ Creds "dummy" (CI.original ident) [] + setCredsRedirect $ Creds "dummy" (CI.original ident) [] apDispatch _ _ = notFound + + apLogin :: (Route Auth -> Route site) -> WidgetFor site () apLogin toMaster = do (login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard dummyForm let loginForm = wrapForm login FormSettings diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index 320ab6e27..1ba6af9e7 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -84,7 +84,7 @@ instance Exception CampusUserException makePrisms ''CampusUserException -campusUser :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) => LdapConf -> LdapPool -> Creds site -> m (Ldap.AttrList []) +campusUser :: MonadUnliftIO m => LdapConf -> LdapPool -> Creds site -> m (Ldap.AttrList []) campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdap pool $ \ldap -> do Ldap.bind ldap ldapDn ldapPassword results <- case lookup "DN" credsExtra of @@ -109,15 +109,15 @@ campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $ , Exc.Handler $ \(HostCannotConnect host excs) -> throwM $ CampusUserHostCannotConnect host excs ] -campusUser' :: (MonadBaseControl IO m, MonadCatch m, MonadIO m) => LdapConf -> LdapPool -> User -> m (Maybe (Ldap.AttrList [])) +campusUser' :: (MonadCatch m, MonadUnliftIO m) => LdapConf -> LdapPool -> User -> m (Maybe (Ldap.AttrList [])) campusUser' conf pool User{userIdent} = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUser conf pool (Creds apLdap (CI.original userIdent) []) -campusForm :: ( RenderMessage site FormMessage - , RenderMessage site CampusMessage - , Button site ButtonSubmit - ) => WForm (HandlerT site IO) (FormResult CampusLogin) +campusForm :: ( RenderMessage (HandlerSite m) FormMessage + , RenderMessage (HandlerSite m) CampusMessage + , MonadHandler m + ) => WForm m (FormResult CampusLogin) campusForm = do MsgRenderer mr <- getMsgRenderer @@ -133,24 +133,26 @@ apLdap = "LDAP" campusLogin :: forall site. ( YesodAuth site - , RenderMessage site FormMessage , RenderMessage site CampusMessage , RenderMessage site AFormMessage , Button site ButtonSubmit ) => LdapConf -> LdapPool -> AuthPlugin site campusLogin conf@LdapConf{..} pool = AuthPlugin{..} where + apName :: Text apName = apLdap - apDispatch :: Text -> [Text] -> HandlerT Auth (HandlerT site IO) TypedContent - apDispatch "POST" [] = do - ((loginRes, _), _) <- lift . runFormPost $ renderWForm FormStandard campusForm + + apDispatch :: forall m. MonadAuthHandler site m => Text -> [Text] -> m TypedContent + apDispatch "POST" [] = liftSubHandler $ do + ((loginRes, _), _) <- runFormPost $ renderWForm FormStandard campusForm + tp <- getRouteToParent case loginRes of FormFailure errs -> do forM_ errs $ addMessage Error . toHtml - redirect LoginR - FormMissing -> redirect LoginR + redirect $ tp LoginR + FormMissing -> redirect $ tp LoginR FormSuccess CampusLogin{ campusIdent = CI.original -> campusIdent, ..} -> do - ldapResult <- withLdap pool $ \ldap -> do + ldapResult <- withLdap pool $ \ldap -> liftIO $ do Ldap.bind ldap ldapDn ldapPassword searchResults <- findUser conf ldap campusIdent [ldapUserPrincipalName] case searchResults of @@ -169,11 +171,13 @@ campusLogin conf@LdapConf{..} pool = AuthPlugin{..} $logErrorS "LDAP" $ "Error during login: " <> tshow err loginErrorMessageI LoginR Msg.AuthError Right (Right (userDN, credsIdent)) -> - lift . setCredsRedirect $ Creds apName credsIdent [("DN", userDN)] + setCredsRedirect $ Creds apName credsIdent [("DN", userDN)] Right (Left searchResults) -> do $logWarnS "LDAP" $ "Could not extract principal name: " <> tshow searchResults loginErrorMessageI LoginR Msg.AuthError apDispatch _ _ = notFound + + apLogin :: (Route Auth -> Route site) -> WidgetFor site () apLogin toMaster = do (login, loginEnctype) <- handlerToWidget . generateFormPost $ renderWForm FormStandard campusForm let loginForm = wrapForm login FormSettings diff --git a/src/Auth/PWHash.hs b/src/Auth/PWHash.hs index d6f5bf4e8..b2194bf90 100644 --- a/src/Auth/PWHash.hs +++ b/src/Auth/PWHash.hs @@ -26,68 +26,50 @@ data PWHashMessage = MsgPWHashIdent deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) -hashForm :: ( RenderMessage site FormMessage - , RenderMessage site PWHashMessage - , Button site ButtonSubmit - ) => AForm (HandlerT site IO) HashLogin +hashForm :: ( RenderMessage (HandlerSite m) FormMessage + , RenderMessage (HandlerSite m) PWHashMessage + , MonadHandler m + ) => AForm m HashLogin hashForm = HashLogin <$> areq ciField (fslpI MsgPWHashIdent "Identifikation") Nothing <*> areq passwordField (fslpI MsgPWHashPassword "Passwort") Nothing -hashLogin :: ( YesodAuth site +hashLogin :: forall site. + ( YesodAuth site , YesodPersist site , SqlBackendCanRead (YesodPersistBackend site) - , RenderMessage site FormMessage + , PersistRecordBackend User (YesodPersistBackend site) , RenderMessage site PWHashMessage , RenderMessage site AFormMessage , Button site ButtonSubmit ) => PWHashAlgorithm -> AuthPlugin site hashLogin pwHashAlgo = AuthPlugin{..} where + apName :: Text apName = "PWHash" - apDispatch "POST" [] = do - ((loginRes, _), _) <- lift . runFormPost $ renderAForm FormStandard hashForm + + apDispatch :: forall m. MonadAuthHandler site m => Text -> [Text] -> m TypedContent + apDispatch "POST" [] = liftSubHandler $ do + ((loginRes, _), _) <- runFormPost $ renderAForm FormStandard hashForm + tp <- getRouteToParent case loginRes of FormFailure errs -> do forM_ errs $ addMessage Error . toHtml - redirect LoginR - FormMissing -> redirect LoginR + redirect $ tp LoginR + FormMissing -> redirect $ tp LoginR FormSuccess HashLogin{..} -> do - user <- lift . runDB . getBy $ UniqueAuthentication hashIdent + user <- liftHandler . runDB . getBy $ UniqueAuthentication hashIdent case user of Just (Entity _ User{ userAuthentication = AuthPWHash{..}, userIdent = CI.original -> userIdent }) | verifyPasswordWith pwHashAlgo (2^) (encodeUtf8 hashPassword) (encodeUtf8 authPWHash) -> -- (2^) is magic. - lift . setCredsRedirect $ Creds apName userIdent [] + setCredsRedirect $ Creds apName userIdent [] other -> do $logDebugS "PWHash" $ tshow other loginErrorMessageI LoginR Msg.InvalidLogin - -- apDispatch "GET" [] = do - -- authData <- lookupBasicAuth - -- pwdata <- liftIO $ Yaml.decodeFileEither fp - - -- addHeader "WWW-Authenticate" [st|Basic realm="uni2work maintenance auth" charset="UTF-8"|] - - -- case pwdata of - -- Left err -> $logDebugS "Auth" $ tshow err - -- Right pws -> $logDebugS "Auth" $ tshow (length pws) <> " pw entries" - - -- case (authData, pwdata) of - -- (Nothing, _) -> do - -- notAuthenticated - -- (Just (usr, (Text.encodeUtf8 -> pw)), Right pwdata') - -- | [ PWEntry{ pwUser = pwUser@(User{..}), pwHash = (Text.encodeUtf8 -> pwHash) } ] - -- <- [ pwe | pwe@PWEntry{..} <- pwdata' - -- , let User{..} = pwUser - -- , userIdent == usr - -- , userPlugin == apName - -- ] - -- , verifyPassword pw pwHash - -- -> lift $ do - -- runDB . void $ insertUnique pwUser - -- setCredsRedirect $ Creds apName userIdent [] - -- _ -> permissionDenied "Invalid auth" apDispatch _ _ = notFound + + apLogin :: (Route Auth -> Route site) -> WidgetFor site () apLogin toMaster = do (login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard hashForm let loginForm = wrapForm login FormSettings diff --git a/src/Control/Concurrent/Async/Lifted/Safe/Utils.hs b/src/Control/Concurrent/Async/Lifted/Safe/Utils.hs deleted file mode 100644 index 27dc86127..000000000 --- a/src/Control/Concurrent/Async/Lifted/Safe/Utils.hs +++ /dev/null @@ -1,17 +0,0 @@ -module Control.Concurrent.Async.Lifted.Safe.Utils - ( allocateAsync, allocateLinkedAsync - ) where - -import ClassyPrelude hiding (cancel) -import Control.Lens - -import Control.Concurrent.Async.Lifted.Safe - -import Control.Monad.Trans.Resource - - -allocateLinkedAsync, allocateAsync :: forall m a. - MonadResource m - => IO a -> m (Async a) -allocateAsync = fmap (view _2) . flip allocate cancel . async -allocateLinkedAsync = uncurry (<$) . (id &&& link) <=< allocateAsync diff --git a/src/CryptoID.hs b/src/CryptoID.hs index 9263ca308..0f1296887 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -8,11 +8,12 @@ module CryptoID , module System.FilePath.Cryptographic.ImplicitNamespace ) where -import CryptoID.TH -import ClassyPrelude +import Import.NoModel import Model +import CryptoID.TH + import qualified Data.CryptoID as E import Data.CryptoID.Poly.ImplicitNamespace import Data.UUID.Cryptographic.ImplicitNamespace @@ -20,9 +21,6 @@ import System.FilePath.Cryptographic.ImplicitNamespace import qualified Data.Text as Text --- import Data.UUID.Types -import Web.PathPieces - import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI diff --git a/src/Data/CaseInsensitive/Instances.hs b/src/Data/CaseInsensitive/Instances.hs index 937fb2c46..f218308f5 100644 --- a/src/Data/CaseInsensitive/Instances.hs +++ b/src/Data/CaseInsensitive/Instances.hs @@ -1,5 +1,6 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} module Data.CaseInsensitive.Instances ( diff --git a/src/Data/CryptoID/Instances.hs b/src/Data/CryptoID/Instances.hs index 0867f60b5..b48c0df70 100644 --- a/src/Data/CryptoID/Instances.hs +++ b/src/Data/CryptoID/Instances.hs @@ -43,5 +43,5 @@ instance Csv.FromField s => Csv.FromField (CID.CryptoID c s) where instance Csv.ToField s => Csv.ToField (CID.CryptoID c s) where toField = Csv.toField . CID.ciphertext -instance {-# OVERLAPS #-} (Csv.ToField s, CI.FoldCase s) => Csv.ToField (CID.CryptoID c (CI s)) where +instance {-# OVERLAPS #-} Csv.ToField s => Csv.ToField (CID.CryptoID c (CI s)) where toField = Csv.toField . CI.foldedCase . CID.ciphertext diff --git a/src/Data/List/NonEmpty/Instances.hs b/src/Data/List/NonEmpty/Instances.hs deleted file mode 100644 index f151b6c18..000000000 --- a/src/Data/List/NonEmpty/Instances.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Data.List.NonEmpty.Instances - ( - ) where - -import Data.List.NonEmpty - -import Language.Haskell.TH.Syntax (Lift(..)) - -instance Lift a => Lift (NonEmpty a) where - lift (toList -> xs) = [e|fromList xs|] diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index a71b0b811..2cdfc69d2 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} module Database.Esqueleto.Utils ( true, false @@ -61,24 +62,22 @@ false :: E.SqlExpr (E.Value Bool) false = E.val False -- | Negation of `isNothing` which is missing -isJust :: (E.Esqueleto query expr backend, PersistField typ) => expr (E.Value (Maybe typ)) -> expr (E.Value Bool) +isJust :: PersistField typ => E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool) isJust = E.not_ . E.isNothing infix 4 `isInfixOf`, `hasInfix` -- | Check if the first string is contained in the text derived from the second argument -isInfixOf :: ( E.Esqueleto query expr backend - , E.SqlString s1 +isInfixOf :: ( E.SqlString s1 , E.SqlString s2 ) - => expr (E.Value s1) -> expr (E.Value s2) -> expr (E.Value Bool) + => E.SqlExpr (E.Value s1) -> E.SqlExpr (E.Value s2) -> E.SqlExpr (E.Value Bool) isInfixOf needle strExpr = E.castString strExpr `E.ilike` (E.%) E.++. needle E.++. (E.%) -hasInfix :: ( E.Esqueleto query expr backend - , E.SqlString s1 +hasInfix :: ( E.SqlString s1 , E.SqlString s2 ) - => expr (E.Value s2) -> expr (E.Value s1) -> expr (E.Value Bool) + => E.SqlExpr (E.Value s2) -> E.SqlExpr (E.Value s1) -> E.SqlExpr (E.Value Bool) hasInfix = flip isInfixOf and, or :: Foldable f => f (E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool) diff --git a/src/Database/Persist/Class/Instances.hs b/src/Database/Persist/Class/Instances.hs index 2dbb2bfb0..8666a2c87 100644 --- a/src/Database/Persist/Class/Instances.hs +++ b/src/Database/Persist/Class/Instances.hs @@ -8,11 +8,14 @@ module Database.Persist.Class.Instances import ClassyPrelude import Database.Persist.Class +import Database.Persist.Types (HaskellName, DBName, PersistValue) import Database.Persist.Types.Instances () import Data.Binary (Binary) import qualified Data.Binary as Binary +import qualified Data.Map as Map + instance PersistEntity record => Hashable (Key record) where hashWithSalt s = hashWithSalt s . toPersistValue @@ -24,3 +27,13 @@ instance PersistEntity record => Binary (Key record) where instance PersistEntity record => NFData (Key record) where rnf = rnf . keyToValues + + +uniqueToMap :: PersistEntity record => Unique record -> Map (HaskellName, DBName) PersistValue +uniqueToMap = fmap Map.fromList $ zip <$> persistUniqueToFieldNames <*> persistUniqueToValues + +instance PersistEntity record => Eq (Unique record) where + (==) = (==) `on` uniqueToMap + +instance PersistEntity record => Show (Unique record) where + showsPrec p = showsPrec p . uniqueToMap diff --git a/src/Foundation.hs b/src/Foundation.hs index 3f70dd564..a9d2d1df0 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -5,7 +5,6 @@ module Foundation where import Import.NoFoundation hiding (embedFile) -import qualified ClassyPrelude.Yesod as Yesod (getHttpManager) import Database.Persist.Sql (ConnectionPool, runSqlPool) import Text.Hamlet (hamletFile) @@ -48,9 +47,6 @@ import Data.List (nubBy, (!!), findIndex) import Data.Monoid (Any(..)) -import Data.Pool - -import Data.Conduit (($$)) import Data.Conduit.List (sourceList) import qualified Database.Esqueleto as E @@ -94,6 +90,8 @@ import Data.FileEmbed (embedFile) import qualified Ldap.Client as Ldap +import UnliftIO.Pool + type SMTPPool = Pool SMTPConnection @@ -162,9 +160,9 @@ deriving instance Generic (Route UniWorX) -- | Convenient Type Synonyms: type DB = YesodDB UniWorX -type Form x = Html -> MForm (HandlerT UniWorX IO) (FormResult x, Widget) +type Form x = Html -> MForm (HandlerFor UniWorX) (FormResult x, Widget) type MsgRenderer = MsgRendererS UniWorX -- see Utils -type MailM a = MailT (HandlerT UniWorX IO) a +type MailM a = MailT (HandlerFor UniWorX) a -- Pattern Synonyms for convenience pattern CSheetR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetR -> Route UniWorX @@ -531,13 +529,13 @@ class (MonadHandler m, HandlerSite m ~ UniWorX) => MonadAP m where evalAccessPred :: AccessPredicate -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult instance {-# INCOHERENT #-} (MonadHandler m, HandlerSite m ~ UniWorX) => MonadAP m where - evalAccessPred aPred aid r w = liftHandlerT $ case aPred of + evalAccessPred aPred aid r w = liftHandler $ case aPred of (APPure p) -> runReader (p aid r w) <$> getMsgRenderer (APHandler p) -> p aid r w (APDB p) -> runDB $ p aid r w instance (MonadHandler m, HandlerSite m ~ UniWorX, backend ~ YesodPersistBackend UniWorX) => MonadAP (ReaderT backend m) where - evalAccessPred aPred aid r w = mapReaderT liftHandlerT $ case aPred of + evalAccessPred aPred aid r w = mapReaderT liftHandler $ case aPred of (APPure p) -> lift $ runReader (p aid r w) <$> getMsgRenderer (APHandler p) -> lift $ p aid r w (APDB p) -> p aid r w @@ -573,7 +571,6 @@ falseAP = APPure . const . const . const $ falseAR <$> ask -- included for compl askTokenUnsafe :: forall m. ( MonadHandler m , HandlerSite m ~ UniWorX - , MonadLogger m , MonadCatch m ) => ExceptT AuthResult m (BearerToken (UniWorX)) @@ -690,7 +687,7 @@ tagAccessPredicate AuthNoEscalation = APDB $ \mAuthId route _ -> case route of tagAccessPredicate AuthDeprecated = APHandler $ \_ r _ -> do $logWarnS "AccessControl" ("deprecated route: " <> tshow r) addMessageI Error MsgDeprecatedRoute - allow <- view _appAllowDeprecated + allow <- getsYesod $ view _appAllowDeprecated return $ bool (Unauthorized "Deprecated Route") Authorized allow tagAccessPredicate AuthDevelopment = APHandler $ \_ r _ -> do $logWarnS "AccessControl" ("route in development: " <> tshow r) @@ -1107,9 +1104,9 @@ tagAccessPredicate AuthAllocationRegistered = APDB $ \mAuthId route _ -> case ro tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of CourseR tid ssh csh (CUserR cID) -> exceptT return return $ do cTime <- liftIO getCurrentTime - let authorizedIfExists f = do - [E.Value ok] <- lift . E.select . return . E.exists $ E.from f - whenExceptT ok Authorized + let + authorizedIfExists :: E.From a => (a -> E.SqlQuery b) -> ExceptT AuthResult DB () + authorizedIfExists = flip whenExceptT Authorized <=< lift . E.selectExists . E.from participant <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedParticipant) (const True :: CryptoIDError -> Bool) $ decrypt cID -- participant is currently registered $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` courseParticipant) -> do @@ -1395,42 +1392,42 @@ evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . dnf return result -evalAccessFor :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult +evalAccessFor :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult evalAccessFor mAuthId route isWrite = do dnf <- either throwM return $ routeAuthTags route fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) dnf mAuthId route isWrite -evalAccessForDB :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult +evalAccessForDB :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult evalAccessForDB = evalAccessFor -evalAccess :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m AuthResult +evalAccess :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m AuthResult evalAccess route isWrite = do - mAuthId <- liftHandlerT maybeAuthId + mAuthId <- liftHandler maybeAuthId tagActive <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags dnf <- either throwM return $ routeAuthTags route (result, deactivated) <- runWriterT $ evalAuthTags tagActive dnf mAuthId route isWrite result <$ tellSessionJson SessionInactiveAuthTags deactivated -evalAccessDB :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult +evalAccessDB :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult evalAccessDB = evalAccess -- | Check whether the current user is authorized by `evalAccess` for the given route -- Convenience function for a commonly used code fragment -hasAccessTo :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m Bool +hasAccessTo :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m Bool hasAccessTo route isWrite = (== Authorized) <$> evalAccess route isWrite -- | Check whether the current user is authorized by `evalAccess` to read from the given route -- Convenience function for a commonly used code fragment -hasReadAccessTo :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m Bool +hasReadAccessTo :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m Bool hasReadAccessTo = flip hasAccessTo False -- | Check whether the current user is authorized by `evalAccess` to rwrite to the given route -- Convenience function for a commonly used code fragment -hasWriteAccessTo :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m Bool +hasWriteAccessTo :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m Bool hasWriteAccessTo = flip hasAccessTo True -- | Conditional redirect that hides the URL if the user is not authorized for the route -redirectAccess :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m a +redirectAccess :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m a redirectAccess url = do -- must hide URL if not authorized access <- evalAccess url False @@ -1439,7 +1436,7 @@ redirectAccess url = do _ -> permissionDeniedI MsgUnauthorizedRedirect -- | Verify that the currently logged in user is lecturer or corrector for at least one sheet for the given course -evalAccessCorrector :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) +evalAccessCorrector :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => TermId -> SchoolId -> CourseShorthand -> m AuthResult evalAccessCorrector tid ssh csh = evalAccess (CourseR tid ssh csh CNotesR) False @@ -1481,7 +1478,7 @@ instance Yesod UniWorX where $logDebugS "updateFavourites" "Updating favourites" now <- liftIO $ getCurrentTime - uid <- MaybeT $ liftHandlerT maybeAuthId + uid <- MaybeT $ liftHandler maybeAuthId cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh user <- MaybeT $ get uid let courseFavourite = CourseFavourite uid now cid @@ -1533,7 +1530,7 @@ instance Yesod UniWorX where encrypted :: ToJSON a => a -> Widget -> Widget encrypted plaintextJson plaintext = do canDecrypt <- (== Authorized) <$> evalAccess AdminErrMsgR True - shouldEncrypt <- view _appEncryptErrors + shouldEncrypt <- getsYesod $ view _appEncryptErrors if | shouldEncrypt , not canDecrypt -> do @@ -1596,14 +1593,13 @@ instance Yesod UniWorX where . decodeUtf8 . Base64.encode . (convert :: Digest (SHAKE256 144) -> ByteString) - . runIdentity - $ sourceList (Lazy.ByteString.toChunks content) $$ sinkHash + . runConduitPure + $ sourceList (Lazy.ByteString.toChunks content) .| sinkHash fileUpload _site _length = FileUploadMemory lbsBackEnd -- What messages should be logged. The following includes all messages when -- in development, and warnings and errors in production. - shouldLog _ _ _ = error "Must use shouldLogIO" shouldLogIO app _source level = do LogSettings{..} <- readTVarIO $ appLogSettings app return $ logAll || level >= logMinimumLevel @@ -1626,7 +1622,7 @@ siteLayout = siteLayout' . Just siteLayout' :: Maybe Widget -- ^ Optionally override `pageHeading` -> Widget -> Handler Html siteLayout' headingOverride widget = do - AppSettings { appUserDefaults = UserDefaultConf{..}, .. } <- view appSettings + AppSettings { appUserDefaults = UserDefaultConf{..}, .. } <- getsYesod $ view appSettings isModal <- hasCustomHeader HeaderIsModal @@ -1747,7 +1743,7 @@ siteLayout' headingOverride widget = do applySystemMessages :: (MonadHandler m, HandlerSite m ~ UniWorX) => m () -applySystemMessages = liftHandlerT . runDB . runConduit $ selectSource [] [] .| C.mapM_ applyMessage +applySystemMessages = liftHandler . runDB . runConduit $ selectSource [] [] .| C.mapM_ applyMessage where applyMessage (Entity smId SystemMessage{..}) = maybeT_ $ do cID <- encrypt smId @@ -2548,7 +2544,7 @@ pageActions (CourseR tid ssh csh SheetListR) = case muid of Nothing -> return False (Just uid) -> do - [E.Value ok] <- runDB . E.select . return . E.exists . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission) -> do + ok <- runDB . E.selectExists . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission) -> do E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId E.where_ $ submission E.^. SubmissionRatingBy E.==. E.just (E.val uid) @@ -2717,6 +2713,24 @@ pageActions (CExamR tid ssh csh examn EUsersR) = , menuItemModal = True , menuItemAccessCallback' = return True } + , MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuExamGrades + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CExamR tid ssh csh examn EGradesR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + ] +pageActions (CExamR tid ssh csh examn EGradesR) = + [ MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuExamUsers + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CExamR tid ssh csh examn EUsersR + , menuItemModal = False + , menuItemAccessCallback' = return True + } ] pageActions (CSheetR tid ssh csh shn SShowR) = [ MenuItem @@ -2726,7 +2740,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) = , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SubmissionNewR , menuItemModal = True , menuItemAccessCallback' = runDB . maybeT (return False) $ do - uid <- MaybeT $ liftHandlerT maybeAuthId + uid <- MaybeT $ liftHandler maybeAuthId submissions <- lift $ submissionList tid csh shn uid guard $ null submissions return True @@ -2738,7 +2752,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) = , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SubmissionOwnR , menuItemModal = False , menuItemAccessCallback' = runDB . maybeT (return False) $ do - uid <- MaybeT $ liftHandlerT maybeAuthId + uid <- MaybeT $ liftHandler maybeAuthId submissions <- lift $ submissionList tid csh shn uid guard . not $ null submissions return True @@ -2948,7 +2962,7 @@ pageActions (CorrectionsR) = , menuItemRoute = SomeRoute CorrectionsCreateR , menuItemModal = False , menuItemAccessCallback' = runDB . maybeT (return False) $ do - uid <- MaybeT $ liftHandlerT maybeAuthId + uid <- MaybeT $ liftHandler maybeAuthId sheets <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse let @@ -2987,7 +3001,7 @@ pageActions (CorrectionsGradeR) = , menuItemRoute = SomeRoute CorrectionsCreateR , menuItemModal = False , menuItemAccessCallback' = runDB . maybeT (return False) $ do - uid <- MaybeT $ liftHandlerT maybeAuthId + uid <- MaybeT $ liftHandler maybeAuthId sheets <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse let @@ -3006,7 +3020,7 @@ pageActions _ = [] i18nHeading :: (MonadWidget m, RenderMessage site msg, HandlerSite m ~ site) => msg -> m () -i18nHeading msg = liftWidgetT $ toWidget =<< getMessageRender <*> pure msg +i18nHeading msg = liftWidget $ toWidget =<< getMessageRender <*> pure msg -- | only used in defaultLayout; better use siteLayout instead! pageHeading :: Route UniWorX -> Maybe Widget @@ -3113,7 +3127,7 @@ pageHeading _ = Nothing -routeNormalizers :: [Route UniWorX -> WriterT Any (ReaderT (YesodPersistBackend UniWorX) (HandlerT UniWorX IO)) (Route UniWorX)] +routeNormalizers :: [Route UniWorX -> WriterT Any DB (Route UniWorX)] routeNormalizers = [ normalizeRender , ncSchool @@ -3124,7 +3138,7 @@ routeNormalizers = ] where normalizeRender route = route <$ do - YesodRequest{..} <- liftHandlerT getRequest + YesodRequest{..} <- liftHandler getRequest let original = (W.pathInfo reqWaiRequest, reqGetParams) rendered = renderRoute route if @@ -3320,10 +3334,10 @@ upsertCampusUser ldapData Creds{..} = do . UUID.fromByteString . fromStrict . (convert :: Digest (SHAKE128 128) -> ByteString) - . runIdentity - $ sourceList (toStrict . Binary.encode <$> Set.toList studyTermCandidates) $$ sinkHash + . runConduitPure + $ sourceList (toStrict . Binary.encode <$> Set.toList studyTermCandidates) .| sinkHash - [E.Value candidatesRecorded] <- E.select . return . E.exists . E.from $ \candidate -> + candidatesRecorded <- E.selectExists . E.from $ \candidate -> E.where_ $ candidate E.^. StudyTermCandidateIncidence E.==. E.val studyTermCandidateIncidence unless candidatesRecorded $ do @@ -3401,14 +3415,14 @@ instance YesodAuth UniWorX where loginHandler = do toParent <- getRouteToParent - lift . defaultLayout $ do + liftHandler . defaultLayout $ do plugins <- getsYesod authPlugins $logDebugS "Auth" $ "Enabled plugins: " <> Text.intercalate ", " (map apName plugins) setTitleI MsgLoginTitle $(widgetFile "login") - authenticate Creds{..} = runDB $ do + authenticate Creds{..} = liftHandler . runDB $ do now <- liftIO getCurrentTime let @@ -3477,7 +3491,7 @@ instance YesodAuth UniWorX where , dummyLogin <$ guard appAuthDummyLogin ] - authHttpManager = Yesod.getHttpManager + authHttpManager = getsYesod appHttpManager onLogin = addMessageI Success Auth.NowLoggedIn diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 1427533d3..a992d9eb9 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -54,7 +54,7 @@ instance Button UniWorX ButtonCreate where btnClasses CreateInf = [BCIsButton, BCPrimary] -- END Button needed only here -emailTestForm :: AForm (HandlerT UniWorX IO) (Email, MailContext) +emailTestForm :: AForm (HandlerFor UniWorX) (Email, MailContext) emailTestForm = (,) <$> areq emailField (fslI MsgMailTestFormEmail) Nothing <*> ( MailContext @@ -112,7 +112,7 @@ postAdminTestR = do jId <- queueJob $ JobSendTestEmail email ls tell . pure $ Message Success [shamlet|Email-test gestartet (Job ##{tshow (fromSqlKey jId)})|] (Just IconEmail) return jId - writeJobCtl $ JobCtlPerform jId + runReaderT (writeJobCtl $ JobCtlPerform jId) =<< getYesod addMessage Warning [shamlet|Inkorrekt ausgegebener Alert|] -- For testing alert handling when short circuiting; for proper (not fallback-solution) handling always use `tell` within `formResultModal` let emailWidget' = wrapForm emailWidget def @@ -189,7 +189,7 @@ postAdminTestR = do -- | How does the shape (`ListLength`) change if a certain cell is deleted? deleteCell :: Map ListPosition Int -- ^ Current shape, including initialisation data -> ListPosition -- ^ Coordinate to delete - -> MaybeT (MForm (HandlerT UniWorX IO)) (Map ListPosition ListPosition) -- ^ Monadically compute a set of new positions and their associated old positions + -> MaybeT (MForm (HandlerFor UniWorX)) (Map ListPosition ListPosition) -- ^ Monadically compute a set of new positions and their associated old positions deleteCell = miDeleteList -- | Make a decision on whether an add widget should be allowed to further cells, given the current @liveliness@ (i.e. before performing the addition) allowAdd :: ListPosition -> Natural -> ListLength -> Bool @@ -374,7 +374,7 @@ postAdminFeaturesR = do -> Getter (DBRow r) (Maybe Text) -> Getter (DBRow r) i -> DBRow r - -> DBCell (MForm (HandlerT UniWorX IO)) (FormResult (DBFormResult i a (DBRow r))) + -> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r))) textInputCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex) (\row _mkUnique -> (\(res,fieldView) -> (set lensRes . assertM (not . Text.null) <$> res, fvInput fieldView)) <$> mopt textField "" (Just $ row ^. lensDefault) @@ -385,7 +385,7 @@ postAdminFeaturesR = do -> Getter (DBRow r) Bool -> Getter (DBRow r) i -> DBRow r - -> DBCell (MForm (HandlerT UniWorX IO)) (FormResult (DBFormResult i a (DBRow r))) + -> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r))) checkboxCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex) ( \row _mkUnique -> (\(res, fieldView) -> (set lensRes <$> res, fvInput fieldView)) <$> mpopt checkBoxField "" (Just $ row ^. lensDefault) diff --git a/src/Handler/Allocation/Application.hs b/src/Handler/Allocation/Application.hs index bc19f3dc2..d9e48239a 100644 --- a/src/Handler/Allocation/Application.hs +++ b/src/Handler/Allocation/Application.hs @@ -52,7 +52,7 @@ data ApplicationForm = ApplicationForm { afPriority :: Maybe Natural , afField :: Maybe StudyFeaturesId , afText :: Maybe Text - , afFiles :: Maybe (Source Handler File) + , afFiles :: Maybe (ConduitT () File Handler ()) , afRatingVeto :: Bool , afRatingPoints :: Maybe ExamGrade , afRatingComment :: Maybe Text @@ -77,11 +77,11 @@ applicationForm :: (Maybe AllocationId) -> Html -> MForm Handler (FormResult ApplicationForm, ApplicationFormView) applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf = do - (mApp, coursesNum, Course{..}, maxPrio) <- liftHandlerT . runDB $ do + (mApp, coursesNum, Course{..}, maxPrio) <- liftHandler . runDB $ do mApplication <- listToMaybe <$> selectList [CourseApplicationAllocation ==. maId, CourseApplicationUser ==. uid, CourseApplicationCourse ==. cid] [LimitTo 1] coursesNum <- fromIntegral . fromMaybe 1 <$> for maId (\aId -> count [AllocationCourseAllocation ==. aId]) course <- getJust cid - [E.Value (fromMaybe 0 -> maxPrio)] <- E.select . E.from $ \courseApplication -> do + (fromMaybe 0 -> maxPrio) <- fmap ((>>= E.unValue) . listToMaybe) . E.select . E.from $ \courseApplication -> do E.where_ $ courseApplication E.^. CourseApplicationCourse E.==. E.val cid E.&&. courseApplication E.^. CourseApplicationUser E.==. E.val uid E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.val maId @@ -146,7 +146,7 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf -> over _2 Just . over (_1 . _FormSuccess) (assertM $ not . Text.null) <$> mopt textField' textFs (Just $ mApp >>= courseApplicationText . entityVal) hasFiles <- for mApp $ \(Entity appId _) - -> fmap (not . null) . liftHandlerT . runDB $ selectKeysList [ CourseApplicationFileApplication ==. appId ] [ LimitTo 1 ] + -> fmap (not . null) . liftHandler . runDB $ selectKeysList [ CourseApplicationFileApplication ==. appId ] [ LimitTo 1 ] appCID <- for mApp $ encrypt . entityKey let appFilesInfo = (,) <$> hasFiles <*> appCID @@ -296,7 +296,7 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do fId <- insert file insert_ $ CourseApplicationFile appId fId forM_ afFiles $ \afFiles' -> - runConduit $ transPipe liftHandlerT afFiles' .| C.mapM_ sinkFile' + runConduit $ transPipe liftHandler afFiles' .| C.mapM_ sinkFile' audit $ TransactionCourseApplicationEdit cid uid appId addMessageI Success $ MsgCourseApplicationCreated courseShorthand | is _BtnAllocationApplicationEdit afAction || is _BtnAllocationApplicationRate afAction @@ -327,7 +327,7 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do fId <- lift $ insert file lift . insert_ $ CourseApplicationFile appId fId modify $ Set.insert fId - in runConduit $ transPipe liftHandlerT afFiles' .| C.mapM_ sinkFile' + in runConduit $ transPipe liftHandler afFiles' .| C.mapM_ sinkFile' deleteCascadeWhere [ FileId <-. Set.toList (oldFiles `Set.intersection` changes) ] return changes | otherwise diff --git a/src/Handler/Allocation/List.hs b/src/Handler/Allocation/List.hs index 016db93a0..d64bd13e7 100644 --- a/src/Handler/Allocation/List.hs +++ b/src/Handler/Allocation/List.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + module Handler.Allocation.List ( getAllocationListR ) where diff --git a/src/Handler/Allocation/Show.hs b/src/Handler/Allocation/Show.hs index 0029581b7..3d366d129 100644 --- a/src/Handler/Allocation/Show.hs +++ b/src/Handler/Allocation/Show.hs @@ -68,10 +68,10 @@ getAShowR tid ssh ash = do let Entity cid Course{..} = cEntry ^. resultCourse hasApplicationTemplate = cEntry ^. resultHasTemplate mApp = cEntry ^? resultCourseApplication - cID <- encrypt cid :: WidgetT UniWorX IO CryptoUUIDCourse + cID <- encrypt cid :: WidgetFor UniWorX CryptoUUIDCourse mayApply <- hasWriteAccessTo . AllocationR tid ssh ash $ AApplyR cID isLecturer <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR - mApplyFormView <- liftHandlerT . for muid $ \uid -> generateFormPost . applicationForm (Just aId) cid uid $ ApplicationFormMode True mayApply isLecturer + mApplyFormView <- liftHandler . for muid $ \uid -> generateFormPost . applicationForm (Just aId) cid uid $ ApplicationFormMode True mayApply isLecturer tRoute <- case mApp of Nothing -> return . AllocationR tid ssh ash $ AApplyR cID Just (Entity appId _) -> CApplicationR courseTerm courseSchool courseShorthand <$> encrypt appId <*> pure CAEditR diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 2074fd3b4..4d2c37aba 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -1,6 +1,6 @@ module Handler.Corrections where -import Import +import Import hiding (link) -- import System.FilePath (takeFileName) import Jobs @@ -71,8 +71,8 @@ correctionsTableQuery whereClause returnStatement t@((course `E.InnerJoin` sheet E.where_ $ whereClause t return $ returnStatement t -lastEditQuery :: Database.Esqueleto.Internal.Language.From query expr backend (expr (Entity SubmissionEdit)) - => expr (Entity Submission) -> expr (E.Value (Maybe UTCTime)) +lastEditQuery :: Database.Esqueleto.Internal.Language.From (E.SqlExpr (Entity SubmissionEdit)) + => E.SqlExpr (Entity Submission) -> E.SqlExpr (E.Value (Maybe UTCTime)) lastEditQuery submission = E.sub_select $ E.from $ \edit -> do E.where_ $ edit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId return $ E.max_ $ edit E.^. SubmissionEditTime @@ -216,7 +216,7 @@ colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ for ) colCommentField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, b, Maybe Text) CorrectionTableData))) -colCommentField = sortable (Just "comment") (i18nCell MsgRatingComment) $ fmap (addCellAttrs [("style","width:60%")]) $ formCell id +colCommentField = sortable (Just "comment") (i18nCell MsgRatingComment) $ fmap (cellAttrs <>~ [("style","width:60%")]) $ formCell id (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _) } -> return subId) (\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _, _) } mkUnique -> over (_1.mapped) ((_3 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvInput <$> mopt textareaField (fsUniq mkUnique "comment") (Just $ Textarea <$> submissionRatingComment)) @@ -238,7 +238,7 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d ) in (submission, sheet, crse, corrector, lastEditQuery submission) ) - dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CorrectionTableData + dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerFor UniWorX)) CorrectionTableData dbtProj = traverse $ \(submission@(Entity sId _), sheet@(Entity shId _), (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector, E.Value mbLastEdit) -> do submittors <- lift . E.select . E.from $ \((submissionUser `E.InnerJoin` user) `E.LeftOuterJoin` pseudonym) -> do E.on $ pseudonym E.?. SheetPseudonymUser E.==. E.just (user E.^. UserId) @@ -398,9 +398,9 @@ data ActionCorrectionsData = CorrDownloadData | CorrAutoSetCorrectorData SheetId | CorrDeleteData -correctionsR :: _ -> _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerT UniWorX IO) ActionCorrectionsData) -> Handler TypedContent +correctionsR :: _ -> _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerFor UniWorX) ActionCorrectionsData) -> Handler TypedContent correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do - Just currentRoute <- getCurrentRoute -- This should never be called from a 404 handler + currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler postDeleteR $ \drRecords -> (submissionDeleteRoute drRecords) { drAbort = SomeRoute currentRoute @@ -416,7 +416,7 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do , dbParamsFormAdditional = \frag -> do (actionRes, action) <- multiActionM actions "" Nothing mempty return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action) - , dbParamsFormEvaluate = liftHandlerT . runFormPost + , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormResult = _1 , dbParamsFormIdent = def } @@ -466,7 +466,7 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do ] addMessageI Success $ MsgUpdatedAssignedCorrectorSingle num auditAllSubEdit sIds - (E.Value selfCorrectors:_) <- E.select . E.from $ \(submission `E.InnerJoin` subuser) -> do + selfCorrectors <- fmap (maybe 0 (max 0 . E.unValue) . listToMaybe) . E.select . E.from $ \(submission `E.InnerJoin` subuser) -> do E.on $ submission E.^. SubmissionId E.==. subuser E.^. SubmissionUserSubmission E.where_ $ submission E.^. SubmissionId `E.in_` E.valList subs E.&&. submission E.^. SubmissionRatingBy E.==. E.just (subuser E.^. SubmissionUserUser) @@ -537,7 +537,7 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do where authorizedToAssign :: SubmissionId -> DB Bool authorizedToAssign sId = do - [(E.Value tid, E.Value ssh, E.Value csh, E.Value shn)] <- + (E.Value tid, E.Value ssh, E.Value csh, E.Value shn) <- maybe notFound return . listToMaybe <=< E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission ) -> do E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse @@ -547,7 +547,7 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do let route = CSubmissionR tid ssh csh shn cID SubAssignR (== Authorized) <$> evalAccessDB route True -type ActionCorrections' = (ActionCorrections, AForm (HandlerT UniWorX IO) ActionCorrectionsData) +type ActionCorrections' = (ActionCorrections, AForm (HandlerFor UniWorX) ActionCorrectionsData) downloadAction, deleteAction :: ActionCorrections' downloadAction = ( CorrDownload @@ -560,7 +560,7 @@ deleteAction = ( CorrDelete assignAction :: Either CourseId SheetId -> ActionCorrections' assignAction selId = ( CorrSetCorrector , wFormToAForm $ do - correctors <- liftHandlerT . runDB . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector `E.InnerJoin` user) -> do + correctors <- liftHandler . runDB . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector `E.InnerJoin` user) -> do E.on $ user E.^. UserId E.==. sheetCorrector E.^. SheetCorrectorUser E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse @@ -573,7 +573,7 @@ assignAction selId = ( CorrSetCorrector correctors' <- forM correctors $ \Entity{ entityKey, entityVal = User{..} } -> (SomeMessage userDisplayName, ) <$> encrypt entityKey - cId <- wopt (selectFieldList correctors' :: Field (HandlerT UniWorX IO) CryptoUUIDUser) (fslI MsgCorrector & setTooltip MsgCorrSetCorrectorTooltip) Nothing + cId <- wopt (selectFieldList correctors' :: Field (HandlerFor UniWorX) CryptoUUIDUser) (fslI MsgCorrector & setTooltip MsgCorrSetCorrectorTooltip) Nothing fmap CorrSetCorrectorData <$> (traverse.traverse) decrypt cId ) @@ -740,7 +740,7 @@ postCorrectionR tid ssh csh shn cid = do } formResult corrResult $ \(rated, ratingPoints', ratingComment') -> do - uid <- liftHandlerT requireAuthId + uid <- liftHandler requireAuthId now <- liftIO getCurrentTime if @@ -1013,7 +1013,7 @@ postCorrectionsGradeR = do , colCommentField ] -- Continue here psValidator = def - & defaultSorting [SortDescBy "ratingtime"] :: PSValidator (MForm (HandlerT UniWorX IO)) (FormResult (DBFormResult SubmissionId (Bool, Maybe Points, Maybe Text) CorrectionTableData)) + & defaultSorting [SortDescBy "ratingtime"] :: PSValidator (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult SubmissionId (Bool, Maybe Points, Maybe Text) CorrectionTableData)) unFormResult = getDBFormResult $ \DBRow{ dbrOutput = (Entity _ sub@Submission{..}, _, _, _, _, _) } -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment) dbtProj' i@(Entity subId _, Entity _ Sheet{ sheetName = shn }, (_, csh, tid, ssh), _, _, _) = do cID <- encrypt subId diff --git a/src/Handler/Course/Application/Files.hs b/src/Handler/Course/Application/Files.hs index 31ec53e47..b6d3b77a5 100644 --- a/src/Handler/Course/Application/Files.hs +++ b/src/Handler/Course/Application/Files.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + module Handler.Course.Application.Files ( getCAFilesR , getCAppsFilesR @@ -47,7 +49,7 @@ getCAppsFilesR tid ssh csh = do archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ MsgCourseAllApplicationsArchiveName tid ssh csh let - fsSource :: Source DB File + fsSource :: ConduitT () File DB () fsSource = do apps <- lift . E.select . E.from $ \((course `E.InnerJoin` courseApplication `E.InnerJoin` user) `E.LeftOuterJoin` allocation) -> do E.on $ allocation E.?. AllocationId E.==. courseApplication E.^. CourseApplicationAllocation diff --git a/src/Handler/Course/Application/List.hs b/src/Handler/Course/Application/List.hs index d01699a2a..312ff9d02 100644 --- a/src/Handler/Course/Application/List.hs +++ b/src/Handler/Course/Application/List.hs @@ -1,4 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} module Handler.Course.Application.List ( getCApplicationsR, postCApplicationsR @@ -103,7 +104,7 @@ instance Csv.ToField CourseApplicationsTableVeto where instance Csv.FromField CourseApplicationsTableVeto where parseField f = do (CI.map Text.strip -> t :: CI Text) <- Csv.parseField f - return . CourseApplicationsTableVeto $ any (== t) + return . CourseApplicationsTableVeto $ elem t [ "veto", "v", "yes", "y", "ja", "j", "wahr", "w", "true", "t", "1" ] data CourseApplicationsTableCsv = CourseApplicationsTableCsv diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index 6347b1d38..fcb45369e 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -44,7 +44,7 @@ data CourseForm = CourseForm , cfAllocation :: Maybe AllocationCourseForm , cfAppRequired :: Bool , cfAppInstructions :: Maybe Html - , cfAppInstructionFiles :: Maybe (Source Handler (Either FileId File)) + , cfAppInstructionFiles :: Maybe (ConduitT () (Either FileId File) Handler ()) , cfAppText :: Bool , cfAppFiles :: UploadMode , cfAppRatingsVisible :: Bool @@ -101,13 +101,13 @@ allocationCourseToForm (Entity _ AllocationCourse{..}) = AllocationCourseForm makeCourseForm :: (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)) -> Maybe CourseForm -> Form CourseForm makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB validateCourse $ \html -> do - -- TODO: Refactor to avoid the four repeated calls to liftHandlerT and three runDBs + -- TODO: Refactor to avoid the four repeated calls to liftHandler and three runDBs -- let editCid = cfCourseId =<< template -- possible start for refactoring MsgRenderer mr <- getMsgRenderer - uid <- liftHandlerT requireAuthId - (lecturerSchools, adminSchools) <- liftHandlerT . runDB $ do + uid <- liftHandler requireAuthId + (lecturerSchools, adminSchools) <- liftHandler . runDB $ do lecturerSchools <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolLecturer]] [] protoAdminSchools <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolAdmin]] [] adminSchools <- filterM (hasWriteAccessTo . flip SchoolR SchoolEditR) protoAdminSchools @@ -116,7 +116,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB 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 -> liftHandlerT $ do -- edit existing course + (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 @@ -128,7 +128,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB 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 (addRes, addView) <- mpreq emailField ("" & addName (nudge "user")) Nothing - addRes' <- for addRes $ liftHandlerT . runDB . getKeyBy . UniqueEmail . CI.mk + addRes' <- for addRes $ liftHandler . runDB . getKeyBy . UniqueEmail . CI.mk let addRes'' = case (,) <$> addRes <*> addRes' of FormSuccess (CI.mk -> email, mLid) -> let new = maybe (Left email) Right mLid @@ -143,7 +143,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB miCell :: ListPosition -> Either UserEmail UserId -> Maybe (Maybe LecturerType) -> (Text -> Text) -> Form (Maybe LecturerType) miCell _ (Right lid) defType nudge = \csrf -> do (lrwRes,lrwView) <- mreq (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) (join defType) - User{userEmail, userDisplayName, userSurname} <- liftHandlerT . runDB $ get404 lid + User{userEmail, userDisplayName, userSurname} <- liftHandler . runDB $ get404 lid let lrwView' = $(widgetFile "course/lecturerMassInput/cellKnown") return (Just <$> lrwRes,lrwView') miCell _ (Left lEmail) defType nudge = \csrf -> do @@ -153,7 +153,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB miDelete :: Map ListPosition (Either UserEmail UserId) -- ^ Current shape -> ListPosition -- ^ Coordinate to delete - -> MaybeT (MForm (HandlerT UniWorX IO)) (Map ListPosition ListPosition) + -> MaybeT (MForm (HandlerFor UniWorX)) (Map ListPosition ListPosition) miDelete = miDeleteList miAllowAdd :: ListPosition -> Natural -> ListLength -> Bool @@ -194,7 +194,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB (newRegFrom,newRegTo,newDeRegUntil) <- case template of (Just cform) | (Just _cid) <- cfCourseId cform -> return (Nothing,Nothing,Nothing) _allIOtherCases -> do - mbLastTerm <- liftHandlerT $ runDB $ selectFirst [TermActive ==. True] [Desc TermName] + mbLastTerm <- liftHandler $ runDB $ selectFirst [TermActive ==. True] [Desc TermName] return ( (Just . toMidnight . termStart . entityVal) <$> mbLastTerm , (Just . beforeMidnight . termEnd . entityVal) <$> mbLastTerm , (Just . beforeMidnight . termEnd . entityVal) <$> mbLastTerm ) @@ -202,7 +202,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB let allocationForm :: AForm Handler (Maybe AllocationCourseForm) allocationForm = wFormToAForm $ do - availableAllocations' <- liftHandlerT . runDB . E.select . E.from $ \(allocation `E.InnerJoin` term) -> do + availableAllocations' <- liftHandler . runDB . E.select . E.from $ \(allocation `E.InnerJoin` term) -> do E.on $ allocation E.^. AllocationTerm E.==. term E.^. TermId let alreadyParticipates = flip (maybe E.false) (template >>= cfCourseId) $ \cid -> @@ -226,7 +226,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB activeAllocations = availableAllocations' ^.. folded . filtered ((&&) <$> (not <$> allocationEnabled . view _1) <*> view (_2 . _Value)) . _1 mkAllocationOption :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX) => Entity Allocation -> m (Option AllocationId) - mkAllocationOption (Entity aId Allocation{..}) = liftHandlerT $ do + mkAllocationOption (Entity aId Allocation{..}) = liftHandler $ do cID <- encrypt aId :: Handler CryptoUUIDAllocation return . Option (mr . MsgCourseAllocationOption (mr . ShortTermIdentifier $ unTermKey allocationTerm) $ CI.original allocationName) aId $ toPathPiece cID @@ -295,7 +295,7 @@ validateCourse = do CourseForm{..} <- State.get now <- liftIO getCurrentTime - uid <- liftHandlerT requireAuthId + uid <- liftHandler requireAuthId userAdmin <- hasWriteAccessTo $ SchoolR cfSchool SchoolEditR allocationTerm <- for (acfAllocation <$> cfAllocation) $ lift . fmap allocationTerm . getJust @@ -517,7 +517,7 @@ courseEditHandler miButtonAction mbCourseForm = do tell $ Set.singleton fId lift $ void . insertUnique $ CourseAppInstructionFile cid fId - keep <- execWriterT . runConduit $ transPipe liftHandlerT (traverse_ id $ cfAppInstructionFiles res) .| C.mapM_ finsert + keep <- execWriterT . runConduit $ transPipe liftHandler (traverse_ id $ cfAppInstructionFiles res) .| C.mapM_ finsert acfs <- selectList [ CourseAppInstructionFileCourse ==. cid, CourseAppInstructionFileFile /<-. Set.toList keep ] [] mapM_ deleteCascade $ map (courseAppInstructionFileFile . entityVal) acfs @@ -534,7 +534,7 @@ courseEditHandler miButtonAction mbCourseForm = do , formEncoding = formEnctype } -upsertAllocationCourse :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => CourseId -> Maybe AllocationCourseForm -> ReaderT SqlBackend m () +upsertAllocationCourse :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => CourseId -> Maybe AllocationCourseForm -> ReaderT SqlBackend m () upsertAllocationCourse cid cfAllocation = do now <- liftIO getCurrentTime Course{..} <- getJust cid diff --git a/src/Handler/Course/LecturerInvite.hs b/src/Handler/Course/LecturerInvite.hs index 696ba927b..753bd7c10 100644 --- a/src/Handler/Course/LecturerInvite.hs +++ b/src/Handler/Course/LecturerInvite.hs @@ -57,16 +57,19 @@ lecturerInvitationConfig = InvitationConfig{..} where invitationRoute (Entity _ Course{..}) _ = return . CourseR courseTerm courseSchool courseShorthand $ CLecInviteR invitationResolveFor _ = do - Just (CourseR tid csh ssh CLecInviteR) <- getCurrentRoute - getKeyBy404 $ TermSchoolCourseShort tid csh ssh + cRoute <- getCurrentRoute + case cRoute of + Just (CourseR tid csh ssh CLecInviteR) -> + getKeyBy404 $ TermSchoolCourseShort tid csh ssh + _other -> error "lecturerInvitationConfig called from unsupported route" invitationSubject (Entity _ Course{..}) _ = return . SomeMessage $ MsgMailSubjectLecturerInvitation courseTerm courseSchool courseShorthand invitationHeading (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseLecInviteHeading $ CI.original courseName invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgCourseLecInviteExplanation}|] invitationTokenConfig _ _ = do - itAuthority <- liftHandlerT requireAuthId + itAuthority <- liftHandler requireAuthId return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing invitationRestriction _ _ = return Authorized - invitationForm _ (InvDBDataLecturer mlType, _) _ = hoistAForm liftHandlerT $ toJunction <$> case mlType of + invitationForm _ (InvDBDataLecturer mlType, _) _ = hoistAForm liftHandler $ toJunction <$> case mlType of Nothing -> areq (selectField optionsFinite) lFs Nothing Just lType -> aforced (selectField optionsFinite) lFs lType where diff --git a/src/Handler/Course/List.hs b/src/Handler/Course/List.hs index 650047327..7e815fba2 100644 --- a/src/Handler/Course/List.hs +++ b/src/Handler/Course/List.hs @@ -86,7 +86,7 @@ makeCourseTable whereClause colChoices psValidator = do E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser E.where_ $ cid E.==. lecturer E.^. LecturerCourse E.&&. lecturer E.^. LecturerType E.==. E.val CourseLecturer return user - dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CourseTableData + dbtProj :: DBRow _ -> MaybeT DB CourseTableData dbtProj = traverse $ \(course, E.Value participants, E.Value registered, school) -> do lecturerList <- lift $ E.select $ E.from $ lecturerQuery $ E.val $ entityKey course courseAlloc <- lift $ getBy (UniqueAllocationCourse $ entityKey course) diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index a54af6349..e2962ac0b 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -70,13 +70,17 @@ participantInvitationConfig = InvitationConfig{..} where invitationRoute (Entity _ Course{..}) _ = return $ CourseR courseTerm courseSchool courseShorthand CInviteR invitationResolveFor _ = do - Just (CourseR tid csh ssh CInviteR) <- getCurrentRoute - getKeyBy404 $ TermSchoolCourseShort tid csh ssh + cRoute <- getCurrentRoute + case cRoute of + Just (CourseR tid csh ssh CInviteR) -> + getKeyBy404 $ TermSchoolCourseShort tid csh ssh + _other -> + error "participantInvitationConfig called from unsupported route" invitationSubject (Entity _ Course{..}) _ = return . SomeMessage $ MsgMailSubjectParticipantInvitation courseTerm courseSchool courseShorthand invitationHeading (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseParticipantInviteHeading $ CI.original courseName invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgCourseParticipantInviteExplanation}|] invitationTokenConfig _ _ = do - itAuthority <- liftHandlerT requireAuthId + itAuthority <- liftHandler requireAuthId return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing invitationRestriction _ _ = return Authorized invitationForm (Entity _ Course{..}) _ uid = hoistAForm lift . wFormToAForm $ do @@ -98,9 +102,12 @@ data AddRecipientsResult = AddRecipientsResult , aurSuccess :: [UserEmail] } deriving (Read, Show, Generic, Typeable) +instance Semigroup AddRecipientsResult where + (<>) = mappenddefault + instance Monoid AddRecipientsResult where mempty = memptydefault - mappend = mappenddefault + mappend = (<>) getCAddUserR, postCAddUserR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCAddUserR = postCAddUserR diff --git a/src/Handler/Course/Register.hs b/src/Handler/Course/Register.hs index d134e31d1..abef977ae 100644 --- a/src/Handler/Course/Register.hs +++ b/src/Handler/Course/Register.hs @@ -41,12 +41,12 @@ instance Button UniWorX ButtonCourseRegister where data CourseRegisterForm = CourseRegisterForm { crfStudyFeatures :: Maybe StudyFeaturesId , crfApplicationText :: Maybe Text - , crfApplicationFiles :: Maybe (Source Handler File) + , crfApplicationFiles :: Maybe (ConduitT () File Handler ()) } courseRegisterForm :: (MonadHandler m, HandlerSite m ~ UniWorX) => Entity Course -> m (AForm Handler CourseRegisterForm, ButtonCourseRegister) -- ^ `CourseRegisterForm` for current user -courseRegisterForm (Entity cid Course{..}) = liftHandlerT $ do +courseRegisterForm (Entity cid Course{..}) = liftHandler $ do muid <- maybeAuthId (registration, application) <- runDB $ do registration <- fmap join . for muid $ getBy . flip UniqueParticipant cid @@ -108,7 +108,7 @@ courseRegisterForm (Entity cid Course{..}) = liftHandlerT $ do -> fmap (assertM (not . Text.null) . fmap Text.strip) <$> wopt textField' fs (Just $ application >>= courseApplicationText . entityVal) hasFiles <- for application $ \(Entity appId _) - -> fmap (not . null) . liftHandlerT . runDB $ selectKeysList [ CourseApplicationFileApplication ==. appId ] [ LimitTo 1 ] + -> fmap (not . null) . liftHandler . runDB $ selectKeysList [ CourseApplicationFileApplication ==. appId ] [ LimitTo 1 ] appCID <- for application $ encrypt . entityKey let appFilesInfo = (,) <$> hasFiles <*> appCID filesMsg = bool MsgCourseRegistrationFiles MsgCourseApplicationFiles courseApplicationsRequired @@ -191,7 +191,7 @@ postCRegisterR tid ssh csh = do whenIsJust appRes $ audit . TransactionCourseApplicationEdit cid uid whenIsJust ((,) <$> appRes <*> crfApplicationFiles) $ \(appId, fSource) -> do - runConduit $ transPipe liftHandlerT fSource .| C.mapM_ (\f -> insert f >>= insert_ . CourseApplicationFile appId) + runConduit $ transPipe liftHandler fSource .| C.mapM_ (\f -> insert f >>= insert_ . CourseApplicationFile appId) return appRes | otherwise = return $ Just () diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index 085cc048a..cdab9b549 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -125,11 +125,12 @@ getCShowR tid ssh csh = do , sortable Nothing (i18nCell MsgTutorialFreeCapacity) $ \DBRow{ dbrOutput = Entity tutid Tutorial{..} } -> case tutorialCapacity of Nothing -> mempty Just tutorialCapacity' -> sqlCell $ do - [E.Value freeCapacity] <- E.select $ let numParticipants = E.sub_select . E.from $ \participant -> do - E.where_ $ participant E.^. TutorialParticipantTutorial E.==. E.val tutid - return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int)) - in return $ E.val tutorialCapacity' E.-. numParticipants - return . toWidget . tshow $ max 0 freeCapacity + freeCapacity <- fmap (maybe 0 (max 0 . E.unValue) . listToMaybe) + . E.select $ let numParticipants = E.sub_select . E.from $ \participant -> do + E.where_ $ participant E.^. TutorialParticipantTutorial E.==. E.val tutid + return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int)) + in return $ E.val tutorialCapacity' E.-. numParticipants + return . toWidget $ tshow freeCapacity , sortable Nothing mempty $ \DBRow{ dbrOutput = Entity tutId Tutorial{..} } -> sqlCell $ do mayRegister <- (== Authorized) <$> evalAccessDB (CTutorialR tid ssh csh tutorialName TRegisterR) True isRegistered <- case mbAid of @@ -137,7 +138,7 @@ getCShowR tid ssh csh = do Just uid -> existsBy $ UniqueTutorialParticipant tutId uid if | mayRegister -> do - (tutRegisterForm, tutRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered + (tutRegisterForm, tutRegisterEnctype) <- liftHandler . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered return $ wrapForm tutRegisterForm def { formAction = Just . SomeRoute $ CTutorialR tid ssh csh tutorialName TRegisterR , formEncoding = tutRegisterEnctype @@ -198,7 +199,7 @@ getCShowR tid ssh csh = do -- Just uid -> existsBy $ UniqueExamRegistration eId uid -- if -- | mayRegister -> do - -- (examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnExamRegister] [BtnExamDeregister] isRegistered + -- (examRegisterForm, examRegisterEnctype) <- liftHandler . generateFormPost . buttonForm' $ bool [BtnExamRegister] [BtnExamDeregister] isRegistered -- return $ wrapForm examRegisterForm def -- { formAction = Just . SomeRoute $ CExamR tid ssh csh examName ERegisterR -- , formEncoding = examRegisterEnctype diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs index 7e8cc7cfd..bd222d966 100644 --- a/src/Handler/Course/User.hs +++ b/src/Handler/Course/User.hs @@ -159,7 +159,7 @@ postCUserR tid ssh csh uCId = do addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk redirect currentRoute Nothing -> invalidArgs ["User already registered"] - _other -> fail "Invalid @regButton@" + _other -> error "Invalid @regButton@" mRegAt <- for (courseParticipantRegistration . entityVal <$> mRegistration) $ formatTime SelFormatDateTime diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index 7b12d45d0..df0169438 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -139,7 +139,7 @@ makeCourseUserTable :: forall h acts. -> PSValidator (MForm Handler) (FormResult (First (Element acts), DBFormResult UserId Bool UserTableData)) -> DB (FormResult (Element acts, Set UserId), Widget) makeCourseUserTable cid acts restrict colChoices psValidator = do - Just currentRoute <- liftHandlerT getCurrentRoute + currentRoute <- fromMaybe (error "makeCourseUserTable called from 404-handler") <$> liftHandler getCurrentRoute -- -- psValidator has default sorting and filtering let dbtIdent = "courseUsers" :: Text dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } @@ -210,7 +210,7 @@ makeCourseUserTable cid acts restrict colChoices psValidator = do = renderAForm FormStandard $ (, mempty) . First . Just <$> areq (selectField $ optionsF acts) (fslI MsgAction) Nothing - , dbParamsFormEvaluate = liftHandlerT . runFormPost + , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormResult = id , dbParamsFormIdent = def } diff --git a/src/Handler/Exam/AddUser.hs b/src/Handler/Exam/AddUser.hs index 7aafb58e2..23203d2f2 100644 --- a/src/Handler/Exam/AddUser.hs +++ b/src/Handler/Exam/AddUser.hs @@ -29,9 +29,12 @@ data AddRecipientsResult = AddRecipientsResult , aurSuccessCourse :: [UserEmail] } deriving (Read, Show, Generic, Typeable) +instance Semigroup AddRecipientsResult where + (<>) = mappenddefault + instance Monoid AddRecipientsResult where mempty = memptydefault - mappend = mappenddefault + mappend = (<>) getEAddUserR, postEAddUserR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html @@ -40,7 +43,7 @@ postEAddUserR tid ssh csh examn = do eEnt@(Entity eid Exam{..}) <- runDB $ fetchExam tid ssh csh examn ((usersToEnlist,formWgt),formEncoding) <- runFormPost . renderWForm FormStandard $ do now <- liftIO getCurrentTime - occurrences <- liftHandlerT . runDB $ selectList [ExamOccurrenceExam ==. eid] [] + occurrences <- liftHandler . runDB $ selectList [ExamOccurrenceExam ==. eid] [] let localNow = utcToLocalTime now diff --git a/src/Handler/Exam/CorrectorInvite.hs b/src/Handler/Exam/CorrectorInvite.hs index 738c2a3fb..8314a8ca1 100644 --- a/src/Handler/Exam/CorrectorInvite.hs +++ b/src/Handler/Exam/CorrectorInvite.hs @@ -55,15 +55,19 @@ examCorrectorInvitationConfig = InvitationConfig{..} Course{..} <- get404 examCourse return $ CExamR courseTerm courseSchool courseShorthand examName ECInviteR invitationResolveFor _ = do - Just (CExamR tid csh ssh examn ECInviteR) <- getCurrentRoute - fetchExamId tid csh ssh examn + cRoute <- getCurrentRoute + case cRoute of + Just (CExamR tid csh ssh examn ECInviteR) -> + fetchExamId tid csh ssh examn + _other -> + error "examCorrectorInvitationConfig called from unsupported route" invitationSubject (Entity _ Exam{..}) _ = do Course{..} <- get404 examCourse return . SomeMessage $ MsgMailSubjectExamCorrectorInvitation courseTerm courseSchool courseShorthand examName invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamCorrectorInviteHeading examName invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamCorrectorInviteExplanation}|] invitationTokenConfig _ _ = do - itAuthority <- liftHandlerT requireAuthId + itAuthority <- liftHandler requireAuthId return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing invitationRestriction _ _ = return Authorized invitationForm _ _ _ = pure (JunctionExamCorrector, ()) diff --git a/src/Handler/Exam/Edit.hs b/src/Handler/Exam/Edit.hs index fbd0c1acc..52d90559f 100644 --- a/src/Handler/Exam/Edit.hs +++ b/src/Handler/Exam/Edit.hs @@ -85,6 +85,7 @@ postEEditR tid ssh csh examn = do ExamPartForm{ epfId = Nothing, .. } -> insert_ ExamPart { examPartExam = eId + , examPartNumber = epfNumber , examPartName = epfName , examPartMaxPoints = epfMaxPoints , examPartWeight = epfWeight @@ -96,6 +97,7 @@ postEEditR tid ssh csh examn = do guard $ examPartExam oldPart == eId lift $ replace epfId' ExamPart { examPartExam = eId + , examPartNumber = epfNumber , examPartName = epfName , examPartMaxPoints = epfMaxPoints , examPartWeight = epfWeight diff --git a/src/Handler/Exam/Form.hs b/src/Handler/Exam/Form.hs index 452b0aa3d..be151fdda 100644 --- a/src/Handler/Exam/Form.hs +++ b/src/Handler/Exam/Form.hs @@ -26,6 +26,7 @@ import Text.Blaze.Html.Renderer.String (renderHtml) data ExamForm = ExamForm { efName :: ExamName , efDescription :: Maybe Html + , efShowGrades :: Bool , efStart :: Maybe UTCTime , efEnd :: Maybe UTCTime , efVisibleFrom :: Maybe UTCTime @@ -35,11 +36,10 @@ data ExamForm = ExamForm , efPublishOccurrenceAssignments :: Maybe UTCTime , efFinished :: Maybe UTCTime , efOccurrences :: Set ExamOccurrenceForm - , efShowGrades :: Bool , efPublicStatistics :: Bool - , efGradingRule :: ExamGradingRule - , efBonusRule :: ExamBonusRule - , efOccurrenceRule :: ExamOccurrenceRule + , efGradingRule :: Maybe ExamGradingRule + , efBonusRule :: Maybe ExamBonusRule + , efOccurrenceRule :: Maybe ExamOccurrenceRule , efCorrectors :: Set (Either UserEmail UserId) , efExamParts :: Set ExamPartForm } @@ -56,7 +56,8 @@ data ExamOccurrenceForm = ExamOccurrenceForm data ExamPartForm = ExamPartForm { epfId :: Maybe CryptoUUIDExamPart - , epfName :: ExamPartName + , epfNumber :: ExamPartNumber + , epfName :: Maybe ExamPartName , epfMaxPoints :: Maybe Points , epfWeight :: Rational } deriving (Read, Show, Eq, Ord, Generic, Typeable) @@ -79,6 +80,7 @@ examForm template html = do flip (renderAForm FormStandard) html $ ExamForm <$> areq ciField (fslpI MsgExamName (mr MsgExamName) & setTooltip MsgExamNameTip) (efName <$> template) <*> (assertM (not . null . renderHtml) <$> aopt htmlField (fslpI MsgExamDescription "Html") (efDescription <$> template)) + <*> apopt checkBoxField (fslI MsgExamShowGrades & setTooltip MsgExamShowGradesTip) (efShowGrades <$> template <|> Just True) <* aformSection MsgExamFormTimes <*> aopt utcTimeField (fslpI MsgExamStart (mr MsgDate) & setTooltip MsgExamTimeTip) (efStart <$> template) <*> aopt utcTimeField (fslpI MsgExamEnd (mr MsgDate) & setTooltip MsgExamTimeTip) (efEnd <$> template) @@ -91,11 +93,10 @@ examForm template html = do <* aformSection MsgExamFormOccurrences <*> examOccurrenceForm (efOccurrences <$> template) <* aformSection MsgExamFormAutomaticFunctions - <*> apopt checkBoxField (fslI MsgExamShowGrades & setTooltip MsgExamShowGradesTip) (efShowGrades <$> template <|> Just True) <*> apopt checkBoxField (fslI MsgExamPublicStatistics & setTooltip MsgExamPublicStatisticsTip) (efPublicStatistics <$> template <|> Just True) - <*> examGradingRuleForm (efGradingRule <$> template) - <*> examBonusRuleForm (efBonusRule <$> template) - <*> examOccurrenceRuleForm (efOccurrenceRule <$> template) + <*> optionalActionA (examGradingRuleForm $ efGradingRule =<< template) (fslI MsgExamAutomaticGrading & setTooltip MsgExamAutomaticGradingTip) (is _Just . efGradingRule <$> template) + <*> optionalActionA (examBonusRuleForm $ efBonusRule =<< template) (fslI MsgExamBonus) (is _Just . efBonusRule <$> template) + <*> optionalActionA (examOccurrenceRuleForm $ efOccurrenceRule =<< template) (fslI MsgExamAutomaticOccurrenceAssignment & setTooltip MsgExamAutomaticOccurrenceAssignmentTip) (is _Just . efOccurrenceRule <$> template) <* aformSection MsgExamFormCorrection <*> examCorrectorsForm (efCorrectors <$> template) <* aformSection MsgExamFormParts @@ -104,8 +105,8 @@ examForm template html = do examCorrectorsForm :: Maybe (Set (Either UserEmail UserId)) -> AForm Handler (Set (Either UserEmail UserId)) examCorrectorsForm mPrev = wFormToAForm $ do MsgRenderer mr <- getMsgRenderer - Just currentRoute <- getCurrentRoute - uid <- liftHandlerT requireAuthId + currentRoute <- fromMaybe (error "examCorrectorForm called from 404-handler") <$> getCurrentRoute + uid <- liftHandler requireAuthId let miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) @@ -139,7 +140,7 @@ examCorrectorsForm mPrev = wFormToAForm $ do miCell' (Left email) = $(widgetFile "widgets/massinput/examCorrectors/cellInvitation") miCell' (Right userId) = do - User{..} <- liftHandlerT . runDB $ get404 userId + User{..} <- liftHandler . runDB $ get404 userId $(widgetFile "widgets/massinput/examCorrectors/cellKnown") miLayout' :: MassInputLayout ListLength (Either UserEmail UserId) () @@ -149,7 +150,7 @@ examCorrectorsForm mPrev = wFormToAForm $ do examOccurrenceForm :: Maybe (Set ExamOccurrenceForm) -> AForm Handler (Set ExamOccurrenceForm) examOccurrenceForm prev = wFormToAForm $ do - Just currentRoute <- getCurrentRoute + currentRoute <- fromMaybe (error "examOccurrenceForm called from 404-handler") <$> getCurrentRoute let miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag @@ -191,7 +192,7 @@ examOccurrenceForm prev = wFormToAForm $ do examPartsForm :: Maybe (Set ExamPartForm) -> AForm Handler (Set ExamPartForm) examPartsForm prev = wFormToAForm $ do - Just currentRoute <- getCurrentRoute + currentRoute <- fromMaybe (error "examPartsForm called from 404-handler") <$> getCurrentRoute let miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag @@ -200,12 +201,14 @@ examPartsForm prev = wFormToAForm $ do where examPartForm' nudge mPrev csrf = do (epfIdRes, epfIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ epfId =<< mPrev) - (epfNameRes, epfNameView) <- mpreq (textField & cfStrip & cfCI) ("" & addName (nudge "name")) (epfName <$> mPrev) + (epfNumberRes, epfNumberView) <- mpreq (isoField (from _ExamPartNumber) $ textField & cfStrip & cfCI) ("" & addName (nudge "number") & addPlaceholder "1, 6a, 3.1.4, ...") (epfNumber <$> mPrev) + (epfNameRes, epfNameView) <- mopt (textField & cfStrip & cfCI) ("" & addName (nudge "name")) (epfName <$> mPrev) (epfMaxPointsRes, epfMaxPointsView) <- mopt pointsField ("" & addName (nudge "max-points")) (epfMaxPoints <$> mPrev) (epfWeightRes, epfWeightView) <- mpreq (checkBool (>= 0) MsgExamPartWeightNegative rationalField) ("" & addName (nudge "weight")) (epfWeight <$> mPrev <|> Just 1) return ( ExamPartForm <$> epfIdRes + <*> epfNumberRes <*> epfNameRes <*> epfMaxPointsRes <*> epfWeightRes @@ -217,7 +220,8 @@ examPartsForm prev = wFormToAForm $ do (res, formWidget) <- examPartForm' nudge Nothing csrf let addRes = res <&> \newDat (Set.fromList -> oldDat) -> if - | any (((==) `on` epfName) newDat) oldDat -> FormFailure [mr MsgExamPartAlreadyExists] + | any (\old -> fromMaybe False $ (==) <$> epfName newDat <*> epfName old) oldDat + -> FormFailure [mr MsgExamPartAlreadyExists] | otherwise -> FormSuccess $ pure newDat return (addRes, $(widgetFile "widgets/massinput/examParts/add")) miCell' nudge dat = examPartForm' nudge (Just dat) @@ -266,6 +270,7 @@ examFormTemplate (Entity eId Exam{..}) = do (Just -> epfId, ExamPart{..}) <- examParts' return ExamPartForm { epfId + , epfNumber = examPartNumber , epfName = examPartName , epfMaxPoints = examPartMaxPoints , epfWeight = examPartWeight diff --git a/src/Handler/Exam/New.hs b/src/Handler/Exam/New.hs index 0f863f75b..d4e6582a7 100644 --- a/src/Handler/Exam/New.hs +++ b/src/Handler/Exam/New.hs @@ -50,6 +50,7 @@ postCExamNewR tid ssh csh = do [ ExamPart{..} | ExamPartForm{..} <- Set.toList efExamParts , let examPartExam = examid + examPartNumber = epfNumber examPartName = epfName examPartMaxPoints = epfMaxPoints examPartWeight = epfWeight diff --git a/src/Handler/Exam/RegistrationInvite.hs b/src/Handler/Exam/RegistrationInvite.hs index 5810d3516..ff707cf04 100644 --- a/src/Handler/Exam/RegistrationInvite.hs +++ b/src/Handler/Exam/RegistrationInvite.hs @@ -63,15 +63,19 @@ examRegistrationInvitationConfig = InvitationConfig{..} Course{..} <- get404 examCourse return $ CExamR courseTerm courseSchool courseShorthand examName EInviteR invitationResolveFor _ = do - Just (CExamR tid csh ssh examn EInviteR) <- getCurrentRoute - fetchExamId tid csh ssh examn + cRoute <- getCurrentRoute + case cRoute of + Just (CExamR tid csh ssh examn EInviteR) -> + fetchExamId tid csh ssh examn + _other -> + error "examRegistrationInvitationConfig called from unsupported route" invitationSubject (Entity _ Exam{..}) _ = do Course{..} <- get404 examCourse return . SomeMessage $ MsgMailSubjectExamRegistrationInvitation courseTerm courseSchool courseShorthand examName invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamRegistrationInviteHeading examName invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamRegistrationInviteExplanation}|] invitationTokenConfig _ (InvDBDataExamRegistration{..}, _) = do - itAuthority <- liftHandlerT requireAuthId + itAuthority <- liftHandler requireAuthId let itExpiresAt = Just $ Just invDBExamRegistrationDeadline itAddAuth | not invDBExamRegistrationCourseRegister @@ -81,8 +85,8 @@ examRegistrationInvitationConfig = InvitationConfig{..} itStartsAt = Nothing return InvitationTokenConfig{..} invitationRestriction _ _ = return Authorized - invitationForm (Entity _ Exam{..}) (InvDBDataExamRegistration{..}, _) uid = hoistAForm liftHandlerT . wFormToAForm $ do - isRegistered <- fmap (is _Just) . liftHandlerT . runDB . getBy $ UniqueParticipant uid examCourse + invitationForm (Entity _ Exam{..}) (InvDBDataExamRegistration{..}, _) uid = hoistAForm liftHandler . wFormToAForm $ do + isRegistered <- fmap (is _Just) . liftHandler . runDB . getBy $ UniqueParticipant uid examCourse now <- liftIO getCurrentTime case (isRegistered, invDBExamRegistrationCourseRegister) of diff --git a/src/Handler/Exam/Show.hs b/src/Handler/Exam/Show.hs index 72c6058b4..27c55a9b4 100644 --- a/src/Handler/Exam/Show.hs +++ b/src/Handler/Exam/Show.hs @@ -22,7 +22,7 @@ getEShowR tid ssh csh examn = do cTime <- liftIO getCurrentTime mUid <- maybeAuthId - (Entity _ Exam{..}, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister), occurrenceNamesShown) <- runDB $ do + (Entity _ 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 @@ -33,7 +33,7 @@ getEShowR tid ssh csh examn = do let occurrenceAssignmentsVisible = NTop (Just cTime) >= NTop examPublishOccurrenceAssignments occurrenceAssignmentsShown <- or2M (return occurrenceAssignmentsVisible) . hasReadAccessTo $ CExamR tid ssh csh examn EEditR - examParts <- selectList [ ExamPartExam ==. eId ] [ Asc ExamPartName ] + examParts <- sortOn (view $ _entityVal . _examPartNumber) <$> selectList [ ExamPartExam ==. eId ] [ Asc ExamPartName ] resultsRaw <- for mUid $ \uid -> E.select . E.from $ \examPartResult -> do @@ -43,6 +43,7 @@ getEShowR tid ssh csh examn = do let results = maybe Map.empty (\rs -> Map.fromList [ (examPartResultExamPart, res) | res@(Entity _ ExamPartResult{..}) <- rs ]) resultsRaw result <- fmap join . for mUid $ getBy . UniqueExamResult eId + bonus <- fmap join . for mUid $ getBy . UniqueExamBonus eId occurrencesRaw <- E.select . E.from $ \examOccurrence -> do E.where_ $ examOccurrence E.^. ExamOccurrenceExam E.==. E.val eId @@ -62,15 +63,27 @@ getEShowR tid ssh csh examn = do registered <- for mUid $ existsBy . UniqueExamRegistration eId mayRegister <- (== Authorized) <$> evalAccessDB (CExamR tid ssh csh examName ERegisterR) True - occurrenceNamesShown <- hasReadAccessTo $ CExamR tid ssh csh examn EEditR + lecturerInfoShown <- hasReadAccessTo $ CExamR tid ssh csh examn EEditR - return (exam, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister), occurrenceNamesShown) + return (exam, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, bonus, occurrences, (registered, mayRegister), lecturerInfoShown) + + let occurrenceNamesShown = lecturerInfoShown + partNumbersShown = lecturerInfoShown + examClosedShown = lecturerInfoShown + + sumMaxPoints = sum [ fromRational examPartWeight * mPoints | Entity _ ExamPart{..} <- examParts, let Just mPoints = examPartMaxPoints ] + sumPoints = getSum <$> foldMap (fmap Sum . examPartResultResult . entityVal) results + + noBonus = fromMaybe False $ do + guardM $ bonusOnlyPassed <$> examBonusRule + return . fromMaybe True $ result ^? _Just . _entityVal . _examResultResult . _examResult . passingGrade . _Wrapped . to not + let examTimes = all (\(Entity _ ExamOccurrence{..}, _) -> Just examOccurrenceStart == examStart && examOccurrenceEnd == examEnd) occurrences registerWidget | Just isRegistered <- registered , mayRegister = Just $ do - (examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnExamRegister] [BtnExamDeregister] isRegistered + (examRegisterForm, examRegisterEnctype) <- liftHandler . generateFormPost . buttonForm' $ bool [BtnExamRegister] [BtnExamDeregister] isRegistered [whamlet|

$if isRegistered @@ -86,6 +99,9 @@ getEShowR tid ssh csh examn = do | fromMaybe False registered = Just [whamlet|_{MsgExamRegistered}|] | otherwise = Nothing + showMaxPoints = any (has $ _entityVal . _examPartMaxPoints . _Just) examParts + showAchievedPoints = not $ null results + let heading = prependCourseTitle tid ssh csh $ CI.original examName siteLayoutMsg heading $ do diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index 42a1f12f5..121f430ff 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -4,7 +4,7 @@ module Handler.Exam.Users ( getEUsersR, postEUsersR ) where -import Import +import Import hiding ((<.), (.>)) import Handler.Utils import Handler.Utils.Exam @@ -18,11 +18,13 @@ import Database.Esqueleto.Utils.TH import qualified Data.Csv as Csv -import Data.Map ((!)) +import Data.Map ((!), (!?)) import qualified Data.Map as Map import qualified Data.Set as Set +import qualified Data.HashMap.Lazy as HashMap import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text import qualified Data.Text.Lens as Text import qualified Data.Conduit.List as C @@ -33,9 +35,33 @@ import Numeric.Lens (integral) import Database.Persist.Sql (deleteWhereCount, updateWhereCount) +import Control.Lens.Indexed ((<.), (.>)) -type ExamUserTableExpr = (E.SqlExpr (Entity ExamRegistration) `E.InnerJoin` E.SqlExpr (Entity User)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamOccurrence)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity CourseParticipant)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity StudyFeatures)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms)))) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamResult)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseUserNote)) -type ExamUserTableData = DBRow (Entity ExamRegistration, Entity User, Maybe (Entity ExamOccurrence), Maybe (Entity StudyFeatures), Maybe (Entity StudyDegree), Maybe (Entity StudyTerms), Maybe (Entity ExamResult), Maybe (Entity CourseUserNote)) + +type ExamUserTableExpr = ( E.SqlExpr (Entity ExamRegistration) + `E.InnerJoin` E.SqlExpr (Entity User) + ) + `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamOccurrence)) + `E.LeftOuterJoin` ( E.SqlExpr (Maybe (Entity CourseParticipant)) + `E.LeftOuterJoin` ( E.SqlExpr (Maybe (Entity StudyFeatures)) + `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) + `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms)) + ) + ) + `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamBonus)) + `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamResult)) + `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseUserNote)) +type ExamUserTableData = DBRow ( Entity ExamRegistration + , Entity User + , Maybe (Entity ExamOccurrence) + , Maybe (Entity StudyFeatures) + , Maybe (Entity StudyDegree) + , Maybe (Entity StudyTerms) + , Maybe (Entity ExamBonus) + , Maybe (Entity ExamResult) + , Map ExamPartId (ExamPart, Maybe (Entity ExamPartResult)) + , Maybe (Entity CourseUserNote) + ) instance HasEntity ExamUserTableData User where hasEntity = _dbrOutput . _2 @@ -47,28 +73,51 @@ _userTableOccurrence :: Lens' ExamUserTableData (Maybe (Entity ExamOccurrence)) _userTableOccurrence = _dbrOutput . _3 queryUser :: ExamUserTableExpr -> E.SqlExpr (Entity User) -queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 5 1) - -queryStudyFeatures :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures)) -queryStudyFeatures = $(sqlIJproj 3 1) . $(sqlLOJproj 2 2) . $(sqlLOJproj 5 3) +queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 6 1) queryExamRegistration :: ExamUserTableExpr -> E.SqlExpr (Entity ExamRegistration) -queryExamRegistration = $(sqlIJproj 2 1) . $(sqlLOJproj 5 1) +queryExamRegistration = $(sqlIJproj 2 1) . $(sqlLOJproj 6 1) queryExamOccurrence :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamOccurrence)) -queryExamOccurrence = $(sqlLOJproj 5 2) +queryExamOccurrence = $(sqlLOJproj 6 2) + +queryCourseParticipant :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity CourseParticipant)) +queryCourseParticipant = $(sqlLOJproj 2 1) . $(sqlLOJproj 6 3) + +queryStudyFeatures :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures)) +queryStudyFeatures = $(sqlIJproj 3 1) . $(sqlLOJproj 2 2) . $(sqlLOJproj 6 3) queryStudyDegree :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyDegree)) -queryStudyDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 2 2) . $(sqlLOJproj 5 3) +queryStudyDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 2 2) . $(sqlLOJproj 6 3) queryStudyField :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyTerms)) -queryStudyField = $(sqlIJproj 3 3) . $(sqlLOJproj 2 2) . $(sqlLOJproj 5 3) +queryStudyField = $(sqlIJproj 3 3) . $(sqlLOJproj 2 2) . $(sqlLOJproj 6 3) + +queryExamBonus :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamBonus)) +queryExamBonus = $(sqlLOJproj 6 4) queryExamResult :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamResult)) -queryExamResult = $(sqlLOJproj 5 4) +queryExamResult = $(sqlLOJproj 6 5) queryCourseNote :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity CourseUserNote)) -queryCourseNote = $(sqlLOJproj 5 5) +queryCourseNote = $(sqlLOJproj 6 6) + +queryExamPart :: forall a. + PersistField a + => ExamPartId + -> (E.SqlExpr (Entity ExamPart) -> E.SqlExpr (Maybe (Entity ExamPartResult)) -> E.SqlQuery (E.SqlExpr (E.Value a))) + -> ExamUserTableExpr + -> E.SqlExpr (E.Value a) +queryExamPart epId cont inp = E.sub_select . E.from $ \(examPart `E.LeftOuterJoin` examPartResult) -> flip runReaderT inp $ do + examRegistration <- asks queryExamRegistration + + lift $ do + E.on $ E.just (examPart E.^. ExamPartId) E.==. examPartResult E.?. ExamPartResultExamPart + E.&&. examPartResult E.?. ExamPartResultUser E.==. E.just (examRegistration E.^. ExamRegistrationUser) + E.where_ $ examPart E.^. ExamPartExam E.==. examRegistration E.^. ExamRegistrationExam + E.&&. examPart E.^. ExamPartId E.==. E.val epId + + cont examPart examPartResult resultExamRegistration :: Lens' ExamUserTableData (Entity ExamRegistration) resultExamRegistration = _dbrOutput . _1 @@ -88,11 +137,48 @@ resultStudyField = _dbrOutput . _6 . _Just resultExamOccurrence :: Traversal' ExamUserTableData (Entity ExamOccurrence) resultExamOccurrence = _dbrOutput . _3 . _Just +resultExamBonus :: Traversal' ExamUserTableData (Entity ExamBonus) +resultExamBonus = _dbrOutput . _7 . _Just + resultExamResult :: Traversal' ExamUserTableData (Entity ExamResult) -resultExamResult = _dbrOutput . _7 . _Just +resultExamResult = _dbrOutput . _8 . _Just + +resultExamParts :: IndexedTraversal' ExamPartId ExamUserTableData (ExamPart, Maybe (Entity ExamPartResult)) +resultExamParts = _dbrOutput . _9 . itraversed + +-- resultExamParts' :: Traversal' ExamUserTableData (Entity ExamPart) +-- resultExamParts' = (resultExamParts <. _1) . withIndex . from _Entity + +resultExamPartResult :: ExamPartId -> Lens' ExamUserTableData (Maybe (Entity ExamPartResult)) +resultExamPartResult epId = _dbrOutput . _9 . unsafeSingular (ix epId) . _2 + +resultExamPartResults :: IndexedTraversal' ExamPartId ExamUserTableData (Maybe (Entity ExamPartResult)) +resultExamPartResults = resultExamParts <. _2 resultCourseNote :: Traversal' ExamUserTableData (Entity CourseUserNote) -resultCourseNote = _dbrOutput . _8 . _Just +resultCourseNote = _dbrOutput . _10 . _Just + + +resultAutomaticExamBonus :: Exam -> Map UserId SheetTypeSummary -> Fold ExamUserTableData Points +resultAutomaticExamBonus exam examBonus' = resultUser . _entityKey . folding (\uid -> examResultBonus <$> examBonusRule exam <*> pure (examBonusPossible uid examBonus') <*> pure (examBonusAchieved uid examBonus')) + +resultAutomaticExamResult :: Exam -> Map UserId SheetTypeSummary -> Fold ExamUserTableData ExamResultGrade +resultAutomaticExamResult exam examBonus' = folding . runReader $ do + parts' <- asks $ sequence . toListOf (resultExamPartResults . to (^? _Just . _entityVal . _examPartResultResult)) + bonus <- preview $ resultExamBonus . _entityVal . _examBonusBonus <> resultAutomaticExamBonus exam examBonus' + return $ examGrade exam bonus =<< parts' + + +csvExamPartHeader :: Prism' Csv.Name ExamPartNumber +csvExamPartHeader = prism' toHeader fromHeader + where + toHeader pName = encodeUtf8 $ partPrefix <> CI.foldedCase (pName ^. _ExamPartNumber) + fromHeader hdr = do + tHdr <- either (const Nothing) Just $ Text.decodeUtf8' hdr + review _ExamPartNumber . CI.mk <$> stripPrefix partPrefix tHdr + + partPrefix = "part-" + data ExamUserTableCsv = ExamUserTableCsv { csvEUserSurname :: Maybe Text @@ -103,24 +189,46 @@ data ExamUserTableCsv = ExamUserTableCsv , csvEUserDegree :: Maybe Text , csvEUserSemester :: Maybe Int , csvEUserOccurrence :: Maybe (CI Text) - , csvEUserExercisePoints :: Maybe Points - , csvEUserExerciseNumPasses :: Maybe Int - , csvEUserExercisePointsMax :: Maybe Points - , csvEUserExerciseNumPassesMax :: Maybe Int + , csvEUserExercisePoints :: Maybe (Maybe Points) + , csvEUserExerciseNumPasses :: Maybe (Maybe Int) + , csvEUserExercisePointsMax :: Maybe (Maybe Points) + , csvEUserExerciseNumPassesMax :: Maybe (Maybe Int) + , csvEUserBonus :: Maybe (Maybe Points) + , csvEUserExamPartResults :: Map ExamPartNumber (Maybe ExamResultPoints) , csvEUserExamResult :: Maybe ExamResultPassedGrade , csvEUserCourseNote :: Maybe Html } deriving (Generic) makeLenses_ ''ExamUserTableCsv -examUserTableCsvOptions :: Csv.Options -examUserTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 3 } - instance ToNamedRecord ExamUserTableCsv where - toNamedRecord = Csv.genericToNamedRecord examUserTableCsvOptions + toNamedRecord ExamUserTableCsv{..} = Csv.namedRecord $ + [ "surname" Csv..= csvEUserSurname + , "first-name" Csv..= csvEUserFirstName + , "name" Csv..= csvEUserName + , "matriculation" Csv..= csvEUserMatriculation + , "field" Csv..= csvEUserField + , "degree" Csv..= csvEUserDegree + , "semester" Csv..= csvEUserSemester + , "occurrence" Csv..= csvEUserOccurrence + ] ++ catMaybes + [ fmap ("exercise-points" Csv..=) csvEUserExercisePoints + , fmap ("exercise-num-passes" Csv..=) csvEUserExerciseNumPasses + , fmap ("exercise-points-max" Csv..=) csvEUserExercisePointsMax + , fmap ("exercise-num-passes-max" Csv..=) csvEUserExerciseNumPassesMax + , fmap ("bonus" Csv..=) csvEUserBonus + ] + ++ examPartResults ++ + [ "exam-result" Csv..= csvEUserExamResult + , "course-note" Csv..= csvEUserCourseNote + ] + where + examPartResults + = flip ifoldMap csvEUserExamPartResults $ + \pNumber pResult -> pure $ (csvExamPartHeader # pNumber) Csv..= pResult instance FromNamedRecord ExamUserTableCsv where - parseNamedRecord csv -- Manually defined awaiting issue #427 + parseNamedRecord csv = ExamUserTableCsv <$> csv .:?? "surname" <*> csv .:?? "first-name" @@ -130,36 +238,66 @@ instance FromNamedRecord ExamUserTableCsv where <*> csv .:?? "degree" <*> csv .:?? "semester" <*> csv .:?? "occurrence" - <*> csv .:?? "exercise-points" - <*> csv .:?? "exercise-num-passes" - <*> csv .:?? "exercise-points-max" - <*> csv .:?? "exercise-num-passes-max" + <*> fmap Just (csv .:?? "exercise-points") + <*> fmap Just (csv .:?? "exercise-num-passes") + <*> fmap Just (csv .:?? "exercise-points-max") + <*> fmap Just (csv .:?? "exercise-num-passes-max") + <*> fmap Just (csv .:?? "bonus") + <*> examPartResults <*> csv .:?? "exam-result" <*> csv .:?? "course-note" - -instance DefaultOrdered ExamUserTableCsv where - headerOrder = Csv.genericHeaderOrder examUserTableCsvOptions + where + examPartResults = fmap fold . sequence . flip HashMap.mapMaybeWithKey csv $ \pNumber' _ -> do + pNumber <- pNumber' ^? csvExamPartHeader + return . fmap (singletonMap pNumber ) $ csv .:?? pNumber' instance CsvColumnsExplained ExamUserTableCsv where - csvColumnsExplanations = genericCsvColumnsExplanations examUserTableCsvOptions $ Map.fromList - [ ('csvEUserSurname , MsgCsvColumnExamUserSurname ) - , ('csvEUserFirstName , MsgCsvColumnExamUserFirstName ) - , ('csvEUserName , MsgCsvColumnExamUserName ) - , ('csvEUserMatriculation , MsgCsvColumnExamUserMatriculation ) - , ('csvEUserField , MsgCsvColumnExamUserField ) - , ('csvEUserDegree , MsgCsvColumnExamUserDegree ) - , ('csvEUserSemester , MsgCsvColumnExamUserSemester ) - , ('csvEUserOccurrence , MsgCsvColumnExamUserOccurrence ) - , ('csvEUserExercisePoints , MsgCsvColumnExamUserExercisePoints ) - , ('csvEUserExerciseNumPasses , MsgCsvColumnExamUserExercisePasses ) - , ('csvEUserExercisePointsMax , MsgCsvColumnExamUserExercisePointsMax ) - , ('csvEUserExerciseNumPassesMax, MsgCsvColumnExamUserExercisePassesMax ) - , ('csvEUserExamResult , MsgCsvColumnExamUserResult ) - , ('csvEUserCourseNote , MsgCsvColumnExamUserCourseNote ) + csvColumnsExplanations _ = mconcat + [ single "surname" MsgCsvColumnExamUserSurname + , single "first-name" MsgCsvColumnExamUserFirstName + , single "name" MsgCsvColumnExamUserName + , single "matriculation" MsgCsvColumnExamUserMatriculation + , single "field" MsgCsvColumnExamUserField + , single "degree" MsgCsvColumnExamUserDegree + , single "semester" MsgCsvColumnExamUserSemester + , single "occurrence" MsgCsvColumnExamUserOccurrence + , single "exercise-points" MsgCsvColumnExamUserExercisePoints + , single "exercise-num-passes" MsgCsvColumnExamUserExercisePasses + , single "exercise-points-max" MsgCsvColumnExamUserExercisePointsMax + , single "exercise-num-passes-max" MsgCsvColumnExamUserExercisePassesMax + , single "bonus" MsgCsvColumnExamUserBonus + , single "part-*" MsgCsvColumnExamUserParts + , single "exam-result" MsgCsvColumnExamUserResult + , single "course-note" MsgCsvColumnExamUserCourseNote ] + where + single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget + single k v = singletonMap k [whamlet|_{v}|] + +examUserTableCsvHeader :: ( MonoFoldable mono + , Element mono ~ ExamPartNumber + ) + => SheetGradeSummary -> Bool -> mono -> Csv.Header +examUserTableCsvHeader allBoni doBonus pNames = Csv.header $ + [ "surname", "first-name", "name" + , "matriculation" + , "field", "degree", "semester" + , "course-note" + , "occurrence" + ] ++ bool mempty ["exercise-points", "exercise-points-max"] (doBonus && showPoints) + ++ bool mempty ["exercise-num-passes", "exercise-num-passes-max"] (doBonus && showPasses) + ++ bool mempty ["bonus"] doBonus + ++ map (review csvExamPartHeader) (sort $ otoList pNames) ++ + [ "exam-result" + ] + where + showPasses = numSheetsPasses allBoni /= 0 + showPoints = getSum (numSheetsPoints allBoni) /= 0 data ExamUserAction = ExamUserDeregister | ExamUserAssignOccurrence + | ExamUserAcceptComputedResult + | ExamUserResetToComputedResult deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) instance Universe ExamUserAction @@ -169,13 +307,21 @@ embedRenderMessage ''UniWorX ''ExamUserAction id data ExamUserActionData = ExamUserDeregisterData | ExamUserAssignOccurrenceData (Maybe ExamOccurrenceId) + | ExamUserAcceptComputedResultData + | ExamUserResetToComputedResultData + { examUserResetBonus :: Bool + } data ExamUserCsvActionClass = ExamUserCsvCourseRegister | ExamUserCsvRegister | ExamUserCsvAssignOccurrence | ExamUserCsvSetCourseField + | ExamUserCsvSetPartResult + | ExamUserCsvSetBonus + | ExamUserCsvOverrideBonus | ExamUserCsvSetResult + | ExamUserCsvOverrideResult | ExamUserCsvSetCourseNote | ExamUserCsvDeregister deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) @@ -202,8 +348,19 @@ data ExamUserCsvAction | ExamUserCsvDeregisterData { examUserCsvActRegistration :: ExamRegistrationId } - | ExamUserCsvSetResultData + | ExamUserCsvSetPartResultData { examUserCsvActUser :: UserId + , examUserCsvActExamPart :: ExamPartNumber + , examUserCsvActExamPartResult :: Maybe ExamResultPoints + } + | ExamUserCsvSetBonusData + { examUserCsvIsBonusOverride :: Bool + , examUserCsvActUser :: UserId + , examUserCsvActExamBonus :: Maybe Points + } + | ExamUserCsvSetResultData + { examUserCsvIsResultOverride :: Bool + , examUserCsvActUser :: UserId , examUserCsvActExamResult :: Maybe ExamResultPassedGrade } | ExamUserCsvSetCourseNoteData @@ -230,75 +387,148 @@ embedRenderMessage ''UniWorX ''ExamUserCsvException id getEUsersR, postEUsersR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html getEUsersR = postEUsersR postEUsersR tid ssh csh examn = do - ((registrationResult, examUsersTable), Entity eId _) <- runDB $ do - exam@(Entity eid Exam{..}) <- fetchExam tid ssh csh examn + (((Any computedValues, registrationResult), examUsersTable), Entity eId examVal, bonus) <- runDB $ do + exam@(Entity eid examVal@Exam{..}) <- fetchExam tid ssh csh examn + examParts <- selectList [ExamPartExam ==. eid] [Asc ExamPartName] bonus <- examBonus exam let + allBoni :: SheetGradeSummary allBoni = (mappend <$> normalSummary <*> bonusSummary) $ fold bonus - showPasses = numSheetsPasses allBoni /= 0 - showPoints = getSum (numSheetsPoints allBoni) /= 0 + + doBonus = is _Just examBonusRule + showPasses = doBonus && numSheetsPasses allBoni /= 0 + showPoints = doBonus && getSum (numSheetsPoints allBoni) /= 0 resultView :: ExamResultGrade -> ExamResultPassedGrade resultView = fmap $ bool (Left . view passingGrade) Right examShowGrades + examPartNumbers = examParts ^.. folded . _entityVal . _examPartNumber + + resultAutomaticExamBonus' :: Fold ExamUserTableData Points + resultAutomaticExamBonus' = resultAutomaticExamBonus examVal bonus + resultAutomaticExamResult' :: Fold ExamUserTableData ExamResultGrade + resultAutomaticExamResult' = resultAutomaticExamResult examVal bonus + + automaticCell :: forall msg m a b r. + ( RenderMessage UniWorX msg + , IsDBTable m a + , Eq msg + , Monoid b + , a ~ (Any, b) + ) + => Getting (Endo [Either msg msg]) r (Either msg msg) + -> r + -> DBCell m a + automaticCell l r = case toListOf l r of + [] -> mempty + (Left auto : _) + -> i18nCell auto & cellAttrs <>~ [("class", "table__td--automatic")] & tellCell (Any True, mempty) + (Right man : others) + | all ((== man) . either id id) others + -> i18nCell man + | otherwise + -> i18nCell man & cellAttrs <>~ [("class", "table__td--overriden")] & tellCell (Any True, mempty) + csvName <- getMessageRender <*> pure (MsgExamUserCsvName tid ssh csh examn) let examUsersDBTable = DBTable{..} where - dbtSQLQuery ((examRegistration `E.InnerJoin` user) `E.LeftOuterJoin` occurrence `E.LeftOuterJoin` (courseParticipant `E.LeftOuterJoin` (studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyField)) `E.LeftOuterJoin` examResult `E.LeftOuterJoin` courseUserNote) = do - E.on $ courseUserNote E.?. CourseUserNoteUser E.==. E.just (user E.^. UserId) - E.&&. courseUserNote E.?. CourseUserNoteCourse E.==. E.just (E.val examCourse) - E.on $ examResult E.?. ExamResultUser E.==. E.just (user E.^. UserId) - E.&&. examResult E.?. ExamResultExam E.==. E.just (E.val eid) - E.on $ studyField E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField - E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree - E.on $ studyFeatures E.?. StudyFeaturesId E.==. E.joinV (courseParticipant E.?. CourseParticipantField) - E.on $ courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val examCourse) - E.&&. courseParticipant E.?. CourseParticipantUser E.==. E.just (user E.^. UserId) - E.on $ occurrence E.?. ExamOccurrenceExam E.==. E.just (E.val eid) - E.&&. occurrence E.?. ExamOccurrenceId E.==. examRegistration E.^. ExamRegistrationOccurrence - E.on $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId - E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eid - return (examRegistration, user, occurrence, studyFeatures, studyDegree, studyField, examResult, courseUserNote) + dbtSQLQuery = runReaderT $ do + examRegistration <- asks queryExamRegistration + user <- asks queryUser + occurrence <- asks queryExamOccurrence + courseParticipant <- asks queryCourseParticipant + studyFeatures <- asks queryStudyFeatures + studyDegree <- asks queryStudyDegree + studyField <- asks queryStudyField + examBonus' <- asks queryExamBonus + examResult <- asks queryExamResult + courseUserNote <- asks queryCourseNote + + lift $ do + E.on $ courseUserNote E.?. CourseUserNoteUser E.==. E.just (user E.^. UserId) + E.&&. courseUserNote E.?. CourseUserNoteCourse E.==. E.just (E.val examCourse) + E.on $ examResult E.?. ExamResultUser E.==. E.just (user E.^. UserId) + E.&&. examResult E.?. ExamResultExam E.==. E.just (E.val eid) + E.on $ examBonus' E.?. ExamBonusUser E.==. E.just (user E.^. UserId) + E.&&. examBonus' E.?. ExamBonusExam E.==. E.just (E.val eid) + E.on $ studyField E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField + E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree + E.on $ studyFeatures E.?. StudyFeaturesId E.==. E.joinV (courseParticipant E.?. CourseParticipantField) + E.on $ courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val examCourse) + E.&&. courseParticipant E.?. CourseParticipantUser E.==. E.just (user E.^. UserId) + E.on $ occurrence E.?. ExamOccurrenceExam E.==. E.just (E.val eid) + E.&&. occurrence E.?. ExamOccurrenceId E.==. examRegistration E.^. ExamRegistrationOccurrence + E.on $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId + + E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eid + + return (examRegistration, user, occurrence, studyFeatures, studyDegree, studyField, examBonus', examResult, courseUserNote) dbtRowKey = queryExamRegistration >>> (E.^. ExamRegistrationId) - dbtProj = return + dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $ + (,,,,,,,,,) + <$> view _1 <*> view _2 <*> view _3 <*> view _4 <*> view _5 <*> view _6 <*> view _7 <*> view _8 + <*> getExamParts + <*> view _9 + where + getExamParts :: ReaderT _ (MaybeT (YesodDB UniWorX)) (Map ExamPartId (ExamPart, Maybe (Entity ExamPartResult))) + getExamParts = do + uid <- view $ _2 . _entityKey + rawResults <- lift . lift . E.select . E.from $ \(examPart `E.LeftOuterJoin` examPartResult) -> do + E.on $ examPartResult E.?. ExamPartResultExamPart E.==. E.just (examPart E.^. ExamPartId) + E.&&. examPartResult E.?. ExamPartResultUser E.==. E.just (E.val uid) + E.where_ $ examPart E.^. ExamPartExam E.==. E.val eid + return (examPart, examPartResult) + return $ Map.fromList + [ (epId, (examPart, mbRes)) + | (Entity epId examPart, mbRes) <- rawResults + ] + dbtColonnade = mconcat $ catMaybes - [ pure $ dbSelect (applying _2) id $ return . view (resultExamRegistration . _entityKey) + [ pure $ dbSelect (_2 . applying _2) _1 $ return . view (resultExamRegistration . _entityKey) , pure $ colUserNameLink (CourseR tid ssh csh . CUserR) , pure colUserMatriclenr , pure $ colField resultStudyField , pure $ colDegreeShort resultStudyDegree , pure $ colFeaturesSemester resultStudyFeatures , pure $ sortable (Just "occurrence") (i18nCell MsgExamOccurrence) $ maybe mempty (anchorCell' (\n -> CExamR tid ssh csh examn EShowR :#: [st|exam-occurrence__#{n}|]) id . examOccurrenceName . entityVal) . view _userTableOccurrence - , guardOn showPasses $ sortable Nothing (i18nCell MsgAchievedPasses) $ \(view $ resultUser . _entityKey -> uid) -> fromMaybe mempty $ do - SheetGradeSummary{achievedPasses} <- examBonusAchieved uid bonus - SheetGradeSummary{numSheetsPasses} <- examBonusPossible uid bonus - return $ propCell (getSum achievedPasses) (getSum numSheetsPasses) - , guardOn showPoints $ sortable Nothing (i18nCell MsgAchievedPoints) $ \(view $ resultUser . _entityKey -> uid) -> fromMaybe mempty $ do - SheetGradeSummary{achievedPoints} <- examBonusAchieved uid bonus - SheetGradeSummary{sumSheetsPoints} <- examBonusPossible uid bonus - return $ propCell (getSum achievedPoints) (getSum sumSheetsPoints) - , guardOn examShowGrades $ sortable (Just "result") (i18nCell MsgExamResult) $ maybe mempty i18nCell . preview (resultExamResult . _entityVal . _examResultResult) - , guardOn (not examShowGrades) $ sortable (Just "result-bool") (i18nCell MsgExamResult) $ maybe mempty i18nCell . preview (resultExamResult . _entityVal . _examResultResult . to (over _examResult $ view passingGrade)) + , guardOn showPasses $ sortable Nothing (i18nCell MsgAchievedPasses) $ \(view $ resultUser . _entityKey -> uid) -> + let SheetGradeSummary{achievedPasses} = examBonusAchieved uid bonus + SheetGradeSummary{numSheetsPasses} = examBonusPossible uid bonus + in propCell (getSum achievedPasses) (getSum numSheetsPasses) + , guardOn showPoints $ sortable Nothing (i18nCell MsgAchievedPoints) $ \(view $ resultUser . _entityKey -> uid) -> + let SheetGradeSummary{achievedPoints} = examBonusAchieved uid bonus + SheetGradeSummary{sumSheetsPoints} = examBonusPossible uid bonus + in propCell (getSum achievedPoints) (getSum sumSheetsPoints) + , guardOn doBonus $ sortable (Just "bonus") (i18nCell MsgExamBonusAchieved) . automaticCell $ resultExamBonus . _entityVal . _examBonusBonus . to Right <> resultAutomaticExamBonus' . to Left + , pure $ mconcat + [ sortable (Just $ fromText [st|part-#{toPathPiece examPartNumber}|]) (i18nCell $ MsgExamPartNumbered examPartNumber) $ maybe mempty i18nCell . preview (resultExamPartResult epId . _Just . _entityVal . _examPartResultResult) + | Entity epId ExamPart{..} <- sortOn (examPartNumber . entityVal) examParts + ] + , pure $ sortable (Just $ bool "result-bool" "result" examShowGrades) (i18nCell MsgExamResult) . automaticCell $ (resultExamResult . _entityVal . _examResultResult . to Right <> resultAutomaticExamResult' . to Left) . to (bimap resultView resultView) , pure . sortable (Just "note") (i18nCell MsgCourseUserNote) $ \((,) <$> view (resultUser . _entityKey) <*> has resultCourseNote -> (uid, hasNote)) -> bool mempty (anchorCellM (CourseR tid ssh csh . CUserR <$> encrypt uid) $ hasComment True) hasNote ] - dbtSorting = Map.fromList - [ sortUserNameLink queryUser - , sortUserMatriclenr queryUser - , sortField queryStudyField - , sortDegreeShort queryStudyDegree - , sortFeaturesSemester queryStudyFeatures - , ("occurrence", SortColumn $ queryExamOccurrence >>> (E.?. ExamOccurrenceName)) - , ("result", SortColumn $ queryExamResult >>> (E.?. ExamResultResult)) - , ("result-bool", SortColumn $ queryExamResult >>> (E.?. ExamResultResult) >>> E.orderByList [Just ExamVoided, Just ExamNoShow, Just $ ExamAttended Grade50]) - , ("note", SortColumn $ queryCourseNote >>> \note -> -- sort by last edit date + dbtSorting = mconcat + [ uncurry singletonMap $ sortUserNameLink queryUser + , uncurry singletonMap $ sortUserMatriclenr queryUser + , uncurry singletonMap $ sortField queryStudyField + , uncurry singletonMap $ sortDegreeShort queryStudyDegree + , uncurry singletonMap $ sortFeaturesSemester queryStudyFeatures + , mconcat + [ singletonMap (fromText [st|part-#{toPathPiece examPartNumber}|]) . SortColumn . queryExamPart epId $ \_ examPartResult -> return $ examPartResult E.?. ExamPartResultResult + | Entity epId ExamPart{..} <- examParts + ] + , singletonMap "occurrence" . SortColumn $ queryExamOccurrence >>> (E.?. ExamOccurrenceName) + , singletonMap "bonus" . SortColumn $ queryExamBonus >>> (E.?. ExamBonusBonus) + , singletonMap "result" . SortColumn $ queryExamResult >>> (E.?. ExamResultResult) + , singletonMap "result-bool" . SortColumn $ queryExamResult >>> (E.?. ExamResultResult) >>> E.orderByList [Just ExamVoided, Just ExamNoShow, Just $ ExamAttended Grade50] + , singletonMap "note" . SortColumn $ queryCourseNote >>> \note -> -- sort by last edit date E.sub_select . E.from $ \edit -> do E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote) return . E.max_ $ edit E.^. CourseUserNoteEditTime - ) ] dbtFilter = Map.fromList [ fltrUserNameEmail queryUser @@ -341,39 +571,55 @@ postEUsersR tid ssh csh examn = do , dbParamsFormAdditional = \csrf -> do let actionMap :: Map ExamUserAction (AForm Handler ExamUserActionData) - actionMap = Map.fromList - [ ( ExamUserDeregister - , pure ExamUserDeregisterData - ) - , ( ExamUserAssignOccurrence - , ExamUserAssignOccurrenceData + actionMap = mconcat + [ singletonMap ExamUserDeregister $ + pure ExamUserDeregisterData + , singletonMap ExamUserAssignOccurrence $ + ExamUserAssignOccurrenceData <$> aopt (examOccurrenceField eid) (fslI MsgExamOccurrence) (Just Nothing) - ) + , bool mempty computeActionMap $ is _Just examGradingRule + ] + computeActionMap = mconcat + [ singletonMap ExamUserAcceptComputedResult $ + pure ExamUserAcceptComputedResultData + , singletonMap ExamUserResetToComputedResult $ + ExamUserResetToComputedResultData + <$> bool (pure True) (apopt checkBoxField (fslI MsgExamUserResetBonus) (Just True)) (is _Just examBonusRule) ] (res, formWgt) <- multiActionM actionMap (fslI MsgAction) Nothing csrf let formRes = (, mempty) . First . Just <$> res return (formRes, formWgt) - , dbParamsFormEvaluate = liftHandlerT . runFormPost - , dbParamsFormResult = id + , dbParamsFormEvaluate = liftHandler . runFormPost + , dbParamsFormResult = _2 , dbParamsFormIdent = def } dbtIdent :: Text dbtIdent = "exam-users" - dbtCsvEncode = simpleCsvEncode csvName $ ExamUserTableCsv - <$> view (resultUser . _entityVal . _userSurname . to Just) - <*> view (resultUser . _entityVal . _userFirstName . to Just) - <*> view (resultUser . _entityVal . _userDisplayName . to Just) - <*> view (resultUser . _entityVal . _userMatrikelnummer) - <*> preview (resultStudyField . _entityVal . to (\StudyTerms{..} -> studyTermsName <|> studyTermsShorthand <|> Just (tshow studyTermsKey)) . _Just) - <*> preview (resultStudyDegree . _entityVal . to (\StudyDegree{..} -> studyDegreeName <|> studyDegreeShorthand <|> Just (tshow studyDegreeKey)) . _Just) - <*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester) - <*> preview (resultExamOccurrence . _entityVal . _examOccurrenceName) - <*> preview (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPoints . _Wrapped) - <*> preview (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPasses . _Wrapped . integral) - <*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _sumSheetsPoints . _Wrapped) - <*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _numSheetsPasses . _Wrapped . integral) - <*> preview (resultExamResult . _entityVal . _examResultResult . to resultView) - <*> preview (resultCourseNote . _entityVal . _courseUserNoteNote) + dbtCsvEncode = Just DBTCsvEncode + { dbtCsvExportForm = pure () + , dbtCsvDoEncode = \() -> C.map (doEncode' . view _2) + , dbtCsvName = unpack csvName + , dbtCsvNoExportData = Just id + , dbtCsvHeader = const . return . examUserTableCsvHeader allBoni doBonus $ examParts ^.. folded . _entityVal . _examPartNumber + } + where + doEncode' = ExamUserTableCsv + <$> view (resultUser . _entityVal . _userSurname . to Just) + <*> view (resultUser . _entityVal . _userFirstName . to Just) + <*> view (resultUser . _entityVal . _userDisplayName . to Just) + <*> view (resultUser . _entityVal . _userMatrikelnummer) + <*> preview (resultStudyField . _entityVal . to (\StudyTerms{..} -> studyTermsName <|> studyTermsShorthand <|> Just (tshow studyTermsKey)) . _Just) + <*> preview (resultStudyDegree . _entityVal . to (\StudyDegree{..} -> studyDegreeName <|> studyDegreeShorthand <|> Just (tshow studyDegreeKey)) . _Just) + <*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester) + <*> preview (resultExamOccurrence . _entityVal . _examOccurrenceName) + <*> previews (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _achievedPoints . _Wrapped) (bool (const Nothing) Just showPoints) + <*> previews (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _achievedPasses . _Wrapped . integral) (bool (const Nothing) Just showPasses) + <*> previews (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _sumSheetsPoints . _Wrapped) (bool (const Nothing) Just showPoints) + <*> previews (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _numSheetsPasses . _Wrapped . integral) (bool (const Nothing) Just showPasses) + <*> previews (resultExamBonus . _entityVal . _examBonusBonus <> resultAutomaticExamBonus') (bool (const Nothing) Just doBonus) + <*> (Map.fromList . map (over _1 examPartNumber . over (_2 . _Just) (examPartResultResult . entityVal)) <$> asks (toListOf resultExamParts)) + <*> previews (resultExamResult . _entityVal . _examResultResult <> resultAutomaticExamResult') resultView + <*> preview (resultCourseNote . _entityVal . _courseUserNoteNote) dbtCsvDecode = Just DBTCsvDecode { dbtCsvRowKey = \csv -> do uid <- lift $ view _2 <$> guessUser csv @@ -382,20 +628,28 @@ postEUsersR tid ssh csh examn = do DBCsvDiffMissing{dbCsvOldKey} -> yield . ExamUserCsvDeregisterData $ E.unValue dbCsvOldKey DBCsvDiffNew{dbCsvNewKey = Just _} - -> fail "An UniqueExamRegistration could be found, but the ExamRegistrationKey is not among the existing keys" + -> error "An UniqueExamRegistration could be found, but the ExamRegistrationKey is not among the existing keys" DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do (isPart, uid) <- lift $ guessUser dbCsvNew if | isPart -> do yieldM $ ExamUserCsvRegisterData <$> pure uid <*> lookupOccurrence dbCsvNew newFeatures <- lift $ lookupStudyFeatures dbCsvNew - Just (Entity cpId CourseParticipant{ courseParticipantField = oldFeatures }) <- lift . getBy $ UniqueParticipant uid examCourse + Entity cpId CourseParticipant{ courseParticipantField = oldFeatures } <- lift . getJustBy $ UniqueParticipant uid examCourse when (newFeatures /= oldFeatures) $ yield $ ExamUserCsvSetCourseFieldData cpId newFeatures | otherwise -> yieldM $ ExamUserCsvCourseRegisterData uid <$> lookupStudyFeatures dbCsvNew <*> lookupOccurrence dbCsvNew + + iforMOf_ (ifolded <. _Just) (csvEUserExamPartResults dbCsvNew) $ \epNumber epRes -> + when (epNumber `elem` examPartNumbers) $ + yield $ ExamUserCsvSetPartResultData uid epNumber (Just epRes) + + when (doBonus && is _Just (join $ csvEUserBonus dbCsvNew)) $ + yield . ExamUserCsvSetBonusData False uid . join $ csvEUserBonus dbCsvNew + when (is _Just $ csvEUserExamResult dbCsvNew) $ - yield . ExamUserCsvSetResultData uid $ csvEUserExamResult dbCsvNew + yield . ExamUserCsvSetResultData False uid $ csvEUserExamResult dbCsvNew note <- lift . getBy $ UniqueCourseUserNote uid examCourse when (csvEUserCourseNote dbCsvNew /= note ^? _Just . _entityVal . _courseUserNoteNote) $ @@ -407,11 +661,54 @@ postEUsersR tid ssh csh examn = do newFeatures <- lift $ lookupStudyFeatures dbCsvNew when (newFeatures /= dbCsvOld ^? resultStudyFeatures . _entityKey) $ do - Just (Entity cpId _) <- lift . getBy . flip UniqueParticipant examCourse $ dbCsvOld ^. resultUser . _entityKey + Entity cpId _ <- lift . getJustBy . flip UniqueParticipant examCourse $ dbCsvOld ^. resultUser . _entityKey yield $ ExamUserCsvSetCourseFieldData cpId newFeatures - when (csvEUserExamResult dbCsvNew /= dbCsvOld ^? resultExamResult . _entityVal . _examResultResult . to resultView) $ - yield . ExamUserCsvSetResultData (dbCsvOld ^. resultUser . _entityKey) $ csvEUserExamResult dbCsvNew + let uid = dbCsvOld ^. resultUser . _entityKey + + forM_ examPartNumbers $ \epNumber -> + let oldPartResult = dbCsvOld ^? resultExamParts . filtered (views (_1 . _examPartNumber) (== epNumber)) . _2 . _Just . _entityVal . _examPartResultResult + in whenIsJust (csvEUserExamPartResults dbCsvNew !? epNumber) $ \epRes -> + when (epRes /= oldPartResult) $ + yield $ ExamUserCsvSetPartResultData uid epNumber epRes + + let newResults :: Maybe (Map ExamPartNumber ExamResultPoints) + newResults = sequence (csvEUserExamPartResults dbCsvNew) + <|> sequence (toMapOf (resultExamParts .> ito (over _1 $ examPartNumber) <. to (fmap $ examPartResultResult . entityVal)) dbCsvOld) + + newBonus, oldBonus :: Maybe Points + newBonus = join (csvEUserBonus dbCsvNew) + oldBonus = dbCsvOld ^? (resultExamBonus . _entityVal . _examBonusBonus <> resultAutomaticExamBonus') + + newResult, oldResult :: Maybe ExamResultPassedGrade + newResult = fmap resultView <$> examGrade examVal (newBonus <|> oldBonus) =<< newResults + oldResult = dbCsvOld ^? (resultExamResult . _entityVal . _examResultResult <> resultAutomaticExamResult') . to resultView + + when doBonus $ + case newBonus of + _ | newBonus == oldBonus + -> return () + _ | is _Nothing newBonus + -> return () + Nothing + -> yield $ ExamUserCsvSetBonusData False uid newBonus + Just _ + -> yield $ ExamUserCsvSetBonusData True uid newBonus + + case newResult of + _ | csvEUserExamResult dbCsvNew == oldResult + -> return () + _ | is _Nothing $ csvEUserExamResult dbCsvNew + -> return () + Nothing + -> yield . ExamUserCsvSetResultData False uid $ csvEUserExamResult dbCsvNew + Just _ + | csvEUserExamResult dbCsvNew /= newResult + -> yield . ExamUserCsvSetResultData True uid $ csvEUserExamResult dbCsvNew + | oldResult /= newResult + -> yield . ExamUserCsvSetResultData False uid $ csvEUserExamResult dbCsvNew + | otherwise + -> return () when (csvEUserCourseNote dbCsvNew /= dbCsvOld ^? resultCourseNote . _entityVal . _courseUserNoteNote) $ yield . ExamUserCsvSetCourseNoteData (dbCsvOld ^. resultUser . _entityKey) $ csvEUserCourseNote dbCsvNew @@ -421,7 +718,13 @@ postEUsersR tid ssh csh examn = do ExamUserCsvDeregisterData{} -> ExamUserCsvDeregister ExamUserCsvAssignOccurrenceData{} -> ExamUserCsvAssignOccurrence ExamUserCsvSetCourseFieldData{} -> ExamUserCsvSetCourseField - ExamUserCsvSetResultData{} -> ExamUserCsvSetResult + ExamUserCsvSetPartResultData{} -> ExamUserCsvSetPartResult + ExamUserCsvSetBonusData{..} + | examUserCsvIsBonusOverride -> ExamUserCsvOverrideBonus + | otherwise -> ExamUserCsvSetBonus + ExamUserCsvSetResultData{..} + | examUserCsvIsResultOverride -> ExamUserCsvOverrideResult + | otherwise -> ExamUserCsvSetResult ExamUserCsvSetCourseNoteData{} -> ExamUserCsvSetCourseNote , dbtCsvCoarsenActionClass = \case ExamUserCsvCourseRegister -> DBCsvActionNew @@ -462,6 +765,34 @@ postEUsersR tid ssh csh examn = do update examUserCsvActCourseParticipant [ CourseParticipantField =. examUserCsvActCourseField ] CourseParticipant{..} <- getJust examUserCsvActCourseParticipant audit $ TransactionCourseParticipantEdit examCourse courseParticipantUser + ExamUserCsvSetPartResultData{..} -> do + epid <- getKeyJustBy $ UniqueExamPartNumber eid examUserCsvActExamPart + case examUserCsvActExamPartResult of + Nothing -> do + deleteBy $ UniqueExamPartResult epid examUserCsvActUser + audit $ TransactionExamPartResultDeleted epid examUserCsvActUser + Just res -> do + now <- liftIO getCurrentTime + void $ upsertBy + (UniqueExamPartResult epid examUserCsvActUser) + (ExamPartResult epid examUserCsvActUser res now) + [ ExamPartResultResult =. res + , ExamPartResultLastChanged =. now + ] + audit $ TransactionExamPartResultEdit epid examUserCsvActUser + ExamUserCsvSetBonusData{..} -> case examUserCsvActExamBonus of + Nothing -> do + deleteBy $ UniqueExamBonus eid examUserCsvActUser + audit $ TransactionExamBonusDeleted eid examUserCsvActUser + Just res -> do + now <- liftIO getCurrentTime + void $ upsertBy + (UniqueExamBonus eid examUserCsvActUser) + (ExamBonus eid examUserCsvActUser res now) + [ ExamBonusBonus =. res + , ExamBonusLastChanged =. now + ] + audit $ TransactionExamBonusEdit eid examUserCsvActUser ExamUserCsvSetResultData{..} -> case examUserCsvActExamResult of Nothing -> do deleteBy $ UniqueExamResult eid examUserCsvActUser @@ -491,13 +822,13 @@ postEUsersR tid ssh csh examn = do delete nid ExamUserCsvSetCourseNoteData{ examUserCsvActCourseNote = Just note, .. } -> do now <- liftIO getCurrentTime - uid <- liftHandlerT requireAuthId + uid <- liftHandler requireAuthId Entity nid _ <- upsert (CourseUserNote examCourse examUserCsvActUser note) [ CourseUserNoteNote =. note ] insert_ $ CourseUserNoteEdit uid now nid return $ CExamR tid ssh csh examn EUsersR , dbtCsvRenderKey = \(registeredUserName -> registeredUserName') -> \case ExamUserCsvCourseRegisterData{..} -> do - (User{..}, occ) <- liftHandlerT . runDB $ (,) <$> getJust examUserCsvActUser <*> for examUserCsvActOccurrence getJust + (User{..}, occ) <- liftHandler . runDB $ (,) <$> getJust examUserCsvActUser <*> for examUserCsvActOccurrence getJust [whamlet| $newline never ^{nameWidget userDisplayName userSurname} @@ -511,7 +842,7 @@ postEUsersR tid ssh csh examn = do \ (_{MsgExamNoOccurrence}) |] ExamUserCsvRegisterData{..} -> do - (User{..}, occ) <- liftHandlerT . runDB $ (,) <$> getJust examUserCsvActUser <*> for examUserCsvActOccurrence getJust + (User{..}, occ) <- liftHandler . runDB $ (,) <$> getJust examUserCsvActUser <*> for examUserCsvActOccurrence getJust [whamlet| $newline never ^{nameWidget userDisplayName userSurname} @@ -521,7 +852,7 @@ postEUsersR tid ssh csh examn = do \ (_{MsgExamNoOccurrence}) |] ExamUserCsvAssignOccurrenceData{..} -> do - occ <- for examUserCsvActOccurrence $ liftHandlerT . runDB . getJust + occ <- for examUserCsvActOccurrence $ liftHandler . runDB . getJust [whamlet| $newline never ^{registeredUserName' examUserCsvActRegistration} @@ -531,7 +862,7 @@ postEUsersR tid ssh csh examn = do \ (_{MsgExamNoOccurrence}) |] ExamUserCsvSetCourseFieldData{..} -> do - User{..} <- liftHandlerT . runDB $ getJust . courseParticipantUser =<< getJust examUserCsvActCourseParticipant + User{..} <- liftHandler . runDB $ getJust . courseParticipantUser =<< getJust examUserCsvActCourseParticipant [whamlet| $newline never ^{nameWidget userDisplayName userSurname} @@ -540,8 +871,34 @@ postEUsersR tid ssh csh examn = do $nothing , _{MsgCourseStudyFeatureNone} |] + ExamUserCsvSetPartResultData{..} -> do + (User{..}, Entity _ ExamPart{..}) <- liftHandler . runDB $ + (,) <$> getJust examUserCsvActUser + <*> getJustBy (UniqueExamPartNumber eid examUserCsvActExamPart) + [whamlet| + $newline never + ^{nameWidget userDisplayName userSurname} + $maybe pName <- examPartName + , „#{pName}“ + $nothing + , _{MsgExamPartNumbered examPartNumber} + $maybe newResult <- examUserCsvActExamPartResult + , _{newResult} + $nothing + , _{MsgExamResultNone} + |] + ExamUserCsvSetBonusData{..} -> do + User{..} <- liftHandler . runDB $ getJust examUserCsvActUser + [whamlet| + $newline never + ^{nameWidget userDisplayName userSurname} + $maybe newBonus <- examUserCsvActExamBonus + , _{newBonus} + $nothing + , _{MsgExamBonusNone} + |] ExamUserCsvSetResultData{..} -> do - User{..} <- liftHandlerT . runDB $ getJust examUserCsvActUser + User{..} <- liftHandler . runDB $ getJust examUserCsvActUser [whamlet| $newline never ^{nameWidget userDisplayName userSurname} @@ -551,7 +908,7 @@ postEUsersR tid ssh csh examn = do , _{MsgExamResultNone} |] ExamUserCsvSetCourseNoteData{..} -> do - User{..} <- liftHandlerT . runDB $ getJust examUserCsvActUser + User{..} <- liftHandler . runDB $ getJust examUserCsvActUser [whamlet| $newline never ^{nameWidget userDisplayName userSurname} @@ -651,21 +1008,21 @@ postEUsersR tid ssh csh examn = do examUsersDBTableValidator = def & defaultSorting [SortAscBy "user-name"] & defaultPagesize PagesizeAll - postprocess :: FormResult (First ExamUserActionData, DBFormResult ExamRegistrationId Bool ExamUserTableData) -> FormResult (ExamUserActionData, Set ExamRegistrationId) + postprocess :: FormResult (First ExamUserActionData, DBFormResult ExamRegistrationId (Bool, ExamUserTableData) ExamUserTableData) -> FormResult (ExamUserActionData, Map ExamRegistrationId ExamUserTableData) postprocess inp = do (First (Just act), regMap) <- inp - let regSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) regMap - return (act, regSet) - (, exam) . over _1 postprocess <$> dbTable examUsersDBTableValidator examUsersDBTable + let regMap' = Map.mapMaybe (uncurry guardOn) $ getDBFormResult (False,) regMap + return (act, regMap') + (, exam, bonus) . over (_1 . _2) postprocess <$> dbTable examUsersDBTableValidator examUsersDBTable formResult registrationResult $ \case - (ExamUserDeregisterData, selectedRegistrations) -> do + (ExamUserDeregisterData, Map.keysSet -> selectedRegistrations) -> do nrDel <- runDB $ deleteWhereCount [ ExamRegistrationId <-. Set.toList selectedRegistrations ] addMessageI Success $ MsgExamUsersDeregistered nrDel redirect $ CExamR tid ssh csh examn EUsersR - (ExamUserAssignOccurrenceData occId, selectedRegistrations) -> do + (ExamUserAssignOccurrenceData occId, Map.keysSet -> selectedRegistrations) -> do nrUpdated <- runDB $ updateWhereCount [ ExamRegistrationId <-. Set.toList selectedRegistrations ] @@ -673,9 +1030,67 @@ postEUsersR tid ssh csh examn = do ] addMessageI Success $ MsgExamUsersOccurrenceUpdated nrUpdated redirect $ CExamR tid ssh csh examn EUsersR + (ExamUserAcceptComputedResultData, Map.elems -> rows) -> do + nrAccepted <- fmap (getSum . fold) . runDB . forM rows . runReaderT $ do + now <- liftIO getCurrentTime + uid <- view $ resultUser . _entityKey + hasResult <- asks $ has resultExamResult + hasBonus <- asks $ has resultExamBonus + autoResult <- preview $ resultAutomaticExamResult examVal bonus + autoBonus <- preview $ resultAutomaticExamBonus examVal bonus + lift $ if + | not hasResult + , Just examResultResult <- autoResult + -> do + if + | Just examBonusBonus <- autoBonus + , not hasBonus + -> do + insert_ ExamBonus + { examBonusExam = eId + , examBonusUser = uid + , examBonusLastChanged = now + , .. + } + audit $ TransactionExamBonusEdit eId uid + | otherwise + -> return () + + insert_ ExamResult + { examResultExam = eId + , examResultUser = uid + , examResultLastChanged = now + , .. + } + audit $ TransactionExamResultEdit eId uid + return $ Sum 1 + | otherwise + -> return mempty + addMessageI Success $ MsgExamUsersResultsAccepted nrAccepted + redirect $ CExamR tid ssh csh examn EUsersR + (ExamUserResetToComputedResultData{..}, Map.elems -> rows) -> do + nrReset <- fmap (getSum . fold) . runDB . forM rows . runReaderT $ do + uid <- view $ resultUser . _entityKey + lift $ do + when examUserResetBonus $ do + bonusId' <- getKeyBy $ UniqueExamBonus eId uid + whenIsJust bonusId' $ \bonusId -> do + delete bonusId + audit $ TransactionExamBonusDeleted eId uid + + result <- getKeyBy $ UniqueExamResult eId uid + case result of + Just resId -> do + delete resId + audit $ TransactionExamResultDeleted eId uid + return $ Sum 1 + Nothing -> return mempty + addMessageI Success $ MsgExamUsersResultsReset nrReset + redirect $ CExamR tid ssh csh examn EUsersR closeWgt <- examCloseWidget (SomeRoute $ CExamR tid ssh csh examn EUsersR) eId siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamUsersHeading) $ do setTitleI $ prependCourseTitle tid ssh csh MsgExamUsersHeading + let computedValuesTip = $(i18nWidgetFile "exam-users/computed-values-tip") $(widgetFile "exam-users") diff --git a/src/Handler/ExamOffice/Course.hs b/src/Handler/ExamOffice/Course.hs index 73ed6e0ba..2db5ecf76 100644 --- a/src/Handler/ExamOffice/Course.hs +++ b/src/Handler/ExamOffice/Course.hs @@ -16,7 +16,7 @@ import Handler.Utils examOfficeOptOutForm :: UserId -> CourseId -> Maybe (Set SchoolId) -> Form (Set SchoolId) -- ^ Deals with sets of _opt outs_ examOfficeOptOutForm uid cid (fromMaybe Set.empty -> template) = renderWForm FormStandard $ do - schools <- liftHandlerT . runDB . E.select $ courseExamOfficeSchools (E.val uid) (E.val cid) + schools <- liftHandler . runDB . E.select $ courseExamOfficeSchools (E.val uid) (E.val cid) res <- fmap sequence . forM schools $ \(Entity ssh School{..}, E.Value isForced) -> fmap (ssh, ) <$> bool wpopt wforcedJust isForced checkBoxField (fslI schoolName) (Just $ ssh `Set.notMember` template) diff --git a/src/Handler/ExamOffice/Exam.hs b/src/Handler/ExamOffice/Exam.hs index c44f50ee1..87f5bbf10 100644 --- a/src/Handler/ExamOffice/Exam.hs +++ b/src/Handler/ExamOffice/Exam.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + module Handler.ExamOffice.Exam ( getEGradesR, postEGradesR , examCloseWidget @@ -84,7 +86,7 @@ type ExamUserTableData = DBRow ( Entity ExamResult ) queryExamRegistration :: Getter ExamUserTableExpr (E.SqlExpr (Maybe (Entity ExamRegistration))) -queryExamRegistration = to $ $(E.sqlLOJproj 4 2) +queryExamRegistration = to $(E.sqlLOJproj 4 2) queryUser :: Getter ExamUserTableExpr (E.SqlExpr (Entity User)) queryUser = to $ $(E.sqlIJproj 2 2) . $(E.sqlLOJproj 4 1) @@ -213,7 +215,7 @@ postEGradesR tid ssh csh examn = do partAnchor :: Widget partAnchor = do let partId = x ^. resultUser . _entityKey - cID <- encrypt partId :: WidgetT UniWorX IO CryptoUUIDUser + cID <- encrypt partId :: WidgetFor UniWorX CryptoUUIDUser [whamlet| $newline never @@ -262,6 +264,7 @@ postEGradesR tid ssh csh examn = do E.on $ occurrence E.?. ExamOccurrenceExam E.==. E.just (E.val eid) E.&&. occurrence E.?. ExamOccurrenceId E.==. E.joinV (examRegistration E.?. ExamRegistrationOccurrence) E.on $ examRegistration E.?. ExamRegistrationUser E.==. E.just (user E.^. UserId) + E.&&. examRegistration E.?. ExamRegistrationExam E.==. E.just (E.val eid) E.on $ examResult E.^. ExamResultUser E.==. user E.^. UserId E.&&. examResult E.^. ExamResultExam E.==. E.val eid @@ -385,7 +388,7 @@ postEGradesR tid ssh csh examn = do (res, formWgt) <- multiActionM actionMap (fslI MsgAction) Nothing csrf let formRes = (, mempty) . First . Just <$> res return (formRes, formWgt) - , dbParamsFormEvaluate = liftHandlerT . runFormPost + , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormResult = id , dbParamsFormIdent = def } @@ -408,6 +411,7 @@ postEGradesR tid ssh csh examn = do (row ^. resultExamResult . _entityVal . _examResultResult . to (fmap $ bool (Left . view passingGrade) Right examShowGrades)) , dbtCsvName = unpack csvName , dbtCsvNoExportData = Nothing + , dbtCsvHeader = const . return $ Csv.headerOrder (error "headerOrder" :: ExamUserTableCsv) } dbtCsvDecode = Nothing diff --git a/src/Handler/ExamOffice/Exams.hs b/src/Handler/ExamOffice/Exams.hs index a5794e701..9fd949692 100644 --- a/src/Handler/ExamOffice/Exams.hs +++ b/src/Handler/ExamOffice/Exams.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + module Handler.ExamOffice.Exams ( getEOExamsR ) where diff --git a/src/Handler/ExamOffice/Fields.hs b/src/Handler/ExamOffice/Fields.hs index 2df3860c2..58f7bc57a 100644 --- a/src/Handler/ExamOffice/Fields.hs +++ b/src/Handler/ExamOffice/Fields.hs @@ -45,7 +45,7 @@ eofModeField = Field{..} makeExamOfficeFieldsForm :: UserId -> Maybe (Map StudyTermsId Bool) -> Form (Map StudyTermsId Bool) makeExamOfficeFieldsForm uid template = renderWForm FormStandard $ do - availableFields <- liftHandlerT . runDB . E.select . E.from $ \(terms `E.InnerJoin` schoolTerms) -> do + availableFields <- liftHandler . runDB . E.select . E.from $ \(terms `E.InnerJoin` schoolTerms) -> do E.on $ terms E.^. StudyTermsId E.==. schoolTerms E.^. SchoolTermsTerms E.where_ . E.exists . E.from $ \userFunction -> E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val uid @@ -75,7 +75,7 @@ getEOFieldsR = postEOFieldsR postEOFieldsR = do uid <- requireAuthId - oldFields <- liftHandlerT . runDB $ do + oldFields <- runDB $ do fields <- E.select . E.from $ \examOfficeField -> do E.where_ $ examOfficeField E.^. ExamOfficeFieldOffice E.==. E.val uid return $ (examOfficeField E.^. ExamOfficeFieldField, examOfficeField E.^. ExamOfficeFieldForced) @@ -84,7 +84,7 @@ postEOFieldsR = do ((fieldsRes, fieldsView), fieldsEnc) <- runFormPost . makeExamOfficeFieldsForm uid $ Just oldFields formResult fieldsRes $ \newFields -> do - liftHandlerT . runDB . forM_ (Map.keysSet newFields `Set.union` Map.keysSet oldFields) $ \fieldId -> if + runDB . forM_ (Map.keysSet newFields `Set.union` Map.keysSet oldFields) $ \fieldId -> if | Just forced <- Map.lookup fieldId newFields , fieldId `Map.member` oldFields -> do updateBy (UniqueExamOfficeField uid fieldId) [ ExamOfficeFieldForced =. forced ] diff --git a/src/Handler/ExamOffice/Users.hs b/src/Handler/ExamOffice/Users.hs index 1ff543437..123238812 100644 --- a/src/Handler/ExamOffice/Users.hs +++ b/src/Handler/ExamOffice/Users.hs @@ -67,7 +67,7 @@ examOfficeUserInvitationConfig = InvitationConfig{..} return . SomeMessage $ MsgExamOfficeUserInviteHeading userDisplayName invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamOfficeUserInviteExplanation}|] invitationTokenConfig _ _ = do - itAuthority <- liftHandlerT requireAuthId + itAuthority <- liftHandler requireAuthId let itExpiresAt = Nothing itStartsAt = Nothing itAddAuth = Nothing @@ -85,7 +85,7 @@ examOfficeUserInvitationConfig = InvitationConfig{..} makeExamOfficeUsersForm :: Maybe (Set (Either UserEmail UserId)) -> Form (Set (Either UserEmail UserId)) makeExamOfficeUsersForm template = renderWForm FormStandard $ do - Just cRoute <- getCurrentRoute + cRoute <- fromMaybe (error "makeExamOfficeUsersForm called from 404-handler") <$> getCurrentRoute let miAdd' :: (Text -> Text) @@ -105,7 +105,7 @@ makeExamOfficeUsersForm template = renderWForm FormStandard $ do miCell' :: Either UserEmail UserId -> Widget miCell' (Left email) = $(widgetFile "widgets/massinput/examOfficeUsers/cellInvitation") miCell' (Right uid) = do - User{..} <- liftHandlerT . runDB $ getJust uid + User{..} <- liftHandler . runDB $ getJust uid $(widgetFile "widgets/massinput/examOfficeUsers/cellKnown") miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) miButtonAction' frag = Just . SomeRoute $ cRoute :#: frag @@ -119,7 +119,7 @@ makeExamOfficeUsersForm template = renderWForm FormStandard $ do fRequired :: Bool fRequired = False - template' <- for template $ \uids -> liftHandlerT . runDB $ do + template' <- for template $ \uids -> liftHandler . runDB $ do let (invitations, knownUsers) = partitionEithers $ Set.toList uids knownUsers' <- fmap (map E.unValue) . E.select . E.from $ \user -> do E.where_ $ user E.^. UserId `E.in_` E.valList knownUsers @@ -137,7 +137,7 @@ getEOUsersR = postEOUsersR postEOUsersR = do uid <- requireAuthId - oldUsers <- liftHandlerT . runDB $ do + oldUsers <- liftHandler . runDB $ do users <- E.select . E.from $ \(user `E.InnerJoin` examOfficeUser) -> do E.on $ user E.^. UserId E.==. examOfficeUser E.^. ExamOfficeUserUser E.&&. examOfficeUser E.^. ExamOfficeUserOffice E.==. E.val uid @@ -148,7 +148,7 @@ postEOUsersR = do ((usersRes, usersView), usersEnc) <- runFormPost . makeExamOfficeUsersForm $ Just oldUsers formResult usersRes $ \(setSymmDiff oldUsers -> changes) -> do - liftHandlerT . runDBJobs . forM_ changes $ \change -> if + liftHandler . runDBJobs . forM_ changes $ \change -> if | change `Set.member` oldUsers -> case change of Right change' -> do deleteBy $ UniqueExamOfficeUser uid change' diff --git a/src/Handler/Health.hs b/src/Handler/Health.hs index dad7ef747..7cb8aa83b 100644 --- a/src/Handler/Health.hs +++ b/src/Handler/Health.hs @@ -27,7 +27,7 @@ getHealthR = do waitResult <- atomically $ maybe (pure $ Left False) (fmap (const $ Left True) . waitDelay) delay <|> (fmap Right . assertM (not. Set.null) $ readTVar reportStore) case waitResult of Left False -> sendResponseStatus noContent204 () - Left True -> fail "System is not generating HealthReports" + Left True -> sendResponseStatus internalServerError500 ("System is not generating HealthReports" :: Text) Right _ -> redirect HealthR Just healthReports -> do let (Max lastUpdated, Min status) = ofoldMap1 (Max *** Min . healthReportStatus) healthReports diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 4d48043f2..0382fab4a 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -58,7 +58,7 @@ homeUpcomingSheets uid = do , E.Value UTCTime , E.Value (Maybe SubmissionId) )) - (DBCell (HandlerT UniWorX IO) ()) + (DBCell Handler ()) colonnade = mconcat [ -- dbRow -- TOOD: sortable (Just "term") (textCell MsgTerm) $ \DBRow{ dbrOutput=(view _1 -> E.Value tid) } -> @@ -82,7 +82,7 @@ homeUpcomingSheets uid = do (hasTickmark True) ] let validator = def & defaultSorting [SortDescBy "done", SortAscBy "deadline"] - sheetTable <- liftHandlerT . runDB $ dbTableWidget' validator DBTable + sheetTable <- liftHandler . runDB $ dbTableWidget' validator DBTable { dbtSQLQuery = tableData , dbtRowKey = \((_ `E.InnerJoin` _ `E.InnerJoin` sheet) `E.LeftOuterJoin` _) -> sheet E.^. SheetId , dbtColonnade = colonnade @@ -127,7 +127,7 @@ homeUpcomingSheets uid = do homeUpcomingExams :: UserId -> Widget homeUpcomingExams uid = do now <- liftIO getCurrentTime - ((Any hasExams, examTable), warningDays) <- liftHandlerT . runDB $ do + ((Any hasExams, examTable), warningDays) <- liftHandler . runDB $ do User {userWarningDays} <- get404 uid let fortnight = addUTCTime userWarningDays now let -- code copied and slightly adapted from Handler.Course.getCShowR: @@ -202,7 +202,7 @@ homeUpcomingExams uid = do isRegistered <- existsBy $ UniqueExamRegistration eId uid if | mayRegister -> do - (examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered + (examRegisterForm, examRegisterEnctype) <- liftHandler . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered return $ wrapForm examRegisterForm def { formAction = Just . SomeRoute $ CExamR courseTerm courseSchool courseShorthand examName ERegisterR , formEncoding = examRegisterEnctype diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index 85c7ca08d..c9d1e2677 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -28,7 +28,7 @@ data MaterialForm = MaterialForm , mfType :: Maybe (CI Text) , mfDescription :: Maybe Html , mfVisibleFrom :: Maybe UTCTime - , mfFiles :: Maybe (Source Handler (Either FileId File)) + , mfFiles :: Maybe (ConduitT () (Either FileId File) Handler ()) } makeMaterialForm :: CourseId -> Maybe MaterialForm -> Form MaterialForm @@ -40,7 +40,7 @@ makeMaterialForm cid template = identifyForm FIDmaterial $ \html -> do | Just source <- template >>= mfFiles = runConduit $ source .| C.foldMap setIds | otherwise = return Set.empty - typeOptions :: HandlerT UniWorX IO (OptionList (CI Text)) + typeOptions :: HandlerFor UniWorX (OptionList (CI Text)) typeOptions = do let defaults = Set.fromList $ map (CI.mk . mr) [MsgMaterialTypeSlides,MsgMaterialTypeCode,MsgMaterialTypeExample] previouslyUsed <- runDB $ @@ -77,8 +77,8 @@ getMaterialKeyBy404 tid ssh csh mnm = do getKeyBy404 $ UniqueMaterial cid mnm fetchMaterial :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> DB (Entity Material) -fetchMaterial tid ssh csh mnm = do - [matEnt] <- E.select . E.from $ -- uniqueness guaranteed by DB constraints +fetchMaterial tid ssh csh mnm = + maybe notFound return . listToMaybe <=< E.select . E.from $ -- uniqueness guaranteed by DB constraints \(course `E.InnerJoin` material) -> do E.on $ course E.^. CourseId E.==. material E.^. MaterialCourse E.where_ $ course E.^. CourseTerm E.==. E.val tid @@ -86,7 +86,6 @@ fetchMaterial tid ssh csh mnm = do E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. material E.^. MaterialName E.==. E.val mnm return material - return matEnt getMaterialListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html @@ -245,7 +244,7 @@ postMEditR tid ssh csh mnm = do E.on $ matFile E.^. MaterialFileFile E.==. file E.^. FileId E.where_ $ matFile E.^. MaterialFileMaterial E.==. E.val (entityKey matEnt) return $ file E.^. FileId - return (matEnt, (Left . E.unValue) <$> fileIds) + return (matEnt, Left . E.unValue <$> fileIds) -- let cid = materialCourse let template = Just MaterialForm { mfName = materialName @@ -308,14 +307,14 @@ handleMaterialEdit tid ssh csh cid template dbMaterial = do when saveOk $ redirect -- redirect must happen outside of runDB $ CourseR tid ssh csh (MaterialR mfName MShowR) - insertMaterialFile' :: MaterialId -> Source Handler (Either FileId File) -> DB () + insertMaterialFile' :: MaterialId -> ConduitT () (Either FileId File) Handler () -> DB () insertMaterialFile' mid fs = do oldFileIdVals <- E.select . E.from $ \(file `E.InnerJoin` materialFile) -> do E.on $ materialFile E.^. MaterialFileFile E.==. file E.^. FileId E.where_ $ materialFile E.^. MaterialFileMaterial E.==. E.val mid return $ file E.^. FileId let oldFileIds = setFromList $ map E.unValue oldFileIdVals - keep <- execWriterT . runConduit $ transPipe (lift . lift) fs =$= C.mapM_ finsert + keep <- execWriterT . runConduit $ transPipe (lift . lift) fs .| C.mapM_ finsert mapM_ deleteCascade (oldFileIds \\ keep :: Set FileId) where finsert (Left fileId) = tell $ singleton fileId diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index e6999d947..13a0e9c81 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -94,7 +94,7 @@ schoolsForm template = formToAForm $ schoolsFormView =<< renderWForm FormStandar where schoolsForm' :: WForm Handler (FormResult (Set SchoolId)) schoolsForm' = do - allSchools <- liftHandlerT . runDB $ selectList [] [Asc SchoolName] + allSchools <- liftHandler . runDB $ selectList [] [Asc SchoolName] let schoolForm (Entity ssh School{schoolName}) @@ -116,7 +116,7 @@ schoolsForm template = formToAForm $ schoolsFormView =<< renderWForm FormStandar notificationForm :: Maybe NotificationSettings -> AForm Handler NotificationSettings notificationForm template = wFormToAForm $ do - mbUid <- liftHandlerT maybeAuthId + mbUid <- liftHandler maybeAuthId isAdmin <- hasReadAccessTo AdminR let @@ -144,7 +144,7 @@ notificationForm template = wFormToAForm $ do | otherwise = return False - ntHidden <- liftHandlerT . runDB + ntHidden <- liftHandler . runDB $ Set.fromList universeF & Map.fromSet sectionIsHidden & sequenceA diff --git a/src/Handler/School.hs b/src/Handler/School.hs index 1f665fb15..fa0ef7fe1 100644 --- a/src/Handler/School.hs +++ b/src/Handler/School.hs @@ -70,7 +70,7 @@ mkSchoolForm mSsh template = renderAForm FormStandard $ SchoolForm <*> areq (textField & cfStrip & cfCI) (fslI MsgSchoolName) (sfName <$> template) <*> (Set.fromList . mapMaybe (fmap CI.mk . assertM' (not . Text.null) . Text.strip . CI.original) <$> massInputListA (ciField & addDatalist ldapOrgs) (const "") (const Nothing) ("ldap-organisations" :: Text) (fslI MsgSchoolLdapOrganisations & setTooltip MsgSchoolLdapOrganisationsTip) False (Set.toList . sfOrgUnits <$> template)) where - ldapOrgs :: HandlerT UniWorX IO (OptionList (CI Text)) + ldapOrgs :: HandlerFor UniWorX (OptionList (CI Text)) ldapOrgs = fmap (mkOptionList . map (\t -> Option (CI.original t) t (CI.original t)) . Set.toAscList) . runDB $ setOf (folded . _entityVal . _schoolLdapOrgUnit) <$> selectList [] [] diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 784afcff1..7d521389f 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -2,7 +2,7 @@ module Handler.Sheet where -import Import +import Import hiding (link) import Jobs.Queue @@ -69,10 +69,7 @@ data SheetForm = SheetForm , sfActiveTo :: UTCTime , sfHintFrom :: Maybe UTCTime , sfSolutionFrom :: Maybe UTCTime - , sfSheetF :: Maybe (Source Handler (Either FileId File)) - , sfHintF :: Maybe (Source Handler (Either FileId File)) - , sfSolutionF :: Maybe (Source Handler (Either FileId File)) - , sfMarkingF :: Maybe (Source Handler (Either FileId File)) + , sfSheetF, sfHintF, sfSolutionF, sfMarkingF :: Maybe (ConduitT () (Either FileId File) Handler ()) , sfType :: SheetType , sfGrouping :: SheetGroup , sfSubmissionMode :: SubmissionMode @@ -93,7 +90,7 @@ makeSheetForm :: Maybe SheetId -> Maybe SheetForm -> Form SheetForm makeSheetForm msId template = identifyForm FIDsheet $ \html -> do oldFileIds <- (return.) <$> case msId of Nothing -> return $ partitionFileType mempty - (Just sId) -> liftHandlerT $ runDB $ getFtIdMap sId + (Just sId) -> liftHandler $ runDB $ getFtIdMap sId mr <- getMsgRenderer ctime <- ceilingQuarterHour <$> liftIO getCurrentTime (result, widget) <- flip (renderAForm FormStandard) html $ SheetForm @@ -637,20 +634,20 @@ postSDelR tid ssh csh shn = do insertSheetFile :: SheetId -> SheetFileType -> FileInfo -> YesodDB UniWorX () insertSheetFile sid ftype finfo = do - runConduit $ (sourceFiles finfo) =$= C.mapM_ finsert + runConduit $ sourceFiles finfo .| C.mapM_ finsert where finsert file = do fid <- insert file void . insert $ SheetFile sid fid ftype -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step -insertSheetFile' :: SheetId -> SheetFileType -> Source Handler (Either FileId File) -> YesodDB UniWorX () +insertSheetFile' :: SheetId -> SheetFileType -> ConduitT () (Either FileId File) Handler () -> YesodDB UniWorX () insertSheetFile' sid ftype fs = do oldFileIds <- fmap setFromList . fmap (map E.unValue) . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFile E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sid E.&&. sheetFile E.^. SheetFileType E.==. E.val ftype return (file E.^. FileId) - keep <- execWriterT . runConduit $ transPipe (lift . lift) fs =$= C.mapM_ finsert + keep <- execWriterT . runConduit $ transPipe (lift . lift) fs .| C.mapM_ finsert mapM_ deleteCascade $ (oldFileIds \\ keep :: Set FileId) where finsert (Left fileId) = tell $ singleton fileId @@ -689,13 +686,13 @@ defaultLoads shid = do return (sheetCorrector E.^. SheetCorrectorUser, sheetCorrector E.^. SheetCorrectorLoad, sheetCorrector E.^. SheetCorrectorState) where toMap :: [(E.Value UserId, E.Value Load, E.Value CorrectorState)] -> Loads - toMap = foldMap $ \(E.Value uid, E.Value load, E.Value state) -> Map.singleton (Right uid) (state, load) + toMap = foldMap $ \(E.Value uid, E.Value cLoad, E.Value cState) -> Map.singleton (Right uid) (cState, cLoad) correctorForm :: SheetId -> AForm Handler (Set (Either (Invitation' SheetCorrector) SheetCorrector)) correctorForm shid = wFormToAForm $ do - Just currentRoute <- liftHandlerT getCurrentRoute - userId <- liftHandlerT requireAuthId + currentRoute <- fromMaybe (error "correctorForm called from 404-handler") <$> liftHandler getCurrentRoute + userId <- liftHandler requireAuthId MsgRenderer mr <- getMsgRenderer let @@ -703,9 +700,9 @@ correctorForm shid = wFormToAForm $ do currentLoads = Map.union <$> fmap (foldMap $ \(Entity _ SheetCorrector{..}) -> Map.singleton (Right sheetCorrectorUser) (sheetCorrectorState, sheetCorrectorLoad)) (selectList [ SheetCorrectorSheet ==. shid ] []) <*> fmap (fmap ((,) <$> invDBSheetCorrectorState <*> invDBSheetCorrectorLoad) . Map.mapKeysMonotonic Left) (sourceInvitationsF shid) - (defaultLoads', currentLoads') <- liftHandlerT . runDB $ (,) <$> defaultLoads shid <*> currentLoads + (defaultLoads', currentLoads') <- liftHandler . runDB $ (,) <$> defaultLoads shid <*> currentLoads - isWrite <- liftHandlerT $ isWriteRequest currentRoute + isWrite <- liftHandler $ isWriteRequest currentRoute let applyDefaultLoads = Map.null currentLoads' && not isWrite @@ -766,7 +763,7 @@ correctorForm shid = wFormToAForm $ do identWidget <- case userIdent of Left email -> return . toWidget $ mailtoHtml email Right uid -> do - User{userEmail, userDisplayName, userSurname} <- liftHandlerT . runDB $ getJust uid + User{userEmail, userDisplayName, userSurname} <- liftHandler . runDB $ getJust uid return $ nameEmailWidget userEmail userDisplayName userSurname return (res, $(widgetFile "sheetCorrectors/cell")) @@ -812,7 +809,7 @@ correctorForm shid = wFormToAForm $ do postProcess' :: (Either UserEmail UserId, (CorrectorState, Load)) -> Either (Invitation' SheetCorrector) SheetCorrector postProcess' (Right sheetCorrectorUser, (sheetCorrectorState, sheetCorrectorLoad)) = Right SheetCorrector{..} - postProcess' (Left email, (state, load)) = Left (email, shid, (InvDBDataSheetCorrector load state, InvTokenDataSheetCorrector)) + postProcess' (Left email, (cState, load)) = Left (email, shid, (InvDBDataSheetCorrector load cState, InvTokenDataSheetCorrector)) filledData :: Maybe (Map ListPosition (Either UserEmail UserId, (CorrectorState, Load))) filledData = Just . Map.fromList . zip [0..] $ Map.toList loads -- TODO orderBy Name?! @@ -894,18 +891,22 @@ correctorInvitationConfig = InvitationConfig{..} Course{..} <- get404 sheetCourse return $ CSheetR courseTerm courseSchool courseShorthand sheetName SCorrInviteR invitationResolveFor _ = do - Just (CSheetR tid csh ssh shn SCorrInviteR) <- getCurrentRoute - fetchSheetId tid csh ssh shn + cRoute <- getCurrentRoute + case cRoute of + Just (CSheetR tid csh ssh shn SCorrInviteR) -> + fetchSheetId tid csh ssh shn + _other -> + error "correctorInvitationConfig called from unsupported route" invitationSubject (Entity _ Sheet{..}) _ = do Course{..} <- get404 sheetCourse return . SomeMessage $ MsgMailSubjectCorrectorInvitation courseTerm courseSchool courseShorthand sheetName invitationHeading (Entity _ Sheet{..}) _ = return . SomeMessage $ MsgSheetCorrInviteHeading sheetName invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgSheetCorrInviteExplanation}|] invitationTokenConfig _ _ = do - itAuthority <- liftHandlerT requireAuthId + itAuthority <- liftHandler requireAuthId return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing invitationRestriction _ _ = return Authorized - invitationForm _ (InvDBDataSheetCorrector load state, _) _ = pure $ (JunctionSheetCorrector load state, ()) + invitationForm _ (InvDBDataSheetCorrector cLoad cState, _) _ = pure $ (JunctionSheetCorrector cLoad cState, ()) invitationInsertHook _ _ _ _ = id invitationSuccessMsg (Entity _ Sheet{..}) _ = return . SomeMessage $ MsgCorrectorInvitationAccepted sheetName invitationUltDest (Entity _ Sheet{..}) _ = do diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 03fdbe079..d3482dc22 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -89,9 +89,13 @@ submissionUserInvitationConfig = InvitationConfig{..} cID <- encrypt subId return $ CSubmissionR courseTerm courseSchool courseShorthand sheetName cID SInviteR invitationResolveFor _ = do - Just (CSubmissionR _tid _ssh _csh _shn cID SInviteR) <- getCurrentRoute - subId <- decrypt cID - bool notFound (return subId) =<< existsKey subId + cRoute <- getCurrentRoute + case cRoute of + Just (CSubmissionR _tid _ssh _csh _shn cID SInviteR) -> do + subId <- decrypt cID + bool notFound (return subId) =<< existsKey subId + _other -> + error "submissionUserInvitationConfig called from unsupported route" invitationSubject (Entity _ Submission{..}) _ = do Sheet{..} <- getJust submissionSheet Course{..} <- getJust sheetCourse @@ -103,7 +107,7 @@ submissionUserInvitationConfig = InvitationConfig{..} invitationTokenConfig (Entity _ Submission{..}) _ = do Sheet{..} <- getJust submissionSheet Course{..} <- getJust sheetCourse - itAuthority <- liftHandlerT requireAuthId + itAuthority <- liftHandler requireAuthId itAddAuth <- either throwM (return . Just) $ routeAuthTags (CSheetR courseTerm courseSchool courseShorthand sheetName SubmissionNewR) let itExpiresAt = Nothing itStartsAt = Nothing @@ -121,7 +125,7 @@ submissionUserInvitationConfig = InvitationConfig{..} return . SomeRoute $ CSubmissionR courseTerm courseSchool courseShorthand sheetName cID SubShowR -makeSubmissionForm :: CourseId -> Maybe SubmissionId -> UploadMode -> SheetGroup -> Bool -> Set (Either UserEmail UserId) -> Form (Maybe (Source Handler File), Set (Either UserEmail UserId)) +makeSubmissionForm :: CourseId -> Maybe SubmissionId -> UploadMode -> SheetGroup -> Bool -> Set (Either UserEmail UserId) -> Form (Maybe (ConduitT () File Handler ()), Set (Either UserEmail UserId)) makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = identifyForm FIDsubmission . renderAForm FormStandard $ (,) <$> fileUploadForm (not isLecturer && is _Nothing msmid) (fslI . bool MsgSubmissionFile MsgSubmissionArchive) uploadMode <*> wFormToAForm submittorsForm @@ -129,7 +133,7 @@ makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = ident miCell' :: Markup -> Either UserEmail UserId -> Widget miCell' csrf (Left email) = $(widgetFile "widgets/massinput/submissionUsers/cellInvitation") miCell' csrf (Right uid) = do - User{..} <- liftHandlerT . runDB $ getJust uid + User{..} <- liftHandler . runDB $ getJust uid $(widgetFile "widgets/massinput/submissionUsers/cellKnown") miLayout :: ListLength @@ -191,7 +195,7 @@ makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = ident | null submittors' -> FormFailure [mr MsgSubmissionUsersEmpty] | otherwise -> FormSuccess $ Set.fromList submittors' | otherwise = do - uid <- liftHandlerT requireAuthId + uid <- liftHandler requireAuthId mRoute <- getCurrentRoute let @@ -275,7 +279,7 @@ submissionHelper :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Maybe submissionHelper tid ssh csh shn mcid = do uid <- requireAuthId msmid <- traverse decrypt mcid - Just actionUrl <- getCurrentRoute + actionUrl <- fromMaybe (error "submissionHelper called from 404-handler") <$> getCurrentRoute (Entity shid Sheet{..}, buddies, lastEdits, maySubmit, isLecturer, isOwner) <- runDB $ do csheet@(Entity shid Sheet{..}) <- fetchSheet tid ssh csh shn @@ -478,7 +482,7 @@ submissionHelper tid ssh csh shn mcid = do Nothing -> return () -- Maybe construct a table to display uploaded archive files - let colonnadeFiles :: _ -> Colonnade Sortable _ (DBCell (HandlerT UniWorX IO) ()) + let colonnadeFiles :: _ -> Colonnade Sortable _ (DBCell (HandlerFor UniWorX) ()) colonnadeFiles cid = mconcat [ sortable (Just "path") (i18nCell MsgFileTitle) $ \(coalesce -> (mOrig, mCorr)) -> let Just fileTitle' = fileTitle . entityVal . snd <$> (mOrig <|> mCorr) diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs index 5198338bc..c6a3c2214 100644 --- a/src/Handler/SystemMessage.hs +++ b/src/Handler/SystemMessage.hs @@ -179,7 +179,7 @@ postMessageListR = do { dbrOutput = (smE, smT) , .. } - psValidator = def :: PSValidator (MForm (HandlerT UniWorX IO)) (FormResult (Last ActionSystemMessageData, DBFormResult CryptoUUIDSystemMessage Bool MessageListData)) + psValidator = def :: PSValidator (MForm Handler) (FormResult (Last ActionSystemMessageData, DBFormResult CryptoUUIDSystemMessage Bool MessageListData)) (tableRes', tableView) <- runDB $ dbTable psValidator DBTable { dbtSQLQuery , dbtRowKey = (E.^. SystemMessageId) @@ -216,7 +216,7 @@ postMessageListR = do ] (actionRes, action) <- multiActionM actions "" (Just SMActivate) mempty return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action) - , dbParamsFormEvaluate = liftHandlerT . runFormPost + , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormResult = id , dbParamsFormIdent = def } @@ -225,8 +225,8 @@ postMessageListR = do , dbtCsvDecode = Nothing } - let tableRes = tableRes' & mapped._2 %~ Map.keysSet . Map.filter id . getDBFormResult (const False) - & mapped._1 %~ fromMaybe (error "By construction the form should always return an action") . getLast + let tableRes = tableRes' <&> _2 %~ Map.keysSet . Map.filter id . getDBFormResult (const False) + <&> _1 %~ fromMaybe (error "By construction the form should always return an action") . getLast case tableRes of FormMissing -> return () diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index 85b81efb9..26c349c83 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -176,7 +176,7 @@ postTermEditExistR tid = do termEditHandler :: TermFormTemplate -> Handler Html termEditHandler term = do - Just eHandler <- getCurrentRoute + eHandler <- fromMaybe (error "termEditHandler called from 404-handler") <$> getCurrentRoute ((result, formWidget), formEnctype) <- runFormPost $ newTermForm term case result of (FormSuccess res) -> do diff --git a/src/Handler/Tutorial.hs b/src/Handler/Tutorial.hs index 0aa65b045..94a00e645 100644 --- a/src/Handler/Tutorial.hs +++ b/src/Handler/Tutorial.hs @@ -14,6 +14,7 @@ import Handler.Utils.Invitations import Jobs.Queue import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH import Data.Map ((!)) @@ -198,7 +199,7 @@ postTCommR tid ssh csh tutn = do ) ] , crRecipientAuth = Just $ \uid -> do - [E.Value isTutorialUser] <- E.select . return . E.exists . E.from $ \tutorialUser -> + isTutorialUser <- E.selectExists . E.from $ \tutorialUser -> E.where_ $ tutorialUser E.^. TutorialParticipantUser E.==. E.val uid E.&&. tutorialUser E.^. TutorialParticipantTutorial E.==. E.val tutid @@ -250,15 +251,19 @@ tutorInvitationConfig = InvitationConfig{..} Course{..} <- get404 tutorialCourse return $ CTutorialR courseTerm courseSchool courseShorthand tutorialName TInviteR invitationResolveFor _ = do - Just (CTutorialR tid csh ssh tutn TInviteR) <- getCurrentRoute - fetchTutorialId tid csh ssh tutn + cRoute <- getCurrentRoute + case cRoute of + Just (CTutorialR tid csh ssh tutn TInviteR) -> + fetchTutorialId tid csh ssh tutn + _other -> + error "tutorInvitationConfig called from unsupported route" invitationSubject (Entity _ Tutorial{..}) _ = do Course{..} <- get404 tutorialCourse return . SomeMessage $ MsgMailSubjectTutorInvitation courseTerm courseSchool courseShorthand tutorialName invitationHeading (Entity _ Tutorial{..}) _ = return . SomeMessage $ MsgTutorInviteHeading tutorialName invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgTutorInviteExplanation}|] invitationTokenConfig _ _ = do - itAuthority <- liftHandlerT requireAuthId + itAuthority <- liftHandler requireAuthId return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing invitationRestriction _ _ = return Authorized invitationForm _ _ _ = pure (JunctionTutor, ()) @@ -289,8 +294,8 @@ data TutorialForm = TutorialForm tutorialForm :: CourseId -> Maybe TutorialForm -> Form TutorialForm tutorialForm cid template html = do MsgRenderer mr <- getMsgRenderer - Just cRoute <- getCurrentRoute - uid <- liftHandlerT requireAuthId + cRoute <- fromMaybe (error "tutorialForm called from 404-Handler") <$> getCurrentRoute + uid <- liftHandler requireAuthId let tutorForm = Set.fromList <$> massInputAccumA miAdd' miCell' (\p -> Just . SomeRoute $ cRoute :#: p) miLayout' ("tutors" :: Text) (fslI MsgTutorialTutors & setTooltip MsgMassInputTip) True (Set.toList . tfTutors <$> template) @@ -314,7 +319,7 @@ tutorialForm cid template html = do miCell' (Left email) = $(widgetFile "tutorial/tutorMassInput/cellInvitation") miCell' (Right userId) = do - User{..} <- liftHandlerT . runDB $ get404 userId + User{..} <- liftHandler . runDB $ get404 userId $(widgetFile "tutorial/tutorMassInput/cellKnown") miLayout' :: MassInputLayout ListLength (Either UserEmail UserId) () @@ -338,7 +343,7 @@ tutorialForm cid template html = do ) (tfDeregisterUntil <$> template) <*> tutorForm where - tutTypeDatalist :: HandlerT UniWorX IO (OptionList (CI Text)) + tutTypeDatalist :: HandlerFor UniWorX (OptionList (CI Text)) tutTypeDatalist = fmap (mkOptionList . map (\t -> Option (CI.original t) t (CI.original t)) . Set.toAscList) . runDB $ fmap (setOf $ folded . _Value) . E.select . E.from $ \tutorial -> do E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 55f9260da..af6339dbc 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -74,7 +74,7 @@ postUsersR = do , sortable (Just "ldap-sync") (i18nCell MsgLdapSynced) $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastLdapSynchronisation , flip foldMap universeF $ \function -> sortable Nothing (i18nCell function) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do - schools <- liftHandlerT . runDB . E.select . E.from $ \(school `E.InnerJoin` userFunction) -> do + schools <- liftHandler . runDB . E.select . E.from $ \(school `E.InnerJoin` userFunction) -> do E.on $ school E.^. SchoolId E.==. userFunction E.^. UserFunctionSchool E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val uid E.&&. userFunction E.^. UserFunctionFunction E.==. E.val function @@ -92,7 +92,7 @@ postUsersR = do , formCellContents = do cID <- encrypt uid mayHijack <- (== Authorized) <$> evalAccess (AdminHijackUserR cID) True - myUid <- liftHandlerT maybeAuthId + myUid <- liftHandler maybeAuthId if | mayHijack , Just uid /= myUid @@ -191,7 +191,7 @@ postUsersR = do = renderAForm FormStandard $ (, mempty) . First . Just <$> areq (selectField $ optionsF [UserLdapSync]) (fslI MsgAction) Nothing - , dbParamsFormEvaluate = liftHandlerT . runFormPost + , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormResult = id , dbParamsFormIdent = def } @@ -309,7 +309,7 @@ postAdminUserR uuid = do campusHandler _ = mzero campusResult <- runMaybeT . handle campusHandler $ do (Just pool, Just conf) <- getsYesod $ (,) <$> view _appLdapPool <*> view _appLdapConf - void . Auth.campusUser conf pool $ Creds Auth.apLdap (CI.original userIdent) [] + void . lift . Auth.campusUser conf pool $ Creds Auth.apLdap (CI.original userIdent) [] case campusResult of Nothing -> addMessageI Error MsgAuthLDAPInvalidLookup _other @@ -475,7 +475,7 @@ postUserPasswordR cID = do formResultModal passResult (bool ProfileR (UserPasswordR cID) isAdmin) $ \newPass -> do newHash <- fmap decodeUtf8 . liftIO $ PWStore.makePasswordWith pwHashAlgorithm newPass pwHashStrength - liftHandlerT . runDB $ update tUid [ UserAuthentication =. AuthPWHash newHash ] + liftHandler . runDB $ update tUid [ UserAuthentication =. AuthPWHash newHash ] tell . pure =<< messageI Success MsgPasswordChangedSuccess siteLayout [whamlet|_{MsgUserPasswordHeadingFor} ^{nameEmailWidget userEmail userDisplayName userSurname}|] $ @@ -545,7 +545,7 @@ functionInvitationConfig = InvitationConfig{..} MsgRenderer mr <- getMsgRenderer return [ihamlet|_{SomeMessage $ MsgSchoolFunctionInviteExplanation (mr $ SomeMessage invTokenUserFunctionFunction)}|] invitationTokenConfig _ (InvDBDataUserFunction{..}, _) = do - itAuthority <- liftHandlerT requireAuthId + itAuthority <- liftHandler requireAuthId let itExpiresAt = Just $ Just invDBUserFunctionDeadline itAddAuth = Nothing itStartsAt = Nothing diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 18a94bb9f..40eaadcba 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -2,7 +2,7 @@ module Handler.Utils ( module Handler.Utils ) where -import Import +import Import hiding (link) import qualified Data.Text.Encoding as T import Data.Map ((!)) @@ -38,7 +38,7 @@ sendThisFile File{..} | otherwise = sendResponseStatus noContent204 () -- | Serve a single file, identified through a given DB query -serveOneFile :: Source (YesodDB UniWorX) File -> Handler TypedContent +serveOneFile :: ConduitT () File (YesodDB UniWorX) () -> Handler TypedContent serveOneFile source = do results <- runDB . runConduit $ source .| Conduit.take 2 -- We don't need more than two files to make a decision below case results of @@ -51,7 +51,7 @@ serveOneFile source = do -- | Serve one file directly or a zip-archive of files, identified through a given DB query -- -- Like `serveOneFile`, but sends a zip-archive if multiple results are returned -serveSomeFiles :: FilePath -> Source (YesodDB UniWorX) File -> Handler TypedContent +serveSomeFiles :: FilePath -> ConduitT () File (YesodDB UniWorX) () -> Handler TypedContent serveSomeFiles archiveName source = do results <- runDB . runConduit $ source .| peekN 2 @@ -69,7 +69,7 @@ serveSomeFiles archiveName source = do -- | Serve any number of files as a zip-archive of files, identified through a given DB query -- -- Like `serveSomeFiles`, but always sends a zip-archive, even if a single file is returned -serveZipArchive :: FilePath -> Source (YesodDB UniWorX) File -> Handler TypedContent +serveZipArchive :: FilePath -> ConduitT () File (YesodDB UniWorX) () -> Handler TypedContent serveZipArchive archiveName source = do results <- runDB . runConduit $ source .| peekN 2 @@ -122,7 +122,7 @@ warnTermDays tid timeNames = do -- | return a value only if the current user ist authorized for a given route -guardAuthorizedFor :: ( HandlerSite h ~ UniWorX, MonadHandler h, MonadLogger h +guardAuthorizedFor :: ( HandlerSite h ~ UniWorX, MonadHandler h, MonadThrow h , MonadTrans m, MonadPlus (m (ReaderT SqlBackend h))) => Route UniWorX -> a -> m (ReaderT SqlBackend h) a guardAuthorizedFor link val = @@ -138,7 +138,7 @@ runAppLoggingT app@(appLogger -> (_, loggerTVar)) = flip runLoggingT logFunc studyFeaturesWidget :: StudyFeaturesId -> Widget studyFeaturesWidget featId = do - (StudyFeatures{studyFeaturesSemester}, (degree, terms)) <- liftHandlerT . runDB . ($ featId) . runKleisli $ Kleisli getJust >>> Kleisli return &&& Kleisli (getJust . studyFeaturesDegree) &&& Kleisli (getJust . studyFeaturesField) + (StudyFeatures{studyFeaturesSemester}, (degree, terms)) <- liftHandler . runDB . ($ featId) . runKleisli $ Kleisli getJust >>> Kleisli return &&& Kleisli (getJust . studyFeaturesDegree) &&& Kleisli (getJust . studyFeaturesField) [whamlet| $newline never _{StudyDegreeTerm degree terms}, _{MsgStudyFeatureAge} #{studyFeaturesSemester} diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index 2e2ef88c8..da9ed5a2e 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -71,7 +71,7 @@ instance RenderMessage UniWorX RecipientCategory where data CommunicationRoute = CommunicationRoute { crRecipients :: Map RecipientGroup (E.SqlQuery (E.SqlExpr (Entity User))) , crRecipientAuth :: Maybe (UserId -> DB AuthResult) -- ^ Only resolve userids given as GET-Parameter if they fulfil this criterion - , crJobs :: Communication -> Source (YesodDB UniWorX) Job + , crJobs :: Communication -> ConduitT () Job (YesodDB UniWorX) () , crHeading :: SomeMessage UniWorX , crUltDest :: SomeRoute UniWorX } @@ -150,9 +150,9 @@ commR CommunicationRoute{..} = do -> Map (EnumPosition RecipientCategory, ListPosition) (FieldView UniWorX) -> Map (Natural, (EnumPosition RecipientCategory, ListPosition)) Widget -> Widget - miLayout liveliness state cellWdgts _delButtons addWdgts = do + miLayout liveliness cState cellWdgts _delButtons addWdgts = do checkedIdentBase <- newIdent - let checkedCategories = Set.mapMonotonic (unEnumPosition . fst) . Set.filter (\k' -> Map.foldrWithKey (\k (_, checkState) -> (||) $ k == k' && checkState /= FormSuccess False && (checkState /= FormMissing || maybe True snd (chosenRecipients' !? k))) False state) $ Map.keysSet state + let checkedCategories = Set.mapMonotonic (unEnumPosition . fst) . Set.filter (\k' -> Map.foldrWithKey (\k (_, checkState) -> (||) $ k == k' && checkState /= FormSuccess False && (checkState /= FormMissing || maybe True snd (chosenRecipients' !? k))) False cState) $ Map.keysSet cState checkedIdent c = checkedIdentBase <> "-" <> toPathPiece c hasContent c = not (null $ categoryIndices c) || Map.member (1, (EnumPosition c, 0)) addWdgts categoryIndices c = Set.filter ((== c) . unEnumPosition . fst) $ review liveCoords liveliness @@ -165,12 +165,15 @@ commR CommunicationRoute{..} = do postProcess :: Map (EnumPosition RecipientCategory, ListPosition) (Either UserEmail UserId, Bool) -> Set (Either UserEmail UserId) postProcess = Set.fromList . map fst . filter snd . Map.elems + recipientsListMsg <- messageI Info MsgCommRecipientsList + ((commRes,commWdgt),commEncoding) <- runFormPost . identifyForm FIDCommunication . renderAForm FormStandard $ Communication <$> recipientAForm + <* aformMessage recipientsListMsg <*> aopt textField (fslI MsgCommSubject) Nothing - <*> areq htmlField (fslpI MsgCommBody "Html") Nothing + <*> areq htmlField (fslpI MsgCommBody "Html" & setTooltip MsgCommBodyTip) Nothing formResult commRes $ \comm -> do - runDBJobs . runConduit $ hoist (mapReaderT lift) (crJobs comm) .| sinkDBJobs + runDBJobs . runConduit $ transPipe (mapReaderT lift) (crJobs comm) .| sinkDBJobs addMessageI Success . MsgCommSuccess . Set.size $ cRecipients comm redirect crUltDest @@ -183,4 +186,3 @@ commR CommunicationRoute{..} = do siteLayoutMsg crHeading $ do setTitleI crHeading formWdgt - $(i18nWidgetFile "html-input") diff --git a/src/Handler/Utils/ContentDisposition.hs b/src/Handler/Utils/ContentDisposition.hs index b353d1bb3..3fa5d579a 100644 --- a/src/Handler/Utils/ContentDisposition.hs +++ b/src/Handler/Utils/ContentDisposition.hs @@ -8,7 +8,7 @@ import Import -- | Check whether the user's preference for files is inline-viewing or downloading downloadFiles :: (MonadHandler m, HandlerSite m ~ UniWorX) => m Bool downloadFiles = do - mauth <- liftHandlerT maybeAuth + mauth <- liftHandler maybeAuth case mauth of Just (Entity _ User{..}) -> return userDownloadFiles Nothing -> do diff --git a/src/Handler/Utils/Csv.hs b/src/Handler/Utils/Csv.hs index 0ebbb4cdb..ff84ddfb9 100644 --- a/src/Handler/Utils/Csv.hs +++ b/src/Handler/Utils/Csv.hs @@ -1,17 +1,16 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Handler.Utils.Csv - ( typeCsv, extensionCsv - , decodeCsv + ( decodeCsv , encodeCsv + , encodeDefaultOrderedCsv , respondCsv, respondCsvDB + , respondDefaultOrderedCsv, respondDefaultOrderedCsvDB , fileSourceCsv , CsvParseError(..) , ToNamedRecord(..), FromNamedRecord(..) , DefaultOrdered(..) , ToField(..), FromField(..) - , CsvRendered(..) - , toCsvRendered ) where import Import hiding (Header, mapM_) @@ -37,19 +36,7 @@ import qualified Data.ByteString.Lazy as LBS import qualified Data.Attoparsec.ByteString.Lazy as A -deriving instance Typeable CsvParseError -instance Exception CsvParseError - - -typeCsv, typeCsv' :: ContentType -typeCsv = simpleContentType typeCsv' -typeCsv' = "text/csv; charset=UTF-8; header=present" - -extensionCsv :: Extension -extensionCsv = fromMaybe "csv" $ listToMaybe [ ext | (ext, mime) <- Map.toList mimeMap, mime == typeCsv ] - - -decodeCsv :: (MonadThrow m, FromNamedRecord csv, MonadLogger m) => Conduit ByteString m csv +decodeCsv :: (MonadThrow m, FromNamedRecord csv, MonadLogger m) => ConduitT ByteString csv m () decodeCsv = transPipe throwExceptT $ do testBuffer <- accumTestBuffer LBS.empty mapM_ leftover $ LBS.toChunks testBuffer @@ -111,47 +98,67 @@ decodeCsv = transPipe throwExceptT $ do encodeCsv :: ( ToNamedRecord csv - , DefaultOrdered csv , Monad m ) - => Conduit csv m ByteString + => Header + -> ConduitT csv ByteString m () -- ^ Encode a stream of records -- -- Currently not streaming -encodeCsv = fmap encodeDefaultOrderedByName (C.foldMap pure) >>= C.sourceLazy +encodeCsv hdr = fmap (encodeByName hdr) (C.foldMap pure) >>= C.sourceLazy + +encodeDefaultOrderedCsv :: forall csv m. + ( ToNamedRecord csv + , DefaultOrdered csv + , Monad m + ) + => ConduitT csv ByteString m () +encodeDefaultOrderedCsv = encodeCsv $ headerOrder (error "headerOrder" :: csv) -respondCsv :: ( ToNamedRecord csv - , DefaultOrdered csv - ) - => Source (HandlerT site IO) csv - -> HandlerT site IO TypedContent -respondCsv src = respondSource typeCsv' $ src .| encodeCsv .| awaitForever sendChunk +respondCsv :: ToNamedRecord csv + => Header + -> ConduitT () csv (HandlerFor site) () + -> HandlerFor site TypedContent +respondCsv hdr src = respondSource typeCsv' $ src .| encodeCsv hdr .| awaitForever sendChunk + +respondDefaultOrderedCsv :: forall csv site. + ( ToNamedRecord csv + , DefaultOrdered csv + ) + => ConduitT () csv (HandlerFor site) () + -> HandlerFor site TypedContent +respondDefaultOrderedCsv = respondCsv $ headerOrder (error "headerOrder" :: csv) respondCsvDB :: ( ToNamedRecord csv - , DefaultOrdered csv , YesodPersistRunner site ) - => Source (YesodDB site) csv - -> HandlerT site IO TypedContent -respondCsvDB src = respondSourceDB typeCsv' $ src .| encodeCsv .| awaitForever sendChunk + => Header + -> ConduitT () csv (YesodDB site) () + -> HandlerFor site TypedContent +respondCsvDB hdr src = respondSourceDB typeCsv' $ src .| encodeCsv hdr .| awaitForever sendChunk + +respondDefaultOrderedCsvDB :: forall csv site. + ( ToNamedRecord csv + , DefaultOrdered csv + , YesodPersistRunner site + ) + => ConduitT () csv (YesodDB site) () + -> HandlerFor site TypedContent +respondDefaultOrderedCsvDB = respondCsvDB $ headerOrder (error "headerOrder" :: csv) fileSourceCsv :: ( FromNamedRecord csv , MonadResource m , MonadLogger m + , MonadThrow m ) => FileInfo - -> Source m csv + -> ConduitT () csv m () fileSourceCsv = (.| decodeCsv) . fileSource -data CsvRendered = CsvRendered - { csvRenderedHeader :: Header - , csvRenderedData :: [NamedRecord] - } deriving (Eq, Read, Show, Generic, Typeable) - instance ToWidget UniWorX CsvRendered where - toWidget CsvRendered{..} = liftWidgetT $(widgetFile "widgets/csvRendered") + toWidget CsvRendered{..} = liftWidget $(widgetFile "widgets/csvRendered") where csvData = [ [ decodeUtf8 <$> HashMap.lookup columnKey row | columnKey <- Vector.toList csvRenderedHeader @@ -160,14 +167,3 @@ instance ToWidget UniWorX CsvRendered where ] headers = decodeUtf8 <$> Vector.toList csvRenderedHeader - -toCsvRendered :: forall mono. - ( ToNamedRecord (Element mono) - , DefaultOrdered (Element mono) - , MonoFoldable mono - ) - => mono -> CsvRendered -toCsvRendered (otoList -> csvs) = CsvRendered{..} - where - csvRenderedHeader = headerOrder (error "not forced" :: Element mono) - csvRenderedData = map toNamedRecord csvs diff --git a/src/Handler/Utils/Database.hs b/src/Handler/Utils/Database.hs index 83b299a94..b6f82ced0 100644 --- a/src/Handler/Utils/Database.hs +++ b/src/Handler/Utils/Database.hs @@ -34,10 +34,10 @@ getSchoolsOf uid uschool uuser = fmap (Import.map E.unValue) $ E.select $ E.from -- | Sub-Query to retrieve StudyFeatures with their human-readable names -studyFeaturesQuery :: E.Esqueleto query expr backend - => expr (E.Value StudyFeaturesId) -- ^ query is joined on this @StudyFeaturesId@ - -> expr (Entity StudyFeatures) `E.InnerJoin` expr (Entity StudyDegree) `E.InnerJoin` expr (Entity StudyTerms) - -> query (expr (Entity StudyFeatures), expr (Entity StudyDegree), expr (Entity StudyTerms)) +studyFeaturesQuery + :: E.SqlExpr (E.Value StudyFeaturesId) -- ^ query is joined on this @StudyFeaturesId@ + -> E.SqlExpr (Entity StudyFeatures) `E.InnerJoin` E.SqlExpr (Entity StudyDegree) `E.InnerJoin` E.SqlExpr (Entity StudyTerms) + -> E.SqlQuery (E.SqlExpr (Entity StudyFeatures), E.SqlExpr (Entity StudyDegree), E.SqlExpr (Entity StudyTerms)) studyFeaturesQuery studyFeaturesId (features `E.InnerJoin` degree `E.InnerJoin` terms) = do E.on $ terms E.^. StudyTermsId E.==. features E.^. StudyFeaturesField E.on $ degree E.^. StudyDegreeId E.==. features E.^. StudyFeaturesDegree diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index 159ad7779..cf337d3d1 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/src/Handler/Utils/DateTime.hs @@ -75,7 +75,7 @@ instance HasLocalTime UTCTime where instance HasLocalTime TimeOfDay where toLocalTime = LocalTime systemEpochDay -formatTime' :: (HasLocalTime t, MonadHandler m, HandlerSite m ~ UniWorX) => String -> t -> m Text +formatTime' :: (HasLocalTime t, MonadHandler m) => String -> t -> m Text formatTime' fmtStr t = fmap fromString $ Time.formatTime <$> getTimeLocale <*> pure fmtStr <*> pure (toLocalTime t) -- formatTime :: (FormatTime t, MonadHandler m, HandlerSite m ~ UniWorX, IsString str) => (DateTimeFormat -> String) -> t -> m str @@ -92,12 +92,12 @@ formatTimeW s t = toWidget =<< formatTime s t formatTimeMail :: (MonadMail m, HasLocalTime t) => SelDateTimeFormat -> t -> m Text formatTimeMail sel t = fmap fromString $ Time.formatTime <$> (getTimeLocale' . mailLanguages <$> askMailLanguages) <*> (unDateTimeFormat <$> askMailDateTimeFormat sel) <*> pure (toLocalTime t) -getTimeLocale :: (MonadHandler m, HandlerSite m ~ UniWorX) => m TimeLocale +getTimeLocale :: MonadHandler m => m TimeLocale getTimeLocale = getTimeLocale' <$> languages getDateTimeFormat :: (MonadHandler m, HandlerSite m ~ UniWorX) => SelDateTimeFormat -> m DateTimeFormat getDateTimeFormat sel = do - mauth <- liftHandlerT maybeAuth + mauth <- liftHandler maybeAuth UserDefaultConf{..} <- getsYesod $ view _appUserDefaults let fmt diff --git a/src/Handler/Utils/Delete.hs b/src/Handler/Utils/Delete.hs index 65c312fe0..6c5e6a0f2 100644 --- a/src/Handler/Utils/Delete.hs +++ b/src/Handler/Utils/Delete.hs @@ -29,12 +29,12 @@ import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect) import qualified Database.Esqueleto.Internal.Language as E (From) -data DeleteRoute record = forall tables infoExpr info. (E.SqlSelect infoExpr info, E.From E.SqlQuery E.SqlExpr SqlBackend tables) => DeleteRoute +data DeleteRoute record = forall tables infoExpr info. (E.SqlSelect infoExpr info, E.From tables) => DeleteRoute { drRecords :: Set (Key record) -- ^ Records to be deleted , drGetInfo :: tables -> E.SqlQuery infoExpr -- ^ SQL-Query to get necessary information to render identifing information about records to the user (`drRenderRecord`, `drRecordConfirmString`); @tables@ is an arbitrary join, see `E.from`; @infoExpr@ gets converted to @info@ by esqueleto , drUnjoin :: tables -> E.SqlExpr (Entity record) -- ^ `E.SqlExpr` of @Key record@ extracted from @tables@, `deleteR` restricts `drGetInfo` to `drRecords` automatically - , drRenderRecord :: info -> ReaderT SqlBackend (HandlerT UniWorX IO) Widget -- ^ Present a single record, to be deleted, to the user for inspection prior to deletion - , drRecordConfirmString :: info -> ReaderT SqlBackend (HandlerT UniWorX IO) Text -- ^ Text for the user to copy to confirm deletion; should probably contain all information from `drRenderRecord` so user gets prompted to think about what they're deleting + , drRenderRecord :: info -> DB Widget -- ^ Present a single record, to be deleted, to the user for inspection prior to deletion + , drRecordConfirmString :: info -> DB Text -- ^ Text for the user to copy to confirm deletion; should probably contain all information from `drRenderRecord` so user gets prompted to think about what they're deleting , drCaption , drSuccessMessage :: SomeMessage UniWorX , drAbort @@ -98,7 +98,7 @@ getDeleteR DeleteRoute{..} = do (deleteFormWdgt, deleteFormEnctype) <- generateFormPost $ confirmForm' drRecords confirmString - Just targetRoute <- getCurrentRoute + targetRoute <- fromMaybe (error "getDeleteR called from 404-handler") <$> getCurrentRoute let deleteForm = wrapForm deleteFormWdgt def { formAction = Just $ SomeRoute targetRoute , formEncoding = deleteFormEnctype diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs index 5cdd6fd29..ec5d7f5d2 100644 --- a/src/Handler/Utils/Exam.hs +++ b/src/Handler/Utils/Exam.hs @@ -2,6 +2,7 @@ module Handler.Utils.Exam ( fetchExamAux , fetchExam, fetchExamId, fetchCourseIdExamId, fetchCourseIdExam , examBonus, examBonusPossible, examBonusAchieved + , examResultBonus, examGrade ) where import Import.NoFoundation @@ -16,6 +17,8 @@ import qualified Data.Conduit.List as C import qualified Data.Map as Map +import Data.Fixed (Fixed(..)) + fetchExamAux :: ( SqlBackendCanRead backend , E.SqlSelect b a @@ -75,9 +78,86 @@ examBonus (Entity eId Exam{..}) = runConduit $ ) return (examRegistration E.^. ExamRegistrationUser, sheet E.^. SheetType, submission) accum = C.fold ?? Map.empty $ \acc (E.Value uid, E.Value sheetType, fmap entityVal -> sub) -> - Map.unionWith mappend acc . Map.singleton uid . sheetTypeSum sheetType . (>>= submissionRatingPoints) $ assertM submissionRatingDone sub + flip (Map.insertWith mappend uid) acc . sheetTypeSum sheetType $ assertM submissionRatingDone sub >>= submissionRatingPoints in rawData .| accum -examBonusPossible, examBonusAchieved :: UserId -> Map UserId SheetTypeSummary -> Maybe SheetGradeSummary -examBonusPossible uid bonusMap = normalSummary <$> Map.lookup uid bonusMap -examBonusAchieved uid bonusMap = (mappend <$> normalSummary <*> bonusSummary) <$> Map.lookup uid bonusMap +examBonusPossible, examBonusAchieved :: UserId -> Map UserId SheetTypeSummary -> SheetGradeSummary +examBonusPossible uid bonusMap = normalSummary $ Map.findWithDefault mempty uid bonusMap +examBonusAchieved uid bonusMap = mappend <$> normalSummary <*> bonusSummary $ Map.findWithDefault mempty uid bonusMap + + +examResultBonus :: ExamBonusRule + -> SheetGradeSummary -- ^ `examBonusPossible` + -> SheetGradeSummary -- ^ `examBonusAchieved` + -> Points +examResultBonus bonusRule bonusPossible bonusAchieved = case bonusRule of + ExamBonusManual{} + -> 0 + ExamBonusPoints{..} + -> roundToPoints bonusRound $ toRational bonusMaxPoints * bonusProp + where + bonusProp :: Rational + bonusProp + | possible <= 0 = 1 + | otherwise = achieved / possible + where + achieved = toRational (getSum $ achievedPoints bonusAchieved) + scalePasses (getSum $ achievedPasses bonusAchieved) + possible = toRational (getSum $ sumSheetsPoints bonusPossible) + scalePasses (getSum $ numSheetsPasses bonusPossible) + + scalePasses :: Integer -> Rational + -- ^ Rescale passes so count of all sheets with pass is worth as many points as sum of all sheets with points + scalePasses passes + | passesPossible <= 0 = 0 + | otherwise = fromInteger passes / fromInteger passesPossible * toRational pointsPossible + where + passesPossible = getSum $ numSheetsPasses bonusPossible + pointsPossible = getSum $ sumSheetsPoints bonusPossible + + roundToPoints :: forall a. HasResolution a => Fixed a -> Rational -> Fixed a + -- ^ 'round-to-nearest' whole multiple + roundToPoints (MkFixed mult'@(fromInteger -> mult)) ((* toRational (resolution (Proxy @a))) -> raw) + = MkFixed . (* mult') $ + let (whole, frac) = raw `divMod'` mult + in if | abs frac < abs (mult / 2) + -> whole + | raw >= 0 + -> succ whole + | otherwise + -> pred whole + +examGrade :: ( MonoFoldable mono + , Element mono ~ ExamResultPoints + ) + => Exam + -> Maybe Points -- ^ Bonus + -> mono -- ^ `ExamPartResult`s + -> Maybe ExamResultGrade +examGrade Exam{..} mBonus (otoList -> results) + = traverse pointsToGrade achievedPoints' + where + achievedPoints' :: ExamResultPoints + achievedPoints' = withBonus . getSum <$> foldMap (fmap Sum) results + + withBonus :: Points -> Points + withBonus ps + | Just bonusRule <- examBonusRule + = if + | maybe True not (bonusRule ^? _bonusOnlyPassed) + || fmap (view passingGrade) (pointsToGrade ps) == Just (_Wrapped # True) + -> maybe id (+) mBonus ps + | otherwise + -> ps + | otherwise + = ps + + pointsToGrade :: Points -> Maybe ExamGrade + pointsToGrade ps = examGradingRule <&> \case + ExamGradingKey{..} + -> gradeFromKey examGradingKey + where + gradeFromKey :: [Points] -> ExamGrade + gradeFromKey examGradingKey' = maximum $ Grade50 `ncons` [ g | (g, b) <- lowerBounds, b <= ps ] + where + lowerBounds :: [(ExamGrade, Points)] + lowerBounds = zip [Grade40, Grade37 ..] examGradingKey' + diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 20d04f535..2f8af499c 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -214,7 +214,7 @@ optionalActionW' minp justAct fs defAction = aFormToWForm $ optionalActionA' min multiAction :: forall action a. - ( RenderMessage UniWorX action, PathPiece action, Ord action, Eq action ) + ( RenderMessage UniWorX action, PathPiece action, Ord action ) => Map action (AForm Handler a) -> FieldSettings UniWorX -> Maybe action @@ -235,22 +235,22 @@ multiAction acts fs@FieldSettings{..} defAction csrf = do return ((actionResults Map.!) =<< actionRes, over _fvInput (mappend $ toWidget csrf) actionView : actionViews) -multiActionA :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action) - => Map action (AForm (HandlerT UniWorX IO) a) +multiActionA :: (RenderMessage UniWorX action, PathPiece action, Ord action) + => Map action (AForm Handler a) -> FieldSettings UniWorX -> Maybe action -> AForm Handler a multiActionA acts fSettings defAction = formToAForm $ multiAction acts fSettings defAction mempty -multiActionW :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action) +multiActionW :: (RenderMessage UniWorX action, PathPiece action, Ord action) => Map action (AForm Handler a) -> FieldSettings UniWorX -> Maybe action -> WForm Handler (FormResult a) multiActionW acts fSettings defAction = aFormToWForm $ multiActionA acts fSettings defAction -multiActionM :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action) - => Map action (AForm (HandlerT UniWorX IO) a) +multiActionM :: (RenderMessage UniWorX action, PathPiece action, Ord action) + => Map action (AForm Handler a) -> FieldSettings UniWorX -> Maybe action -> (Html -> MForm Handler (FormResult a, Widget)) @@ -279,7 +279,7 @@ routeField :: ( Monad m routeField = checkMMap (return . maybe (Left MsgInvalidRoute) Right . fromPathPiece) toPathPiece textField -- | Variant that simply removes leading and trailing white space -htmlField' :: Field (HandlerT UniWorX IO) Html +htmlField' :: Field Handler Html htmlField' = htmlField { fieldParse = \vs fis -> fieldParse htmlField (map Text.strip vs) fis } @@ -444,9 +444,11 @@ uploadModeForm prev = multiActionA actions (fslI MsgSheetUploadMode) (classifyUp specificFileForm :: AForm Handler (NonNull (Set UploadSpecificFile)) specificFileForm = wFormToAForm $ do - Just currentRoute <- getCurrentRoute + currentRoute' <- getCurrentRoute let miButtonAction :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) - miButtonAction frag = Just . SomeRoute $ currentRoute :#: frag + miButtonAction frag = do + currentRoute <- currentRoute' + return . SomeRoute $ currentRoute :#: frag miIdent <- ("specific-files--" <>) <$> newIdent postProcess =<< massInputW MassInput{..} (fslI MsgUploadSpecificFiles & setTooltip MsgMassInputTip) True (preProcess <$> prev ^? _Just . _specificFiles) where @@ -518,7 +520,7 @@ submissionModeForm prev = multiActionA actions (fslI MsgSheetSubmissionMode) $ c ) ] -data ExamBonusRule' = ExamNoBonus' +data ExamBonusRule' = ExamBonusManual' | ExamBonusPoints' deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) instance Universe ExamBonusRule' @@ -529,7 +531,7 @@ embedRenderMessage ''UniWorX ''ExamBonusRule' id classifyBonusRule :: ExamBonusRule -> ExamBonusRule' classifyBonusRule = \case - ExamNoBonus -> ExamNoBonus' + ExamBonusManual{} -> ExamBonusManual' ExamBonusPoints{} -> ExamBonusPoints' examBonusRuleForm :: Maybe ExamBonusRule -> AForm Handler ExamBonusRule @@ -537,18 +539,19 @@ examBonusRuleForm prev = multiActionA actions (fslI MsgExamBonusRule) $ classify where actions :: Map ExamBonusRule' (AForm Handler ExamBonusRule) actions = Map.fromList - [ ( ExamNoBonus' - , pure ExamNoBonus + [ ( ExamBonusManual' + , ExamBonusManual + <$> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamBonusOnlyPassed) (Just <$> preview _bonusOnlyPassed =<< prev)) ) , ( ExamBonusPoints' , ExamBonusPoints - <$> apreq (checkBool (> 0) MsgExamBonusMaxPointsNonPositive pointsField) (fslI MsgExamBonusMaxPoints) (preview _bonusMaxPoints =<< prev) + <$> apreq (checkBool (> 0) MsgExamBonusMaxPointsNonPositive pointsField) (fslI MsgExamBonusMaxPoints & setTooltip MsgExamBonusMaxPointsTip) (preview _bonusMaxPoints =<< prev) <*> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamBonusOnlyPassed) (Just <$> preview _bonusOnlyPassed =<< prev)) + <*> areq (checkBool (> 0) MsgExamBonusRoundNonPositive pointsField) (fslI MsgExamBonusRound & setTooltip MsgExamBonusRoundTip) (preview _bonusRound =<< prev) ) ] -data ExamOccurrenceRule' = ExamRoomManual' - | ExamRoomSurname' +data ExamOccurrenceRule' = ExamRoomSurname' | ExamRoomMatriculation' | ExamRoomRandom' deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) @@ -560,7 +563,6 @@ embedRenderMessage ''UniWorX ''ExamOccurrenceRule' id classifyExamOccurrenceRule :: ExamOccurrenceRule -> ExamOccurrenceRule' classifyExamOccurrenceRule = \case - ExamRoomManual -> ExamRoomManual' ExamRoomSurname -> ExamRoomSurname' ExamRoomMatriculation -> ExamRoomMatriculation' ExamRoomRandom -> ExamRoomRandom' @@ -569,13 +571,11 @@ examOccurrenceRuleForm :: Maybe ExamOccurrenceRule -> AForm Handler ExamOccurren examOccurrenceRuleForm = fmap reverseClassify . areq (selectField optionsFinite) (fslI MsgExamOccurrenceRule) . fmap classifyExamOccurrenceRule where reverseClassify = \case - ExamRoomManual' -> ExamRoomManual ExamRoomSurname' -> ExamRoomSurname ExamRoomMatriculation' -> ExamRoomMatriculation ExamRoomRandom' -> ExamRoomRandom -data ExamGradingRule' = ExamGradingManual' - | ExamGradingKey' +data ExamGradingRule' = ExamGradingKey' deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) instance Universe ExamGradingRule' instance Finite ExamGradingRule' @@ -585,7 +585,6 @@ embedRenderMessage ''UniWorX ''ExamGradingRule' id classifyExamGradingRule :: ExamGradingRule -> ExamGradingRule' classifyExamGradingRule = \case - ExamGradingManual -> ExamGradingManual' ExamGradingKey{} -> ExamGradingKey' examGradingRuleForm :: Maybe ExamGradingRule -> AForm Handler ExamGradingRule @@ -593,10 +592,7 @@ examGradingRuleForm prev = multiActionA actions (fslI MsgExamGradingRule) $ clas where actions :: Map ExamGradingRule' (AForm Handler ExamGradingRule) actions = Map.fromList - [ ( ExamGradingManual' - , pure ExamGradingManual - ) - , ( ExamGradingKey' + [ ( ExamGradingKey' , ExamGradingKey <$> gradingKeyForm (fslI MsgExamGradingKey & setTooltip MsgExamGradingKeyTip) (preview _examGradingKey =<< prev) ) ] @@ -659,7 +655,7 @@ pseudonymWordField = checkMMap doCheck id $ ciField & addDatalist (return $ mkOp | otherwise = return . Left $ MsgUnknownPseudonymWord (CI.original w) -specificFileField :: UploadSpecificFile -> Field Handler (Source Handler File) +specificFileField :: UploadSpecificFile -> Field Handler (ConduitT () File Handler ()) specificFileField UploadSpecificFile{..} = Field{..} where fieldEnctype = Multipart @@ -677,7 +673,7 @@ specificFileField UploadSpecificFile{..} = Field{..} zipFileField :: Bool -- ^ Unpack zips? -> Maybe (NonNull (Set Extension)) -- ^ Restrictions on file extensions - -> Field Handler (Source Handler File) + -> Field Handler (ConduitT () File Handler ()) zipFileField doUnpack permittedExtensions = Field{..} where fieldEnctype = Multipart @@ -696,7 +692,7 @@ zipFileField doUnpack permittedExtensions = Field{..} fileUploadForm :: Bool -- ^ Required? -> (Bool -> FieldSettings UniWorX) -- ^ given @unpackZips@ generate `FieldSettings` in the case of `UploadAny` - -> UploadMode -> AForm Handler (Maybe (Source Handler File)) + -> UploadMode -> AForm Handler (Maybe (ConduitT () File Handler ())) fileUploadForm isReq mkFs = \case NoUpload -> pure Nothing @@ -705,21 +701,21 @@ fileUploadForm isReq mkFs = \case UploadSpecific{..} -> mergeFileSources <$> sequenceA (map specificFileForm . Set.toList $ toNullable specificFiles) where - specificFileForm :: UploadSpecificFile -> AForm Handler (Maybe (Source Handler File)) + specificFileForm :: UploadSpecificFile -> AForm Handler (Maybe (ConduitT () File Handler ())) specificFileForm spec@UploadSpecificFile{..} = bool (\f fs d -> aopt f fs $ fmap Just d) (\f fs d -> Just <$> areq f fs d) specificFileRequired (specificFileField spec) (fsl specificFileLabel) Nothing - mergeFileSources :: [Maybe (Source Handler File)] -> Maybe (Source Handler File) + mergeFileSources :: [Maybe (ConduitT () File Handler ())] -> Maybe (ConduitT () File Handler ()) mergeFileSources (catMaybes -> sources) = case sources of [] -> Nothing fs -> Just $ sequence_ fs -multiFileField' :: Source Handler (Either FileId File) -- ^ Permitted files in same format as produced by `multiFileField` - -> Field Handler (Source Handler (Either FileId File)) +multiFileField' :: ConduitT () (Either FileId File) Handler () -- ^ Permitted files in same format as produced by `multiFileField` + -> Field Handler (ConduitT () (Either FileId File) Handler ()) multiFileField' permittedFiles = multiFileField . runConduit $ permittedFiles .| C.mapMaybe (preview _Left) .| C.foldMap Set.singleton multiFileField :: Handler (Set FileId) -- ^ Set of files that may be submitted by id-reference - -> Field Handler (Source Handler (Either FileId File)) + -> Field Handler (ConduitT () (Either FileId File) Handler ()) multiFileField permittedFiles' = Field{..} where fieldEnctype = Multipart @@ -735,7 +731,7 @@ multiFileField permittedFiles' = Field{..} .| C.filter (`elem` pVals) .| C.map Left let - handleFile :: FileInfo -> Source Handler File + handleFile :: FileInfo -> ConduitT () File Handler () handleFile | doUnpack = sourceFiles | otherwise = yieldM . acceptFile @@ -899,7 +895,7 @@ utcTimeField = checkMMap (return . localTimeToUTC') utcToLocalTime localTimeFiel langField :: Bool -- ^ Only allow values from `appLanguages` - -> Field (HandlerT UniWorX IO) Lang + -> Field Handler Lang langField False = checkBool langCheck MsgInvalidLangFormat $ textField & addDatalist appLanguagesOpts where langCheck (T.splitOn "-" -> lParts) = all ((&&) <$> not . null <*> T.all Char.isAlpha) lParts @@ -922,7 +918,7 @@ jsonField hide = Field{..} fieldParse [encodeUtf8 -> v] [] = return . bimap (SomeMessage . MsgJSONFieldDecodeFailure) Just $ eitherDecodeStrict' v <|> eitherDecodeStrict' (urlDecode True v) fieldParse [] [] = return $ Right Nothing fieldParse _ _ = return . Left $ SomeMessage MsgValueRequired - fieldView theId name attrs val isReq = liftWidgetT [whamlet| + fieldView theId name attrs val isReq = liftWidget [whamlet| |] fieldEnctype = UrlEncoded @@ -1019,7 +1015,7 @@ fsUniq mkUnique seed = "" { fsName = Just $ mkUnique seed } optionsPersistCryptoId :: forall site backend a msg. ( YesodPersist site , PersistQueryRead backend - , HasCryptoUUID (Key a) (HandlerT site IO) + , HasCryptoUUID (Key a) (HandlerFor site) , RenderMessage site msg , YesodPersistBackend site ~ backend , PersistRecordBackend a backend @@ -1027,7 +1023,7 @@ optionsPersistCryptoId :: forall site backend a msg. => [Filter a] -> [SelectOpt a] -> (a -> msg) - -> HandlerT site IO (OptionList (Entity a)) + -> HandlerFor site (OptionList (Entity a)) optionsPersistCryptoId filts ords toDisplay = fmap mkOptionList $ do mr <- getMessageRender pairs <- runDB $ selectList filts ords @@ -1044,7 +1040,7 @@ examOccurrenceField :: ( MonadHandler m => ExamId -> Field m ExamOccurrenceId examOccurrenceField eid - = hoistField liftHandlerT . selectField . (fmap $ fmap entityKey) + = hoistField liftHandler . selectField . (fmap $ fmap entityKey) $ optionsPersistCryptoId [ ExamOccurrenceExam ==. eid ] [ Asc ExamOccurrenceName ] examOccurrenceName @@ -1080,7 +1076,7 @@ userMatriculationField = Field{..} fieldParse ts _ = runExceptT . fmap Just $ do let ts' = concatMap (Text.splitOn ",") ts forM ts' $ \matr -> do - dbRes <- liftHandlerT . runDB . E.select . E.from $ \user -> do + dbRes <- liftHandler . runDB . E.select . E.from $ \user -> do E.where_ $ E.strip (user E.^. UserMatrikelnummer) `E.ciEq` E.just (E.val $ Text.strip matr) return user case dbRes of @@ -1114,7 +1110,7 @@ multiUserField onlySuggested suggestions = Field{..} rEmails <- case lookupExpr of Nothing -> return [] Just lookupExpr' -> fmap concat . forM uids $ \uid -> do - dbRes <- liftHandlerT . runDB . E.select $ do + dbRes <- liftHandler . runDB . E.select $ do user <- lookupExpr' E.where_ $ user E.^. UserId E.==. E.val uid return $ user E.^. UserEmail @@ -1131,7 +1127,7 @@ multiUserField onlySuggested suggestions = Field{..} |] whenIsJust suggestions $ \suggestions' -> do - suggestedEmails <- fmap (Set.fromList . map E.unValue) . liftHandlerT . runDB . E.select $ do + suggestedEmails <- fmap (Set.fromList . map E.unValue) . liftHandler . runDB . E.select $ do user <- suggestions' return $ user E.^. UserEmail [whamlet| @@ -1147,14 +1143,14 @@ multiUserField onlySuggested suggestions = Field{..} fmap Set.fromList . forM emails $ \(CI.mk -> email) -> case lookupExpr of Nothing -> return $ Left email Just lookupExpr' -> do - dbRes <- liftHandlerT . runDB . E.select $ do + dbRes <- liftHandler . runDB . E.select $ do user <- lookupExpr' E.where_ $ user E.^. UserEmail E.==. E.val email return $ user E.^. UserId case dbRes of [] -> return $ Left email [E.Value uid] -> return $ Right uid - _other -> fail "Ambiguous e-mail addr" + _other -> throwE $ SomeMessage ("Ambiguous e-mail addr" :: Text) examResultField :: forall m res. ( MonadHandler m @@ -1195,11 +1191,11 @@ examGradeField :: forall m. , HandlerSite m ~ UniWorX ) => Field m ExamGrade -examGradeField = hoistField liftHandlerT $ selectField optionsFinite +examGradeField = hoistField liftHandler $ selectField optionsFinite examPassedField :: forall m. ( MonadHandler m , HandlerSite m ~ UniWorX ) => Field m ExamPassed -examPassedField = hoistField liftHandlerT $ selectField optionsFinite +examPassedField = hoistField liftHandler $ selectField optionsFinite diff --git a/src/Handler/Utils/Form/MassInput.hs b/src/Handler/Utils/Form/MassInput.hs index 87dcc7a85..a0ba3dfb4 100644 --- a/src/Handler/Utils/Form/MassInput.hs +++ b/src/Handler/Utils/Form/MassInput.hs @@ -1,5 +1,5 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- tupleBoxCoord -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, UndecidableInstances #-} module Handler.Utils.Form.MassInput ( MassInput(..), MassInputLayout @@ -271,7 +271,7 @@ massInput :: forall handler cellData cellResult liveliness. ( MonadHandler handler, HandlerSite handler ~ UniWorX , ToJSON cellData, FromJSON cellData , Liveliness liveliness - , MonadLogger handler + , MonadThrow handler ) => MassInput handler liveliness cellData cellResult -> FieldSettings UniWorX @@ -414,7 +414,7 @@ massInput MassInput{ miIdent = toPathPiece -> miIdent, ..} FieldSettings{..} fvR MsgRenderer mr <- getMsgRenderer - whenM ((== Just miIdent) <$> lookupCustomHeader HeaderMassInputShortcircuit) . liftHandlerT $ do + whenM ((== Just miIdent) <$> lookupCustomHeader HeaderMassInputShortcircuit) . liftHandler $ do PageContent{..} <- widgetToPageContent $(widgetFile "widgets/massinput/massinput-standalone") ur <- getUrlRenderParams @@ -459,7 +459,7 @@ listMiLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/mas -- | Wrapper around `massInput` for the common case, that we just want an arbitrary list of single fields without any constraints massInputList :: forall handler cellResult ident. ( MonadHandler handler, HandlerSite handler ~ UniWorX - , MonadLogger handler + , MonadThrow handler , PathPiece ident ) => Field handler cellResult @@ -488,7 +488,7 @@ massInputList field fieldSettings miButtonAction miIdent miSettings miRequired m massInputListA :: forall handler cellResult ident. ( MonadHandler handler, HandlerSite handler ~ UniWorX - , MonadLogger handler + , MonadThrow handler , PathPiece ident ) => Field handler cellResult @@ -505,7 +505,7 @@ massInputListA field fieldSettings miButtonAction miIdent miSettings miRequired -- | Wrapper around `massInput` for the common case, that we just want a list of data with no option to modify it except deletion and addition massInputAccum :: forall handler cellData ident. ( MonadHandler handler, HandlerSite handler ~ UniWorX - , MonadLogger handler + , MonadThrow handler , ToJSON cellData, FromJSON cellData , PathPiece ident ) @@ -544,7 +544,7 @@ massInputAccum miAdd' miCell' miButtonAction miLayout miIdent fSettings fRequire massInputAccumA :: forall handler cellData ident. ( MonadHandler handler, HandlerSite handler ~ UniWorX - , MonadLogger handler + , MonadThrow handler , ToJSON cellData, FromJSON cellData , PathPiece ident ) @@ -562,7 +562,7 @@ massInputAccumA miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fReq massInputAccumW :: forall handler cellData ident. ( MonadHandler handler, HandlerSite handler ~ UniWorX - , MonadLogger handler + , MonadThrow handler , ToJSON cellData, FromJSON cellData , PathPiece ident ) @@ -582,7 +582,7 @@ massInputAccumW miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fReq -- | Wrapper around `massInput` for the common case, that we just want a list of data with existing data modified the same way as new data is added massInputAccumEdit :: forall handler cellData ident. ( MonadHandler handler, HandlerSite handler ~ UniWorX - , MonadLogger handler + , MonadThrow handler , ToJSON cellData, FromJSON cellData , PathPiece ident ) @@ -621,7 +621,7 @@ massInputAccumEdit miAdd' miCell' miButtonAction miLayout miIdent fSettings fReq massInputAccumEditA :: forall handler cellData ident. ( MonadHandler handler, HandlerSite handler ~ UniWorX - , MonadLogger handler + , MonadThrow handler , ToJSON cellData, FromJSON cellData , PathPiece ident ) @@ -639,7 +639,7 @@ massInputAccumEditA miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings massInputAccumEditW :: forall handler cellData ident. ( MonadHandler handler, HandlerSite handler ~ UniWorX - , MonadLogger handler + , MonadThrow handler , ToJSON cellData, FromJSON cellData , PathPiece ident ) @@ -660,7 +660,7 @@ massInputA :: forall handler cellData cellResult liveliness. ( MonadHandler handler, HandlerSite handler ~ UniWorX , ToJSON cellData, FromJSON cellData , Liveliness liveliness - , MonadLogger handler + , MonadThrow handler ) => MassInput handler liveliness cellData cellResult -> FieldSettings UniWorX @@ -674,7 +674,7 @@ massInputW :: forall handler cellData cellResult liveliness. ( MonadHandler handler, HandlerSite handler ~ UniWorX , ToJSON cellData, FromJSON cellData , Liveliness liveliness - , MonadLogger handler + , MonadThrow handler ) => MassInput handler liveliness cellData cellResult -> FieldSettings UniWorX diff --git a/src/Handler/Utils/Form/Occurrences.hs b/src/Handler/Utils/Form/Occurrences.hs index ced9c3c0b..1486ff192 100644 --- a/src/Handler/Utils/Form/Occurrences.hs +++ b/src/Handler/Utils/Form/Occurrences.hs @@ -31,9 +31,10 @@ nullaryPathPiece ''OccurrenceExceptionKind $ camelToPathPiece' 2 embedRenderMessage ''UniWorX ''OccurrenceExceptionKind id +{-# ANN occurrencesAForm ("HLint: ignore Use const" :: String) #-} occurrencesAForm :: PathPiece ident => ident -> Maybe Occurrences -> AForm Handler Occurrences occurrencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do - Just cRoute <- getCurrentRoute + cRoute <- fromMaybe (error "occurrencesAForm called from 404-handler") <$> getCurrentRoute let scheduled :: AForm Handler (Set OccurrenceSchedule) diff --git a/src/Handler/Utils/Invitations.hs b/src/Handler/Utils/Invitations.hs index b1618fc99..c7ea02cb3 100644 --- a/src/Handler/Utils/Invitations.hs +++ b/src/Handler/Utils/Invitations.hs @@ -1,5 +1,6 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE AllowAmbiguousTypes #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} module Handler.Utils.Invitations ( -- * Procedure @@ -38,7 +39,7 @@ import qualified Data.Aeson as JSON import Data.Proxy (Proxy(..)) import Data.Typeable -import Database.Persist.Sql (SqlBackendCanWrite, SqlBackendCanRead) +import Database.Persist.Sql (SqlBackendCanWrite) class ( PersistRecordBackend junction (YesodPersistBackend UniWorX) @@ -169,11 +170,13 @@ instance IsInvitableJunction junction => FromJSON (InvitationTokenRestriction ju sinkInvitations :: forall junction m backend. ( IsInvitableJunction junction - , MonadHandler m, SqlBackendCanWrite backend + , MonadHandler m + , PersistRecordBackend Invitation backend, SqlBackendCanWrite backend + , HasPersistBackend backend , HandlerSite m ~ UniWorX ) => InvitationConfig junction - -> Sink (Invitation' junction) (ReaderT backend (WriterT (Set QueuedJobId) m)) () + -> ConduitT (Invitation' junction) Void (ReaderT backend (WriterT (Set QueuedJobId) m)) () -- | Register invitations in the database and send them by email -- -- When an invitation for a certain junction (i.e. an `UserEmail`, `Key @@ -181,9 +184,10 @@ sinkInvitations :: forall junction m backend. -- (because the token-data may have changed) sinkInvitations InvitationConfig{..} = determineExists .| sinkInvitations' where - determineExists :: Conduit (Invitation' junction) - (ReaderT backend (WriterT (Set QueuedJobId) m)) - (Invitation' junction) + determineExists :: ConduitT (Invitation' junction) + (Invitation' junction) + (ReaderT backend (WriterT (Set QueuedJobId) m)) + () determineExists | is _Just (ephemeralInvitation @junction) = C.map id @@ -203,10 +207,10 @@ sinkInvitations InvitationConfig{..} = determineExists .| sinkInvitations' decode invData = case fromJSON invData of JSON.Success dbData -> return dbData - JSON.Error str -> fail $ "Could not decode invitationData: " <> str + JSON.Error str -> throwM . PersistMarshalError . pack $ "Could not decode invitationData: " <> str - sinkInvitations' :: Sink (Invitation' junction) (ReaderT backend (WriterT (Set QueuedJobId) m)) () - sinkInvitations' = transPipe (hoist (hoist liftHandlerT) . withReaderT persistBackend) $ do + sinkInvitations' :: ConduitT (Invitation' junction) Void (ReaderT backend (WriterT (Set QueuedJobId) m)) () + sinkInvitations' = transPipe (hoist (hoist liftHandler) . withReaderT persistBackend) $ do C.mapM_ $ \(jInvitee, fid, dat) -> do app <- getYesod let mr = renderMessage app $ NonEmpty.toList appLanguages @@ -214,15 +218,15 @@ sinkInvitations InvitationConfig{..} = determineExists .| sinkInvitations' fEnt <- Entity fid <$> get404 fid - jInviter <- liftHandlerT requireAuthId - route <- mapReaderT liftHandlerT $ invitationRoute fEnt dat - InvitationTokenConfig{..} <- mapReaderT liftHandlerT $ invitationTokenConfig fEnt dat + jInviter <- liftHandler requireAuthId + route <- mapReaderT liftHandler $ invitationRoute fEnt dat + InvitationTokenConfig{..} <- mapReaderT liftHandler $ invitationTokenConfig fEnt dat protoToken <- bearerToken itAuthority (Just . HashSet.singleton $ urlRoute route) itAddAuth itExpiresAt itStartsAt let token = protoToken & tokenRestrict (urlRoute route) (InvitationTokenRestriction jInvitee $ dat ^. _invitationTokenData) jwt <- encodeToken token jInvitationUrl <- toTextUrl (route, [(toPathPiece GetBearer, toPathPiece jwt)]) - jInvitationSubject <- fmap mr . mapReaderT liftHandlerT $ invitationSubject fEnt dat - jInvitationExplanation <- (\ihtml -> ihtml (toHtml . mr) ur) <$> mapReaderT liftHandlerT (invitationExplanation fEnt dat) + jInvitationSubject <- fmap mr . mapReaderT liftHandler $ invitationSubject fEnt dat + jInvitationExplanation <- (\ihtml -> ihtml (toHtml . mr) ur) <$> mapReaderT liftHandler (invitationExplanation fEnt dat) when (is _Nothing (ephemeralInvitation @junction)) $ insert_ $ Invitation { invitationEmail = jInvitee @@ -237,7 +241,10 @@ sinkInvitationsF :: forall junction mono m backend. ( IsInvitableJunction junction , MonoFoldable mono , Element mono ~ Invitation' junction - , MonadHandler m, SqlBackendCanWrite backend + , MonadHandler m + , MonadThrow m + , PersistRecordBackend Invitation backend, SqlBackendCanWrite backend + , HasPersistBackend backend , HandlerSite m ~ UniWorX ) => InvitationConfig junction @@ -248,7 +255,10 @@ sinkInvitationsF cfg invs = runConduit $ mapM_ yield invs .| sinkInvitations cfg sinkInvitation :: forall junction m backend. ( IsInvitableJunction junction - , MonadHandler m, SqlBackendCanWrite backend + , MonadHandler m + , MonadThrow m + , PersistRecordBackend Invitation backend, SqlBackendCanWrite backend + , HasPersistBackend backend , HandlerSite m ~ UniWorX ) => InvitationConfig junction @@ -260,23 +270,29 @@ sinkInvitation cfg = sinkInvitationsF cfg . Identity sourceInvitations :: forall junction m backend. ( IsInvitableJunction junction - , MonadResource m, SqlBackendCanRead backend + , MonadResource m + , MonadThrow m + , PersistRecordBackend Invitation backend + , HasPersistBackend backend ) => Key (InvitationFor junction) - -> Source (ReaderT backend m) (UserEmail, InvitationDBData junction) + -> ConduitT () (UserEmail, InvitationDBData junction) (ReaderT backend m) () sourceInvitations forKey = selectSource [InvitationFor ==. invRef @junction forKey] [] .| C.mapM decode where decode (Entity _ (Invitation{invitationEmail, invitationData})) = case fromJSON invitationData of JSON.Success dbData -> return (invitationEmail, dbData) - JSON.Error str -> fail $ "Could not decode invitationData: " <> str + JSON.Error str -> throwM . PersistMarshalError . pack $ "Could not decode invitationData: " <> str sourceInvitationsF :: forall junction map m backend. ( IsInvitableJunction junction , IsMap map , ContainerKey map ~ UserEmail , MapValue map ~ InvitationDBData junction - , MonadResource m, SqlBackendCanRead backend + , MonadResource m + , MonadThrow m + , PersistRecordBackend Invitation backend + , HasPersistBackend backend ) => Key (InvitationFor junction) -> ReaderT backend m map @@ -291,15 +307,17 @@ sourceInvitationsF forKey = runConduit $ sourceInvitations forKey .| C.foldMap ( -- > runConduit $ yield userEmail .| deleteInvitations @SubmissionUser submissionId deleteInvitations :: forall junction m backend. ( IsInvitableJunction junction - , MonadIO m, SqlBackendCanWrite backend + , MonadIO m + , PersistRecordBackend Invitation backend, SqlBackendCanWrite backend ) => Key (InvitationFor junction) - -> Sink UserEmail (ReaderT backend m) () + -> ConduitT UserEmail Void (ReaderT backend m) () deleteInvitations k = C.foldMap Set.singleton >>= lift . deleteInvitationsF @junction k deleteInvitationsF :: forall junction m mono backend. ( IsInvitableJunction junction - , MonadIO m, SqlBackendCanWrite backend + , MonadIO m + , PersistRecordBackend Invitation backend, SqlBackendCanWrite backend , MonoFoldable mono , Element mono ~ UserEmail ) @@ -312,7 +330,8 @@ deleteInvitationsF invitationFor (otoList -> emailList) deleteInvitation :: forall junction m backend. ( IsInvitableJunction junction - , MonadIO m, SqlBackendCanWrite backend + , MonadIO m + , PersistRecordBackend Invitation backend, SqlBackendCanWrite backend ) => Key (InvitationFor junction) -> UserEmail @@ -344,10 +363,10 @@ invitationR' :: forall junction m. => InvitationConfig junction -> m Html -- | Generic handler for incoming invitations -invitationR' InvitationConfig{..} = liftHandlerT $ do +invitationR' InvitationConfig{..} = liftHandler $ do InvitationTokenRestriction{..} <- maybeM (invalidArgsI [MsgInvitationMissingRestrictions]) return requireCurrentTokenRestrictions :: Handler (InvitationTokenRestriction junction) invitee <- requireAuthId - Just cRoute <- getCurrentRoute + cRoute <- fromMaybe (error "invitationR' called from 404-handler") <$> getCurrentRoute (tRoute, (dataWidget, dataEnctype), heading, explanation) <- runDB $ do fEnt@(Entity fid _) <- invitationResolveFor itData >>= (\k -> Entity k <$> get404 k) @@ -356,7 +375,7 @@ invitationR' InvitationConfig{..} = liftHandlerT $ do Invitation{..} <- entityVal <$> getBy404 (UniqueInvitation itEmail $ invRef @junction fid) case fromJSON invitationData of JSON.Success dbData -> return dbData - JSON.Error str -> fail $ "Could not decode invitationData: " <> str + JSON.Error str -> throwM . PersistMarshalError $ "Could not decode invitationData: " <> pack str Just (cloneIso -> _DBData) -> return $ view _DBData () let iData :: InvitationData junction diff --git a/src/Handler/Utils/Mail.hs b/src/Handler/Utils/Mail.hs index e370676d5..726d7c975 100644 --- a/src/Handler/Utils/Mail.hs +++ b/src/Handler/Utils/Mail.hs @@ -19,11 +19,10 @@ import Control.Monad.Trans.State (StateT) addRecipientsDB :: ( MonadMail m - , MonadHandler m , HandlerSite m ~ UniWorX ) => [Filter User] -> m () -- ^ @setRecipientId uid@ throws an exception if @uid@ does not refer to an existing user -addRecipientsDB uFilter = runConduit $ transPipe (liftHandlerT . runDB) (selectSource uFilter [Asc UserDisplayName]) .| C.mapM_ addRecipient +addRecipientsDB uFilter = runConduit $ transPipe (liftHandler . runDB) (selectSource uFilter [Asc UserDisplayName]) .| C.mapM_ addRecipient where addRecipient (Entity _ User{userEmail, userDisplayName}) = do let addr = Address (Just userDisplayName) $ CI.original userEmail @@ -34,8 +33,8 @@ userAddress User{userEmail, userDisplayName} = Address (Just userDisplayName) $ userMailT :: ( MonadHandler m , HandlerSite m ~ UniWorX - , MonadBaseControl IO m - , MonadLogger m + , MonadThrow m + , MonadUnliftIO m ) => UserId -> MailT m a -> m a userMailT uid mAct = do user@User @@ -43,7 +42,7 @@ userMailT uid mAct = do , userDateTimeFormat , userDateFormat , userTimeFormat - } <- liftHandlerT . runDB $ getJust uid + } <- liftHandler . runDB $ getJust uid let ctx = MailContext { mcLanguages = userMailLanguages @@ -57,14 +56,13 @@ userMailT uid mAct = do mAct addFileDB :: ( MonadMail m - , MonadHandler m , HandlerSite m ~ UniWorX - ) => FileId -> m MailObjectId -addFileDB fId = do - File{fileTitle = pack . takeBaseName -> fileName, fileContent = Just fileContent} <- liftHandlerT . runDB $ getJust fId - addPart $ do + ) => FileId -> m (Maybe MailObjectId) +addFileDB fId = runMaybeT $ do + File{fileTitle = pack . takeBaseName -> fileName, fileContent = Just fileContent} <- MaybeT . liftHandler . runDB $ get fId + lift . addPart $ do _partType .= decodeUtf8 (mimeLookup fileName) _partEncoding .= Base64 _partFilename .= Just fileName _partContent .= LBS.fromStrict fileContent - setMailObjectIdCrypto fId :: StateT Part (HandlerT UniWorX IO) MailObjectId + setMailObjectIdCrypto fId :: StateT Part (HandlerFor UniWorX) MailObjectId diff --git a/src/Handler/Utils/Rating.hs b/src/Handler/Utils/Rating.hs index ecc5af873..2292ccfed 100644 --- a/src/Handler/Utils/Rating.hs +++ b/src/Handler/Utils/Rating.hs @@ -133,7 +133,7 @@ ratingFile cID rating@Rating{ ratingValues = Rating'{..}, .. } = do parseRating :: MonadThrow m => File -> m Rating' parseRating File{ fileContent = Just input, .. } = do - inputText <- either (throw . RatingNotUnicode) return $ Text.decodeUtf8' input + inputText <- either (throwM . RatingNotUnicode) return $ Text.decodeUtf8' input let (headerLines', commentLines) = break (commentSep `Text.isInfixOf`) $ Text.lines inputText (reverse -> ratingLines, reverse -> _headerLines) = break (sep' `Text.isInfixOf`) $ reverse headerLines' @@ -143,20 +143,20 @@ parseRating File{ fileContent = Just input, .. } = do rating = "Bewertung:" comment' <- case commentLines of (_:commentLines') -> return . Text.strip $ Text.unlines commentLines' - _ -> throw RatingMissingSeparator + _ -> throwM RatingMissingSeparator let ratingComment | Text.null comment' = Nothing | otherwise = Just comment' ratingLine' <- case ratingLines' of [l] -> return l - _ -> throw RatingMultiple + _ -> throwM RatingMultiple let (_, ratingLine) = Text.breakOnEnd rating ratingLine' ratingStr = Text.unpack $ Text.strip ratingLine ratingPoints <- case () of _ | null ratingStr -> return Nothing - | otherwise -> either (throw . RatingInvalid . pack) return $ Just <$> readEither ratingStr + | otherwise -> either (throwM . RatingInvalid . pack) return $ Just <$> readEither ratingStr return Rating'{ ratingTime = Just fileModified, .. } parseRating _ = throwM RatingFileIsDirectory @@ -166,7 +166,7 @@ type SubmissionContent = Either File (SubmissionId, Rating') extractRatings :: ( MonadHandler m , HandlerSite m ~ UniWorX , MonadCatch m - ) => Conduit File m SubmissionContent + ) => ConduitT File SubmissionContent m () extractRatings = Conduit.mapM $ \f@File{..} -> do msId <- isRatingFile fileTitle case () of diff --git a/src/Handler/Utils/Sheet.hs b/src/Handler/Utils/Sheet.hs index b3161ac89..58a873228 100644 --- a/src/Handler/Utils/Sheet.hs +++ b/src/Handler/Utils/Sheet.hs @@ -16,13 +16,11 @@ sheetFileTypeDates Sheet{..} = \case SheetMarking -> Nothing -fetchSheetAux :: ( BaseBackend backend ~ SqlBackend - , E.SqlSelect b a - , Typeable a, MonadHandler m, IsPersistBackend backend - , PersistQueryRead backend, PersistUniqueRead backend +fetchSheetAux :: ( E.SqlSelect b a + , Typeable a, MonadHandler m ) => (E.SqlExpr (Entity Sheet) -> E.SqlExpr (Entity Course) -> b) - -> TermId -> SchoolId -> CourseShorthand -> SheetName -> ReaderT backend m a + -> TermId -> SchoolId -> CourseShorthand -> SheetName -> SqlReadT m a fetchSheetAux prj tid ssh csh shn = let cachId = encodeUtf8 $ tshow (tid, ssh, csh, shn) in cachedBy cachId $ do diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index bafc69e84..383e7fe4e 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -252,7 +252,7 @@ planSubmissions sid restriction = do unstableSortBy cmp = fmap concat . mapM Rand.shuffleM . groupBy (\a b -> cmp a b == EQ) . sortBy cmp -submissionFileSource :: SubmissionId -> Source (YesodDB UniWorX) (Entity File) +submissionFileSource :: SubmissionId -> ConduitT () (Entity File) (YesodDB UniWorX) () submissionFileSource = E.selectSource . fmap snd . E.from . submissionFileQuery submissionFileQuery :: SubmissionId -> E.SqlExpr (Entity SubmissionFile) `E.InnerJoin` E.SqlExpr (Entity File) @@ -285,7 +285,7 @@ submissionMultiArchive (Set.toList -> ids) = do setContentDisposition' $ Just ((addExtension `on` unpack) archiveName extensionZip) (<* cleanup) . respondSource typeZip . transPipe (runDBRunner dbrunner) $ do let - fileEntitySource' :: (Rating, Entity Submission, (SheetName,CourseShorthand,SchoolId,TermId)) -> Source (YesodDB UniWorX) File + fileEntitySource' :: (Rating, Entity Submission, (SheetName,CourseShorthand,SchoolId,TermId)) -> ConduitT () File (YesodDB UniWorX) () fileEntitySource' (rating, Entity submissionID Submission{..},(shn,csh,ssh,tid)) = do cID <- encrypt submissionID @@ -301,7 +301,7 @@ submissionMultiArchive (Set.toList -> ids) = do | otherwise = submissionDirectory fileEntitySource = do - submissionFileSource submissionID =$= Conduit.map entityVal + submissionFileSource submissionID .| Conduit.map entityVal yieldM (ratingFile cID rating) withinDirectory f@File{..} = f { fileTitle = directoryName fileTitle } @@ -316,9 +316,9 @@ submissionMultiArchive (Set.toList -> ids) = do , fileContent = Nothing } - fileEntitySource =$= mapC withinDirectory + fileEntitySource .| mapC withinDirectory - mapM_ fileEntitySource' ratedSubmissions =$= produceZip def =$= Conduit.map toFlushBuilder + mapM_ fileEntitySource' ratedSubmissions .| produceZip def .| Conduit.map toFlushBuilder @@ -331,9 +331,12 @@ data SubmissionSinkState = SubmissionSinkState , sinkFilenames :: Set FilePath } deriving (Show, Eq, Generic, Typeable) +instance Semigroup SubmissionSinkState where + (<>) = mappenddefault + instance Monoid SubmissionSinkState where mempty = memptydefault - mappend = mappenddefault + mappend = (<>) filterSubmission :: MonadLogger m => ConduitM File File m (Set FilePath) -- ^ Removes all `File`s matching `submissionBlacklist`, returning their `fileTitle`s @@ -351,15 +354,13 @@ filterSubmission = do extractRatings :: ( MonadHandler m , HandlerSite m ~ UniWorX , MonadCatch m - , MonadLogger m ) => ConduitM File SubmissionContent m (Set FilePath) extractRatings = filterSubmission `fuseUpstream` Rating.extractRatings extractRatingsMsg :: ( MonadHandler m , HandlerSite m ~ UniWorX , MonadCatch m - , MonadLogger m - ) => Conduit File m SubmissionContent + ) => ConduitT File SubmissionContent m () extractRatingsMsg = do ignored' <- filterSubmission `fuseUpstream` Rating.extractRatings let ignoredFiles :: Set (Either CryptoFileNameSubmission FilePath) @@ -385,7 +386,7 @@ msgSubmissionErrors = flip catches sinkSubmission :: UserId -> Either SheetId SubmissionId -> Bool -- ^ Is this a correction - -> Sink SubmissionContent (YesodJobDB UniWorX) SubmissionId + -> ConduitT SubmissionContent Void (YesodJobDB UniWorX) SubmissionId -- ^ Replace the currently saved files for the given submission (either -- corrected files or original ones, depending on arguments) with the supplied -- 'SubmissionContent'. @@ -420,7 +421,7 @@ sinkSubmission userId mExists isUpdate = do where tellSt = modify . mappend - guardFileTitles :: MonadThrow m => SubmissionMode -> Conduit SubmissionContent m SubmissionContent + guardFileTitles :: MonadThrow m => SubmissionMode -> ConduitT SubmissionContent SubmissionContent m () guardFileTitles SubmissionMode{..} | Just UploadAny{..} <- submissionModeUser , not isUpdate @@ -435,7 +436,7 @@ sinkSubmission userId mExists isUpdate = do | otherwise = Conduit.map id sinkSubmission' :: SubmissionId - -> Sink SubmissionContent (YesodJobDB UniWorX) () + -> ConduitT SubmissionContent Void (YesodJobDB UniWorX) () sinkSubmission' submissionId = lift . finalize <=< execStateLC mempty . Conduit.mapM_ $ \case Left file@(File{..}) -> do $logDebugS "sinkSubmission" . tshow $ (submissionId, fileTitle) @@ -628,7 +629,7 @@ sinkSubmission userId mExists isUpdate = do sinkMultiSubmission :: UserId -> Bool {-^ Are these corrections -} - -> Sink SubmissionContent (YesodJobDB UniWorX) (Set SubmissionId) + -> ConduitT SubmissionContent Void (YesodJobDB UniWorX) (Set SubmissionId) -- ^ Expects all supplied 'SubmissionContent' to contain an encrypted 'SubmissionId' and replaces the currently saved files for the respective submissions (either corrected files or original ones, depending on arguments) with the supplied 'SubmissionContent'. -- @@ -666,7 +667,7 @@ sinkMultiSubmission userId isUpdate = do v@(Right (sId, _)) -> do cID <- encrypt sId $logDebugS "sinkMultiSubmission" $ "Feeding rating for " <> toPathPiece cID - lift (feed sId v) `catches` [ E.Handler (throwM . SubmissionSinkException cID Nothing), E.Handler (void . handleHCError (Left cID)) ] + lift (feed sId v `catches` [ E.Handler (throwM . SubmissionSinkException cID Nothing), E.Handler (void . handleHCError (Left cID)) ]) (Left f@File{..}) -> do let acc :: (Maybe SubmissionId, [FilePath]) -> FilePath -> _ (Maybe SubmissionId, [FilePath]) @@ -678,7 +679,7 @@ sinkMultiSubmission userId isUpdate = do sId <- decrypt (cID :: CryptoFileNameSubmission) Just sId <$ get404 sId | otherwise = return Nothing - msId <- lift (lift $ tryDecrypt segment) `catches` [ E.Handler handleCryptoID, E.Handler (handleHCError $ Right fileTitle) ] + msId <- lift (lift (tryDecrypt segment) `catches` [ E.Handler handleCryptoID, E.Handler (handleHCError $ Right fileTitle) ]) return (msId, fp) (msId, (joinPath -> fileTitle')) <- foldM acc (Nothing, []) $ splitDirectories fileTitle case msId of @@ -687,8 +688,8 @@ sinkMultiSubmission userId isUpdate = do Just sId -> do $logDebugS "sinkMultiSubmission" $ "Feeding " <> tshow (splitDirectories fileTitle, msId, fileTitle') cID <- encrypt sId - handle (throwM . SubmissionSinkException cID (Just fileTitle)) $ - lift . feed sId $ Left f{ fileTitle = fileTitle' } + lift . handle (throwM . SubmissionSinkException cID (Just fileTitle)) $ + feed sId $ Left f{ fileTitle = fileTitle' } when (not $ null ignoredFiles) $ do mr <- (toHtml .) <$> getMessageRender addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr) diff --git a/src/Handler/Utils/Table.hs b/src/Handler/Utils/Table.hs index 2e204b2cc..bf4ca6f13 100644 --- a/src/Handler/Utils/Table.hs +++ b/src/Handler/Utils/Table.hs @@ -1,100 +1,7 @@ module Handler.Utils.Table ( module Handler.Utils.Table ) where --- General Utilities for Tables - -import Import - -import Control.Monad.Except - -import Text.Blaze as B - -import Colonnade -import Yesod.Colonnade as Yesod - -import Data.List ((!!)) -import Data.Either import Handler.Utils.Table.Pagination as Handler.Utils.Table import Handler.Utils.Table.Columns as Handler.Utils.Table import Handler.Utils.Table.Cells as Handler.Utils.Table - - --- Table design -{-# DEPRECATED tableDefault, tableSortable "Use dbTable" #-} -tableDefault :: Attribute -tableDefault = customAttribute "class" "table table-striped table-hover" - -tableSortable :: Attribute -tableSortable = customAttribute "class" "js-sortable" - --- Colonnade Tools -{-# DEPRECATED numberColonnade, pairColonnade "Use dbTable" #-} -numberColonnade :: (IsString c) => Colonnade Headed Int c -numberColonnade = headed "Nr" (fromString.show) - -pairColonnade :: (Functor h) => Colonnade h a c -> Colonnade h b c -> Colonnade h (a,b) c -pairColonnade a b = mconcat [ lmap fst a, lmap snd b] - - --- Table Modification -{-# DEPRECATED encodeHeadedWidgetTableNumbered, headedRowSelector "Use dbTable" #-} -encodeHeadedWidgetTableNumbered :: Attribute -> Colonnade Headed a (WidgetT site IO ()) -> [a] -> WidgetT site IO () -encodeHeadedWidgetTableNumbered attrs colo tdata = - encodeWidgetTable attrs (mconcat [numberCol, lmap snd colo]) (zip [1..] tdata) - where - numberCol :: Colonnade Headed (Int,a) (WidgetT site IO ()) - numberCol = headed "Nr" (fromString.show.fst) - -headedRowSelector :: ( PathPiece b - , Eq b - ) - => (a -> Handler b) - -> (b -> Handler c) - -> Attribute - -> Colonnade Headed a (Cell UniWorX) - -> [a] - -> MForm Handler (FormResult [c], Widget) -headedRowSelector toExternal fromExternal attrs colonnade tdata = do - externalIds <- mapM (lift . toExternal) tdata - - let - checkbox extId = Field{..} - where - fieldEnctype = UrlEncoded - - fieldParse [] _ = return $ Right Nothing - fieldParse optlist _ = runExceptT $ do - extIds <- maybe (throwError "Error parsing values") return $ mapM fromPathPiece optlist - case () of - _ | extId `elem` extIds - -> Just <$> lift (fromExternal extId) - | otherwise - -> return Nothing - - fieldView theId name attributes val _ = - -- TODO: move this to a *.hamlet file - [whamlet| -

-

_{MsgAssignSubmissionsRandomWarning} \ No newline at end of file +

_{MsgAssignSubmissionsRandomWarning} diff --git a/templates/default-layout.lucius b/templates/default-layout.lucius index 9cb58b2b0..a6cc039d4 100644 --- a/templates/default-layout.lucius +++ b/templates/default-layout.lucius @@ -319,18 +319,24 @@ input[type="button"].btn-info:hover, .table--striped { - .table__row:not(.no-stripe):nth-child(even) { + .table__row:not(.no-stripe):not(.table__row--sum):nth-child(even) { background-color: rgba(0, 0, 0, 0.03); } } .table--hover { - .table__row:not(.no-hover):not(.table__row--head):hover { + .table__row:not(.no-hover):not(.table__row--sum):not(.table__row--head):hover { background-color: rgba(0, 0, 0, 0.07); } } +.table__row--sum td.table__td::before { + content: 'Σ'; + font-weight: bold; + margin-right: .25em; +} + /* SCROLLTABLE */ .scrolltable { overflow: auto; @@ -366,11 +372,20 @@ input[type="button"].btn-info:hover, vertical-align: top; } +.table__td--automatic { + font-style: oblique; + color: var(--color-fontsec); +} + +.table__td--overriden { + font-weight: bold; +} + .table__th { background-color: var(--color-dark); position: relative; font-size: 16px; - color: #fff; + color: white; line-height: 1.4; padding-top: 10px; padding-bottom: 10px; @@ -378,7 +393,20 @@ input[type="button"].btn-info:hover, text-align: left; a { + color: white; text-decoration: none; + font-weight: bold; + + &:hover { + color: inherit; + } + + &::before { + content: "\f0c1"; + font-family: "Font Awesome 5 Free"; + font-weight: 900; + margin-right: 0.25em; + } } } @@ -395,11 +423,10 @@ input[type="button"].btn-info:hover, } .table__th-link { - color: white; font-weight: bold; - &:hover { - color: inherit; + &::before { + display: none; } } @@ -575,7 +602,7 @@ section { position: relative; border-radius: 3px; padding: 10px 20px 20px; - margin: 40px 0; + margin: 40px auto; box-shadow: 0 0 4px 2px inset currentColor; padding-left: 100px; min-height: 100px; @@ -587,7 +614,7 @@ section { &::before { font-family: "Font Awesome 5 Free"; - font-weight: 900; + font-weight: 600; position: absolute; display: flex; left: 0; @@ -602,6 +629,12 @@ section { .notification__content { grid-column: 1; align-self: center; + + color: var(--color-font); + } + + &.notification--broad { + max-width: none; } } diff --git a/templates/exam-show.cassius b/templates/exam-show.cassius index b0f051fcb..4588a6011 100644 --- a/templates/exam-show.cassius +++ b/templates/exam-show.cassius @@ -1,6 +1,6 @@ -.occurrence--not-registered - text-decoration: strike-through; +.occurrence--not-registered, .no-bonus + text-decoration: line-through .result - padding-left: 2em; - font-size: 20px; + font-size: 3rem + margin: 30px 30px 0 !important diff --git a/templates/exam-show.hamlet b/templates/exam-show.hamlet index 4602c9184..b05d2c2b6 100644 --- a/templates/exam-show.hamlet +++ b/templates/exam-show.hamlet @@ -55,35 +55,35 @@ $maybe desc <- examDescription $maybe finished <- examFinished

_{MsgExamFinishedParticipant}
^{formatTimeW SelFormatDateTime finished} - $maybe closed <- examClosed -
_{MsgExamClosed} -
^{formatTimeW SelFormatDateTime closed} + $if examClosedShown + $maybe closed <- examClosed +
_{MsgExamClosed} ^{isVisible False} +
^{formatTimeW SelFormatDateTime closed} $if gradingShown - $if examGradingRule /= ExamGradingManual + $maybe gradingRule <- examGradingRule
_{MsgExamGradingRule} $if not gradingVisible \ ^{isVisible False}
- $case examGradingRule - $of ExamGradingManual - _{MsgExamGradingManual'} + $case gradingRule $of ExamGradingKey{..} ^{gradingKeyW examGradingKey} - $if examBonusRule /= ExamNoBonus + $maybe bonusRule <- examBonusRule
_{MsgExamBonusRule} $if not gradingVisible \ ^{isVisible False}
- ^{examBonusW examBonusRule} - $if occurrenceAssignmentsShown -
- _{MsgExamOccurrenceRuleParticipant} - $if not occurrenceAssignmentsVisible - \ ^{isVisible False} -
- _{classifyExamOccurrenceRule examOccurrenceRule} + ^{examBonusW bonusRule} + $maybe occurrenceRule <- examOccurrenceRule + $if occurrenceAssignmentsShown +
+ _{MsgExamOccurrenceRuleParticipant} + $if not occurrenceAssignmentsVisible + \ ^{isVisible False} +
+ _{classifyExamOccurrenceRule occurrenceRule} $maybe registerWdgt <- registerWidget
_{MsgExamRegistration}
^{registerWdgt} @@ -138,24 +138,86 @@ $if gradingShown && not (null examParts) + $if partNumbersShown + - $forall Entity partId ExamPart{examPartName, examPartWeight, examPartMaxPoints} <- examParts + $forall Entity partId ExamPart{examPartNumber, examPartName, examPartWeight, examPartMaxPoints} <- examParts - + $maybe mPoints <- fmap (examBonusBonus . entityVal) bonus + $if showMaxPoints + + $if partNumbersShown + + $if partNumbersShown + + $if partNumbersShown + + $if partNumbersShown +
+ _{MsgExamPartNumber} ^{isVisible False} _{MsgExamPartName} - _{MsgExamPartMaxPoints} - _{MsgExamPartResultPoints} + $if showMaxPoints + _{MsgExamPartMaxPoints} + $if showAchievedPoints + _{MsgExamPartResultPoints}
#{examPartName} + $if partNumbersShown + #{examPartNumber} - $maybe mPoints <- examPartMaxPoints - #{showFixed True (fromRational examPartWeight * mPoints)} + $maybe pName <- examPartName + #{pName} + $nothing + _{MsgExamPartNumbered examPartNumber} + $if showMaxPoints + + $maybe mPoints <- examPartMaxPoints + #{showFixed True (fromRational examPartWeight * mPoints)} + $if showAchievedPoints + + $case fmap (examPartResultResult . entityVal) (results !? partId) + $of Nothing + $of Just (ExamAttended ps) + #{showFixed True ps} + $of Just ExamNoShow + _{MsgExamNoShow} + $of Just ExamVoided + _{MsgExamVoided} +
+ + + #{showFixed True sumMaxPoints} + +
- $case fmap (examPartResultResult . entityVal) (results !? partId) - $of Nothing - $of Just (ExamAttended ps) - #{showFixed True ps} - $of Just ExamNoShow - _{MsgExamNoShow} - $of Just ExamVoided - _{MsgExamVoided} + + _{MsgExamBonusAchieved} + $if showMaxPoints + + $if showAchievedPoints + + #{showFixed True mPoints} +
+ + $if showMaxPoints + + $if showAchievedPoints + + $case sumPoints + $of ExamAttended ps + #{showFixed True ps} + $of _ + $nothing +
+ + $if showMaxPoints + + #{showFixed True sumMaxPoints} + $if showAchievedPoints + + $case sumPoints + $of ExamAttended ps + #{showFixed True ps} + $of _ + + $# TODO: Statistics diff --git a/templates/exam-users.hamlet b/templates/exam-users.hamlet index efa46523c..06e3e489f 100644 --- a/templates/exam-users.hamlet +++ b/templates/exam-users.hamlet @@ -2,4 +2,6 @@ $newline never
^{closeWgt}
+ $if computedValues + ^{computedValuesTip} ^{examUsersTable} diff --git a/templates/i18n/exam-users/computed-values-tip/de.hamlet b/templates/i18n/exam-users/computed-values-tip/de.hamlet new file mode 100644 index 000000000..22f185706 --- /dev/null +++ b/templates/i18n/exam-users/computed-values-tip/de.hamlet @@ -0,0 +1,24 @@ +$newline never +
+
+

+ Die Tabelle enthält Werte, die automatisch berechnet wurden. +

+ Automatisch berechnete Werte (Bonus und Prüfungsergebnis) werden weder dem # + entsprechenden Teilnehmer angezeigt, noch an das Prüfungsamt gemeldet # + bevor sie manuell übernommen wurden.
+ Hierzu können Sie die Aktion „Berechnetes Prüfungsergebnis übernehmen“ # + verwenden. +

+ Sie können die automatisch berechneten Werte auch manuell (via CSV-Import) # + überschreiben.
+ Wenn die so gesetzten Werte nicht den automatisch Berechneten entsprechen # + sind sie inkonsistent. +

+ Automatisch berechnete Werte sind gekennzeichnet wie folgt: + + + +
Automatisch berechnet + Normaler Wert + Inkonsistent diff --git a/templates/table/cell/body.hamlet b/templates/table/cell/body.hamlet index 0928779b9..dcf1074bb 100644 --- a/templates/table/cell/body.hamlet +++ b/templates/table/cell/body.hamlet @@ -1,4 +1,4 @@ $newline never - +
^{widget} diff --git a/templates/widgets/bonusRule.hamlet b/templates/widgets/bonusRule.hamlet index bf72b1684..1c59049c0 100644 --- a/templates/widgets/bonusRule.hamlet +++ b/templates/widgets/bonusRule.hamlet @@ -1,8 +1,8 @@ $newline never $case bonusRule - $of ExamNoBonus - _{MsgExamNoBonus'} - $of ExamBonusPoints ps False + $of ExamBonusManual _ + _{MsgExamBonusManualParticipants} + $of ExamBonusPoints ps False _ _{MsgExamBonusPoints ps} - $of ExamBonusPoints ps True + $of ExamBonusPoints ps True _ _{MsgExamBonusPointsPassed ps} diff --git a/templates/widgets/massinput/examParts/form.hamlet b/templates/widgets/massinput/examParts/form.hamlet index 0ef5c4f7a..5b0b0e9a1 100644 --- a/templates/widgets/massinput/examParts/form.hamlet +++ b/templates/widgets/massinput/examParts/form.hamlet @@ -1,4 +1,5 @@ $newline never -
#{csrf}^{fvInput epfIdView}^{fvInput epfNameView} +#{csrf}^{fvInput epfIdView}^{fvInput epfNumberView} +^{fvInput epfNameView} ^{fvInput epfMaxPointsView} ^{fvInput epfWeightView} diff --git a/templates/widgets/massinput/examParts/layout.hamlet b/templates/widgets/massinput/examParts/layout.hamlet index 87ab7fef4..86f968148 100644 --- a/templates/widgets/massinput/examParts/layout.hamlet +++ b/templates/widgets/massinput/examParts/layout.hamlet @@ -1,10 +1,25 @@ $newline never - + + $forall coord <- review liveCoords lLength diff --git a/templates/widgets/massinput/examRooms/layout.hamlet b/templates/widgets/massinput/examRooms/layout.hamlet index c8a4bf270..8bd82ae6e 100644 --- a/templates/widgets/massinput/examRooms/layout.hamlet +++ b/templates/widgets/massinput/examRooms/layout.hamlet @@ -1,13 +1,22 @@ $newline never
_{MsgExamPartName} - _{MsgExamPartMaxPoints} - _{MsgExamPartWeight} - +
+ _{MsgExamPartNumber} # + + _{MsgExamPartName} + _{MsgExamPartMaxPoints} + + _{MsgExamPartWeight} # + + +
+ _{MsgExamPartNumberTip} + + _{MsgExamPartNameTip} + + + _{MsgExamPartWeightTip} +
- + $forall coord <- review liveCoords lLength diff --git a/test/Database.hs b/test/Database.hs index 280bcead3..140f0e490 100755 --- a/test/Database.hs +++ b/test/Database.hs @@ -7,7 +7,7 @@ module Database import "uniworx" Import hiding (Option(..)) import "uniworx" Application (db, getAppDevSettings) -import Data.Pool (destroyAllResources) +import UnliftIO.Pool (destroyAllResources) import Database.Persist.Postgresql import Control.Monad.Logger @@ -25,6 +25,8 @@ import Control.Monad.Random.Class (MonadRandom(..)) import qualified Data.Set as Set +import Database.Persist.Sql.Raw.QQ + data DBAction = DBClear | DBTruncate @@ -48,7 +50,7 @@ main = do DBClear -> runStderrLoggingT $ do -- We don't use `db` here, since we do /not/ want any migrations to run, yet settings <- liftIO getAppDevSettings withPostgresqlConn (pgConnStr $ appDatabaseConf settings) . runSqlConn $ do - rawExecute "drop owned by current_user;" [] + [executeQQ|drop owned by current_user|] :: ReaderT SqlBackend _ () DBTruncate -> db $ do foundation <- getYesod liftIO . destroyAllResources $ appConnPool foundation @@ -467,6 +469,31 @@ fillDb = do ,(tinaTester, Just sfTTc) ] + examFFP <- insert' $ Exam + { examCourse = ffp + , examName = "Klausur" + , examGradingRule = Nothing + , examBonusRule = Nothing + , examOccurrenceRule = Nothing + , examVisibleFrom = Just now + , examRegisterFrom = Just now + , examRegisterTo = Just $ addUTCTime (14 * nominalDay) now + , examDeregisterUntil = Just $ addUTCTime (15 * nominalDay) now + , examPublishOccurrenceAssignments = Just $ addUTCTime (15 * nominalDay) now + , examStart = Just $ addUTCTime (16 * nominalDay) now + , examEnd = Just $ addUTCTime (17 * nominalDay) now + , examFinished = Just $ addUTCTime (21 * nominalDay) now + , examClosed = Nothing + , examPublicStatistics = True + , examShowGrades = True + , examDescription = Nothing + } + void . insertMany $ map (\u -> ExamRegistration examFFP u Nothing now) + [ fhamann + , maxMuster + , tinaTester + ] + -- EIP eip <- insert' Course { courseName = "Einführung in die Programmierung" diff --git a/test/Handler/Utils/ZipSpec.hs b/test/Handler/Utils/ZipSpec.hs index eaa471881..667edad18 100644 --- a/test/Handler/Utils/ZipSpec.hs +++ b/test/Handler/Utils/ZipSpec.hs @@ -19,7 +19,7 @@ spec = describe "Zip file handling" $ do it "has compatible encoding/decoding to/from zip files" . property $ do zipFiles <- listOf $ scale (`div` 2) arbitrary return . property $ do - zipFiles' <- runConduit $ Conduit.sourceList zipFiles =$= produceZip def =$= void consumeZip =$= Conduit.consume + zipFiles' <- runConduit $ Conduit.sourceList zipFiles .| produceZip def .| void consumeZip .| Conduit.consume forM_ (zipFiles `zip` zipFiles') $ \(file, file') -> do let acceptableFilenameChanges = makeValid . dropWhile isPathSeparator . bool (dropWhileEnd isPathSeparator) addTrailingPathSeparator (isNothing $ fileContent file) . normalise . makeValid diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index 49faef34f..c27083034 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -240,8 +240,7 @@ instance Arbitrary ExamGrade where instance Arbitrary ExamGradingRule where arbitrary = oneof - [ pure ExamGradingManual - , ExamGradingKey . reverse . fromOffsets . map getNonNegative <$> replicateM 11 arbitrary + [ ExamGradingKey . reverse . fromOffsets . map getNonNegative <$> replicateM 10 arbitrary ] where fromOffsets [] = [] diff --git a/test/Test/QuickCheck/Classes/JSON.hs b/test/Test/QuickCheck/Classes/JSON.hs index 78d586ec3..5d323bbcb 100644 --- a/test/Test/QuickCheck/Classes/JSON.hs +++ b/test/Test/QuickCheck/Classes/JSON.hs @@ -24,7 +24,7 @@ jsonKeyLaws _ = Laws "ToJSONKey/FromJSONKey" ) ] where - partialIsomorphism :: forall a'. (Arbitrary a', FromJSONKey a', ToJSONKey a', Eq a', Show a') => a' -> Property + partialIsomorphism :: forall a'. (FromJSONKey a', ToJSONKey a', Eq a') => a' -> Property partialIsomorphism a = case (toJSONKey, fromJSONKey) of (ToJSONKeyText toVal _, FromJSONKeyCoerce _) -> property $ unsafeCoerce (toVal a) == a diff --git a/test/TestImport.hs b/test/TestImport.hs index 61b96ab43..d14c8ae07 100644 --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -4,7 +4,13 @@ module TestImport ) where import Application (makeFoundation, makeLogWare, shutdownApp) -import ClassyPrelude as X hiding (delete, deleteBy, Handler, Index, (<.>), (<|), index, uncons, unsnoc, cons, snoc) +import ClassyPrelude as X + hiding ( delete, deleteBy + , Handler, Index + , (<.>), (<|) + , index, uncons, unsnoc, cons, snoc + , try, catches, handle, catch, bracket, bracketOnError, bracket_, catchJust, finally, handleJust, mask, mask_, onException, tryJust, uninterruptibleMask, uninterruptibleMask_ + ) import Database.Persist as X hiding (get) import Database.Persist.Sql as X (SqlPersistM) import Database.Persist.Sql (runSqlPersistMPool) @@ -42,7 +48,9 @@ import Net.IP as X (IP) import Database (truncateDb) import Database as X (fillDb) -import Control.Monad.Trans.Resource (runResourceT, MonadResourceBase) +import Control.Monad.Catch as X hiding (Handler(..)) + +import Control.Monad.Trans.Resource (runResourceT) import Settings @@ -84,7 +92,7 @@ withApp = around $ \act -> runResourceT $ do -- This function will truncate all of the tables in your database. -- 'withApp' calls it before each test, creating a clean environment for each -- spec to run in. -wipeDB :: (MonadResourceBase m, MonadMask m) => UniWorX -> m () +wipeDB :: MonadUnliftIO m => UniWorX -> m () wipeDB app = runDBWithApp app Database.truncateDb -- | Authenticate as a user. This relies on the `auth-dummy-login: true` flag
_{MsgExamRoomName} - _{MsgExamRoom} - _{MsgExamRoomCapacity} - _{MsgExamRoomStart} - _{MsgExamRoomEnd} - _{MsgExamRoomDescription} - +
+ _{MsgExamRoomName} # + + + _{MsgExamRoom} # + + + _{MsgExamRoomCapacity} # + + + _{MsgExamRoomStart} # + + _{MsgExamRoomEnd} + _{MsgExamRoomDescription} +