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

Merge branch 'master' into 466-zeit-wird-beim-editieren-zuruckgesetzt

Browse Source
This commit is contained in:
Gregor Kleen 2019-09-26 11:02:56 +02:00
commit 2ac6fc55d2
162 changed files with 2587 additions and 1486 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
CHANGELOG.md
View File

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

36
README.md
View File

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

7
app/DevelMain.hs
View File

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

13
clean.sh
View File

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

2
config/test-settings.yml
View File

@ -8,3 +8,5 @@ log-settings:
destination: "test.log"
auth-dummy-login: true
job-workers: 1

8
frontend/src/utils/inputs/inputs.scss
View File

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

2
haddock.sh
View File

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

46
messages/uniworx/de.msg
View File

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

8
models/courses
View File

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

19
models/exams
View File

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

4
nixpkgs.nix
View File

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

14
package-lock.json generated
View File

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

4
package.json
View File

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

56
package.yaml
View File

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

8
shell.nix
View File

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

43
src/Application.hs
View File

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

5
src/Audit.hs
View File

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

18
src/Audit/Types.hs
View File

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

40
src/Auth/Dummy.hs
View File

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

32
src/Auth/LDAP.hs
View File

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

56
src/Auth/PWHash.hs
View File

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

17
src/Control/Concurrent/Async/Lifted/Safe/Utils.hs
View File

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

8
src/CryptoID.hs
View File

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

1
src/Data/CaseInsensitive/Instances.hs
View File

@ -1,5 +1,6 @@
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
module Data.CaseInsensitive.Instances
(

2
src/Data/CryptoID/Instances.hs
View File

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

12
src/Data/List/NonEmpty/Instances.hs
View File

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

13
src/Database/Esqueleto/Utils.hs
View File

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

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

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

102
src/Foundation.hs
View File

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

10
src/Handler/Admin.hs
View File

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

12
src/Handler/Allocation/Application.hs
View File

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

2
src/Handler/Allocation/List.hs
View File

@ -1,3 +1,5 @@
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
module Handler.Allocation.List
( getAllocationListR
) where

4
src/Handler/Allocation/Show.hs
View File

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

30
src/Handler/Corrections.hs
View File

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

4
src/Handler/Course/Application/Files.hs
View File

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

3
src/Handler/Course/Application/List.hs
View File

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

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

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

11
src/Handler/Course/LecturerInvite.hs
View File

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

2
src/Handler/Course/List.hs
View File

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

15
src/Handler/Course/ParticipantInvite.hs
View File

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

8
src/Handler/Course/Register.hs
View File

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

15
src/Handler/Course/Show.hs
View File

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

2
src/Handler/Course/User.hs
View File

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

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

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

7
src/Handler/Exam/AddUser.hs
View File

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

10
src/Handler/Exam/CorrectorInvite.hs
View File

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

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

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

37
src/Handler/Exam/Form.hs
View File

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

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

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

14
src/Handler/Exam/RegistrationInvite.hs
View File

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

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

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

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

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

2
src/Handler/ExamOffice/Course.hs
View File

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

10
src/Handler/ExamOffice/Exam.hs
View File

@ -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
<span ##{toPathPiece cID}>
@ -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

2
src/Handler/ExamOffice/Exams.hs
View File

@ -1,3 +1,5 @@
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
module Handler.ExamOffice.Exams
( getEOExamsR
) where

6
src/Handler/ExamOffice/Fields.hs
View File

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

12
src/Handler/ExamOffice/Users.hs
View File

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

2
src/Handler/Health.hs
View File

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

8
src/Handler/Home.hs
View File

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

15
src/Handler/Material.hs
View File

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

6
src/Handler/Profile.hs
View File

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

2
src/Handler/School.hs
View File

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

41
src/Handler/Sheet.hs
View File

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

22
src/Handler/Submission.hs
View File

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

8
src/Handler/SystemMessage.hs
View File

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

2
src/Handler/Term.hs
View File

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

21
src/Handler/Tutorial.hs
View File

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

12
src/Handler/Users.hs
View File

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

12
src/Handler/Utils.hs
View File

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

14
src/Handler/Utils/Communication.hs
View File

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

2
src/Handler/Utils/ContentDisposition.hs
View File

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

92
src/Handler/Utils/Csv.hs
View File

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

8
src/Handler/Utils/Database.hs
View File

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

6
src/Handler/Utils/DateTime.hs
View File

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

8
src/Handler/Utils/Delete.hs
View File

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

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

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

88
src/Handler/Utils/Form.hs
View File

@ -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|
<input id=#{theId} name=#{name} *{attrs} type=#{inputType} :isReq:required value=#{either fromStrict encodeToLazyText val}>
|]
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

26
src/Handler/Utils/Form/MassInput.hs
View File

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

3
src/Handler/Utils/Form/Occurrences.hs
View File

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

73
src/Handler/Utils/Invitations.hs
View File

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

20
src/Handler/Utils/Mail.hs
View File

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

10
src/Handler/Utils/Rating.hs
View File

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

8
src/Handler/Utils/Sheet.hs
View File

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

35
src/Handler/Utils/Submission.hs
View File

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

93
src/Handler/Utils/Table.hs
View File

@ -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|
<label style="display: block">
<input ##{theId} type=checkbox name=#{name} value=#{toPathPiece extId} *{attributes} :isRight val:checked>
|]
selectionIdent <- newFormIdent
(selectionResults, selectionBoxes) <- fmap unzip . forM externalIds $ \ident -> mopt (checkbox ident) ("" { fsName = Just selectionIdent }) Nothing
let
selColonnade :: Colonnade Headed Int (Cell UniWorX)
selColonnade = headed "Markiert" $ Yesod.cell . fvInput . (selectionBoxes !!)
collectResult :: [FormResult a] -> FormResult [a]
collectResult [] = FormSuccess []
collectResult (FormFailure errs : _) = FormFailure errs
collectResult (FormMissing:rs) = collectResult rs
collectResult (FormSuccess x:rs) = (x :) <$> collectResult rs
return ( catMaybes <$> collectResult selectionResults
, encodeCellTable attrs (pairColonnade selColonnade colonnade) (zip [0..] tdata)
)

62
src/Handler/Utils/Table/Cells.hs
View File

@ -1,8 +1,6 @@
module Handler.Utils.Table.Cells where
import Import
import qualified Control.Monad.Trans.RWS.Lazy
import Import hiding (link)
import Data.CaseInsensitive (CI)
-- import qualified Data.CaseInsensitive as CI
@ -28,37 +26,17 @@ type CourseLink = (TermId, SchoolId, CourseShorthand) -- TODO: Refactor with Wit
-- Some basic cells are defined in Handler.Utils.Table.Pagination
-- such as: i18nCell, cellTooltip, anchorCell for links, etc.
----------------
-- Cell transformation
-- | Add cell attributes
addCellAttrs :: [(Text, Text)]
-> DBCell (Control.Monad.Trans.RWS.Lazy.RWST
(Maybe (Env, FileEnv), UniWorX, [Lang])
Enctype
Ints
(HandlerT UniWorX IO))
x
-> DBCell (Control.Monad.Trans.RWS.Lazy.RWST
(Maybe (Env, FileEnv), UniWorX, [Lang])
Enctype
Ints
(HandlerT UniWorX IO))
x
addCellAttrs newAttrs fcell = fcell { formCellAttrs = newAttrs <> formCellAttrs fcell } -- Isn't there already a lens for that?
----------------
-- Special cells
-- | Display a breakable space
spacerCell :: (IsDBTable m a) => DBCell m a
spacerCell :: IsDBTable m a => DBCell m a
spacerCell = cell [whamlet|&emsp;|]
tellCell :: (Monoid a, IsDBTable m a) => a -> DBCell m a -> DBCell m a
tellCell :: IsDBTable m a => a -> DBCell m a -> DBCell m a
tellCell = flip mappend . writerCell . tell
cellTell :: (Monoid a, IsDBTable m a) => DBCell m a -> a -> DBCell m a
cellTell :: IsDBTable m a => DBCell m a -> a -> DBCell m a
cellTell = flip tellCell
indicatorCell :: IsDBTable m Any => DBCell m Any -- For dbTables that return a Bool to indicate content
@ -67,7 +45,7 @@ indicatorCell = writerCell . tell $ Any True
writerCell :: IsDBTable m w => WriterT w m () -> DBCell m w
writerCell act = mempty & cellContents %~ (<* act)
maybeCell :: (IsDBTable m a) => Maybe a -> (a -> DBCell m a) -> DBCell m a
maybeCell :: IsDBTable m a => Maybe a -> (a -> DBCell m a) -> DBCell m a
maybeCell = flip foldMap
htmlCell :: (IsDBTable m a, ToMarkup c) => c -> DBCell m a
@ -81,12 +59,12 @@ sqlCell :: (IsDBTable (YesodDB UniWorX) a) => YesodDB UniWorX Widget -> DBCell (
sqlCell act = mempty & cellContents .~ lift act
-- | Highlight table cells with warning: Is not yet implemented in frontend.
markCell :: (IsDBTable m a) => MessageStatus -> (t -> Bool) -> (t -> DBCell m a) -> (t -> DBCell m a)
markCell :: IsDBTable m a => MessageStatus -> (t -> Bool) -> (t -> DBCell m a) -> (t -> DBCell m a)
markCell status condition normal x
| condition x = normal x & over cellAttrs (insertAttr "class" $ statusToUrgencyClass status)
| condition x = normal x & addCellClass (statusToUrgencyClass status)
| otherwise = normal x
ifCell :: (IsDBTable m a) => (t -> Bool) -> (t -> DBCell m a) -> (t -> DBCell m a) -> (t -> DBCell m a)
ifCell :: (t -> Bool) -> (t -> DBCell m a) -> (t -> DBCell m a) -> (t -> DBCell m a)
ifCell decision cTrue cFalse x
| decision x = cTrue x
| otherwise = cFalse x
@ -105,22 +83,22 @@ msgCell = textCell . toMessage
iconCell :: IsDBTable m a => Icon -> DBCell m a
iconCell = cell . toWidget . icon
addIconFixedWidth :: (IsDBTable m a) => DBCell m a -> DBCell m a
addIconFixedWidth = over cellAttrs $ insertClass "icon-fixed-width"
addIconFixedWidth :: IsDBTable m a => DBCell m a -> DBCell m a
addIconFixedWidth = addCellClass ("icon-fixed-width" :: Text)
iconSpacerCell :: (IsDBTable m a) => DBCell m a
iconSpacerCell :: IsDBTable m a => DBCell m a
iconSpacerCell = mempty & addIconFixedWidth
-- | Maybe display a tickmark/checkmark icon
tickmarkCell :: (IsDBTable m a) => Bool -> DBCell m a
tickmarkCell :: IsDBTable m a => Bool -> DBCell m a
tickmarkCell = cell . toWidget . hasTickmark
-- | Maybe display an icon for tainted rows
isBadCell :: (IsDBTable m a) => Bool -> DBCell m a
isBadCell :: IsDBTable m a => Bool -> DBCell m a
isBadCell = cell . toWidget . isBad
-- | Maybe display a exclamation icon
isNewCell :: (IsDBTable m a) => Bool -> DBCell m a
isNewCell :: IsDBTable m a => Bool -> DBCell m a
isNewCell = cell . toWidget . isNew
-- | Maybe display comment icon linking a given URL or show nothing at all
@ -129,11 +107,11 @@ commentCell Nothing = mempty
commentCell (Just link) = anchorCell link $ hasComment True
-- | whether something is visible or hidden
isVisibleCell :: (IsDBTable m a) => Bool -> DBCell m a
isVisibleCell :: IsDBTable m a => Bool -> DBCell m a
isVisibleCell True = cell . toWidget $ isVisible True
isVisibleCell False = (cell . toWidget $ isVisible False) & addUrgencyClass
where
addUrgencyClass = over cellAttrs $ insertClass $ statusToUrgencyClass Warning
addUrgencyClass = addCellClass $ statusToUrgencyClass Warning
-- | for simple file downloads
fileCell :: IsDBTable m a => Route UniWorX -> DBCell m a
@ -171,7 +149,7 @@ dateTimeCellVisible watershed t
| otherwise = cell timeStampWgt
where
timeStampWgt = formatTimeW SelFormatDateTime t
addUrgencyClass = over cellAttrs $ insertClass $ statusToUrgencyClass Warning
addUrgencyClass = addCellClass $ statusToUrgencyClass Warning
userCell :: IsDBTable m a => Text -> Text -> DBCell m a
userCell displayName surname = cell $ nameWidget displayName surname
@ -218,13 +196,13 @@ cellHasDegreeShort x = maybe (numCell $ x ^. _studyDegreeKey) textCell $ x ^. _s
maybeDateTimeCell :: IsDBTable m a => Maybe UTCTime -> DBCell m a
maybeDateTimeCell = maybe mempty dateTimeCell
numCell :: (IsDBTable m a, Num b, ToMessage b) => b -> DBCell m a
numCell :: (IsDBTable m a, ToMessage b) => b -> DBCell m a
numCell = textCell . toMessage
propCell :: (IsDBTable m a, Real b, ToMessage b) => b -> b -> DBCell m a
propCell curr max' = i18nCell $ MsgProportion (toMessage curr) (toMessage max') (toRational curr / toRational max')
int64Cell :: (IsDBTable m a) => Int64-> DBCell m a
int64Cell :: IsDBTable m a => Int64-> DBCell m a
int64Cell = numCell
termCell :: IsDBTable m a => TermId -> DBCell m a
@ -269,7 +247,7 @@ sheetCell crse shn =
let tid = crse ^. _1
ssh = crse ^. _2
csh = crse ^. _3
link= CSheetR tid ssh csh shn SShowR
link = CSheetR tid ssh csh shn SShowR
in anchorCell link $ toWgt shn
submissionCell :: IsDBTable m a => CourseLink -> SheetName -> SubmissionId -> DBCell m a

8
src/Handler/Utils/Table/Columns.hs
View File

@ -1,6 +1,8 @@
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
module Handler.Utils.Table.Columns where
import Import
import Import hiding (link)
-- import Data.CaseInsensitive (CI)
-- import qualified Data.CaseInsensitive as CI
@ -323,7 +325,7 @@ colApplicationId :: OpticColonnade CourseApplicationId
colApplicationId resultId = Colonnade.singleton (fromSortable header) body
where
header = Sortable Nothing (i18nCell MsgCourseApplicationId)
body = views resultId $ cell . (toWidget . toMarkup =<<) . (encrypt :: CourseApplicationId -> WidgetT UniWorX IO CryptoFileNameCourseApplication)
body = views resultId $ cell . (toWidget . toMarkup =<<) . (encrypt :: CourseApplicationId -> WidgetFor UniWorX CryptoFileNameCourseApplication)
colApplicationRatingPoints :: OpticColonnade (Maybe ExamGrade)
colApplicationRatingPoints resultPoints = Colonnade.singleton (fromSortable header) body
@ -813,7 +815,7 @@ anchorColonnadeM :: forall h r' m a url.
, IsDBTable m a
, HandlerSite m ~ UniWorX
)
=> (r' -> WidgetT UniWorX IO url)
=> (r' -> WidgetFor UniWorX url)
-> Colonnade h r' (DBCell m a)
-> Colonnade h r' (DBCell m a)
anchorColonnadeM mkUrl = imapColonnade anchorColonnade'

196
src/Handler/Utils/Table/Pagination.hs
View File

@ -1,3 +1,5 @@
{-# LANGUAGE UndecidableInstances #-}
module Handler.Utils.Table.Pagination
( module Handler.Utils.Table.Pagination.Types
, dbFilterKey
@ -17,6 +19,7 @@ module Handler.Utils.Table.Pagination
, singletonFilter
, DBParams(..)
, cellAttrs, cellContents
, addCellClass
, PagesizeLimit(..)
, PaginationSettings(..), PaginationInput(..), piIsUnset
, PSValidator(..)
@ -50,6 +53,9 @@ import Utils
import Utils.Lens
import Import hiding (pi)
import qualified Yesod.Form.Functions as Yesod
import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E
import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect,unsafeSqlValue)
@ -111,6 +117,8 @@ import qualified Control.Monad.Catch as Catch
import Data.Dynamic
import qualified Data.Csv as Csv
#if MIN_VERSION_base(4,11,0)
type Monoid' = Monoid
@ -513,17 +521,18 @@ singletonFilter key = prism' fromInner (fmap Just . fromOuter)
data DBTCsvEncode r' k' csv = forall exportData.
( ToNamedRecord csv, DefaultOrdered csv, CsvColumnsExplained csv
( ToNamedRecord csv, CsvColumnsExplained csv
, DBTableKey k'
, Typeable exportData
) => DBTCsvEncode
{ dbtCsvExportForm :: AForm (YesodDB UniWorX) exportData
, dbtCsvDoEncode :: exportData -> Conduit (k', r') (YesodDB UniWorX) csv
, dbtCsvHeader :: Maybe exportData -> YesodDB UniWorX Csv.Header -- ^ @exportData@ is @Nothing@, if we're reporting an error
, dbtCsvDoEncode :: exportData -> ConduitT (k', r') csv (YesodDB UniWorX) ()
, dbtCsvName :: FilePath
, dbtCsvNoExportData :: Maybe (AnIso' exportData ())
}
data DBTCsvDecode r' k' csv = forall route csvAction csvActionClass csvException.
( FromNamedRecord csv, ToNamedRecord csv, DefaultOrdered csv
( FromNamedRecord csv, ToNamedRecord csv
, DBTableKey k'
, RedirectUrl UniWorX route
, Typeable csv
@ -532,10 +541,10 @@ data DBTCsvDecode r' k' csv = forall route csvAction csvActionClass csvException
, Exception csvException
) => DBTCsvDecode
{ dbtCsvRowKey :: csv -> MaybeT (YesodDB UniWorX) k'
, dbtCsvComputeActions :: DBCsvDiff r' csv k' -> Source (YesodDB UniWorX) csvAction
, dbtCsvComputeActions :: DBCsvDiff r' csv k' -> ConduitT () csvAction (YesodDB UniWorX) ()
, dbtCsvClassifyAction :: csvAction -> csvActionClass
, dbtCsvCoarsenActionClass :: csvActionClass -> DBCsvActionMode
, dbtCsvExecuteActions :: Sink csvAction (YesodDB UniWorX) route
, dbtCsvExecuteActions :: ConduitT csvAction Void (YesodDB UniWorX) route
, dbtCsvRenderKey :: Map k' r' -> csvAction -> Widget
, dbtCsvRenderActionClass :: csvActionClass -> Widget
, dbtCsvRenderException :: csvException -> YesodDB UniWorX Text
@ -545,7 +554,7 @@ data DBTable m x = forall a r r' h i t k k' csv.
( ToSortable h, Functor h
, E.SqlSelect a r, E.SqlIn k k', DBTableKey k'
, PathPiece i, Eq i
, E.From E.SqlQuery E.SqlExpr E.SqlBackend t
, E.From t
) => DBTable
{ dbtSQLQuery :: t -> E.SqlQuery a
, dbtRowKey :: t -> k -- ^ required for table forms; always same key for repeated requests. For joins: return unique tuples.
@ -566,7 +575,8 @@ type DBFilterUI = Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map F
noCsvEncode :: Maybe (DBTCsvEncode r' k' Void)
noCsvEncode = Nothing
simpleCsvEncode :: ( ToNamedRecord csv, DefaultOrdered csv, CsvColumnsExplained csv
simpleCsvEncode :: forall fp r' k' csv.
( ToNamedRecord csv, DefaultOrdered csv, CsvColumnsExplained csv
, DBTableKey k'
, Textual fp
)
@ -576,9 +586,11 @@ simpleCsvEncode fName f = Just DBTCsvEncode
, dbtCsvDoEncode = \() -> C.map (f . view _2)
, dbtCsvName = unpack fName
, dbtCsvNoExportData = Just id
, dbtCsvHeader = const . return $ headerOrder (error "headerOrder" :: csv)
}
simpleCsvEncodeM :: ( ToNamedRecord csv, DefaultOrdered csv, CsvColumnsExplained csv
simpleCsvEncodeM :: forall fp r' k' csv.
( ToNamedRecord csv, DefaultOrdered csv, CsvColumnsExplained csv
, DBTableKey k'
, Textual fp
)
@ -588,6 +600,7 @@ simpleCsvEncodeM fName f = Just DBTCsvEncode
, dbtCsvDoEncode = \() -> C.mapM (runReaderT f . view _2)
, dbtCsvName = unpack fName
, dbtCsvNoExportData = Just id
, dbtCsvHeader = const . return $ headerOrder (error "headerOrder" :: csv)
}
@ -615,14 +628,17 @@ cellAttrs = dbCell . _1
cellContents :: IsDBTable m x => Lens' (DBCell m x) (WriterT x m Widget)
cellContents = dbCell . _2
instance Monoid' x => IsDBTable (HandlerT UniWorX IO) x where
data DBParams (HandlerT UniWorX IO) x = DBParamsWidget
type DBResult (HandlerT UniWorX IO) x = (x, Widget)
-- type DBResult' (WidgetT UniWorX IO) () = ()
addCellClass :: (IsDBTable m x, PathPiece t) => t -> DBCell m x -> DBCell m x
addCellClass = over cellAttrs . Yesod.addClass . toPathPiece
data DBCell (HandlerT UniWorX IO) x = WidgetCell
instance Monoid' x => IsDBTable (HandlerFor UniWorX) x where
data DBParams (HandlerFor UniWorX) x = DBParamsWidget
type DBResult (HandlerFor UniWorX) x = (x, Widget)
-- type DBResult' (WidgetFor UniWorX) () = ()
data DBCell (HandlerFor UniWorX) x = WidgetCell
{ wgtCellAttrs :: [(Text, Text)]
, wgtCellContents :: WriterT x (HandlerT UniWorX IO) Widget
, wgtCellContents :: WriterT x (HandlerFor UniWorX) Widget
}
dbCell = iso
@ -632,25 +648,25 @@ instance Monoid' x => IsDBTable (HandlerT UniWorX IO) x where
-- dbWidget Proxy Proxy = iso (, ()) $ view _1
dbWidget _ _ = return . snd
dbHandler _ _ f = return . over _2 f
runDBTable _ _ _ = liftHandlerT
runDBTable _ _ _ = liftHandler
instance Monoid' x => Sem.Semigroup (DBCell (HandlerT UniWorX IO) x) where
instance Monoid' x => Sem.Semigroup (DBCell (HandlerFor UniWorX) x) where
(WidgetCell a c) <> (WidgetCell a' c') = WidgetCell (a <> a') ((<>) <$> c <*> c')
instance Monoid' x => Monoid (DBCell (HandlerT UniWorX IO) x) where
instance Monoid' x => Monoid (DBCell (HandlerFor UniWorX) x) where
mempty = WidgetCell mempty $ return mempty
mappend = (<>)
instance Default (DBParams (HandlerT UniWorX IO) x) where
instance Default (DBParams (HandlerFor UniWorX) x) where
def = DBParamsWidget
instance Monoid' x => IsDBTable (ReaderT SqlBackend (HandlerT UniWorX IO)) x where
data DBParams (ReaderT SqlBackend (HandlerT UniWorX IO)) x = DBParamsDB
type DBResult (ReaderT SqlBackend (HandlerT UniWorX IO)) x = (x, Widget)
instance Monoid' x => IsDBTable (ReaderT SqlBackend (HandlerFor UniWorX)) x where
data DBParams (ReaderT SqlBackend (HandlerFor UniWorX)) x = DBParamsDB
type DBResult (ReaderT SqlBackend (HandlerFor UniWorX)) x = (x, Widget)
data DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x = DBCell
data DBCell (ReaderT SqlBackend (HandlerFor UniWorX)) x = DBCell
{ dbCellAttrs :: [(Text, Text)]
, dbCellContents :: WriterT x (ReaderT SqlBackend (HandlerT UniWorX IO)) Widget
, dbCellContents :: WriterT x (ReaderT SqlBackend (HandlerFor UniWorX)) Widget
}
dbCell = iso
@ -659,17 +675,17 @@ instance Monoid' x => IsDBTable (ReaderT SqlBackend (HandlerT UniWorX IO)) x whe
dbWidget _ _ = return . snd
dbHandler _ _ f = return . over _2 f
-- runDBTable :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX) => ReaderT SqlBackend (HandlerT UniWorX IO) ((), Widget) -> m (Widget)
runDBTable _ _ _ = mapReaderT liftHandlerT
-- runDBTable :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX) => ReaderT SqlBackend (HandlerFor UniWorX) ((), Widget) -> m (Widget)
runDBTable _ _ _ = mapReaderT liftHandler
instance Monoid' x => Sem.Semigroup (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x) where
instance Monoid' x => Sem.Semigroup (DBCell (ReaderT SqlBackend (HandlerFor UniWorX)) x) where
(DBCell a c) <> (DBCell a' c') = DBCell (a <> a') ((<>) <$> c <*> c')
instance Monoid' x => Monoid (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x) where
instance Monoid' x => Monoid (DBCell (ReaderT SqlBackend (HandlerFor UniWorX)) x) where
mempty = DBCell mempty $ return mempty
mappend = (<>)
instance Default (DBParams (ReaderT SqlBackend (HandlerT UniWorX IO)) x) where
instance Default (DBParams (ReaderT SqlBackend (HandlerFor UniWorX)) x) where
def = DBParamsDB
data DBParamsFormIdent where
@ -685,29 +701,29 @@ unDBParamsFormIdent DBTable{dbtIdent} DBParamsFormTableIdent = Just $ toP
unDBParamsFormIdent _ (DBParamsFormOverrideIdent x) = Just $ toPathPiece x
unDBParamsFormIdent _ DBParamsFormNoIdent = Nothing
instance Monoid' x => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x where
data DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x = forall a. DBParamsForm
instance Monoid' x => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) x where
data DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) x = forall a. DBParamsForm
{ dbParamsFormMethod :: StdMethod
, dbParamsFormAction :: Maybe (SomeRoute UniWorX)
, dbParamsFormAttrs :: [(Text, Text)]
, dbParamsFormSubmit :: FormSubmitType
, dbParamsFormAdditional :: Form a
, dbParamsFormEvaluate :: forall m' a' x'. (MonadHandler m', HandlerSite m' ~ UniWorX, MonadResource m') => (Html -> MForm (HandlerT UniWorX IO) (FormResult a', x')) -> m' ((FormResult a', x'), Enctype)
, dbParamsFormEvaluate :: forall m' a' x'. (MonadHandler m', HandlerSite m' ~ UniWorX, MonadResource m') => (Html -> MForm (HandlerFor UniWorX) (FormResult a', x')) -> m' ((FormResult a', x'), Enctype)
, dbParamsFormResult :: Lens' x (FormResult a)
, dbParamsFormIdent :: DBParamsFormIdent
}
type DBResult (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x = (x, Widget)
-- type DBResult' (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = (FormResult a, Enctype)
type DBResult (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) x = (x, Widget)
-- type DBResult' (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) (FormResult a) = (FormResult a, Enctype)
data DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x = forall a. FormCell
data DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) x = forall a. FormCell
{ formCellAttrs :: [(Text, Text)]
, formCellContents :: WriterT x (MForm (HandlerT UniWorX IO)) (FormResult a, Widget)
, formCellContents :: WriterT x (MForm (HandlerFor UniWorX)) (FormResult a, Widget)
, formCellLens :: Lens' x (FormResult a)
}
-- dbCell :: Iso'
-- (DBCell (RWST ... ... ... (HandlerT UniWorX IO)) x)
-- ([(Text, Text)], WriterT x (RWST ... ... ... (HandlerT UniWorX IO)) Widget)
-- (DBCell (RWST ... ... ... (HandlerFor UniWorX)) x)
-- ([(Text, Text)], WriterT x (RWST ... ... ... (HandlerFor UniWorX)) Widget)
dbCell = iso
(\FormCell{..} -> (formCellAttrs, formCellContents >>= uncurry ($>) . over _1 (tell . (flip $ set formCellLens) mempty)))
(\(attrs, mkWidget) -> FormCell attrs ((pure (), ) <$> mkWidget) $ lens (\_ -> pure ()) (\s _ -> s))
@ -716,7 +732,7 @@ instance Monoid' x => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) En
-- ((,) <$> ((,) <$> view (_2._1) <*> view _1) <*> view (_2._2))
dbWidget _ _ = return . snd
dbHandler _ _ f = return . over _2 f
-- runDBTable :: forall m' k'. (MonadHandler m', HandlerSite m' ~ UniWorX, ToJSON k') => DBTable (MForm (HandlerT UniWorX IO)) x -> PaginationInput -> [k'] -> (MForm (HandlerT UniWorX IO)) (x, Widget) -> ReaderT SqlBackend m' (x, Widget)
-- runDBTable :: forall m' k'. (MonadHandler m', HandlerSite m' ~ UniWorX, ToJSON k') => DBTable (MForm (HandlerFor UniWorX)) x -> PaginationInput -> [k'] -> (MForm (HandlerFor UniWorX)) (x, Widget) -> ReaderT SqlBackend m' (x, Widget)
runDBTable dbtable@(DBTable{ dbtParams = dbtParams@DBParamsForm{..} }) pi pKeys
= fmap ((\(res, (wdgt, x)) -> (x & dbParamsFormResult .~ res, wdgt)) . view _1)
. dbParamsFormEvaluate
@ -734,19 +750,19 @@ instance Monoid' x => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) En
adjResult _ = FormFailure $ pure reasonTxt
return $ over (_1 . dbParamsFormResult) adjResult result
instance Monoid' x => Default (DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x) where
instance Default (DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) x) where
def = DBParamsForm
{ dbParamsFormMethod = POST
, dbParamsFormAction = Nothing
, dbParamsFormAttrs = []
, dbParamsFormSubmit = FormSubmit
, dbParamsFormAdditional = \_ -> return (pure (), mempty)
, dbParamsFormEvaluate = liftHandlerT . runFormPost
, dbParamsFormEvaluate = liftHandler . runFormPost
, dbParamsFormResult = lens (\_ -> pure ()) (\s _ -> s)
, dbParamsFormIdent = def
}
dbParamsFormWrap :: Monoid' x => DBTable (MForm (HandlerT UniWorX IO)) x -> DBParams (MForm (HandlerT UniWorX IO)) x -> (Html -> MForm (HandlerT UniWorX IO) (x, Widget)) -> (Html -> MForm (HandlerT UniWorX IO) (x, Widget))
dbParamsFormWrap :: Monoid' x => DBTable (MForm (HandlerFor UniWorX)) x -> DBParams (MForm (HandlerFor UniWorX)) x -> (Html -> MForm (HandlerFor UniWorX) (x, Widget)) -> (Html -> MForm (HandlerFor UniWorX) (x, Widget))
dbParamsFormWrap DBTable{ dbtIdent } DBParamsForm{..} tableForm frag = do
let form = mappend <$> tableForm frag <*> (fmap (over _1 $ (flip $ set dbParamsFormResult) mempty) $ dbParamsFormAdditional mempty)
((res, fWidget), enctype) <- listen form
@ -781,10 +797,10 @@ addPreviousHiddenField DBTable{ dbtIdent } pKeys form fragment = do
wIdent :: Text -> Text
wIdent = toPathPiece . WithIdent dbtIdent
instance Monoid' x => Sem.Semigroup (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x) where
instance Monoid' x => Sem.Semigroup (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) x) where
(FormCell attrs c l) <> (FormCell attrs' c' l') = FormCell (attrs <> attrs') ((\(a, w) (a', w') -> ((,) <$> a <*> a', w <> w')) <$> c <*> c') (lens (liftA2 (,) <$> view l <*> view l') (\s as -> s & l .~ (fst <$> as) & l' .~ (snd <$> as)))
instance Monoid' x => Monoid (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x) where
instance Monoid' x => Monoid (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) x) where
mempty = FormCell mempty (return mempty) $ lens (\_ -> pure ()) (\s _ -> s)
mappend = (<>)
@ -839,7 +855,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
(filterRes'@((filterRes, _), _)) <- runFormGet . identifyForm FIDDBTableFilter . addPIHiddenField dbtable (prevPi & _piFilter .~ Nothing & _piPage .~ Nothing & _piLimit .~ (formResult' pagesizeRes <|> piLimit prevPi)) . renderAForm FormDBTableFilter $ dbtFilterUI (piFilter prevPi)
(pagesizeRes'@((pagesizeRes, _), _)) <- lift . runFormGet . identifyForm FIDDBTablePagesize . addPIHiddenField dbtable (prevPi & _piPage .~ Nothing & _piLimit .~ Nothing & _piFilter .~ (formResult' filterRes <|> piFilter prevPi)) . renderAForm FormDBTablePagesize $
areq (pagesizeField referencePagesize) (fslI MsgDBTablePagesize & addName (wIdent "pagesize") & addClass "select--pagesize") (Just referencePagesize)
areq (pagesizeField referencePagesize) (fslI MsgDBTablePagesize & addName (wIdent "pagesize") & addClass ("select--pagesize" :: Text)) (Just referencePagesize)
return (filterRes', pagesizeRes')
let
@ -863,8 +879,8 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
mapM_ (addMessageI Warning) errs
Just currentRoute <- getCurrentRoute -- `dbTable` should never be called from a 404-handler
getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
currentRoute <- fromMaybe (error "dbTable called from 404-handler") <$> getCurrentRoute
getParams <- liftHandler $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
let
tblLink :: (QueryText -> QueryText) -> SomeRoute UniWorX
tblLink f = SomeRoute . (currentRoute, ) . over (mapped . _2) (fromMaybe Text.empty) $ (f . substPi . setParam "_hasdata" Nothing) getParams
@ -964,15 +980,17 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
DBCsvExport{..}
| Just DBTCsvEncode{..} <- dbtCsvEncode
, Just exportData <- fromDynamic dbCsvExportData -> do
hdr <- dbtCsvHeader $ Just exportData
let ensureExtension ext fName = bool (addExtension ext) id (ext `isExtensionOf` fName) fName
setContentDisposition' . Just $ ensureExtension (unpack extensionCsv) dbtCsvName
sendResponse <=< liftHandlerT . respondCsvDB $ C.sourceList (zip currentKeys rows) .| dbtCsvDoEncode exportData >> lift E.transactionSave
sendResponse <=< liftHandler . respondCsvDB hdr $ C.sourceList (zip currentKeys rows) .| dbtCsvDoEncode exportData >> lift E.transactionSave
DBCsvImport{..}
| Just (DBTCsvDecode{ dbtCsvClassifyAction = dbtCsvClassifyAction :: csvAction -> csvActionClass
| Just DBTCsvEncode{..} <- dbtCsvEncode
, Just (DBTCsvDecode{ dbtCsvClassifyAction = dbtCsvClassifyAction :: csvAction -> csvActionClass
, ..
} :: DBTCsvDecode r' k' csv) <- dbtCsvDecode -> do
let existing = Map.fromList $ zip currentKeys rows
sourceDiff :: Source (StateT (Map k' csv) (YesodDB UniWorX)) (DBCsvDiff r' csv k')
sourceDiff :: ConduitT () (DBCsvDiff r' csv k') (StateT (Map k' csv) (YesodDB UniWorX)) ()
sourceDiff = do
let
toDiff :: csv -> StateT (Map k' csv) (YesodDB UniWorX) (DBCsvDiff r' csv k')
@ -1001,7 +1019,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
importCsv = do
let
dbtCsvComputeActions' :: Sink (DBCsvDiff r' csv k') (YesodDB UniWorX) (Map csvActionClass (Set csvAction))
dbtCsvComputeActions' :: ConduitT (DBCsvDiff r' csv k') Void (YesodDB UniWorX) (Map csvActionClass (Set csvAction))
dbtCsvComputeActions' = do
let innerAct = awaitForever $ \x
-> let doHandle
@ -1017,7 +1035,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
addMessageI Info MsgCsvImportUnnecessary
redirect $ tblLink id
liftHandlerT . (>>= sendResponse) $
liftHandler . (>>= sendResponse) $
siteLayoutMsg MsgCsvImportConfirmationHeading $ do
setTitleI MsgCsvImportConfirmationHeading
@ -1033,14 +1051,14 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
csvActionCheckBox :: [(Text, Text)] -> csvAction -> Widget
csvActionCheckBox vAttrs act = do
let
sJsonField :: Field (HandlerT UniWorX IO) csvAction
sJsonField :: Field (HandlerFor UniWorX) csvAction
sJsonField = secretJsonField' $ \theId name attrs val _isReq ->
[whamlet|
$newline never
<input id=#{theId} *{attrs} type=checkbox name=#{name} value=#{either id id val} :defaultChecked (dbtCsvClassifyAction act):checked>
|]
fieldView sJsonField (actionIdent act) (toPathPiece PostDBCsvImportAction) vAttrs (Right act) False
(csvImportConfirmForm', csvImportConfirmEnctype) <- liftHandlerT . generateFormPost . identifyForm FIDDBTableCsvImportConfirm $ \csrf -> return (error "No meaningful FormResult", $(widgetFile "csv-import-confirmation"))
(csvImportConfirmForm', csvImportConfirmEnctype) <- liftHandler . generateFormPost . identifyForm FIDDBTableCsvImportConfirm $ \csrf -> return (error "No meaningful FormResult", $(widgetFile "csv-import-confirmation"))
let csvImportConfirmForm = wrapForm' BtnCsvImportConfirm csvImportConfirmForm' FormSettings
{ formMethod = POST
, formAction = Just $ tblLink id
@ -1052,14 +1070,14 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
$(widgetFile "csv-import-confirmation-wrapper")
let defaultHeaderOrder = headerOrder (error "not to be forced" :: csv)
hdr <- dbtCsvHeader Nothing
catches importCsv
[ Catch.Handler $ \case
(DBCsvDuplicateKey{..} :: DBCsvException k')
-> liftHandlerT $ sendResponseStatus badRequest400 =<< do
-> liftHandler $ sendResponseStatus badRequest400 =<< do
mr <- getMessageRender
let offendingCsv = CsvRendered defaultHeaderOrder [ dbCsvDuplicateKeyRowA, dbCsvDuplicateKeyRowB ]
let offendingCsv = CsvRendered hdr [ dbCsvDuplicateKeyRowA, dbCsvDuplicateKeyRowB ]
heading = ErrorResponseTitle $ InvalidArgs [mr MsgDBCsvDuplicateKey]
siteLayoutMsg heading $ do
@ -1070,10 +1088,10 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
^{offendingCsv}
|]
(DBCsvException{..} :: DBCsvException k')
-> liftHandlerT $ sendResponseStatus badRequest400 =<< do
-> liftHandler $ sendResponseStatus badRequest400 =<< do
mr <- getMessageRender
let offendingCsv = CsvRendered defaultHeaderOrder [ dbCsvExceptionRow ]
let offendingCsv = CsvRendered hdr [ dbCsvExceptionRow ]
heading = ErrorResponseTitle $ InvalidArgs [mr MsgDBCsvException]
siteLayoutMsg heading $ do
@ -1098,7 +1116,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
. setParam (wIdent "page") Nothing
. setParam (wIdent "pagination") Nothing
table' :: HandlerSite m ~ UniWorX => WriterT x m Widget
table' :: WriterT x m Widget
table' = let
columnCount :: Int64
columnCount = olength64 $ getColonnade dbtColonnade
@ -1182,7 +1200,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
where
tblLayout :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => Widget -> m' Html
tblLayout tbl' = do
tbl <- liftHandlerT $ widgetToPageContent tbl'
tbl <- liftHandler $ widgetToPageContent tbl'
withUrlRenderer $(hamletFile "templates/table/layout-standalone.hamlet")
setParams :: Text -> [Text] -> QueryText -> QueryText
@ -1191,26 +1209,27 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
setParam :: Text -> Maybe Text -> QueryText -> QueryText
setParam key = setParams key . maybeToList
dbTableWidget :: Monoid' x => PSValidator (HandlerT UniWorX IO) x -> DBTable (HandlerT UniWorX IO) x
-> DB (DBResult (HandlerT UniWorX IO) x)
dbTableWidget :: Monoid x
=> PSValidator (HandlerFor UniWorX) x
-> DBTable (HandlerFor UniWorX) x
-> DB (DBResult (HandlerFor UniWorX) x)
dbTableWidget = dbTable
dbTableWidget' :: PSValidator (HandlerT UniWorX IO) () -> DBTable (HandlerT UniWorX IO) () -> DB Widget
dbTableWidget' :: PSValidator (HandlerFor UniWorX) ()
-> DBTable (HandlerFor UniWorX) ()
-> DB Widget
dbTableWidget' = fmap (fmap snd) . dbTable
widgetColonnade :: (Headedness h, Monoid' x)
=> Colonnade h r (DBCell (HandlerT UniWorX IO) x)
-> Colonnade h r (DBCell (HandlerT UniWorX IO) x)
widgetColonnade :: Colonnade h r (DBCell (HandlerFor UniWorX) x)
-> Colonnade h r (DBCell (HandlerFor UniWorX) x)
widgetColonnade = id
formColonnade :: (Headedness h, Monoid' a)
=> Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a))
-> Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a))
formColonnade :: Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) (FormResult a))
-> Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) (FormResult a))
formColonnade = id
dbColonnade :: (Headedness h, Monoid' x)
=> Colonnade h r (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x)
-> Colonnade h r (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x)
dbColonnade :: Colonnade h r (DBCell (ReaderT SqlBackend (HandlerFor UniWorX)) x)
-> Colonnade h r (DBCell (ReaderT SqlBackend (HandlerFor UniWorX)) x)
dbColonnade = id
pagesizeOptions :: PagesizeLimit -- ^ Current/previous value
@ -1271,17 +1290,17 @@ anchorCell' :: ( IsDBTable m a
-> (r -> DBCell m a)
anchorCell' mkRoute mkWidget val = anchorCell (mkRoute val) (mkWidget val)
anchorCellM :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a, HandlerSite m ~ UniWorX) => WidgetT UniWorX IO url -> wgt -> DBCell m a
anchorCellM :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a) => WidgetFor UniWorX url -> wgt -> DBCell m a
anchorCellM routeM widget = anchorCellM' routeM id (const widget)
anchorCellM' :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a, HandlerSite m ~ UniWorX) => WidgetT UniWorX IO x -> (x -> url) -> (x -> wgt) -> DBCell m a
anchorCellM' :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a) => WidgetFor UniWorX x -> (x -> url) -> (x -> wgt) -> DBCell m a
anchorCellM' xM x2route x2widget = linkEitherCellM' xM x2route (x2widget, x2widget)
-- | Variant of `anchorCell` that displays different widgets depending whether the route is authorized for current user
linkEitherCell :: (HasRoute UniWorX url, ToWidget UniWorX wgt, ToWidget UniWorX wgt', IsDBTable m a, HandlerSite m ~ UniWorX) => url -> (wgt, wgt') -> DBCell m a
linkEitherCell :: (HasRoute UniWorX url, ToWidget UniWorX wgt, ToWidget UniWorX wgt', IsDBTable m a) => url -> (wgt, wgt') -> DBCell m a
linkEitherCell = linkEitherCellM . return
linkEitherCellM :: (HasRoute UniWorX url, ToWidget UniWorX wgt, ToWidget UniWorX wgt', IsDBTable m a, HandlerSite m ~ UniWorX) => WidgetT UniWorX IO url -> (wgt, wgt') -> DBCell m a
linkEitherCellM :: (HasRoute UniWorX url, ToWidget UniWorX wgt, ToWidget UniWorX wgt', IsDBTable m a) => WidgetFor UniWorX url -> (wgt, wgt') -> DBCell m a
linkEitherCellM routeM (widgetAuth,widgetUnauth) = linkEitherCellM' routeM id (const widgetAuth, const widgetUnauth)
linkEitherCellM' :: forall m url wgt wgt' a x.
@ -1289,16 +1308,15 @@ linkEitherCellM' :: forall m url wgt wgt' a x.
, ToWidget UniWorX wgt
, ToWidget UniWorX wgt'
, IsDBTable m a
, HandlerSite m ~ UniWorX
)
=> WidgetT UniWorX IO x -> (x -> url) -> (x -> wgt, x -> wgt') -> DBCell m a
=> WidgetFor UniWorX x -> (x -> url) -> (x -> wgt, x -> wgt') -> DBCell m a
linkEitherCellM' xM x2route (x2widgetAuth,x2widgetUnauth) = cell $ do
x <- xM
let route = x2route x
widget, widgetUnauth :: WidgetT UniWorX IO ()
widget, widgetUnauth :: Widget
widget = toWidget $ x2widgetAuth x
widgetUnauth = toWidget $ x2widgetUnauth x
authResult <- liftHandlerT $ isAuthorized (urlRoute route) False
authResult <- liftHandler $ isAuthorized (urlRoute route) False
linkUrl <- toTextUrl route
case authResult of
Authorized -> $(widgetFile "table/cell/link") -- show allowed link
@ -1324,17 +1342,17 @@ instance Ord i => Monoid (DBFormResult i a r) where
mempty = DBFormResult Map.empty
mappend = (<>)
getDBFormResult :: forall r i a. Ord i => (r -> a) -> DBFormResult i a r -> Map i a
getDBFormResult :: forall r i a. (r -> a) -> DBFormResult i a r -> Map i a
getDBFormResult initial (DBFormResult m) = Map.map (\(r, f) -> f $ initial r) m
formCell :: forall x r i a. (Ord i, Monoid x)
formCell :: forall x r i a. Monoid x
=> Lens' x (FormResult (DBFormResult i a (DBRow r))) -- ^ lens focussing on the form result within the larger DBResult; @id@ iff the form delivers the only result of the table
-> (DBRow r -> MForm (HandlerT UniWorX IO) i) -- ^ generate row identfifiers for use in form result
-> (DBRow r -> (forall p. PathPiece p => p -> Text) -> MForm (HandlerT UniWorX IO) (FormResult (a -> a), Widget)) -- ^ Given the row data and a callback to make an input name suitably unique generate the `MForm`
-> (DBRow r -> DBCell (MForm (HandlerT UniWorX IO)) x)
-> (DBRow r -> MForm (HandlerFor UniWorX) i) -- ^ generate row identfifiers for use in form result
-> (DBRow r -> (forall p. PathPiece p => p -> Text) -> MForm (HandlerFor UniWorX) (FormResult (a -> a), Widget)) -- ^ Given the row data and a callback to make an input name suitably unique generate the `MForm`
-> (DBRow r -> DBCell (MForm (HandlerFor UniWorX)) x)
formCell formCellLens genIndex genForm input@(DBRow{dbrKey}) = FormCell
{ formCellAttrs = []
, formCellContents = do -- MForm (HandlerT UniWorX IO) (FormResult (Map i (Endo a)), Widget)
, formCellContents = do -- MForm (HandlerFor UniWorX) (FormResult (Map i (Endo a)), Widget)
i <- lift $ genIndex input
hashKey <- LBS.toStrict . B.encode <$> cryptoIDKey return
let
@ -1354,11 +1372,11 @@ formCell formCellLens genIndex genForm input@(DBRow{dbrKey}) = FormCell
dbRow :: forall h r m a. (Headedness h, IsDBTable m a) => Colonnade h (DBRow r) (DBCell m a)
dbRow = Colonnade.singleton (headednessPure $ i18nCell MsgNrColumn) $ \DBRow{ dbrIndex } -> textCell $ tshow dbrIndex
dbSelect :: forall x h r i a. (Headedness h, Ord i, PathPiece i, Monoid' x)
dbSelect :: forall x h r i a. (Headedness h, Monoid' x)
=> Lens' x (FormResult (DBFormResult i a (DBRow r)))
-> Setter' a Bool
-> (DBRow r -> MForm (HandlerT UniWorX IO) i)
-> Colonnade h (DBRow r) (DBCell (MForm (HandlerT UniWorX IO)) x)
-> (DBRow r -> MForm (HandlerFor UniWorX) i)
-> Colonnade h (DBRow r) (DBCell (MForm (HandlerFor UniWorX)) x)
-- dbSelect resLens selLens genIndex = Colonnade.singleton (headednessPure $ i18nCell MsgSelectColumn) $ formCell resLens genIndex genForm
dbSelect resLens selLens genIndex = Colonnade.singleton (headednessPure $ mempty) $ formCell resLens genIndex genForm
where

3
src/Handler/Utils/Table/Pagination/CsvColumnExplanations.hs
View File

@ -57,8 +57,7 @@ instance GCsvColumnsExplained a => GCsvColumnsExplained (M1 C c a) where
-- | Instance to ensure that you cannot derive DefaultOrdered for
-- constructors without selectors.
instance CsvColumnsExplained (M1 S ('MetaSel 'Nothing srcpk srcstr decstr) a ())
=> GCsvColumnsExplained (M1 S ('MetaSel 'Nothing srcpk srcstr decstr) a)
instance GCsvColumnsExplained (M1 S ('MetaSel 'Nothing srcpk srcstr decstr) a)
where
gCsvColumnsExplanations _ _ =
error "You cannot derive CsvColumnsExplanations for constructors without selectors."

1
src/Handler/Utils/Table/Pagination/Types.hs
View File

@ -18,6 +18,7 @@ import Data.CaseInsensitive (CI)
import Data.Aeson (FromJSON, ToJSON, FromJSONKey, ToJSONKey)
{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}
newtype FilterKey = FilterKey { _unFilterKey :: CI Text }
deriving (Show, Read, Generic)

24
src/Handler/Utils/Tokens.hs
View File

@ -17,7 +17,7 @@ maybeBearerToken = runMaybeT $ catchIfMaybeT cPred requireBearerToken
]
requireBearerToken :: (MonadHandler m, HandlerSite m ~ UniWorX) => m (BearerToken UniWorX)
requireBearerToken = liftHandlerT $ do
requireBearerToken = liftHandler $ do
token <- exceptT (guardAuthResult >=> error "askToken should not throw `Authorized`") return askTokenUnsafe
mAuthId <- maybeAuthId
currentRoute <- maybe (permissionDeniedI MsgUnauthorizedToken404) return =<< getCurrentRoute
@ -25,18 +25,24 @@ requireBearerToken = liftHandlerT $ do
guardAuthResult <=< runDB $ validateToken mAuthId currentRoute isWrite token
return token
maybeCurrentTokenRestrictions, requireCurrentTokenRestrictions :: ( MonadHandler m
, HandlerSite m ~ UniWorX
, MonadCatch m
, MonadLogger m
, FromJSON a
, ToJSON a
)
=> m (Maybe a)
requireCurrentTokenRestrictions :: ( MonadHandler m
, HandlerSite m ~ UniWorX
, FromJSON a
, ToJSON a
)
=> m (Maybe a)
requireCurrentTokenRestrictions = runMaybeT $ do
token <- requireBearerToken
route <- MaybeT getCurrentRoute
hoistMaybe $ token ^? _tokenRestrictionIx route
maybeCurrentTokenRestrictions :: ( MonadHandler m
, HandlerSite m ~ UniWorX
, MonadCatch m
, FromJSON a
, ToJSON a
)
=> m (Maybe a)
maybeCurrentTokenRestrictions = runMaybeT $ do
token <- MaybeT maybeBearerToken
route <- MaybeT getCurrentRoute

94
src/Handler/Utils/Zip.hs
View File

@ -30,6 +30,15 @@ import Data.List (dropWhileEnd)
import qualified Data.Map as Map
import qualified Data.Conduit.List as C
import Data.Encoding ( decodeStrictByteStringExplicit
, encodeStrictByteStringExplicit
)
import Data.Encoding.CP437
import qualified Data.Char as Char
typeZip :: ContentType
typeZip = "application/zip"
@ -45,30 +54,33 @@ instance Default ZipInfo where
}
consumeZip :: ( MonadBase b m
, PrimMonad b
consumeZip :: forall b m.
( MonadThrow b
, MonadThrow m
) => ConduitM ByteString File m ZipInfo
consumeZip = unZipStream `fuseUpstream` consumeZip'
, MonadBase b m
, PrimMonad b
)
=> ConduitT ByteString File m ZipInfo
consumeZip = transPipe liftBase unZipStream `fuseUpstream` consumeZip'
where
consumeZip' :: ( MonadThrow m
) => Conduit (Either ZipEntry ByteString) m File
consumeZip' :: ConduitT (Either ZipEntry ByteString) File m ()
consumeZip' = do
input <- await
case input of
Nothing -> return ()
Just (Right _) -> throw $ userError "Data chunk in unexpected place when parsing ZIP"
Just (Right _) -> throwM $ userError "Data chunk in unexpected place when parsing ZIP"
Just (Left ZipEntry{..}) -> do
contentChunks <- toConsumer accContents
zipEntryName' <- decodeZipEntryName zipEntryName
let
fileTitle = dropWhile isPathSeparator . dropTrailingPathSeparator . normalise $ makeValid zipEntryName
fileTitle = dropWhile isPathSeparator . dropTrailingPathSeparator . normalise $ makeValid zipEntryName'
fileModified = localTimeToUTC utc zipEntryTime
fileContent
| hasTrailingPathSeparator zipEntryName = Nothing
| hasTrailingPathSeparator zipEntryName' = Nothing
| otherwise = Just $ mconcat contentChunks
yield File{..}
consumeZip'
accContents :: Monad m => Sink (Either a b) m [b]
accContents :: ConduitT (Either a b') Void m [b']
accContents = do
input <- await
case input of
@ -76,12 +88,15 @@ consumeZip = unZipStream `fuseUpstream` consumeZip'
Just (Left x) -> [] <$ leftover (Left x)
_ -> return []
produceZip :: ( MonadBase b m
, PrimMonad b
, MonadThrow m
) => ZipInfo
-> Conduit File m ByteString
produceZip info = mapC toZipData =$= void (zipStream zipOptions)
produceZip :: forall b m.
( MonadThrow b
, MonadThrow m
, MonadBase b m
, PrimMonad b
)
=> ZipInfo
-> ConduitT File ByteString m ()
produceZip info = C.map toZipData .| transPipe liftBase (void $ zipStream zipOptions)
where
zipOptions = ZipOptions
{ zipOpt64 = True
@ -89,35 +104,60 @@ produceZip info = mapC toZipData =$= void (zipStream zipOptions)
, zipOptInfo = info
}
toZipData :: Monad m => File -> (ZipEntry, ZipData m)
toZipData f@File{..} = ((toZipEntry f){ zipEntrySize = fromIntegral . ByteString.length <$> fileContent }, maybe mempty (ZipDataByteString . Lazy.ByteString.fromStrict) fileContent)
toZipData :: File -> (ZipEntry, ZipData b)
toZipData f@File{..} =
let zData = maybe mempty (ZipDataByteString . Lazy.ByteString.fromStrict) fileContent
zEntry = (toZipEntry f){ zipEntrySize = fromIntegral . ByteString.length <$> fileContent }
in (zEntry, zData)
toZipEntry :: File -> ZipEntry
toZipEntry File{..} = ZipEntry
{ zipEntryName = bool (dropWhileEnd isPathSeparator) addTrailingPathSeparator isDir . normalise . makeValid $ fileTitle
, zipEntryTime = utcToLocalTime utc fileModified
}
toZipEntry File{..} = ZipEntry{..}
where
isDir = isNothing fileContent
zipEntryName = encodeZipEntryName . bool (dropWhileEnd isPathSeparator) addTrailingPathSeparator isDir . normalise $ makeValid fileTitle
zipEntryTime = utcToLocalTime utc fileModified
zipEntrySize = Nothing
zipEntryExternalAttributes = Nothing
modifyFileTitle :: Monad m => (FilePath -> FilePath) -> Conduit File m File
modifyFileTitle :: Monad m => (FilePath -> FilePath) -> ConduitT File File m ()
modifyFileTitle f = mapC $ \x@File{..} -> x{ fileTitle = f fileTitle }
-- Takes FileInfo and if it is a ZIP-Archive, extract files, otherwiese yield fileinfo
sourceFiles :: (MonadLogger m, MonadResource m, MonadThrow m, MonadIO m) => FileInfo -> Source m File
sourceFiles :: (MonadLogger m, MonadResource m, MonadThrow m, MonadBase IO m) => FileInfo -> ConduitT () File m ()
sourceFiles fInfo
| ((==) `on` simpleContentType) mimeType typeZip = do
$logInfoS "sourceFiles" "Unpacking ZIP"
fileSource fInfo =$= void consumeZip
fileSource fInfo .| void consumeZip
| otherwise = do
$logDebugS "sourceFiles" [st|Not unpacking file of type #{decodeUtf8 mimeType}|]
yieldM $ acceptFile fInfo
where
mimeType = mimeLookup $ fileName fInfo
acceptFile :: (MonadResource m, MonadThrow m, MonadIO m) => FileInfo -> m File
acceptFile :: MonadResource m => FileInfo -> m File
acceptFile fInfo = do
let fileTitle = dropWhile isPathSeparator . dropTrailingPathSeparator . normalise . unpack $ fileName fInfo
fileModified <- liftIO getCurrentTime
fileContent <- Just <$> runConduit (fileSource fInfo =$= foldC)
fileContent <- fmap Just . runConduit $ fileSource fInfo .| foldC
return File{..}
decodeZipEntryName :: MonadThrow m => Either Text ByteString -> m FilePath
-- ^ Extract the filename from a 'ZipEntry' doing decoding along the way.
--
-- Throws 'Data.Encoding.Exception.DecodingException's.
decodeZipEntryName = \case
Left t -> return $ unpack t
Right cp437 -> either throwM return $ decodeStrictByteStringExplicit CP437 cp437
encodeZipEntryName :: FilePath -> Either Text ByteString
-- ^ Encode a filename for use in a 'ZipEntry', encodes as
-- 'Data.Encoding.UTF8.UTF8' iff the given path contains non-ascii characters.
--
-- Does not do any normalisation (in particular this function does not ensure
-- that the 'FilePath' does not start with a slash).
encodeZipEntryName path = fromMaybe (Left $ pack path) $ do
guard $ all Char.isAscii path
either (const mzero) (return . Right) $ encodeStrictByteStringExplicit CP437 path

19
src/Import/NoModel.hs
View File

@ -12,11 +12,15 @@ import ClassyPrelude.Yesod as Import
, Proxy
, foldlM
, static
, boolField, identifyForm
, boolField, identifyForm, addClass
, HasHttpManager(..)
, embed
, try, embed, catches, handle, catch, bracket, bracketOnError, bracket_, catchJust, finally, handleJust, mask, mask_, onException, tryJust, uninterruptibleMask, uninterruptibleMask_
, fail
)
import UnliftIO.Async.Utils as Import
import Model.Types.TH.JSON as Import
import Model.Types.TH.Wordlist as Import
@ -44,7 +48,7 @@ import Text.Shakespeare.Text as Import hiding (text, stext)
import Data.Universe as Import
import Data.Universe.TH as Import
import Data.Pool as Import (Pool)
import UnliftIO.Pool as Import (Pool)
import Network.HaskellNet.SMTP as Import (SMTPConnection)
import Data.Data as Import (Data)
@ -80,6 +84,14 @@ import Control.Monad.Trans.Reader as Import
( reader, Reader, runReader, mapReader, withReader
, ReaderT(..), mapReaderT, withReaderT
)
import Control.Monad.Trans.State as Import
( state, State, runState, mapState, withState
, StateT(..), mapStateT, withStateT
)
import Control.Monad.Base as Import
import Control.Monad.Catch as Import hiding (Handler(..))
import Control.Monad.Trans.Control as Import hiding (embed)
import Control.Monad.Fail as Import
import Jose.Jwt as Import (Jwt)
@ -101,7 +113,6 @@ import Algebra.Lattice as Import hiding (meet, join)
import Data.Proxy as Import (Proxy(..))
import Language.Haskell.TH.Instances as Import ()
import Data.List.NonEmpty.Instances as Import ()
import Data.NonNull.Instances as Import ()
import Data.Monoid.Instances as Import ()
import Data.Maybe.Instances as Import ()
@ -141,7 +152,7 @@ import Control.Lens as Import
hiding ( (<.>)
, universe
, cons, uncons, snoc, unsnoc, (<|)
, Index, index, (<.)
, Index, index, (<.), (.>)
)
import Control.Lens.Extras as Import (is)
import Data.Set.Lens as Import

58
src/Jobs.hs
View File

@ -44,7 +44,7 @@ import Control.Monad.Trans.RWS.Lazy (RWST, mapRWST, evalRWST)
import qualified Control.Monad.State.Class as State
import Control.Monad.Writer.Class (MonadWriter(..))
import Control.Monad.Reader.Class (MonadReader(..))
import Control.Monad.Trans.Resource (MonadResourceBase, runResourceT)
import Control.Monad.Trans.Resource (runResourceT)
import Control.Monad.Trans.Maybe (MaybeT(..))
import Control.Monad.Trans.Cont (ContT(..), callCC)
import Control.Monad.Random.Lazy (evalRandTIO, mapRandT)
@ -55,6 +55,8 @@ import Data.Time.Zones
import Control.Concurrent.STM (retry)
import Control.Concurrent.STM.Delay
import UnliftIO.Concurrent (forkIO)
import Jobs.Handler.SendNotification
import Jobs.Handler.SendTestEmail
@ -82,7 +84,8 @@ instance Exception JobQueueException
handleJobs :: ( MonadResource m
, MonadLoggerIO m
, MonadLogger m
, MonadUnliftIO m
)
=> UniWorX -> m ()
-- | Spawn a set of workers that read control commands from `appJobCtl` and address them as they come in
@ -92,12 +95,11 @@ handleJobs :: ( MonadResource m
handleJobs foundation@UniWorX{..}
| foundation ^. _appJobWorkers == 0 = return ()
| otherwise = do
logger <- askLoggerIO
let runInIO = flip runLoggingT logger . runResourceT
UnliftIO{..} <- askUnliftIO
jobPoolManager <- allocateLinkedAsync . runInIO $ manageJobPool foundation
jobPoolManager <- allocateLinkedAsync . unliftIO $ manageJobPool foundation
jobCron <- allocateLinkedAsync . runInIO $ manageCrontab foundation
jobCron <- allocateLinkedAsync . unliftIO $ manageCrontab foundation
let jobWorkers = Map.empty
jobWorkerName = const $ error "Unknown worker"
@ -109,11 +111,9 @@ handleJobs foundation@UniWorX{..}
, ..
}
manageJobPool, manageCrontab :: forall m.
( MonadResource m
, MonadLogger m
)
=> UniWorX -> m ()
manageCrontab :: forall m.
MonadResource m
=> UniWorX -> m ()
manageCrontab foundation@UniWorX{..} = do
context <- atomically . fmap jobContext $ readTMVar appJobState
let awaitTermination = atomically $ do
@ -125,7 +125,12 @@ manageCrontab foundation@UniWorX{..} = do
writeJobCtlBlock JobCtlDetermineCrontab
evalRWST (forever execCrontab) context HashMap.empty
manageJobPool :: forall m.
( MonadResource m
, MonadLogger m
, MonadUnliftIO m
)
=> UniWorX -> m ()
manageJobPool foundation@UniWorX{..}
= flip runContT return . forever . join . atomically $ asum
[ spawnMissingWorkers
@ -138,6 +143,9 @@ manageJobPool foundation@UniWorX{..}
spawnMissingWorkers, reapDeadWorkers, terminateGracefully :: STM (ContT () m ())
spawnMissingWorkers = do
shouldTerminate' <- readTMVar appJobState >>= fmap not . isEmptyTMVar . jobShutdown
guard $ not shouldTerminate'
oldState <- takeTMVar appJobState
let missing = num - Map.size (jobWorkers oldState)
guard $ missing > 0
@ -163,7 +171,7 @@ manageJobPool foundation@UniWorX{..}
$logInfoS logIdent "Started"
runConduit $ streamChan .| handleJobs' workerId
$logInfoS logIdent "Stopped"
worker <- allocateLinkedAsync runWorker
worker <- lift . lift $ allocateLinkedAsync runWorker
tell . Endo $ \cSt -> cSt
{ jobWorkers = Map.insert worker chan $ jobWorkers cSt
@ -199,28 +207,32 @@ manageJobPool foundation@UniWorX{..}
terminateGracefully = do
shouldTerminate <- readTMVar appJobState >>= fmap not . isEmptyTMVar . jobShutdown
guard shouldTerminate
oldState <- takeTMVar appJobState
guard $ 0 == Map.size (jobWorkers oldState)
return . callCC $ \terminate -> do
$logInfoS "JobPoolManager" "Shutting down"
terminate ()
stopJobCtl :: (MonadIO m, MonadBaseControl IO m) => UniWorX -> m ()
stopJobCtl :: MonadUnliftIO m => UniWorX -> m ()
-- ^ Stop all worker threads currently running
stopJobCtl UniWorX{appJobState} = do
didStop <- atomically $ do
jState <- tryReadTMVar appJobState
for jState $ \jSt'@JobState{jobShutdown} -> jSt' <$ tryPutTMVar jobShutdown ()
whenIsJust didStop $ \jSt' -> void . fork . atomically $ do
whenIsJust didStop $ \jSt' -> void . forkIO . atomically $ do
workers <- maybe [] (Map.keys . jobWorkers) <$> tryTakeTMVar appJobState
mapM_ (void . waitCatchSTM) $
[ jobPoolManager jSt'
, jobCron jSt'
] ++ workers
execCrontab :: RWST JobContext () (HashMap JobCtl (Max UTCTime)) (HandlerT UniWorX IO) ()
execCrontab :: RWST JobContext () (HashMap JobCtl (Max UTCTime)) (HandlerFor UniWorX) ()
-- ^ Keeping a `HashMap` of the latest execution times of `JobCtl`s we have
-- seen, wait for the time of the next job and fire it
execCrontab = do
mapRWST (liftHandlerT . runDB . setSerializable) $ do
mapRWST (liftHandler . runDB . setSerializable) $ do
let
mergeLastExec (Entity _leId CronLastExec{..})
| Just job <- Aeson.parseMaybe parseJSON cronLastExecJob
@ -251,7 +263,7 @@ execCrontab = do
-- now <- liftIO getCurrentTime
-- $logDebugS "Crontab" . intercalate "\n" . map tshow . sortOn fst . flip map (HashMap.toList currentCrontab) $ \(job, cron) -> (,job) $ nextCronMatch appTZ (getMax <$> HashMap.lookup job lastTimes) (debouncingAcc settings job) now cron
let doJob = mapRWST (liftHandlerT . runDBJobs . setSerializable) $ do
let doJob = mapRWST (liftHandler . runDBJobs . setSerializable) $ do
newCrontab <- lift . hoist lift $ determineCrontab'
if
| ((==) `on` HashMap.lookup jobCtl) newCrontab currentCrontab
@ -305,7 +317,7 @@ execCrontab = do
where
t = nextCronMatch appTZ (getMax <$> HashMap.lookup jobCtl lastTimes) (debouncingAcc settings jobCtl) now cron
waitUntil :: (Eq a, MonadResourceBase m, MonadLogger m) => TVar a -> a -> UTCTime -> m Bool
waitUntil :: (Eq a, MonadUnliftIO m, MonadLogger m) => TVar a -> a -> UTCTime -> m Bool
waitUntil crontabTV crontab nextTime = runResourceT $ do
diffT <- diffUTCTime nextTime <$> liftIO getCurrentTime
let waitTime = fromInteger (truncate $ diffT / acc) * toRational acc
@ -328,7 +340,7 @@ execCrontab = do
mkLogIdent :: JobWorkerId -> Text
mkLogIdent wId = "Job-Executor " <> showWorkerId wId
handleJobs' :: JobWorkerId -> Sink JobCtl (ReaderT JobContext Handler) ()
handleJobs' :: JobWorkerId -> ConduitT JobCtl Void (ReaderT JobContext Handler) ()
handleJobs' wNum = C.mapM_ $ \jctl -> do
$logDebugS logIdent $ tshow jctl
res <- fmap (either Just $ const Nothing) . try $ handleCmd jctl
@ -348,7 +360,7 @@ handleJobs' wNum = C.mapM_ $ \jctl -> do
handleQueueException (JLocked jId lInstance lTime) = $logDebugS logIdent $ "Saw locked QueuedJob: " ++ tshow (fromSqlKey jId, lInstance, lTime)
handleCmd JobCtlTest = return ()
handleCmd JobCtlFlush = void . lift . runDB . runConduit $ selectKeys [] [ Asc QueuedJobCreationTime ] .| C.mapM_ (lift . writeJobCtl . JobCtlPerform)
handleCmd JobCtlFlush = void . lift . runDB . runConduit $ selectKeys [] [ Asc QueuedJobCreationTime ] .| C.mapM_ (\j -> lift $ runReaderT (writeJobCtl $ JobCtlPerform j) =<< getYesod)
handleCmd (JobCtlQueue job) = lift $ queueJob' job
handleCmd (JobCtlPerform jId) = lift . handle handleQueueException . jLocked jId $ \j@QueuedJob{..} -> do
content <- case fromJSON queuedJobContent of
@ -379,7 +391,7 @@ handleJobs' wNum = C.mapM_ $ \jctl -> do
]
delete jId
handleCmd JobCtlDetermineCrontab = do
newCTab <- liftHandlerT . runDB $ setSerializable determineCrontab'
newCTab <- liftHandler . runDB $ setSerializable determineCrontab'
-- logDebugS logIdent $ tshow newCTab
mapReaderT (liftIO . atomically) $
lift . void . flip swapTVar newCTab =<< asks jobCrontab
@ -454,5 +466,5 @@ determineCrontab' :: DB (Crontab JobCtl)
determineCrontab' = (\ct -> ct <$ pruneLastExecs ct) =<< determineCrontab
performJob :: Job -> HandlerT UniWorX IO ()
performJob :: Job -> HandlerFor UniWorX ()
performJob = $(dispatchTH ''Job)

2
src/Jobs/Handler/HelpRequest.hs
View File

@ -19,7 +19,7 @@ dispatchJobHelpRequest :: Either (Maybe Address) UserId
-> Maybe Text -- ^ Referer
-> Handler ()
dispatchJobHelpRequest jSender jRequestTime jHelpSubject jHelpRequest jReferer = do
supportAddress <- view _appMailSupport
supportAddress <- getsYesod $ view _appMailSupport
userInfo <- bitraverse return (runDB . getEntity) jSender
let senderAddress = either
id

12
src/Jobs/Handler/SendCourseCommunication.hs
View File

@ -6,8 +6,6 @@ import Import
import Handler.Utils
import qualified Data.Set as Set
import qualified Data.CaseInsensitive as CI
@ -26,11 +24,11 @@ dispatchJobSendCourseCommunication jRecipientEmail jAllRecipientAddresses jCours
either (\email -> mailT def . (assign _mailTo (pure . Address Nothing $ CI.original email) *>)) userMailT jRecipientEmail $ do
void $ setMailObjectUUID jMailObjectUUID
_mailFrom .= userAddress sender
if -- Use `addMailHeader` instead of `_mailCc` to make `mailT` ignore the additional recipients
| jRecipientEmail == Right jSender
-> addMailHeader "Cc" . intercalate ", " . map renderAddress $ Set.toAscList (Set.delete (userAddress sender) jAllRecipientAddresses)
| otherwise
-> addMailHeader "Cc" "Undisclosed Recipients:;"
addMailHeader "Cc" "Undisclosed Recipients:;"
addMailHeader "Auto-Submitted" "no"
setSubjectI . prependCourseTitle courseTerm courseSchool courseShorthand $ maybe (SomeMessage MsgCommCourseSubject) SomeMessage jSubject
void $ addPart jMailContent
when (jRecipientEmail == Right jSender) $
addPart' $ do
partIsAttachment $ "all-recipients" `addExtension` unpack extensionCsv
toMailPart $ toDefaultOrderedCsvRendered jAllRecipientAddresses

10
src/Jobs/Handler/SendNotification/Allocation.hs
View File

@ -21,7 +21,7 @@ import qualified Database.Esqueleto.Utils as E
dispatchNotificationAllocationStaffRegister :: AllocationId -> UserId -> Handler ()
dispatchNotificationAllocationStaffRegister nAllocation jRecipient = userMailT jRecipient $ do
Allocation{..} <- liftHandlerT . runDB $ getJust nAllocation
Allocation{..} <- liftHandler . runDB $ getJust nAllocation
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
setSubjectI $ MsgMailSubjectAllocationStaffRegister allocationName
@ -32,7 +32,7 @@ dispatchNotificationAllocationStaffRegister nAllocation jRecipient = userMailT j
dispatchNotificationAllocationRegister :: AllocationId -> UserId -> Handler ()
dispatchNotificationAllocationRegister nAllocation jRecipient = userMailT jRecipient $ do
Allocation{..} <- liftHandlerT . runDB $ getJust nAllocation
Allocation{..} <- liftHandler . runDB $ getJust nAllocation
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
setSubjectI $ MsgMailSubjectAllocationRegister allocationName
@ -43,7 +43,7 @@ dispatchNotificationAllocationRegister nAllocation jRecipient = userMailT jRecip
dispatchNotificationAllocationAllocation :: AllocationId -> UserId -> Handler ()
dispatchNotificationAllocationAllocation nAllocation jRecipient = do
(Allocation{..}, courses) <- liftHandlerT . runDB $ do
(Allocation{..}, courses) <- runDB $ do
allocation <- getJust nAllocation
courses <- E.select . E.from $ \(course `E.InnerJoin` allocationCourse `E.InnerJoin` lecturer) -> do
E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
@ -75,7 +75,7 @@ dispatchNotificationAllocationAllocation nAllocation jRecipient = do
dispatchNotificationAllocationUnratedApplications :: AllocationId -> UserId -> Handler ()
dispatchNotificationAllocationUnratedApplications nAllocation jRecipient = do
(Allocation{..}, courses) <- liftHandlerT . runDB $ do
(Allocation{..}, courses) <- runDB $ do
allocation <- getJust nAllocation
courses <- E.select . E.from $ \(course `E.InnerJoin` allocationCourse `E.InnerJoin` lecturer) -> do
E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
@ -117,7 +117,7 @@ dispatchNotificationAllocationUnratedApplications nAllocation jRecipient = do
dispatchNotificationAllocationOutdatedRatings :: AllocationId -> UserId -> Handler ()
dispatchNotificationAllocationOutdatedRatings nAllocation jRecipient = do
(Allocation{..}, courses) <- liftHandlerT . runDB $ do
(Allocation{..}, courses) <- runDB $ do
allocation <- getJust nAllocation
courses <- E.select . E.from $ \(course `E.InnerJoin` allocationCourse `E.InnerJoin` lecturer) -> do
E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId

2
src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs
View File

@ -14,7 +14,7 @@ import qualified Data.CaseInsensitive as CI
dispatchNotificationCorrectionsAssigned :: UserId -> SheetId -> UserId -> Handler ()
dispatchNotificationCorrectionsAssigned nUser nSheet jRecipient = do
(Course{..}, Sheet{..}, nbrSubs) <- liftHandlerT . runDB $ do
(Course{..}, Sheet{..}, nbrSubs) <- runDB $ do
sheet <- getJust nSheet
course <- belongsToJust sheetCourse sheet
nbrSubs <- count [ SubmissionSheet ==. nSheet

2
src/Jobs/Handler/SendNotification/CorrectionsNotDistributed.hs
View File

@ -11,7 +11,7 @@ import qualified Data.CaseInsensitive as CI
dispatchNotificationCorrectionsNotDistributed :: SheetId -> UserId -> Handler ()
dispatchNotificationCorrectionsNotDistributed nSheet jRecipient = do
(Course{..}, Sheet{..}, nbrSubs) <- liftHandlerT . runDB $ do
(Course{..}, Sheet{..}, nbrSubs) <- runDB $ do
sheet <- getJust nSheet
course <- belongsToJust sheetCourse sheet
nbrSubs <- count [ SubmissionSheet ==. nSheet

6
src/Jobs/Handler/SendNotification/ExamActive.hs
View File

@ -16,7 +16,7 @@ import qualified Data.CaseInsensitive as CI
dispatchNotificationExamRegistrationActive :: ExamId -> UserId -> Handler ()
dispatchNotificationExamRegistrationActive nExam jRecipient = userMailT jRecipient $ do
(Course{..}, Exam{..}) <- liftHandlerT . runDB $ do
(Course{..}, Exam{..}) <- liftHandler . runDB $ do
exam <- getJust nExam
course <- belongsToJust examCourse exam
return (course, exam)
@ -37,7 +37,7 @@ dispatchNotificationExamRegistrationActive nExam jRecipient = userMailT jRecipie
dispatchNotificationExamRegistrationSoonInactive :: ExamId -> UserId -> Handler ()
dispatchNotificationExamRegistrationSoonInactive nExam jRecipient = userMailT jRecipient $ do
(Course{..}, Exam{..}) <- liftHandlerT . runDB $ do
(Course{..}, Exam{..}) <- liftHandler . runDB $ do
exam <- getJust nExam
course <- belongsToJust examCourse exam
return (course, exam)
@ -58,7 +58,7 @@ dispatchNotificationExamRegistrationSoonInactive nExam jRecipient = userMailT jR
dispatchNotificationExamDeregistrationSoonInactive :: ExamId -> UserId -> Handler ()
dispatchNotificationExamDeregistrationSoonInactive nExam jRecipient = userMailT jRecipient $ do
(Course{..}, Exam{..}) <- liftHandlerT . runDB $ do
(Course{..}, Exam{..}) <- liftHandler . runDB $ do
exam <- getJust nExam
course <- belongsToJust examCourse exam
return (course, exam)

Some files were not shown because too many files have changed in this diff Show More