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

Merge branch 'master' into course-teaser

Browse Source
This commit is contained in:
Felix Hamann 2019-04-12 22:27:40 +02:00
commit c98acacfec
92 changed files with 1764 additions and 926 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.hlint.yaml
View File

@ -4,6 +4,7 @@
- ignore: { name: "Parse error" }
- ignore: { name: "Reduce duplication" }
- ignore: { name: "Redundant lambda" }
- ignore: { name: "Use ||" }
- ignore: { name: "Use &&" }
- ignore: { name: "Use ++" }

6
ChangeLog.md
View File

@ -1,3 +1,9 @@
* Version 27.03.2019
Kurse Veranstalter können nun mehrere Dozenten und Assistenten selbst eintragen
Erfassung Studiengangsdaten
* Version 20.03.2019
Kursanmeldung benötigen assoziertes Hauptfach (für Studierende mit mehreren Hauptfächern)

38
FragenSJ.txt
View File

@ -1,38 +0,0 @@
** Sicherheitsabfragen?
- Verschlüsselung des Zugriffs?
- SDelR tid csh sn : GET zeigt Sicherheitsabfrage
POST löscht.
Ist das so sinnvoll?
Sicherheitsabfrage als PopUpMessage?
- Utils.getKeyBy404 effiziente Variante, welche nur den Key liefert? Esq?
(Sheet.hs -> fetchSheet)
- Handler.Sheet.postSDelR: deleteCascade für Files? Klappt das?
Kann man abfragen, was bei deleteCascade alles gelöscht wird?
** i18n:
- i18n der
Links -> MenuItems verwenden wie bisher
Page Titles -> setTitleI
Buttons? -> Kann leicht geändert werden!
Was ist mit einfachen Text Feldern, z.B. die Beschriftung von Knöpfen wie in Handler.Course.getTermCourseListR, Zeile 66 "pageActions" für menuItemLabel?
** Page pageActions - Berechtigungen prüfen?
=> Eigener Constructor statt NavbarLeft/Right?!
** FORMS
3 - Sheets: Multiple Files -> wird später gemacht
- Versionen für Studenten/Korrektoren/Lecturers/Admins
-> ja über isAuthorizedDB siehe unten,
-> Lecturer kann gleich auf Edit-Seite gehen wie in UniWorX
Freischaltung von Teilen einer Webseite:
- Freigabe der Links über Authorisierung in der Foundation
- Anzeige der Links nach Authorisierung wie in menItemAccessCallback
- möglichst direkt isAuthorizedDB in einem runDB aufrufen!!!

34
PageActionPrime.txt Normal file
View File

@ -0,0 +1,34 @@
Übersicht über PageActions und Workflow im Vergleich zum alten UniWorX:
-----
Course Actions im alten UniWorX:
- Studenten
- Übungsgruppen
- Übungsblätter
- Klausuren
- E-Mails
- Online-Evaluation
-----
CourseActions in Uni2Work:
-1 Übungsblätter (öfter)
[ Auch aus SheetList übernommen un hier ebenfalls angzeigt:
-1 Aktuelles Blatt (häufig)
-1 Letztes unzugewiesenes (häufig, nur Assistenten)
-1 Abgaben (häufig, nur Assistenten)
-1 Korrekturen (häufig, nur Assistenten)
-1 Neues Blatt (häufig, nur Assistenten)
]
-2 Teilnehmerliste (gelegentlich, nur Assistenten)
-2 Kurs editieren (selten, nur Assistenten)
-2 Kurs klonen (selten, nur Assistenten)
-2 Kurs löschen (sehr selten, nur Assistenten/Admins)
SheetList:
- Aktuelles Blatt
- Letztes unzugewiesenes
- Abgaben
- Korrekturen
- Neues Blatt

2
build.sh
View File

@ -1,4 +1,4 @@
#!/usr/bin/env bash
exec -- stack build --fast --flag uniworx:library-only --flag uniworx:dev
exec -- stack build --fast --flag uniworx:-library-only --flag uniworx:dev
echo Build task completed.

2
db.sh
View File

@ -1,4 +1,4 @@
#!/usr/bin/env bash
# Options: see /test/Database.hs (Main)
stack build --fast --flag uniworx:library-only --flag uniworx:dev
stack build --fast --flag uniworx:-library-only --flag uniworx:dev
stack exec uniworxdb -- $@

3
hlint.sh Executable file
View File

@ -0,0 +1,3 @@
#!/usr/bin/env bash
exec -- ./test.sh uniworx:test:hlint

81
messages/uniworx/de.msg
View File

@ -1,11 +1,18 @@
PrintDebugForStupid name@Text: Debug message "#{name}"
BtnSubmit: Senden
BtnAbort: Abbrechen
BtnDelete: Löschen
BtnRegister: Anmelden
BtnDeregister: Abmelden
BtnHijack: Sitzung übernehmen
BtnSave: Speichern
BtnCandidatesInfer: Studienfachzuordnung automatisch lernen
BtnCandidatesDeleteConflicts: Konflikte löschen
BtnCandidatesDeleteAll: Alle Beobachtungen löschen
Aborted: Abgebrochen
Remarks: Hinweise
Registered: Angemeldet
RegisteredHeader: Anmeldung
RegisteredSince date@Text: Angemeldet seit #{date}
@ -13,6 +20,11 @@ RegisterFrom: Anmeldungen von
RegisterTo: Anmeldungen bis
DeRegUntil: Abmeldungen bis
GenericKey: Schlüssel
GenericShort: Kürzel
GenericIsNew: Neu
GenericHasConflict: Konflikt
SummerTerm year@Integer: Sommersemester #{display year}
WinterTerm year@Integer: Wintersemester #{display year}/#{display $ succ year}
SummerTermShort year@Integer: SoSe #{display year}
@ -34,6 +46,8 @@ TermStartDay: Erster Tag
TermStartDayTooltip: Üblicherweise immer 1.April oder 1.Oktober
TermEndDay: Letzter Tag
TermEndDayTooltip: Üblicherweise immer 30.September oder 31.März
TermHolidays: Feiertage
TermHolidayPlaceholder: Feiertag
TermLectureStart: Beginn Vorlesungen
TermLectureEnd: Ende Vorlesungen
TermLectureEndTooltip: Meistens dauer das Sommersemester 14 Wochen und das Wintersemester 15 Wochen.
@ -51,8 +65,8 @@ CourseCapacity: Kapazität
CourseCapacityTip: Anzahl erlaubter Kursanmeldungen, leer lassen für unbeschränkte Kurskapazität
CourseNoCapacity: In diesem Kurs sind keine Plätze mehr frei.
CourseNotEmpty: In diesem Kurs sind momentan Teilnehmer angemeldet.
CourseRegisterOk: Sie wurden angemeldet
CourseDeregisterOk: Sie wurden abgemeldet
CourseRegisterOk: Anmeldung erfolgreich
CourseDeregisterOk: Erfolgreich abgemeldet
CourseStudyFeature: Assoziiertes Hauptfach
CourseStudyFeatureTooltip: Korrekte Angabe kann Notenweiterleitungen beschleunigen
CourseSecretWrong: Falsches Kennwort
@ -71,8 +85,10 @@ CourseNewHeading: Neuen Kurs anlegen
CourseEditHeading tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{csh} editieren
CourseEditTitle: Kurs editieren/anlegen
CourseMembers: Teilnehmer
CourseMemberOf: Teilnehmer
CourseMembersCount n@Int: #{display n}
CourseMembersCountLimited n@Int max@Int: #{display n}/#{display max}
CourseMembersCountOf n@Int mbNum@IntMaybe: #{display n} Anmeldungen #{maybeDisplay " von " mbNum " möglichen"}
CourseName: Name
CourseDescription: Beschreibung
CourseDescriptionTip: Beliebiges HTML-Markup ist gestattet
@ -93,6 +109,20 @@ CourseFilterNone: Egal
CourseDeleteQuestion: Wollen Sie den unten aufgeführten Kurs wirklich löschen?
CourseDeleted: Kurs gelöscht
CourseUserNote: Notiz
CourseUserNoteTooltip: Nur für Dozenten dieses Kurses einsehbar
CourseUserNoteSaved: Notizänderungen gespeichert
CourseUserNoteDeleted: Teilnehmernotiz gelöscht
CourseUserDeregister: Abmelden
CourseUsersDeregistered count@Int64: #{show count} Teilnehmer abgemeldet
CourseLecturers: Kursverwalter
CourseLecturer: Dozent
CourseAssistant: Assistent
CourseLecturerAlreadyAdded email@UserEmail: Es gibt bereits einen Kursverwalter mit E-Mail #{email}
CourseRegistrationEndMustBeAfterStart: Ende des Anmeldezeitraums muss nach dem Anfang liegen
CourseDeregistrationEndMustBeAfterStart: Ende des Abmeldezeitraums muss nach dem Anfang des Anmeldezeitraums liegen
CourseUserMustBeLecturer: Aktueller Benutzer muss als Kursverwalter eingetragen sein
CourseLecturerRightsIdentical: Alle Sorten von Kursverwalter haben identische Rechte
NoSuchTerm tid@TermId: Semester #{display tid} gibt es nicht.
NoSuchSchool ssh@SchoolId: Institut #{display ssh} gibt es nicht.
@ -129,21 +159,21 @@ SheetInvisibleUntil date@Text: Dieses Übungsblatt ist für Teilnehmer momentan
SheetName: Name
SheetDescription: Hinweise für Teilnehmer
SheetGroup: Gruppenabgabe
SheetVisibleFrom: Sichtbar ab
SheetVisibleFromTip: Ohne Datum wird das Blatt nie sichtbar, z.B. weil es noch nicht fertig ist
SheetActiveFrom: Aktiv ab
SheetActiveFromTip: Abgabe und Download der Aufgabenstellung ist erst ab diesem Datum möglich
SheetActiveTo: Abgabefrist
SheetVisibleFrom: Sichtbar für Teilnehmer ab
SheetVisibleFromTip: Ohne Datum nie sichtbar und keine Abgabe möglich; nur für unfertige Blätter leer lassen, deren Fristen/Bewertung sich noch ändern kann
SheetActiveFrom: Beginn Abgabezeitraum
SheetActiveFromTip: Download der Aufgabenstellung erst ab diesem Datum möglich
SheetActiveTo: Ende Abgabezeitraum
SheetHintFromTip: Ohne Datum nie für Teilnehmer sichtbar, Korrektoren können diese Dateien immer herunterladen
SheetSolutionFromTip: Ohne Datum nie für Teilnehmer sichtbar, Korrektoren können diese Dateien immer herunterladen
SheetMarkingTip: Hinweise zur Korrektur, sichtbar nur für Korrektoren
SheetPseudonym: Persönliches Abgabe-Pseudonym
SheetGeneratePseudonym: Generieren
SheetErrVisibility: Sichtbarkeit muss vor Beginn der Abgabefrist liegen
SheetErrDeadlineEarly: Ende der Abgabefrist muss nach deren Beginn liegen
SheetErrHintEarly: Hinweise dürfen erst nach Beginn der Abgabefrist herausgegeben werden
SheetErrSolutionEarly: Die Lösung sollte erst nach Ende der Abgabefrist herausgegeben werden
SheetErrVisibility: "Beginn Abgabezeitraum" muss nach "Sichbar für Teilnehmer ab" liegen
SheetErrDeadlineEarly: "Ende Abgabezeitraum" muss nach "Beginn Abzeitraum" liegen
SheetErrHintEarly: Hinweise dürfen erst nach Beginn des Abgabezeitraums herausgegeben werden
SheetErrSolutionEarly: Lösungen dürfen erst nach Ende der Abgabezeitraums herausgegeben werden
Deadline: Abgabe
@ -214,7 +244,7 @@ AddCorrector: Zusätzlicher Korrektor
CorrectorExists email@UserEmail: #{email} ist bereits als Korrektor eingetragen
SheetCorrectorsTitle tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Korrektoren für #{display tid}-#{display ssh}-#{csh} #{sheetName}
CountTutProp: Tutorien zählen gegen Proportion
AutoAssignCorrs: Korrekturen am Ende der Abgabefrist automatisch zuteilen
AutoAssignCorrs: Korrekturen nach Ablauf des Abgabezeitraums automatisch zuteilen
Corrector: Korrektor
Correctors: Korrektoren
CorState: Status
@ -246,11 +276,15 @@ DataProtHeading: Datenschutzerklärung
SystemMessageHeading: Uni2work Statusmeldung
SystemMessageListHeading: Uni2work Statusmeldungen
HomeOpenCourses: Kurse mit offener Registrierung
HomeUpcomingSheets: Anstehende Übungsblätter
NumCourses num@Int64: #{display num} Kurse
CloseAlert: Schliessen
Name: Name
MatrikelNr: Matrikelnummer
NoMatrikelKnown: Keine Matrikelnummer
Theme: Oberflächen Design
Favoriten: Anzahl gespeicherter Favoriten
Plugin: Plugin
@ -351,6 +385,8 @@ AccessRightsFor: Berechtigungen für
AdminFor: Administrator
LecturerFor: Dozent
LecturersFor: Dozenten
AssistantFor: Assistent
AssistantsFor: Assistenten
ForSchools n@Int: für #{pluralDE n "Institut" "Institute"}
UserListTitle: Komprehensive Benutzerliste
AccessRightsSaved: Berechtigungsänderungen wurden gespeichert.
@ -408,17 +444,23 @@ SheetCorrectorSubmissionsTip: Abgabe erfolgt über ein Uni2work-externes Verfahr
SubmissionNoUploadExpected: Es ist keine Abgabe von Dateien vorgesehen.
AdminFeaturesHeading: Studiengänge
StudyTerms: Studiengänge
StudyTerm: Studiengang
NoStudyTermsKnown: Nicht eingeschrieben
StudyFeatureInference: Studiengangschlüssel-Inferenz
StudyFeatureAge: Fachsemester
StudyFeatureDegree: Abschluss
FieldPrimary: Hauptfach
FieldSecondary: Nebenfach
NoPrimaryStudyField: (kein Hauptfach registriert)
StudyFeatureType:
StudyFeatureValid: Aktiv
StudyFeatureUpdate: Abgeglichen
DegreeKey: Schlüssel Abschluss
DegreeKey: Abschlussschlüssel
DegreeName: Abschluss
DegreeShort: Abschlusskürzel
StudyTermsKey: Schlüssel Studiengang
StudyTermsKey: Studiengangschlüssel
StudyTermsName: Studiengang
StudyTermsShort: Studiengangkürzel
StudyTermsChangeSuccess: Zuordnung Abschlüsse aktualisiert
@ -428,7 +470,10 @@ AmbiguousCandidatesRemoved n@Int: #{show n} #{pluralDE n "uneindeutiger Kandidat
RedundantCandidatesRemoved n@Int: #{show n} bereits #{pluralDE n "bekannter Kandidat" "bekannte Kandiaten"} entfernt
CandidatesInferred n@Int: #{show n} neue #{pluralDE n "Studiengangszuordnung" "Studiengangszuordnungen"} inferiert
NoCandidatesInferred: Keine neuen Studienganszuordnungen inferiert
AllIncidencesDeleted: Alle Beobachtungen wurden gelöscht.
IncidencesDeleted n@Int: #{show n} #{pluralDE n "Beobachtung" "Beobachtungen"} gelöscht
StudyTermIsNew: Neu
StudyFeatureConflict: Es wurden Konflikte in der Studiengang-Zuordnung gefunden
MailTestFormEmail: Email-Addresse
MailTestFormLanguages: Spracheinstellungen
@ -451,7 +496,7 @@ MailSubmissionsUnassignedIntro n@Int courseName@Text termDesc@Text sheetName@She
MailSubjectSheetSoonInactive csh@CourseShorthand sheetName@SheetName: #{sheetName} in #{csh} kann nur noch kurze Zeit abgegeben werden
MailSheetSoonInactiveIntro courseName@Text termDesc@Text sheetName@SheetName: Abgabefirst für #{sheetName} im Kurs #{courseName} (#{termDesc}) endet in Kürze.
MailSubjectSheetInactive csh@CourseShorthand sheetName@SheetName: Abgabfrist für #{sheetName} in #{csh} abgelaufen
MailSubjectSheetInactive csh@CourseShorthand sheetName@SheetName: Abgabezeitraum für #{sheetName} in #{csh} abgelaufen
MailSheetInactiveIntro courseName@Text termDesc@Text sheetName@SheetName n@Int num@Int64: Die Abgabefirst für #{sheetName} im Kurs #{courseName} (#{termDesc}) beendet. Es gab #{noneOneMoreDE n "Keine Abgaben" "Nur eine Abgabe von " (display n <> " Abgaben von ")}#{noneOneMoreDE num "" "einem Teilnehmer" (display num <> " Teilnehmern")}.
MailSubjectCorrectionsAssigned csh@CourseShorthand sheetName@SheetName: Ihnen wurden Korrekturen zu #{sheetName} in #{csh} zugeteilt
@ -465,6 +510,7 @@ MailLecturerRights n@Int: Als Dozent dürfen Sie Veranstaltungen innerhalb #{plu
MailEditNotifications: Benachrichtigungen ein-/ausschalten
MailSubjectSupport: Supportanfrage
MailSubjectSupportCustom customSubject@Text: [Support] #{customSubject}
SheetGrading: Bewertung
SheetGradingPoints maxPoints@Points: #{tshow maxPoints} Punkte
@ -508,7 +554,7 @@ NotificationTriggerSubmissionRatedGraded: Meine Abgabe in einem gewerteten Übun
NotificationTriggerSubmissionRated: Meine Abgabe wurde korrigiert
NotificationTriggerSheetActive: Ich kann ein neues Übungsblatt herunterladen
NotificationTriggerSheetSoonInactive: Ich kann ein Übungsblatt bald nicht mehr abgeben
NotificationTriggerSheetInactive: Abgabefrist eines meiner Übungsblätter ist abgelaufen
NotificationTriggerSheetInactive: Abgabezeitraum eines meiner Übungsblätter ist abgelaufen
NotificationTriggerCorrectionsAssigned: Mir wurden Abgaben zur Korrektur zugeteilt
NotificationTriggerCorrectionsNotDistributed: Abgaben eines meiner Übungsblätter konnten keinem Korrektur zugeteilt werden
NotificationTriggerUserRightsUpdate: Meine Berechtigungen wurden geändert
@ -539,6 +585,7 @@ HelpAnswer: Antworten an
HelpUser: Meinen Benutzeraccount
HelpAnonymous: Keine Antwort (Anonym)
HelpEmail: E-Mail
HelpSubject: Betreff
HelpRequest: Supportanfrage / Verbesserungsvorschlag
HelpProblemPage: Problematische Seite
HelpIntroduction: Wenn Ihnen die Benutzung dieser Webseite Schwierigkeiten bereitet oder Sie einen verbesserbaren Umstand entdecken bitten wir Sie uns das zu melden, auch wenn Sie Ihr Problem bereits selbst lösen konnten. Wir passen die Seite ständig an und versuchen sie auch für zukünftige Benutzer so einsichtig wie möglich zu halten.
@ -683,3 +730,5 @@ DBTIRowsMissing n@Int: #{pluralDE n "Eine Zeile ist" "Einige Zeile sind"} aus de
MassInputAddDimension: Hinzufügen
MassInputDeleteCell: Entfernen
NavigationFavourites: Favoriten

17
models/courses
View File

@ -33,6 +33,7 @@ CourseFavourite -- which user accessed which course when, only display
Lecturer -- course ownership
user UserId
course CourseId
type LecturerType default='"lecturer"'
UniqueLecturer user course -- note: multiple lecturers per course are allowed, but no duplicated rows in this table
CourseParticipant -- course enrolement
course CourseId
@ -40,12 +41,20 @@ CourseParticipant -- course enrolement
registration UTCTime -- time of last enrolement for this course
field StudyFeaturesId Maybe -- associated degree course, user-defined; required for communicating grades
UniqueParticipant user course
-- Replace the last two by the following, once an audit log is available
-- CourseUserNote -- lecturers of a specific course may share a text note on each enrolled student
-- course CourseId
-- user UserId
-- note Html -- arbitrary user-defined text; visible only to lecturer of this course
-- time UTCTime -- PROBLEM: deleted note has no modification date
-- editor UserId -- who edited this note last
-- UniqueCourseUserNote user course
CourseUserNote -- lecturers of a specific course may share a text note on each enrolled student
course CourseId
user UserId
note Text -- arbitrary user-defined text; visible only to lecturer of this course
UniqueCourseUserNotes user course
CourseUserNoteEdit -- who edited a participants course note whenl
note Html -- arbitrary user-defined text; visible only to lecturer of this course
UniqueCourseUserNote user course
CourseUserNoteEdit -- who edited a participants course note when
user UserId
time UTCTime
note CourseUserNoteId
note CourseUserNoteId -- PROBLEM: deleted notes have no modification date any more

4
package.yaml
View File

@ -116,6 +116,7 @@ dependencies:
- lifted-base
- lattices
- hsass
- semigroupoids
other-extensions:
- GeneralizedNewtypeDeriving
@ -217,6 +218,9 @@ executables:
dependencies:
- uniworx
other-modules: []
when:
- condition: flag(library-only)
buildable: false
# Test suite
tests:

11
routes
View File

@ -36,7 +36,8 @@
/ HomeR GET !free
/users UsersR GET -- no tags, i.e. admins only
/users/#CryptoUUIDUser AdminUserR GET POST !development
/users/#CryptoUUIDUser AdminUserR GET POST
/users/#CryptoUUIDUser/delete AdminUserDeleteR POST
/users/#CryptoUUIDUser/hijack AdminHijackUserR POST !adminANDno-escalation
/admin AdminR GET
/admin/features AdminFeaturesR GET POST
@ -52,13 +53,13 @@
/help HelpR GET POST !free
/user ProfileR GET POST !free
/user/profile ProfileDataR GET POST !free
/user/profile ProfileDataR GET !free
/user/authpreds AuthPredsR GET POST !free
/term TermShowR GET !free
/term/current TermCurrentR GET !free
/term/edit TermEditR GET POST
/term/#TermId/edit TermEditExistR GET
/term/#TermId/edit TermEditExistR GET POST
!/term/#TermId TermCourseListR GET !free
!/term/#TermId/#SchoolId TermSchoolCourseListR GET !free
@ -74,8 +75,8 @@
/register CRegisterR POST !timeANDcapacity
/edit CEditR GET POST
/delete CDeleteR GET POST !lecturerANDempty
/users CUsersR GET
/users/#CryptoUUIDUser CUserR GET !lecturerANDparticipant
/users CUsersR GET POST
/users/#CryptoUUIDUser CUserR GET POST !lecturerANDparticipant
/correctors CHiWisR GET
/notes CNotesR GET POST !corrector
/subs CCorrectionsR GET POST

2
shell.nix
View File

@ -19,7 +19,7 @@ let
'';
override = oldAttrs: {
nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ postgresql ]) ++ (with haskellPackages; [ stack yesod-bin hlint cabal-install ]);
nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ postgresql pgadmin openldap ]) ++ (with haskellPackages; [ stack yesod-bin hlint cabal-install ]);
shellHook = ''
export PROMPT_INFO="${oldAttrs.name}"

2
src/Application.hs
View File

@ -76,6 +76,8 @@ import qualified Database.Memcached.Binary.IO as Memcached
-- (HPack takes care to add new modules to our cabal file nowadays.)
import Handler.Common
import Handler.Home
import Handler.Info
import Handler.Help
import Handler.Profile
import Handler.Users
import Handler.Admin

44
src/Auth/LDAP.hs
View File

@ -6,7 +6,7 @@ module Auth.LDAP
, Ldap.AttrList, Ldap.Attr(..), Ldap.AttrValue
) where
import Import.NoFoundation
import Import.NoFoundation hiding (userEmail, userDisplayName)
import Control.Lens
import Network.Connection
@ -39,9 +39,16 @@ data CampusMessage = MsgCampusIdentNote
findUser :: LdapConf -> Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry]
findUser LdapConf{..} ldap campusIdent = Ldap.search ldap ldapBase userSearchSettings userFilter
findUser LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM (not . null) . lift . flip (Ldap.search ldap ldapBase userSearchSettings) retAttrs) userFilters
where
userFilter = userPrincipalName Ldap.:= Text.encodeUtf8 campusIdent
userFilters =
[ userPrincipalName Ldap.:= Text.encodeUtf8 ident
, userPrincipalName Ldap.:= Text.encodeUtf8 [st|#{ident}@campus.lmu.de|]
, userEmail Ldap.:= Text.encodeUtf8 ident
, userEmail Ldap.:= Text.encodeUtf8 [st|#{ident}@lmu.de|]
, userEmail Ldap.:= Text.encodeUtf8 [st|#{ident}@campus.lmu.de|]
, userDisplayName Ldap.:= Text.encodeUtf8 ident
]
userSearchSettings = mconcat
[ Ldap.scope ldapScope
, Ldap.size 2
@ -49,17 +56,18 @@ findUser LdapConf{..} ldap campusIdent = Ldap.search ldap ldapBase userSearchSet
, Ldap.derefAliases Ldap.DerefAlways
]
userPrincipalName :: Ldap.Attr
userPrincipalName, userEmail, userDisplayName :: Ldap.Attr
userPrincipalName = Ldap.Attr "userPrincipalName"
userEmail = Ldap.Attr "mail"
userDisplayName = Ldap.Attr "displayName"
campusForm :: ( RenderMessage site FormMessage
, RenderMessage site CampusMessage
, Button site ButtonSubmit
) => AForm (HandlerT site IO) CampusLogin
campusForm = CampusLogin
<$> areq ciField (fslpI MsgCampusIdent "user.name@campus.lmu.de" & setTooltip MsgCampusIdentNote) Nothing
<$> areq ciField (fslpI MsgCampusIdent "user.name@campus.lmu.de" & setTooltip MsgCampusIdentNote & addAttr "autofocus" "") Nothing
<*> areq passwordField (fslI MsgCampusPassword) Nothing
<* submitButton
campusLogin :: forall site.
( YesodAuth site
@ -80,9 +88,14 @@ campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
FormMissing -> redirect LoginR
FormSuccess CampusLogin{ campusIdent = CI.original -> campusIdent, ..} -> do
ldapResult <- withLdap pool $ \ldap -> do
Ldap.bind ldap (Ldap.Dn campusIdent) (Ldap.Password $ Text.encodeUtf8 campusPassword)
Ldap.bind ldap ldapDn ldapPassword
findUser conf ldap campusIdent [userPrincipalName]
searchResults <- findUser conf ldap campusIdent [userPrincipalName]
case searchResults of
[Ldap.SearchEntry (Ldap.Dn userDN) userAttrs]
| Just [principalName] <- lookup userPrincipalName userAttrs
, Right credsIdent <- Text.decodeUtf8' principalName
-> Right (userDN, credsIdent) <$ Ldap.bind ldap (Ldap.Dn credsIdent) (Ldap.Password $ Text.encodeUtf8 campusPassword)
other -> return $ Left other
case ldapResult of
Left err
| LdapError (Ldap.ResponseError (Ldap.ResponseErrorCode _ Ldap.InvalidCredentials _ _)) <- err
@ -92,16 +105,11 @@ campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
| otherwise -> do
$logErrorS "LDAP" $ "Error during login: " <> tshow err
loginErrorMessageI LoginR Msg.AuthError
Right searchResults
| [Ldap.SearchEntry (Ldap.Dn userDN) userAttrs] <- searchResults
, Just [principalName] <- lookup userPrincipalName userAttrs
, Right credsIdent <- Text.decodeUtf8' principalName
-> do
$logDebugS "LDAP" $ tshow searchResults
lift . setCredsRedirect $ Creds apName credsIdent [("DN", userDN)]
| otherwise -> do
$logWarnS "LDAP" $ "Could not extract principal name: " <> tshow searchResults
loginErrorMessageI LoginR Msg.AuthError
Right (Right (userDN, credsIdent)) ->
lift . 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 toMaster = do
(login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard campusForm

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

@ -0,0 +1,12 @@
{-# 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|]

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

@ -5,8 +5,9 @@ module Database.Esqueleto.Utils
, isInfixOf, hasInfix
, any, all
, SqlIn(..)
, mkExactFilter, mkContainsFilter
, anyFilter
, mkExactFilter, mkExactFilterWith
, mkContainsFilter
, anyFilter, allFilter
) where
import ClassyPrelude.Yesod hiding (isInfixOf, any, all)
@ -54,26 +55,42 @@ all :: Foldable f =>
all test = F.foldr (\needle acc -> acc E.&&. test needle) true
-- Allow usage of Tuples as DbtRowKey, i.e. SqlIn instances for tuples
$(sqlInTuples [2..16])
-- | Example for usage of unValueN
_exampleUnValueN :: (E.Value a, E.Value b, E.Value c) -> (a,b,c)
_exampleUnValueN = $(unValueN 3)
-- | Example for usage of unValueNIs
_exampleUnValueNIs :: (E.Value a, b, E.Value c) -> (a,b,c)
_exampleUnValueNIs = $(unValueNIs 3 [1,3])
-- | Example for usage of sqlIJproj
-- queryFeaturesDegree :: (a `E.InnerJoin` b `E.InnerJoin` c) -> b
-- queryFeaturesDegree = $(sqlIJproj 3 2)
_queryFeaturesDegree :: (a `E.InnerJoin` b `E.InnerJoin` c) -> b
_queryFeaturesDegree = $(sqlIJproj 3 2)
-- | generic filter creation for dbTable
-- Given a lens-like function, make filter for exact matches in a collection
-- (Generalizing from Set to Foldable ok here, but gives ambigouus types elsewhere)
mkExactFilter :: (PersistField a)
=> (t -> E.SqlExpr (E.Value a)) -- ^ getter from query to searched element
=> (t -> E.SqlExpr (E.Value a)) -- ^ getter from query to searched element
-> t -- ^ query row
-> Set.Set a -- ^ needle collection
-> E.SqlExpr (E.Value Bool)
mkExactFilter lenslike row criterias
mkExactFilter = mkExactFilterWith id
-- | like @mkExactFiler@ but allows for conversion; convenient in conjunction with @anyFilter@ and @allFilter@
mkExactFilterWith :: (PersistField b)
=> (a -> b) -- ^ type conversion
-> (t -> E.SqlExpr (E.Value b)) -- ^ getter from query to searched element
-> t -- ^ query row
-> Set.Set a -- ^ needle collection
-> E.SqlExpr (E.Value Bool)
mkExactFilterWith cast lenslike row criterias
| Set.null criterias = true
| otherwise = lenslike row `E.in_` E.valList (Set.toList criterias)
| otherwise = lenslike row `E.in_` E.valList (cast <$> Set.toList criterias)
-- | generic filter creation for dbTable
-- Given a lens-like function, make filter searching for needles in String-like elements
@ -87,9 +104,22 @@ mkContainsFilter lenslike row criterias
| Set.null criterias = true
| otherwise = any (hasInfix $ lenslike row) criterias
anyFilter :: (Foldable f) => f (t -> Set.Set Text-> E.SqlExpr (E.Value Bool))
-> t -> Set.Set Text-> E.SqlExpr (E.Value Bool)
-- | Combine several filters, using logical or
anyFilter :: (Foldable f)
=> f (t -> Set.Set Text-> E.SqlExpr (E.Value Bool))
-> t
-> Set.Set Text
-> E.SqlExpr (E.Value Bool)
anyFilter fltrs needle criterias = F.foldr aux false fltrs
where
aux fltr acc = fltr needle criterias E.||. acc
aux fltr acc = fltr needle criterias E.||. acc
-- | Combine several filters, using logical and
allFilter :: (Foldable f)
=> f (t -> Set.Set Text-> E.SqlExpr (E.Value Bool))
-> t
-> Set.Set Text
-> E.SqlExpr (E.Value Bool)
allFilter fltrs needle criterias = F.foldr aux true fltrs
where
aux fltr acc = fltr needle criterias E.&&. acc

25
src/Database/Esqueleto/Utils/TH.hs
View File

@ -1,6 +1,7 @@
module Database.Esqueleto.Utils.TH
( SqlIn(..)
, sqlInTuple, sqlInTuples
, unValueN, unValueNIs
, sqlIJproj, sqlLOJproj
) where
@ -48,6 +49,30 @@ sqlInTuple arity = do
]
]
-- | Generic unValuing of Tuples of Values, i.e.
-- $(unValueN 3) :: (E.Value a, E.Value b, E.Value c) -> (a,b,c)
unValueN :: Int -> ExpQ
unValueN arity = do
vs <- replicateM arity $ newName "v"
let pat = tupP $ map varP vs
let uvE v = [e|E.unValue $(varE v)|]
let rhs = tupE $ map uvE vs
lam1E pat rhs
-- | Generic unValuing of certain indices of a Tuple, i.e.
-- $(unValueNIs 3 [1,3]) :: (E.Value a, b, E.Value c) -> (a,b,c)
unValueNIs :: Int -> [Int] -> ExpQ
unValueNIs arity uvIdx = do
vs <- replicateM arity $ newName "v"
let pat = tupP $ map varP vs
let rhs = tupE $ zipWith (curry uvEi) vs [1 ..]
lam1E pat rhs
where
uvEi (v,i) | i `elem` uvIdx = [e|E.unValue $(varE v)|]
| otherwise = varE v
-- | Generic projections for InnerJoin-tuples
-- gives I-th element of N-tuple of left-associative InnerJoin-pairs,
-- i.e. @$(projN n m) :: (t1 `E.InnerJoin` .. `E.InnerJoin` tn) -> tm@ (for m<=n)

73
src/Foundation.hs
View File

@ -26,8 +26,10 @@ import qualified Data.CaseInsensitive as CI
import qualified Data.CryptoID as E
import Data.ByteArray (convert)
import Crypto.Hash (Digest, SHAKE256)
import Crypto.Hash (Digest, SHAKE256, SHAKE128)
import Crypto.Hash.Conduit (sinkHash)
import qualified Data.UUID as UUID
import qualified Data.Binary as Binary
import qualified Data.ByteString.Base64.URL as Base64 (encode)
@ -62,7 +64,6 @@ import Control.Monad.Memo (MemoT, startEvalMemoT, MonadMemo(..))
import qualified Control.Monad.Catch as C
import Handler.Utils.StudyFeatures
import Handler.Utils.Templates
import Utils.Lens
import Utils.Form
import Utils.Sheet
@ -172,7 +173,13 @@ noneOneMoreDE num noneText singularForm pluralForm
| num == 1 = singularForm
| otherwise = pluralForm
-- Convenience Type for Messages
type IntMaybe = Maybe Int -- Yesod messages cannot deal with compound type identifiers
-- | Convenience function for i18n messages definitions
maybeDisplay :: DisplayAble m => Text -> Maybe m -> Text -> Text
maybeDisplay _ Nothing _ = mempty
maybeDisplay before (Just x) after = before <> (display x) <> after
-- Messages creates type UniWorXMessage and RenderMessage UniWorX instance
mkMessage "UniWorX" "messages/uniworx" "de"
@ -233,6 +240,7 @@ embedRenderMessage ''UniWorX ''SheetGrading ("SheetGrading" <>)
embedRenderMessage ''UniWorX ''AuthTag $ ("AuthTag" <>) . concat . drop 1 . splitCamel
embedRenderMessage ''UniWorX ''SheetSubmissionMode ("Sheet" <>)
embedRenderMessage ''UniWorX ''EncodedSecretBoxException id
embedRenderMessage ''UniWorX ''LecturerType id
newtype SheetTypeHeader = SheetTypeHeader SheetType
embedRenderMessageVariant ''UniWorX ''SheetTypeHeader ("SheetType" <>)
@ -993,15 +1001,15 @@ siteLayout' headingOverride widget = do
| isModal -> getMessages
| otherwise -> do
applySystemMessages
authTagPivots <- fromMaybe Set.empty <$> getSessionJson SessionInactiveAuthTags
authTagPivots <- fromMaybe Set.empty <$> takeSessionJson SessionInactiveAuthTags
forM_ authTagPivots $
\authTag -> addMessageWidget Info $ modal [whamlet|_{MsgUnauthorizedDisabledTag authTag}|] (Left $ SomeRoute (AuthPredsR, catMaybes [(toPathPiece GetReferer, ) . toPathPiece <$> mcurrentRoute]))
getMessages
let highlight :: Route UniWorX -> Bool -- highlight last route in breadcrumbs, favorites taking priority
highlight = let crumbs = mcons mcurrentRoute $ fst <$> reverse parents
navItems = map snd3 favourites ++ map (urlRoute . menuItemRoute . view _1) menuTypes
highR = find (`elem` navItems) . uncurry (++) $ partition (`elem` map snd3 favourites) crumbs
navItems = map (view _2) favourites ++ map (urlRoute . menuItemRoute . view _1) menuTypes
highR = find (`elem` navItems) . uncurry (++) $ partition (`elem` map (view _2) favourites) crumbs
in \r -> Just r == highR
favouriteTerms :: [TermIdentifier]
favouriteTerms = Set.toDescList $ foldMap (\(Course{..}, _, _) -> Set.singleton $ unTermKey courseTerm) favourites
@ -1014,6 +1022,17 @@ siteLayout' headingOverride widget = do
-- value passed to hamletToRepHtml cannot be a widget, this allows
-- you to use normal widget features in default-layout.
navbarModal (MenuItem{..}, menuIdent') = customModal Modal
{ modalTriggerId = Just menuIdent'
, modalId = Nothing
, modalTrigger = \(Just route) menuIdent -> $(widgetFile "widgets/navbar/item")
, modalContent = Left menuItemRoute
}
navbarItem (MenuItem{..}, menuIdent) = do
route <- toTextUrl menuItemRoute
$(widgetFile "widgets/navbar/item")
navbar :: Widget
navbar = $(widgetFile "widgets/navbar/navbar")
asidenav :: Widget
@ -1141,7 +1160,7 @@ instance YesodBreadcrumbs UniWorX where
-- (CourseR tid ssh csh CRegisterR) -- is POST only
breadcrumb (CourseR tid ssh csh CEditR) = return ("Editieren" , Just $ CourseR tid ssh csh CShowR)
breadcrumb (CourseR tid ssh csh CUsersR) = return ("Anmeldungen", Just $ CourseR tid ssh csh CShowR)
breadcrumb (CourseR tid ssh csh (CUserR _)) = return ("Teilnehmer" , Just $ CourseR tid ssh csh CShowR)
breadcrumb (CourseR tid ssh csh (CUserR _)) = return ("Teilnehmer" , Just $ CourseR tid ssh csh CUsersR)
breadcrumb (CourseR tid ssh csh CCorrectionsR) = return ("Abgaben" , Just $ CourseR tid ssh csh CShowR)
breadcrumb (CourseR tid ssh csh SheetListR) = return ("Übungen" , Just $ CourseR tid ssh csh CShowR)
breadcrumb (CourseR tid ssh csh SheetNewR ) = return ("Neu", Just $ CourseR tid ssh csh SheetListR)
@ -1355,6 +1374,14 @@ pageActions (AdminR) =
, menuItemModal = False
, menuItemAccessCallback' = return True
}
, MenuItem
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuMessageList
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute MessageListR
, menuItemModal = False
, menuItemAccessCallback' = return True
}
, MenuItem
{ menuItemType = PageActionPrime
, menuItemLabel = MsgErrMsgHeading
@ -2105,7 +2132,6 @@ instance YesodAuth UniWorX where
[ UserLastAuthentication =. Just now | not isDummy ]
userId <- lift $ entityKey <$> upsertBy uAuth newUser userUpdate
studyTermCandidateIncidence <- liftIO getRandom
let
userStudyFeatures = fmap concat . forM userStudyFeatures' $ parseStudyFeatures userId now
@ -2126,11 +2152,27 @@ instance YesodAuth UniWorX where
fs <- either (\err -> throwError . ServerError $ "Could not parse features of study: " <> err) return userStudyFeatures
let
studyTermCandidates = do
studyTermCandidateName <- termNames
StudyFeatures{ studyFeaturesField = StudyTermsKey' studyTermCandidateKey } <- fs
return StudyTermCandidate{..}
lift $ insertMany_ studyTermCandidates
studyTermCandidates = Set.fromList $ do
name <- termNames
StudyFeatures{ studyFeaturesField = StudyTermsKey' key } <- fs
return (key, name)
studyTermCandidateIncidence
= fromMaybe (error "Could not convert studyTermCandidateIncidence-Hash to UUID")
. UUID.fromByteString
. fromStrict
. (convert :: Digest (SHAKE128 128) -> ByteString)
. runIdentity
$ sourceList (toStrict . Binary.encode <$> Set.toList studyTermCandidates) $$ sinkHash
[E.Value candidatesRecorded] <- lift . E.select . return . E.exists . E.from $ \candidate ->
E.where_ $ candidate E.^. StudyTermCandidateIncidence E.==. E.val studyTermCandidateIncidence
unless candidatesRecorded $ do
let
studyTermCandidates' = do
(studyTermCandidateKey, studyTermCandidateName) <- Set.toList studyTermCandidates
return StudyTermCandidate{..}
lift $ insertMany_ studyTermCandidates'
lift $ E.updateWhere [StudyFeaturesUser ==. userId] [StudyFeaturesValid =. False]
forM_ fs $ \f@StudyFeatures{..} -> do
@ -2179,12 +2221,9 @@ instance YesodMail UniWorX where
mailT ctx mail = defMailT ctx $ do
void setMailObjectId
setDateCurrent
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
replaceMailHeader "Sender" . Just . addressEmail =<< getsYesod (appMailFrom . appSettings)
ret <- mail
setMailSmtpData
return ret
mail <* setMailSmtpData
instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto m where

103
src/Handler/Admin.hs
View File

@ -170,11 +170,11 @@ postAdminTestR = do
-> Natural -- ^ Dimension Index, outermost dimension ist 0 i.e. if dimension is 3 hyperplane-adders get passed 0, planes get passed 1, lines get 2, and points get 3
-> (Text -> Text) -- ^ Nudge deterministic field ids so they're unique
-> FieldView UniWorX -- ^ Submit-Button for this add-widget
-> Maybe (Form (ListLength -> (ListPosition, Int))) -- ^ Nothing iff adding further cells in this position/dimension makes no sense; returns callback to determine index of new cell and data needed to initialize cell
-> Maybe (Form (Map ListPosition Int -> FormResult (Map ListPosition Int))) -- ^ Nothing iff adding further cells in this position/dimension makes no sense; returns callback to determine index of new cells and data needed to initialize cells
mkAddForm 0 0 nudge submitBtn = Just $ \csrf -> do
(addRes, addView) <- mpreq textField ("" & addName (nudge "text")) Nothing -- Any old field; for demonstration
let addRes' = fromMaybe 0 . readMay . Text.filter isDigit <$> addRes -- Do something semi-interesting on the result of the @textField@ to demonstrate that further processing can be done
addRes'' = (\dat l -> (fromIntegral l, dat)) <$> addRes' -- Construct the callback to determine new cell position and data within @FormResult@ as required
addRes'' = addRes' <&> \dat prev -> FormSuccess (Map.singleton (maybe 0 succ . fmap fst $ Map.lookupMax prev) dat) -- Construct the callback to determine new cell positions and data within @FormResult@ as required, nested @FormResult@ allows aborting the add depending on previous data
return (addRes'', toWidget csrf >> fvInput addView >> fvInput submitBtn)
mkAddForm _pos _dim _ _ = error "Dimension and Position is always 0 for our 1-dimensional form"
@ -199,9 +199,13 @@ postAdminTestR = do
-- | 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
allowAdd _ _ l = l < 7 -- Limit list length; much more complicated checks are possible (this could in principle be monadic, but @massInput@ is probably already complicated enough to cover just current (2019-03) usecases)
-- | Where to send the user when they click a shape-changing button, given the id of the Wrapper of the `massInput`-`Widget`
buttonAction :: PathPiece p => p -> Maybe (SomeRoute UniWorX)
buttonAction frag = Just . SomeRoute $ AdminTestR :#: frag
-- The actual call to @massInput@ is comparatively simple:
((miResult, fvInput -> miForm), miEnc) <- runFormPost . identifyForm ("massinput" :: Text) $ massInput (MassInput mkAddForm mkCellForm deleteCell allowAdd) "" True Nothing
((miResult, fvInput -> miForm), miEnc) <- runFormPost . identifyForm ("massinput" :: Text) $ massInput (MassInput mkAddForm mkCellForm deleteCell allowAdd buttonAction) "" True Nothing
let locallyDefinedPageHeading = [whamlet|Admin TestPage for Uni2work|]
@ -265,46 +269,71 @@ postAdminErrMsgR = do
-- BEGIN - Buttons needed only for StudyTermCandidateManagement
data ButtonInferStudyTerms = ButtonInferStudyTerms
data ButtonAdminStudyTerms
= BtnCandidatesInfer
| BtnCandidatesDeleteConflicts
| BtnCandidatesDeleteAll
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
instance Universe ButtonInferStudyTerms
instance Finite ButtonInferStudyTerms
instance Universe ButtonAdminStudyTerms
instance Finite ButtonAdminStudyTerms
nullaryPathPiece ''ButtonInferStudyTerms camelToPathPiece
nullaryPathPiece ''ButtonAdminStudyTerms camelToPathPiece
embedRenderMessage ''UniWorX ''ButtonAdminStudyTerms id
instance Button UniWorX ButtonInferStudyTerms where
btnLabel ButtonInferStudyTerms = "Studienfachzuordnung automatisch lernen"
btnClasses ButtonInferStudyTerms = [BCIsButton, BCPrimary]
instance Button UniWorX ButtonAdminStudyTerms where
btnClasses BtnCandidatesInfer = [BCIsButton, BCPrimary]
btnClasses BtnCandidatesDeleteConflicts = [BCIsButton, BCDanger]
btnClasses BtnCandidatesDeleteAll = [BCIsButton, BCDanger]
-- END Button needed only here
sessionKeyNewStudyTerms :: Text
sessionKeyNewStudyTerms = "key-new-study-terms"
getAdminFeaturesR, postAdminFeaturesR :: Handler Html
getAdminFeaturesR = postAdminFeaturesR
postAdminFeaturesR = do
((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("infer-button" :: Text) (buttonForm :: Form ButtonInferStudyTerms)
((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("infer-button" :: Text) (buttonForm :: Form ButtonAdminStudyTerms)
let btnForm = wrapForm btnWdgt def
{ formAction = Just $ SomeRoute AdminFeaturesR
, formEncoding = btnEnctype
, formSubmit = FormNoSubmit
}
(infConflicts,infAccepted) <- case btnResult of
(FormSuccess ButtonInferStudyTerms) -> do
(infConflicts,infAmbiguous,infRedundant,infAccepted) <- Candidates.inferHandler
unless (null infAmbiguous) $ addMessageI Info $ MsgAmbiguousCandidatesRemoved $ length infAmbiguous
unless (null infRedundant) $ addMessageI Info $ MsgRedundantCandidatesRemoved $ length infRedundant
if null infAccepted
then addMessageI Info MsgNoCandidatesInferred
else addMessageI Success $ MsgCandidatesInferred $ length infAccepted
return (infConflicts,infAccepted)
_other -> (,[]) <$> runDB Candidates.conflicts
unless (null infConflicts) $ addMessage Warning "KONFLIKTE vorhanden" --TODO i18n
infConflicts <- case btnResult of
FormSuccess BtnCandidatesInfer -> do
(infConflicts, infAmbiguous, infRedundant, infAccepted) <- Candidates.inferHandler
unless (null infAmbiguous) . addMessageI Info . MsgAmbiguousCandidatesRemoved $ length infAmbiguous
unless (null infRedundant) . addMessageI Info . MsgRedundantCandidatesRemoved $ length infRedundant
let newKeys = map (StudyTermsKey' . fst) infAccepted
setSessionJson sessionKeyNewStudyTerms newKeys
if | null infAccepted
-> addMessageI Info MsgNoCandidatesInferred
| otherwise
-> addMessageI Success . MsgCandidatesInferred $ length infAccepted
return infConflicts
FormSuccess BtnCandidatesDeleteConflicts -> runDB $ do
confs <- Candidates.conflicts
incis <- Candidates.getIncidencesFor (entityKey <$> confs)
deleteWhere [StudyTermCandidateIncidence <-. (E.unValue <$> incis)]
addMessageI Success $ MsgIncidencesDeleted $ length incis
return []
FormSuccess BtnCandidatesDeleteAll -> runDB $ do
deleteWhere ([] :: [Filter StudyTermCandidate])
addMessageI Success MsgAllIncidencesDeleted
Candidates.conflicts
_other -> runDB Candidates.conflicts
newStudyTermKeys <- fromMaybe [] <$> lookupSessionJson sessionKeyNewStudyTerms
( (degreeResult,degreeTable)
, (studyTermsResult,studytermsTable)
, ((),candidateTable)) <- runDB $ (,,)
, ((), candidateTable)) <- runDB $ (,,)
<$> mkDegreeTable
<*> mkStudytermsTable (Set.fromList $ map (StudyTermsKey' . fst) infAccepted)
<*> mkStudytermsTable (Set.fromList newStudyTermKeys)
(Set.fromList $ map entityKey infConflicts)
<*> mkCandidateTable
-- This needs to happen after calls to `dbTable` so they can short-circuit correctly
unless (null infConflicts) $ addMessageI Warning MsgStudyFeatureConflict
let degreeResult' :: FormResult (Map (Key StudyDegree) (Maybe Text, Maybe Text))
degreeResult' = degreeResult <&> getDBFormResult
(\row -> ( row ^. _dbrOutput . _entityVal . _studyDegreeName
@ -344,7 +373,7 @@ postAdminFeaturesR = do
dbtRowKey = (E.^. StudyDegreeKey)
dbtProj = return
dbtColonnade = formColonnade $ mconcat
[ sortable (Just "key") (i18nCell MsgDegreeKey) (numCell . view (_dbrOutput . _entityVal . _studyDegreeKey))
[ sortable (Just "key") (i18nCell MsgGenericKey) (numCell . view (_dbrOutput . _entityVal . _studyDegreeKey))
, sortable (Just "name") (i18nCell MsgDegreeName) (textInputCell _1 (_dbrOutput . _entityVal . _studyDegreeName))
, sortable (Just "short") (i18nCell MsgDegreeShort) (textInputCell _2 (_dbrOutput . _entityVal . _studyDegreeShorthand))
, dbRow
@ -358,11 +387,12 @@ postAdminFeaturesR = do
dbtFilterUI = mempty
dbtParams = def { dbParamsFormAction = Just . SomeRoute $ AdminFeaturesR :#: ("admin-studydegrees-table-wrapper" :: Text)
}
psValidator = def & defaultSorting [SortAscBy "name", SortAscBy "short", SortAscBy "key"]
psValidator = def -- & defaultSorting [SortAscBy "name", SortAscBy "short", SortAscBy "key"]
& defaultSorting [SortAscBy "key"]
in dbTable psValidator DBTable{..}
mkStudytermsTable :: Set (Key StudyTerms) -> DB (FormResult (DBFormResult (Key StudyTerms) (Maybe Text, Maybe Text) (DBRow (Entity StudyTerms))), Widget)
mkStudytermsTable newKeys =
mkStudytermsTable :: Set (Key StudyTerms) -> Set (Key StudyTerms) -> DB (FormResult (DBFormResult (Key StudyTerms) (Maybe Text, Maybe Text) (DBRow (Entity StudyTerms))), Widget)
mkStudytermsTable newKeys badKeys =
let dbtIdent = "admin-studyterms" :: Text
dbtStyle = def
dbtSQLQuery :: E.SqlExpr (Entity StudyTerms) -> E.SqlQuery ( E.SqlExpr (Entity StudyTerms))
@ -370,15 +400,18 @@ postAdminFeaturesR = do
dbtRowKey = (E.^. StudyTermsKey)
dbtProj = return
dbtColonnade = formColonnade $ mconcat
[ sortable (Just "key") (i18nCell MsgStudyTermsKey) (numCell . view (_dbrOutput . _entityVal . _studyTermsKey))
, sortable (Just "isnew") (i18nCell MsgStudyTermIsNew) (isNewCell . flip Set.member newKeys . view (_dbrOutput . _entityKey))
, sortable (Just "name") (i18nCell MsgStudyTermsName) (textInputCell _1 (_dbrOutput . _entityVal . _studyTermsName))
, sortable (Just "short") (i18nCell MsgStudyTermsShort) (textInputCell _2 (_dbrOutput . _entityVal . _studyTermsShorthand))
[ sortable (Just "key") (i18nCell MsgGenericKey) (numCell . view (_dbrOutput . _entityVal . _studyTermsKey))
, sortable (Just "isnew") (i18nCell MsgGenericIsNew) (isNewCell . flip Set.member newKeys . view (_dbrOutput . _entityKey))
, sortable (Just "isbad") (i18nCell MsgGenericHasConflict) (isBadCell . flip Set.member badKeys . view (_dbrOutput . _entityKey))
, sortable (Just "name") (i18nCell MsgStudyTermsName) (textInputCell _1 (_dbrOutput . _entityVal . _studyTermsName))
, sortable (Just "short") (i18nCell MsgStudyTermsShort) (textInputCell _2 (_dbrOutput . _entityVal . _studyTermsShorthand))
, dbRow
]
dbtSorting = Map.fromList
[ ("key" , SortColumn (E.^. StudyTermsKey))
, ("isnew" , SortColumn (\studyTerm -> studyTerm E.^. StudyTermsId `E.in_` E.valList (Set.toList newKeys)))
, ("isnew" , SortColumn (\studyTerm -> studyTerm E.^. StudyTermsKey `E.in_` E.valList (unStudyTermsKey <$> Set.toList newKeys))) -- works only once
-- Remember: sorting with E.in_ by StudyTermsId instead will produce esqueleto-error "unsafeSqlBinOp: non-id/composite keys not expected here"
, ("isbad" , SortColumn (\studyTerm -> studyTerm E.^. StudyTermsKey `E.in_` E.valList (unStudyTermsKey <$> Set.toList badKeys)))
, ("name" , SortColumn (E.^. StudyTermsName))
, ("short" , SortColumn (E.^. StudyTermsShorthand))
]
@ -386,7 +419,9 @@ postAdminFeaturesR = do
dbtFilterUI = mempty
dbtParams = def { dbParamsFormAction = Just . SomeRoute $ AdminFeaturesR :#: ("admin-studyterms-table-wrapper" :: Text)
}
psValidator = def & defaultSorting [SortAscBy "name", SortAscBy "short", SortAscBy "key"]
psValidator = def
-- & defaultSorting [SortAscBy "name", SortAscBy "short", SortAscBy "key"]
& defaultSorting [SortDescBy "isnew", SortDescBy "isbad", SortAscBy "key"]
in dbTable psValidator DBTable{..}
mkCandidateTable =

1
src/Handler/Corrections.hs
View File

@ -161,6 +161,7 @@ colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(E
mkRoute = do
cid <- encrypt subId
return $ CSubmissionR tid ssh csh sheetName cid CorrectionR
mTuple mA mB = (,) <$> mA <*> mB -- Hamlet does not support enough haskell-syntax for this
in mconcat
[ anchorCellM mkRoute $(widgetFile "widgets/rating/rating")
, writerCell $ do

490
src/Handler/Course.hs
View File

@ -9,15 +9,17 @@ import Utils.Form
-- import Utils.DB
import Handler.Utils
import Handler.Utils.Course
import Handler.Utils.Form.MassInput
import Handler.Utils.Delete
import Handler.Utils.Database
import Handler.Utils.Table.Cells
import Handler.Utils.Table.Columns
import Database.Esqueleto.Utils
import Database.Persist.Sql (deleteWhereCount)
import qualified Database.Esqueleto.Utils as E
import Database.Esqueleto.Utils.TH
-- import Data.Time
-- import qualified Data.Text as T
import qualified Data.CaseInsensitive as CI
import Data.Function ((&))
-- import Yesod.Form.Bootstrap3
@ -29,6 +31,7 @@ import qualified Data.Map as Map
import qualified Database.Esqueleto as E
import Text.Blaze.Html.Renderer.Text (renderHtml)
-- NOTE: Outdated way to use dbTable; see ProfileDataR Handler for a more recent method.
type CourseTableData = DBRow (Entity Course, Int, Bool, Entity School)
@ -268,7 +271,7 @@ getTermCourseListR tid = do
getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCShowR tid ssh csh = do
mbAid <- maybeAuthId
(course,schoolName,participants,registration,defSFid,lecturers) <- runDB . maybeT notFound $ do
(course,schoolName,participants,registration,defSFid,lecturers,assistants) <- runDB . maybeT notFound $ do
[(E.Entity cid course, E.Value schoolName, E.Value participants, fmap entityVal -> registration)]
<- lift . E.select . E.from $
\((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do
@ -284,12 +287,17 @@ getCShowR tid ssh csh = do
return ( E.countRows :: E.SqlExpr (E.Value Int))
return (course,school E.^. SchoolName, numParticipants, participant)
defSFid <- ifMaybeM mbAid Nothing $ \uid -> lift $ selectFirst [StudyFeaturesUser ==. uid, StudyFeaturesType ==. FieldPrimary, StudyFeaturesValid ==. True] [Desc StudyFeaturesUpdated, Desc StudyFeaturesDegree, Desc StudyFeaturesField] -- sorting by degree & field is an heuristic only, but this is okay for a default suggestion
lecturers <- lift . E.select $ E.from $ \(lecturer `E.InnerJoin` user) -> do
staff <- lift . E.select $ E.from $ \(lecturer `E.InnerJoin` user) -> do
E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId
E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid
E.orderBy [ E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName ]
return (user E.^. UserDisplayName, user E.^. UserSurname, user E.^. UserEmail)
return (course,schoolName,participants,registration,entityKey <$> defSFid,lecturers)
return ( lecturer E.^. LecturerType
, user E.^. UserEmail, user E.^. UserDisplayName, user E.^. UserSurname)
let partStaff :: (LecturerType, UserEmail, Text, Text) -> Either (UserEmail, Text, Text) (UserEmail, Text, Text)
partStaff (CourseLecturer ,name,surn,mail) = Right (name,surn,mail)
partStaff (_courseAssistant,name,surn,mail) = Left (name,surn,mail)
(assistants,lecturers) = partitionWith partStaff $ map $(unValueN 4) staff
return (course,schoolName,participants,registration,entityKey <$> defSFid,lecturers,assistants)
mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course
mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course
@ -303,7 +311,7 @@ getCShowR tid ssh csh = do
}
registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True
siteLayout (toWgt $ courseName course) $ do
setTitle [shamlet| #{toPathPiece tid} - #{csh}|]
setTitleI $ prependCourseTitle tid ssh csh (""::Text)
$(widgetFile "course")
-- | Registration button with maybe a userid if logged in
@ -370,8 +378,14 @@ getCourseNewR = do
<*> iopt ciField "ssh"
<*> iopt ciField "csh"
let courseEditHandler' = courseEditHandler $ \p -> Just . SomeRoute $ (CourseNewR, getParams) :#: p
getParams = concat
[ [ ("tid", toPathPiece tid) | FormSuccess (Just tid, _, _) <- [params] ]
, [ ("ssh", toPathPiece ssh) | FormSuccess (_, Just ssh, _) <- [params] ]
, [ ("csh", toPathPiece csh) | FormSuccess (_, _, Just csh) <- [params] ]
]
let noTemplateAction = courseEditHandler Nothing
let noTemplateAction = courseEditHandler' Nothing
case params of -- DO NOT REMOVE: without this distinction, lecturers would never see an empty makeCourseForm any more!
FormMissing -> noTemplateAction
FormFailure msgs -> forM_ msgs (addMessage Error . toHtml) >>
@ -402,7 +416,7 @@ getCourseNewR = do
return course
template <- case listToMaybe oldCourses of
(Just oldTemplate) ->
let newTemplate = courseToForm oldTemplate in
let newTemplate = courseToForm oldTemplate [] in
return $ Just $ newTemplate
{ cfCourseId = Nothing
, cfTerm = TermKey $ TermIdentifier 0 Winter -- invalid, will be ignored; undefined won't work due to strictness
@ -420,10 +434,10 @@ getCourseNewR = do
unless cshOk $ addMessageI Warning $ MsgNoSuchCourseShorthand $ fromJust mbCsh
when (tidOk && sshOk && cshOk) $ addMessageI Warning MsgNoSuchCourse
return Nothing
courseEditHandler template
courseEditHandler' template
postCourseNewR :: Handler Html
postCourseNewR = courseEditHandler Nothing -- Note: Nothing is safe here, since we will create a new course.
postCourseNewR = courseEditHandler (\p -> Just . SomeRoute $ CourseNewR :#: p) Nothing -- Note: Nothing is safe here, since we will create a new course.
getCEditR, postCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCEditR = pgCEditR
@ -431,10 +445,13 @@ postCEditR = pgCEditR
pgCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
pgCEditR tid ssh csh = do
course <- runDB $ getBy $ TermSchoolCourseShort tid ssh csh
courseLecs <- runDB $ do
mbCourse <- getBy (TermSchoolCourseShort tid ssh csh)
mbLecs <- for mbCourse $ \course -> map entityVal <$> selectList [LecturerCourse ==. entityKey course] [Asc LecturerType]
return $ (,) <$> mbCourse <*> mbLecs
-- IMPORTANT: both GET and POST Handler must use the same template,
-- since an Edit is identified via CourseID, which is not embedded in the received form data for security reasons.
courseEditHandler $ courseToForm <$> course
courseEditHandler (\p -> Just . SomeRoute $ CourseR tid ssh csh CEditR :#: p) $ uncurry courseToForm <$> courseLecs
getCDeleteR, postCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
@ -450,48 +467,50 @@ postCDeleteR tid ssh csh = do
-- | Course Creation and Editing
-- | IMPORTANT: in case of Edit, Post/Get Request is provided with the same CourseForm template (cannot be Nothing),
-- | since an edit is identified via cfCourseId which is not contained in the received form data for security reasons!
courseEditHandler :: Maybe CourseForm -> Handler Html
courseEditHandler mbCourseForm = do
courseEditHandler :: (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)) -> Maybe CourseForm -> Handler Html
courseEditHandler miButtonAction mbCourseForm = do
aid <- requireAuthId -- TODO: Verify that Editor is owner of the Course to be Edited!!!
((result, formWidget), formEnctype) <- runFormPost $ makeCourseForm mbCourseForm
case result of
(FormSuccess res@CourseForm
((result, formWidget), formEnctype) <- runFormPost $ makeCourseForm miButtonAction mbCourseForm
formResult result $ \case
res@CourseForm
{ cfCourseId = Nothing
, cfShort = csh
, cfSchool = ssh
, cfTerm = tid
}) -> do -- create new course
} -> do -- create new course
now <- liftIO getCurrentTime
insertOkay <- runDB $ insertUnique Course
{ courseName = cfName res
, courseDescription = cfDesc res
, courseLinkExternal = cfLink res
, courseShorthand = cfShort res
, courseTerm = cfTerm res
, courseSchool = cfSchool res
, courseCapacity = cfCapacity res
, courseRegisterSecret = cfSecret res
, courseMaterialFree = cfMatFree res
, courseRegisterFrom = cfRegFrom res
, courseRegisterTo = cfRegTo res
, courseDeregisterUntil = cfDeRegUntil res
}
case insertOkay of
(Just cid) -> do
runDB $ do
insertOkay <- runDB $ do
insertOkay <- insertUnique Course
{ courseName = cfName res
, courseDescription = cfDesc res
, courseLinkExternal = cfLink res
, courseShorthand = cfShort res
, courseTerm = cfTerm res
, courseSchool = cfSchool res
, courseCapacity = cfCapacity res
, courseRegisterSecret = cfSecret res
, courseMaterialFree = cfMatFree res
, courseRegisterFrom = cfRegFrom res
, courseRegisterTo = cfRegTo res
, courseDeregisterUntil = cfDeRegUntil res
}
whenIsJust insertOkay $ \cid -> do
forM_ (cfLecturers res) (\(lid,lty) -> insert_ $ Lecturer lid cid lty)
insert_ $ CourseEdit aid now cid
insert_ $ Lecturer aid cid
return insertOkay
case insertOkay of
Just _ -> do
addMessageI Info $ MsgCourseNewOk tid ssh csh
redirect $ TermCourseListR tid
Nothing ->
addMessageI Warning $ MsgCourseNewDupShort tid ssh csh
(FormSuccess res@CourseForm
res@CourseForm
{ cfCourseId = Just cid
, cfShort = csh
, cfSchool = ssh
, cfTerm = tid
}) -> do -- edit existing course
} -> do -- edit existing course
now <- liftIO getCurrentTime
-- addMessage "debug" [shamlet| #{show res}|]
success <- runDB $ do
@ -516,13 +535,12 @@ courseEditHandler mbCourseForm = do
case updOkay of
(Just _) -> addMessageI Warning (MsgCourseEditDupShort tid ssh csh) $> False
Nothing -> do
deleteWhere [LecturerCourse ==. cid]
forM_ (cfLecturers res) (\(lid,lty) -> insert_ $ Lecturer lid cid lty)
insert_ $ CourseEdit aid now cid
addMessageI Success $ MsgCourseEditOk tid ssh csh
return True
when success $ redirect $ CourseR tid ssh csh CShowR
(FormFailure _) -> addMessageI Warning MsgInvalidInput
FormMissing -> return ()
actionUrl <- fromMaybe CourseNewR <$> getCurrentRoute
defaultLayout $ do
setTitleI MsgCourseEditTitle
@ -546,10 +564,11 @@ data CourseForm = CourseForm
, cfRegFrom :: Maybe UTCTime
, cfRegTo :: Maybe UTCTime
, cfDeRegUntil :: Maybe UTCTime
, cfLecturers :: [(UserId, LecturerType)]
}
courseToForm :: Entity Course -> CourseForm
courseToForm (Entity cid Course{..}) = CourseForm
courseToForm :: Entity Course -> [Lecturer] -> CourseForm
courseToForm (Entity cid Course{..}) lecs = CourseForm
{ cfCourseId = Just cid
, cfName = courseName
, cfDesc = courseDescription
@ -563,21 +582,21 @@ courseToForm (Entity cid Course{..}) = CourseForm
, cfRegFrom = courseRegisterFrom
, cfRegTo = courseRegisterTo
, cfDeRegUntil = courseDeregisterUntil
, cfLecturers = [(lecturerUser, lecturerType) | Lecturer{..} <- lecs]
}
makeCourseForm :: Maybe CourseForm -> Form CourseForm
makeCourseForm template = identifyForm FIDcourse $ \html -> do
makeCourseForm :: (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)) -> Maybe CourseForm -> Form CourseForm
makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do
-- TODO: Refactor to avoid the four repeated calls to liftHandlerT and three runDBs
-- let editCid = cfCourseId =<< template -- possible start for refactoring
mr <- liftHandlerT getMessageRender -- needed for translation of placeholders
MsgRenderer mr <- getMsgRenderer
userSchools <- liftHandlerT . runDB $ do
userId <- liftHandlerT requireAuthId
(fmap concat . sequence)
[ map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. userId] []
, map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. userId] []
]
uid <- liftHandlerT requireAuthId
(lecSchools, admSchools) <- liftHandlerT . runDB $ (,)
<$> (map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. uid] [] )
<*> (map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. uid] [] )
let userSchools = lecSchools ++ admSchools
termsField <- case template of
-- Change of term is only allowed if user may delete the course (i.e. no participants) or admin
@ -590,6 +609,48 @@ makeCourseForm template = identifyForm FIDcourse $ \html -> do
| otherwise -> termsSetField [cfTerm cform]
_allOtherCases -> return termsAllowedField
let miAdd :: ListPosition -> Natural -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition UserId -> FormResult (Map ListPosition UserId)))
miAdd _ _ nudge btn = Just $ \csrf -> do
(addRes, addView) <- mpreq emailField ("" & addName (nudge "user")) Nothing
addRes' <- for addRes $ liftHandlerT . runDB . getKeyBy . UniqueEmail . CI.mk
let addRes'' = case (,) <$> addRes <*> addRes' of
FormSuccess (email, Nothing) -> FormFailure [ mr . MsgEMailUnknown $ CI.mk email ]
FormSuccess (email, Just lid) -> FormSuccess $ \prev -> if
| lid `elem` Map.elems prev -> FormFailure [ mr . MsgCourseLecturerAlreadyAdded $ CI.mk email ]
| otherwise -> FormSuccess $ Map.singleton (maybe 0 succ . fmap fst $ Map.lookupMax prev) lid
FormFailure errs -> FormFailure errs
FormMissing -> FormMissing
addView' = toWidget csrf >> fvInput addView >> fvInput btn
return (addRes'', addView')
miCell :: ListPosition -> UserId -> Maybe LecturerType -> (Text -> Text) -> Form LecturerType
miCell _ lid defType nudge = \csrf -> do
(lrwRes,lrwView) <- mreq (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) defType
User{userEmail, userDisplayName, userSurname} <- liftHandlerT . runDB $ get404 lid
let lrwView' = [whamlet|$newline never
#{csrf}
^{nameEmailWidget userEmail userDisplayName userSurname} #
^{fvInput lrwView}
|]
return (lrwRes,lrwView')
miDelete :: ListLength -- ^ Current shape
-> ListPosition -- ^ Coordinate to delete
-> MaybeT (MForm (HandlerT UniWorX IO)) (Map ListPosition ListPosition)
miDelete = miDeleteList
miAllowAdd :: ListPosition -> Natural -> ListLength -> Bool
miAllowAdd _ _ _ = True
lecturerForm :: AForm Handler [(UserId,LecturerType)]
lecturerForm = formToAForm . over (mapped._2) pure . over (mapped._1.mapped) Map.elems $ massInput
MassInput{..}
(fslI MsgCourseLecturers & setTooltip MsgCourseLecturerRightsIdentical)
True
(Just . Map.fromList . zip [0..] $ maybe [(uid, CourseLecturer)] cfLecturers template)
mempty
(newRegFrom,newRegTo,newDeRegUntil) <- case template of
(Just cform) | (Just _cid) <- cfCourseId cform -> return (Nothing,Nothing,Nothing)
_allIOtherCases -> do
@ -621,11 +682,11 @@ makeCourseForm template = identifyForm FIDcourse $ \html -> do
& setTooltip MsgCourseRegisterToTip) (deepAlt (cfRegTo <$> template) newRegTo)
<*> aopt utcTimeField (fslpI MsgDeRegUntil (mr MsgDate)
& setTooltip MsgCourseDeregisterUntilTip) (deepAlt (cfDeRegUntil <$> template) newDeRegUntil)
<* submitButton
return $ case result of
FormSuccess courseResult
| errorMsgs <- validateCourse courseResult
, not $ null errorMsgs ->
<*> lecturerForm
errorMsgs' <- traverse validateCourse result
return $ case errorMsgs' of
FormSuccess errorMsgs
| not $ null errorMsgs ->
(FormFailure errorMsgs,
[whamlet|
<div class="alert alert-danger">
@ -640,23 +701,26 @@ makeCourseForm template = identifyForm FIDcourse $ \html -> do
_ -> (result, widget)
validateCourse :: CourseForm -> [Text]
validateCourse CourseForm{..} =
[ msg | (False, msg) <-
[
( NTop cfRegFrom <= NTop cfRegTo
, "Ende des Anmeldezeitraums muss nach dem Anfang liegen"
)
,
( NTop cfRegFrom <= NTop cfDeRegUntil
, "Ende des Abmeldezeitraums muss nach dem Anfang liegen"
)
-- No starting date is okay: effective immediately
-- ( cfHasReg <= (isNothing cfRegFrom)
-- , "Beginn der Anmeldung angeben oder Anmeldungen deaktivieren"
-- )
-- ,
] ]
validateCourse :: (MonadHandler m, HandlerSite m ~ UniWorX) => CourseForm -> m [Text]
validateCourse CourseForm{..} = do
uid <- liftHandlerT requireAuthId
userAdmin <- liftHandlerT . runDB . getBy $ UniqueUserAdmin uid cfSchool -- FIXME: This /needs/ to be a call to `isAuthorized` on a route
MsgRenderer mr <- getMsgRenderer
return
[ mr msg | (False, msg) <-
[
( NTop cfRegFrom <= NTop cfRegTo
, MsgCourseRegistrationEndMustBeAfterStart
)
,
( NTop cfRegFrom <= NTop cfDeRegUntil
, MsgCourseDeregistrationEndMustBeAfterStart
)
, ( maybe (any ((== uid) . fst) cfLecturers) (\(Entity _ UserAdmin{}) -> True) userAdmin
, MsgCourseUserMustBeLecturer
)
] ]
@ -756,77 +820,131 @@ colUserDegreeShort :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell
colUserDegreeShort = sortable (Just "degree-short") (i18nCell MsgStudyFeatureDegree) $
foldMap (i18nCell . ShortStudyDegree) . preview (_userTableFeatures . _2 . _Just)
makeCourseUserTable :: CourseId -> _ -> _ -> DB Widget
makeCourseUserTable cid colChoices psValidator =
-- -- psValidator has default sorting and filtering
let dbtIdent = "courseUsers" :: Text
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
dbtSQLQuery = userTableQuery cid
dbtRowKey = queryUser >>> (E.^. UserId)
dbtProj = traverse $ \(user, E.Value registrationTime , E.Value userNoteId, (feature,degree,terms)) -> return (user, registrationTime, userNoteId, (entityVal <$> feature, entityVal <$> degree, entityVal <$> terms))
dbtColonnade = colChoices
dbtSorting = Map.fromList
[ sortUserNameLink queryUser -- slower sorting through clicking name column header
, sortUserSurname queryUser -- needed for initial sorting
, sortUserDisplayName queryUser -- needed for initial sorting
, sortUserEmail queryUser
, sortUserMatriclenr queryUser
, ("degree" , SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeName))
, ("degree-short", SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand))
, ("field" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsName))
, ("field-short" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
, ("semesternr" , SortColumn $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
, ("registration", SortColumn $ queryParticipant >>> (E.^. CourseParticipantRegistration))
, ("note" , SortColumn $ queryUserNote >>> \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
[ fltrUserNameLink queryUser
, fltrUserEmail queryUser
, fltrUserMatriclenr queryUser
, fltrUserNameEmail queryUser
-- , ("course-user-degree", error "TODO") -- TODO
-- , ("course-user-field" , error "TODO") -- TODO
, ("course-user-semesternr", FilterColumn $ mkExactFilter $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
-- , ("course-registration", error "TODO") -- TODO
-- , ("course-user-note", error "TODO") -- TODO
]
dbtFilterUI mPrev = mconcat
[ fltrUserNameEmailUI mPrev
, fltrUserMatriclenrUI mPrev
]
dbtParams = def
in dbTableWidget' psValidator DBTable{..}
data CourseUserAction = CourseUserDeregister
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
instance Universe CourseUserAction
instance Finite CourseUserAction
nullaryPathPiece ''CourseUserAction $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''CourseUserAction id
makeCourseUserTable :: CourseId -> _ -> _ -> DB (FormResult (CourseUserAction, Set UserId), Widget)
makeCourseUserTable cid colChoices psValidator = do
Just currentRoute <- liftHandlerT getCurrentRoute
-- -- psValidator has default sorting and filtering
let dbtIdent = "courseUsers" :: Text
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
dbtSQLQuery = userTableQuery cid
dbtRowKey = queryUser >>> (E.^. UserId)
dbtProj = traverse $ \(user, E.Value registrationTime , E.Value userNoteId, (feature,degree,terms)) -> return (user, registrationTime, userNoteId, (entityVal <$> feature, entityVal <$> degree, entityVal <$> terms))
dbtColonnade = colChoices
dbtSorting = Map.fromList
[ sortUserNameLink queryUser -- slower sorting through clicking name column header
, sortUserSurname queryUser -- needed for initial sorting
, sortUserDisplayName queryUser -- needed for initial sorting
, sortUserEmail queryUser
, sortUserMatriclenr queryUser
, ("degree" , SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeName))
, ("degree-short", SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand))
, ("field" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsName))
, ("field-short" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
, ("semesternr" , SortColumn $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
, ("registration", SortColumn $ queryParticipant >>> (E.^. CourseParticipantRegistration))
, ("note" , SortColumn $ queryUserNote >>> \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
[ fltrUserNameLink queryUser
, fltrUserEmail queryUser
, fltrUserMatriclenr queryUser
, fltrUserNameEmail queryUser
, ("field-name" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsName))
, ("field-short" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
, ("field-key" , FilterColumn $ E.mkExactFilter $ queryFeaturesField >>> (E.?. StudyTermsKey))
, ("field" , FilterColumn $ E.anyFilter
[ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsName)
, E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand)
, E.mkExactFilterWith readMay $ queryFeaturesField >>> (E.?. StudyTermsKey)
] )
, ("degree" , FilterColumn $ E.anyFilter
[ E.mkContainsFilter $ queryFeaturesDegree >>> (E.?. StudyDegreeName)
, E.mkContainsFilter $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand)
, E.mkExactFilterWith readMay $ queryFeaturesDegree >>> (E.?. StudyDegreeKey)
] )
, ("semesternr" , FilterColumn $ E.mkExactFilter $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
-- , ("course-registration", error "TODO") -- TODO
-- , ("course-user-note", error "TODO") -- TODO
]
dbtFilterUI mPrev = mconcat
[ fltrUserNameEmailUI mPrev
, fltrUserMatriclenrUI mPrev
, prismAForm (singletonFilter "degree") mPrev $ aopt (searchField False) (fslI MsgStudyFeatureDegree)
, prismAForm (singletonFilter "field") mPrev $ aopt (searchField False) (fslI MsgCourseStudyFeature)
]
dbtParams = DBParamsForm
{ dbParamsFormMethod = POST
, dbParamsFormAction = Just $ SomeRoute currentRoute
, dbParamsFormAttrs = []
, dbParamsFormSubmit = FormSubmit
, dbParamsFormAdditional = \csrf -> do
(res,vw) <- mreq (selectField optionsFinite) "" Nothing
let formWgt = toWidget csrf <> fvInput vw
formRes = (, mempty) . First . Just <$> res
return (formRes,formWgt)
, dbParamsFormEvaluate = liftHandlerT . runFormPost
, dbParamsFormResult = id
, dbParamsFormIdent = def
}
over _1 postprocess <$> dbTable psValidator DBTable{..}
where
postprocess :: FormResult (First CourseUserAction, DBFormResult UserId Bool UserTableData) -> FormResult (CourseUserAction, Set UserId)
postprocess inp = do
(First (Just act), usrMap) <- inp
let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
return (act, usrSet)
getCUsersR, postCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCUsersR = postCUsersR
postCUsersR tid ssh csh = do
(Entity cid course, numParticipants, (participantRes,participantTable)) <- runDB $ do
let colChoices = mconcat
[ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
, colUserNameLink (CourseR tid ssh csh . CUserR)
, colUserEmail
, colUserMatriclenr
, colUserDegreeShort
, colUserField
, colUserSemester
, sortable (Just "registration") (i18nCell MsgRegisteredHeader) (dateCell . view _userTableRegistration)
, colUserComment tid ssh csh
]
psValidator = def & defaultSortingByName
ent@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh
numParticipants <- count [CourseParticipantCourse ==. cid]
table <- makeCourseUserTable cid colChoices psValidator
return (ent, numParticipants, table)
formResult participantRes $ \case
(CourseUserDeregister,selectedUsers) -> do
nrDel <- runDB $ deleteWhereCount
[ CourseParticipantCourse ==. cid
, CourseParticipantUser <-. Set.toList selectedUsers
]
addMessageI Success $ MsgCourseUsersDeregistered nrDel
redirect $ CourseR tid ssh csh CUsersR
let headingLong = [whamlet|_{MsgMenuCourseMembers} #{courseName course} #{display tid}|]
headingShort = prependCourseTitle tid ssh csh MsgCourseMembers
siteLayout headingLong $ do
setTitleI headingShort
$(widgetFile "course-participants")
getCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCUsersR tid ssh csh = do
Entity cid course <- runDB $ getBy404 $ TermSchoolCourseShort tid ssh csh
let heading = [whamlet|_{MsgMenuCourseMembers} #{courseName course} #{display tid}|]
colChoices = mconcat
[ colUserNameLink (CourseR tid ssh csh . CUserR)
, colUserEmail
, colUserMatriclenr
, colUserDegreeShort
, colUserField
, colUserSemester
, sortable (Just "course-registration") (i18nCell MsgRegisteredHeader) (dateCell . view _userTableRegistration)
, colUserComment tid ssh csh
]
psValidator = def & defaultSortingByName
tableWidget <- runDB $ makeCourseUserTable cid colChoices psValidator
siteLayout heading $ do
setTitle [shamlet| #{toPathPiece tid} - #{csh}|]
-- TODO: create hamlet wrapper
tableWidget
getCUserR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDUser -> Handler Html
getCUserR _tid _ssh _csh uCId = do
getCUserR, postCUserR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDUser -> Handler Html
getCUserR = postCUserR
postCUserR tid ssh csh uCId = do
-- Has authorization checks (OR):
--
-- - User is current member of course
@ -836,18 +954,88 @@ getCUserR _tid _ssh _csh uCId = do
-- - User is corrector for course
-- - User is a tutor for course
-- - User is a lecturer for course
let currentRoute = CourseR tid ssh csh (CUserR uCId)
dozentId <- requireAuthId
uid <- decrypt uCId
User{..} <- runDB $ get404 uid
-- USE src/utils/Form.formResult
defaultLayout -- TODO
[whamlet|
<p>^{nameWidget userDisplayName userSurname}
|]
-- DB reads
(cid, User{..}, registration, thisUniqueNote, noteText, noteEdits, studies ) <- runDB $ do
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
-- Abfrage Benutzerdaten
user <- get404 uid
registration <- fmap entityVal <$> getBy (UniqueParticipant uid cid)
-- Abfrage Teilnehmernotiz
let thisUniqueNote = UniqueCourseUserNote uid cid
mbNoteEnt <- getBy thisUniqueNote
(noteText,noteEdits) <- case mbNoteEnt of
Nothing -> return (Nothing,[])
(Just (Entity noteKey CourseUserNote{courseUserNoteNote})) -> do
noteEdits <- E.select $ E.from $ \(edit `E.InnerJoin` usr) -> do
E.on $ edit E.^. CourseUserNoteEditUser E.==. usr E.^. UserId
E.where_ $ edit E.^. CourseUserNoteEditNote E.==. E.val noteKey
E.orderBy [E.desc $ edit E.^. CourseUserNoteEditTime]
E.limit 1 -- more will be shown, if changed here
return (edit E.^. CourseUserNoteEditTime, usr E.^. UserEmail, usr E.^. UserDisplayName, usr E.^. UserSurname)
return (Just courseUserNoteNote, $(unValueN 4) <$> noteEdits)
-- Abfrage Studiengänge
studies <- E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do
E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId
E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId
return (studyfeat, studydegree, studyterms)
return (cid,user,registration,thisUniqueNote,noteText,noteEdits,studies)
let editByWgt = [whamlet|
$forall (etime,_eemail,ename,_esurname) <- noteEdits
<br>
_{MsgLastEdit} ^{editedByW SelFormatDateTime etime ename}
|] -- _{MsgLastEdit} ^{formatTimeW SelFormatDateTime etime} ^{nameWidget ename esurname}
((noteRes, noteView), noteEnctype) <- runFormPost . identifyForm FIDcUserNote . renderAForm FormStandard $
aopt (annotateField editByWgt htmlField') (fslpI MsgCourseUserNote "HTML" & setTooltip MsgCourseUserNoteTooltip) (Just noteText)
<* saveButton
formResult noteRes $ \mbNote -> (do
now <- liftIO getCurrentTime
case mbNote of
Nothing -> do
runDB $ do
-- must delete all edits due to foreign key constraints, which does not make sense -> refactor!
maybeM (return ()) (\nk -> deleteWhere [CourseUserNoteEditNote ==. nk]) (getKeyBy thisUniqueNote)
deleteBy thisUniqueNote
addMessageI Info MsgCourseUserNoteDeleted
redirect currentRoute -- reload page after post
_ | (renderHtml <$> mbNote) == (renderHtml <$> noteText) -> return() -- no changes
(Just note) -> do
runDB $ do
(Entity noteKey _) <- upsertBy thisUniqueNote (CourseUserNote cid uid note) [CourseUserNoteNote =. note]
void . insert $ CourseUserNoteEdit dozentId now noteKey
addMessageI Success MsgCourseUserNoteSaved
redirect currentRoute -- reload page after post
)
-- De-/Register Button for Lecturer
mRegAt <- traverse (formatTime SelFormatDateTime) $ courseParticipantRegistration <$> registration
((registerRes,registerView), registerEnctype) <- runFormPost $ registerForm (Just uid) registration Nothing Nothing -- Lecturers are never asked their own register secret
formResult registerRes $ \(mbSfId, _secretCorrect) -> if -- lecturers need no secret verification
| isJust registration -> do
runDB $ deleteBy $ UniqueParticipant uid cid
addMessageI Info MsgCourseDeregisterOk
| otherwise -> do
actTime <- liftIO getCurrentTime
regOk <- runDB $ insertUnique $ CourseParticipant cid uid actTime mbSfId
when (isJust regOk) $ addMessageI Success MsgCourseRegisterOk
-- generate output
let headingLong = [whamlet|^{nameWidget userDisplayName userSurname} - _{MsgCourseMemberOf} #{csh} #{display tid}|]
headingShort = prependCourseTitle tid ssh csh $ SomeMessage userDisplayName
siteLayout headingLong $ do
setTitleI headingShort
$(widgetFile "course-user")
getCHiWisR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCHiWisR = error "CHiWisR: Not implemented"
getCNotesR, postCNotesR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
-- NOTE: The route getNotesR is abused for correctorORlecturer access rights!
getCNotesR = error "CNotesR: Not implemented"
-- PROBLEM: Correctors usually don't know Participants by name (anonymous), maybe notes are not shared?
-- If they are shared, adjust MsgCourseUserNoteTooltip
getCNotesR = error "CNotesR: Not implemented"
postCNotesR = error "CNotesR: Not implemented"

70
src/Handler/Help.hs Normal file
View File

@ -0,0 +1,70 @@
module Handler.Help where
import Import
import Handler.Utils
import Jobs
import qualified Data.Map as Map
data HelpIdentOptions = HIUser | HIEmail | HIAnonymous
deriving (Eq, Ord, Bounded, Enum, Show, Read)
instance Universe HelpIdentOptions
instance Finite HelpIdentOptions
nullaryPathPiece ''HelpIdentOptions (camelToPathPiece' 1)
embedRenderMessage ''UniWorX ''HelpIdentOptions (("Help" <>) . dropPrefix "HI")
data HelpForm = HelpForm
{ hfReferer :: Maybe (Route UniWorX)
, hfUserId :: Either (Maybe Address) UserId
, hfSubject :: Maybe Text
, hfRequest :: Text
}
helpForm :: (forall msg. RenderMessage UniWorX msg => msg -> Text) -> Maybe (Route UniWorX) -> Maybe UserId -> AForm _ HelpForm
helpForm mr mReferer mUid = HelpForm
<$> aopt routeField (fslI MsgHelpProblemPage & inputReadonly) (Just <$> mReferer)
<*> multiActionA (fslI MsgHelpAnswer) identActions (HIUser <$ mUid)
<*> aopt textField (fslpI MsgHelpSubject $ mr MsgHelpSubject) Nothing
<*> (unTextarea <$> areq textareaField (fslpI MsgHelpRequest $ mr MsgHelpRequest) Nothing)
where
identActions :: Map _ (AForm _ (Either (Maybe Address) UserId))
identActions = Map.fromList $ case mUid of
(Just uid) -> (HIUser, pure $ Right uid):defaultActions
Nothing -> defaultActions
defaultActions =
[ (HIEmail, Left . Just <$> (Address <$> aopt textField (fslpI MsgName $ mr MsgName) Nothing <*> apreq emailField (fslpI MsgEMail $ mr MsgEMail) Nothing))
, (HIAnonymous, pure $ Left Nothing)
]
getHelpR, postHelpR :: Handler Html
getHelpR = postHelpR
postHelpR = do
mUid <- maybeAuthId
mReferer <- flip formResultMaybe return <=< runInputGetResult $ iopt routeField (toPathPiece GetReferer)
isModal <- hasCustomHeader HeaderIsModal
MsgRenderer mr <- getMsgRenderer
((res,formWidget),formEnctype) <- runFormPost $ renderAForm FormStandard $ helpForm mr mReferer mUid
formResultModal res HelpR $ \HelpForm{..} -> do
now <- liftIO getCurrentTime
hfReferer' <- traverse toTextUrl hfReferer
queueJob' JobHelpRequest
{ jSender = hfUserId
, jHelpSubject = hfSubject
, jHelpRequest = hfRequest
, jRequestTime = now
, jReferer = hfReferer'
}
tell . pure =<< messageI Success MsgHelpSent
defaultLayout $ do
setTitleI MsgHelpTitle
wrapForm $(widgetFile "help") def
{ formAction = Just $ SomeRoute HelpR
, formEncoding = formEnctype
, formAttrs = [ ("data-ajax-submit", "") | isModal ]
}

184
src/Handler/Home.hs
View File

@ -4,23 +4,20 @@ import Import
import Handler.Utils
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Database.Esqueleto as E
import Jobs
import Development.GitRev
getHomeR :: Handler Html
getHomeR = do
muid <- maybeAuthId
case muid of
Nothing -> homeAnonymous
Just uid -> homeUser uid
defaultLayout $ do
setTitleI MsgHomeHeading
maybe mempty homeUpcomingSheets muid
homeOpenCourses
homeAnonymous :: Handler Html
homeAnonymous = do
homeOpenCourses :: Widget
homeOpenCourses = do
cTime <- liftIO getCurrentTime
let tableData :: E.SqlExpr (Entity Course)
-> E.SqlQuery (E.SqlExpr (Entity Course))
@ -47,7 +44,7 @@ homeAnonymous = do
, sortable (Just "deadline") (i18nCell MsgRegisterTo) $ \DBRow{ dbrOutput=Entity{entityVal = course} } ->
cell $ traverse (formatTime SelFormatDateTime) (courseRegisterTo course) >>= maybe mempty toWidget
]
courseTable <- runDB $ dbTableWidget' def DBTable
courseTable <- liftHandlerT . runDB $ dbTableWidget' def DBTable
{ dbtSQLQuery = tableData
, dbtRowKey = (E.^. CourseId)
, dbtColonnade = colonnade
@ -75,16 +72,12 @@ homeAnonymous = do
, dbtFilterUI = mempty
, dbtStyle = def
, dbtParams = def
, dbtIdent = "upcomingdeadlines" :: Text
, dbtIdent = "open-courses" :: Text
}
-- let features = $(widgetFile "featureList")
-- addMessage Warning "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen!"
defaultLayout
-- (widgetFile "dsgvDisclaimer")
$(widgetFile "home")
$(widgetFile "home/openCourses")
homeUser :: Key User -> Handler Html
homeUser uid = do
homeUpcomingSheets :: UserId -> Widget
homeUpcomingSheets uid = do
cTime <- liftIO getCurrentTime
let tableData :: E.LeftOuterJoin
(E.InnerJoin (E.InnerJoin (E.SqlExpr (Entity CourseParticipant)) (E.SqlExpr (Entity Course))) (E.SqlExpr (Entity Sheet)))
@ -140,7 +133,7 @@ homeUser uid = do
(toWidget $ hasTickmark True)
]
let validator = def & defaultSorting [SortDescBy "done", SortAscBy "deadline"]
sheetTable <- runDB $ dbTableWidget' validator DBTable
sheetTable <- liftHandlerT . runDB $ dbTableWidget' validator DBTable
{ dbtSQLQuery = tableData
, dbtRowKey = \((_ `E.InnerJoin` _ `E.InnerJoin` sheet) `E.LeftOuterJoin` _) -> sheet E.^. SheetId
, dbtColonnade = colonnade
@ -175,155 +168,6 @@ homeUser uid = do
, dbtFilterUI = mempty
, dbtStyle = def { dbsEmptyStyle = DBESNoHeading, dbsEmptyMessage = MsgNoUpcomingSheetDeadlines }
, dbtParams = def
, dbtIdent = "upcomingdeadlines" :: Text
, dbtIdent = "upcoming-sheets" :: Text
}
-- addMessage Warning "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen."
defaultLayout $
-- setTitle "Willkommen zum Uni2work Test!"
$(widgetFile "homeUser")
-- (widgetFile "dsgvDisclaimer")
-- | Versionsgeschichte
getVersionR :: Handler TypedContent
getVersionR = getInfoR -- TODO
-- | Impressum
getImpressumR :: Handler Html
getImpressumR = -- do
siteLayoutMsg' MsgMenuImpressum $ do
setTitleI MsgImpressumHeading
$(i18nWidgetFile "imprint")
-- | Hinweise zu Datenschutz und Aufbewahrungspflichten
getDataProtR :: Handler Html
getDataProtR = -- do
siteLayoutMsg' MsgMenuDataProt $ do
setTitleI MsgDataProtHeading
$(i18nWidgetFile "data-protection")
-- | Allgemeine Informationen
getInfoR :: Handler TypedContent
getInfoR = selectRep $ do
let infoHeading = [whamlet|Re-Implementierung von <a href="https://uniworx.ifi.lmu.de/">UniWorX</a>|]
provideRep . siteLayout infoHeading $ do
let features = $(widgetFile "featureList")
gitInfo :: Text
gitInfo = $gitDescribe <> " (" <> $gitCommitDate <> ")"
changeLog <- withUrlRenderer $(textFile "ChangeLog.md")
$(widgetFile "versionHistory")
provideRep $
return ($gitDescribe :: Text)
data HelpIdentOptions = HIUser | HIEmail | HIAnonymous
deriving (Eq, Ord, Bounded, Enum, Show, Read)
instance Universe HelpIdentOptions
instance Finite HelpIdentOptions
nullaryPathPiece ''HelpIdentOptions (camelToPathPiece' 1)
embedRenderMessage ''UniWorX ''HelpIdentOptions (("Help" <>) . dropPrefix "HI")
data HelpForm = HelpForm
{ hfReferer:: Maybe (Route UniWorX)
, hfUserId :: Either (Maybe Address) UserId
, hfRequest:: Text
}
helpForm :: Maybe (Route UniWorX) -> Maybe UserId -> AForm _ HelpForm
helpForm mReferer mUid = HelpForm
<$> aopt routeField (fslI MsgHelpProblemPage & inputReadonly) (Just <$> mReferer)
<*> multiActionA (fslI MsgHelpAnswer) identActions (HIUser <$ mUid)
<*> (unTextarea <$> areq textareaField (fslI MsgHelpRequest) Nothing)
where
identActions :: Map _ (AForm _ (Either (Maybe Address) UserId))
identActions = Map.fromList $ case mUid of
(Just uid) -> (HIUser, pure $ Right uid):defaultActions
Nothing -> defaultActions
defaultActions =
[ (HIEmail, Left . Just <$> (Address <$> aopt textField (fslI MsgName) Nothing <*> apreq emailField (fslI MsgEMail) Nothing))
, (HIAnonymous, pure $ Left Nothing)
]
getHelpR, postHelpR :: Handler Html
getHelpR = postHelpR
postHelpR = do
mUid <- maybeAuthId
mReferer <- flip formResultMaybe return <=< runInputGetResult $ iopt routeField (toPathPiece GetReferer)
isModal <- hasCustomHeader HeaderIsModal
((res,formWidget),formEnctype) <- runFormPost $ renderAForm FormStandard $ helpForm mReferer mUid
let form = wrapForm formWidget def
{ formAction = Just $ SomeRoute HelpR
, formEncoding = formEnctype
, formAttrs = [ ("data-ajax-submit", "") | isModal ]
}
formResultModal res HelpR $ \HelpForm{..} -> do
now <- liftIO getCurrentTime
hfReferer' <- traverse toTextUrl hfReferer
queueJob' JobHelpRequest
{ jSender = hfUserId
, jHelpRequest = hfRequest
, jRequestTime = now
, jReferer = hfReferer'
}
tell . pure =<< messageI Success MsgHelpSent
defaultLayout $ do
setTitleI MsgHelpTitle
$(widgetFile "help")
getInfoLecturerR :: Handler Html
getInfoLecturerR =
siteLayoutMsg' MsgInfoLecturerTitle $ do
setTitleI MsgInfoLecturerTitle
$(i18nWidgetFile "info-lecturer")
getAuthPredsR, postAuthPredsR :: Handler Html
getAuthPredsR = postAuthPredsR
postAuthPredsR = do
(AuthTagActive authTagCurrentActive) <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags
let
blacklist = Set.fromList [ AuthFree, AuthDevelopment, AuthDeprecated ]
taForm authTag
| authTag `Set.member` blacklist = aforced checkBoxField (fslI authTag) (authTagIsActive def authTag)
| otherwise = fromMaybe False <$> aopt checkBoxField (fslI authTag) (Just . Just $ authTagCurrentActive authTag)
((authActiveRes, authActiveWidget), authActiveEnctype) <- runFormPost . renderAForm FormStandard
$ AuthTagActive <$> funcForm taForm (fslI MsgActiveAuthTags) True
mReferer <- runMaybeT $ do
param <- MaybeT (lookupGetParam $ toPathPiece GetReferer) <|> MaybeT (lookupPostParam $ toPathPiece GetReferer)
MaybeT . return $ fromPathPiece param
let authActiveForm = wrapForm authActiveWidget' def
{ formAction = Just $ SomeRoute AuthPredsR
, formEncoding = authActiveEnctype
, formSubmit = FormDualSubmit
}
authActiveWidget'
= [whamlet|
$newline never
$maybe referer <- mReferer
<input type=hidden name=#{toPathPiece GetReferer} value=#{toPathPiece referer}>
^{authActiveWidget}
|]
formResult authActiveRes $ \authTagActive -> do
setSessionJson SessionActiveAuthTags authTagActive
modifySessionJson SessionInactiveAuthTags . fmap $ Set.filter (not . authTagIsActive authTagActive)
addMessageI Success MsgAuthPredsActiveChanged
redirect $ fromMaybe AuthPredsR mReferer
siteLayoutMsg MsgAuthPredsActive $ do
setTitleI MsgAuthPredsActive
$(widgetFile "authpreds")
$(widgetFile "home/upcomingSheets")

48
src/Handler/Info.hs Normal file
View File

@ -0,0 +1,48 @@
module Handler.Info where
import Import
import Handler.Utils
import Development.GitRev
-- | Versionsgeschichte
getVersionR :: Handler TypedContent
getVersionR = selectRep $ do
provideRep $
return ($gitDescribe :: Text)
provideRep getInfoR
-- | Impressum
getImpressumR :: Handler Html
getImpressumR = -- do
siteLayoutMsg' MsgMenuImpressum $ do
setTitleI MsgImpressumHeading
$(i18nWidgetFile "imprint")
-- | Hinweise zu Datenschutz und Aufbewahrungspflichten
getDataProtR :: Handler Html
getDataProtR = -- do
siteLayoutMsg' MsgMenuDataProt $ do
setTitleI MsgDataProtHeading
$(i18nWidgetFile "data-protection")
-- | Allgemeine Informationen
getInfoR :: Handler Html
getInfoR = do
let infoHeading = [whamlet|Re-Implementierung von <a href="https://uniworx.ifi.lmu.de/">UniWorX</a>|]
siteLayout infoHeading $ do
let features = $(widgetFile "featureList")
gitInfo :: Text
gitInfo = $gitDescribe <> " (" <> $gitCommitDate <> ")"
changeLog <- withUrlRenderer $(textFile "ChangeLog.md")
$(widgetFile "versionHistory")
getInfoLecturerR :: Handler Html
getInfoLecturerR =
siteLayoutMsg' MsgInfoLecturerTitle $ do
setTitleI MsgInfoLecturerTitle
$(i18nWidgetFile "info-lecturer")

201
src/Handler/Profile.hs
View File

@ -10,7 +10,7 @@ import Utils.Lens
-- import Yesod.Colonnade
import Data.Monoid (Any(..))
import qualified Data.Map as Map
-- import qualified Data.Set as Set
import qualified Data.Set as Set
import qualified Database.Esqueleto as E
-- import Database.Esqueleto ((^.))
@ -121,139 +121,47 @@ postProfileR = do
, formEncoding = formEnctype
}
postProfileDataR :: Handler Html
postProfileDataR = do
((btnResult,_), _) <- runFormPost buttonForm
case btnResult of
(FormSuccess BtnDelete) -> do
(uid, User{..}) <- requireAuthPair
clearCreds False -- Logout-User
((deletedSubmissions,groupSubmissions),deletedSubmissionGroups) <- runDB $ deleteUser uid
-- addMessageIHamlet
$(addMessageFile Success "templates/deletedUser.hamlet") -- USE THIS ONE
-- addMessageI Success $ MsgDeleteUser deletedSubmissions
-- when (groupSubmissions > 0) $ addMessageI Info $ MsgDeleteUserGroupSubmissions groupSubmissions
defaultLayout
$(widgetFile "deletedUser")
-- (FormSuccess BtnAbort ) -> do
-- addMessageI Info MsgAborted
-- redirect ProfileDataR
_other -> getProfileDataR
deleteUser :: UserId -> DB ((Int,Int),Int64) -- TODO: Restrict deletions for lecturers, tutors and students in course that won't allow deregistration
deleteUser duid = do
-- E.deleteCount for submissions is not cascading, hence we first select and then delete manually
-- We delete all files tied to submissions where the user is the lone submissionUser
-- Do not deleteCascade submissions where duid is the corrector:
updateWhere [SubmissionRatingBy ==. Just duid] [SubmissionRatingBy =. Nothing]
groupSubmissions <- selectSubmissionsWhere (\numBuddies -> numBuddies E.>. E.val (0::Int64))
singleSubmissions <- selectSubmissionsWhere (\numBuddies -> numBuddies E.==. E.val (0::Int64))
deleteCascade duid
forM_ singleSubmissions $ \(E.Value submissionId) -> do
deleteFileIds <- map E.unValue <$> getSubmissionFiles submissionId
deleteCascade submissionId
deleteCascadeWhere [FileId <-. deleteFileIds] -- TODO: throws exception for de-duplicated files
deletedSubmissionGroups <- deleteSingleSubmissionGroups
return ((length singleSubmissions, length groupSubmissions),deletedSubmissionGroups)
where
selectSubmissionsWhere :: (E.SqlExpr (E.Value Int64) -> E.SqlExpr (E.Value Bool)) -> DB [E.Value (Key Submission)]
selectSubmissionsWhere whereBuddies = E.select $ E.from $ \(submission `E.InnerJoin` suser) -> do
E.on $ submission E.^. SubmissionId E.==. suser E.^. SubmissionUserSubmission
let numBuddies = E.sub_select $ E.from $ \subUsers -> do
E.where_ $ subUsers E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
E.&&. subUsers E.^. SubmissionUserUser E.!=. E.val duid
return E.countRows
E.where_ $ suser E.^. SubmissionUserUser E.==. E.val duid
E.&&. whereBuddies numBuddies
return $ submission E.^. SubmissionId
getSubmissionFiles :: SubmissionId -> DB [E.Value (Key File)]
getSubmissionFiles subId = E.select $ E.from $ \file -> do
E.where_ $ E.exists $ E.from $ \submissionFile ->
E.where_ $ submissionFile E.^. SubmissionFileSubmission E.==. E.val subId
E.&&. submissionFile E.^. SubmissionFileFile E.==. file E.^. FileId
return $ file E.^. FileId
deleteSingleSubmissionGroups = E.deleteCount $ E.from $ \submissionGroup -> do
E.where_ $ E.exists $ E.from $ \subGroupUser ->
E.where_ $ subGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
E.&&. subGroupUser E.^. SubmissionGroupUserUser E.==. E.val duid
E.where_ $ E.notExists $ E.from $ \subGroupUser ->
E.where_ $ subGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
E.&&. subGroupUser E.^. SubmissionGroupUserUser E.!=. E.val duid
getProfileDataR :: Handler Html
getProfileDataR = do
(uid, User{..}) <- requireAuthPair
userEnt <- requireAuth
dataWidget <- runDB $ makeProfileData userEnt
defaultLayout $ do
dataWidget
$(widgetFile "dsgvDisclaimer")
makeProfileData :: Entity User -> DB Widget
makeProfileData (Entity uid User{..}) = do
-- MsgRenderer mr <- getMsgRenderer
(admin_rights,lecturer_rights,lecture_corrector,studies) <- runDB $ (,,,) <$>
E.select
( E.from $ \(adright `E.InnerJoin` school) -> do
E.where_ $ adright E.^. UserAdminUser E.==. E.val uid
E.on $ adright E.^. UserAdminSchool E.==. school E.^. SchoolId
return (school E.^. SchoolShorthand)
)
<*>
E.select
( E.from $ \(lecright `E.InnerJoin` school) -> do
E.where_ $ lecright E.^. UserLecturerUser E.==. E.val uid
E.on $ lecright E.^. UserLecturerSchool E.==. school E.^. SchoolId
return (school E.^. SchoolShorthand)
)
<*>
E.select
( E.distinct $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid
return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand)
)
<*>
E.select
( E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do
E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId
E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId
return (studyfeat, studydegree, studyterms)
)
( (hasRows, ownedCoursesTable)
, enrolledCoursesTable
, submissionTable
, submissionGroupTable
, correctionsTable
) <- runDB $ (,,,,)
<$> mkOwnedCoursesTable uid -- Tabelle mit eigenen Kursen
<*> mkEnrolledCoursesTable uid -- Tabelle mit allen Teilnehmer: Kurs (link), Datum
<*> mkSubmissionTable uid -- Tabelle mit allen Abgaben und Abgabe-Gruppen
<*> mkSubmissionGroupTable uid -- Tabelle mit allen Abgabegruppen
<*> mkCorrectionsTable uid -- Tabelle mit allen Korrektor-Aufgaben
admin_rights <- E.select $ E.from $ \(adright `E.InnerJoin` school) -> do
E.where_ $ adright E.^. UserAdminUser E.==. E.val uid
E.on $ adright E.^. UserAdminSchool E.==. school E.^. SchoolId
return (school E.^. SchoolShorthand)
lecturer_rights <- E.select $ E.from $ \(lecright `E.InnerJoin` school) -> do
E.where_ $ lecright E.^. UserLecturerUser E.==. E.val uid
E.on $ lecright E.^. UserLecturerSchool E.==. school E.^. SchoolId
return (school E.^. SchoolShorthand)
lecture_corrector <- E.select $ E.distinct $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid
return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand)
studies <- E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do
E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId
E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId
return (studyfeat, studydegree, studyterms)
--Tables
(hasRows, ownedCoursesTable) <- mkOwnedCoursesTable uid -- Tabelle mit eigenen Kursen
enrolledCoursesTable <- mkEnrolledCoursesTable uid -- Tabelle mit allen Teilnehmer: Kurs (link), Datum
submissionTable <- mkSubmissionTable uid -- Tabelle mit allen Abgaben und Abgabe-Gruppen
submissionGroupTable <- mkSubmissionGroupTable uid -- Tabelle mit allen Abgabegruppen
correctionsTable <- mkCorrectionsTable uid -- Tabelle mit allen Korrektor-Aufgaben
let examTable = [whamlet|Klausuren werden momentan leider noch nicht unterstützt.|]
let ownTutorialTable = [whamlet|Übungsgruppen werden momentan leider noch nicht unterstützt.|]
let tutorialTable = [whamlet|Übungsgruppen werden momentan leider noch nicht unterstützt.|]
lastLogin <- traverse (formatTime SelFormatDateTime) userLastAuthentication
-- Delete Button
(btnWdgt, btnEnctype) <- generateFormPost (buttonForm :: Form ButtonDelete)
let btnForm = wrapForm btnWdgt def
{ formAction = Just $ SomeRoute ProfileDataR
, formEncoding = btnEnctype
, formSubmit = FormNoSubmit
}
defaultLayout $ do
let delWdgt = $(widgetFile "widgets/data-delete/data-delete")
$(widgetFile "profileData")
$(widgetFile "dsgvDisclaimer")
return $(widgetFile "profileData")
@ -583,3 +491,44 @@ mkCorrectionsTable =
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid
in dbTableWidget' validator DBTable{..}
getAuthPredsR, postAuthPredsR :: Handler Html
getAuthPredsR = postAuthPredsR
postAuthPredsR = do
(AuthTagActive authTagCurrentActive) <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags
let
blacklist = Set.fromList [ AuthFree, AuthDevelopment, AuthDeprecated ]
taForm authTag
| authTag `Set.member` blacklist = aforced checkBoxField (fslI authTag) (authTagIsActive def authTag)
| otherwise = fromMaybe False <$> aopt checkBoxField (fslI authTag) (Just . Just $ authTagCurrentActive authTag)
((authActiveRes, authActiveWidget), authActiveEnctype) <- runFormPost . renderAForm FormStandard
$ AuthTagActive <$> funcForm taForm (fslI MsgActiveAuthTags) True
mReferer <- runMaybeT $ do
param <- MaybeT (lookupGetParam $ toPathPiece GetReferer) <|> MaybeT (lookupPostParam $ toPathPiece GetReferer)
MaybeT . return $ fromPathPiece param
let authActiveForm = wrapForm authActiveWidget' def
{ formAction = Just $ SomeRoute AuthPredsR
, formEncoding = authActiveEnctype
, formSubmit = FormDualSubmit
}
authActiveWidget'
= [whamlet|
$newline never
$maybe referer <- mReferer
<input type=hidden name=#{toPathPiece GetReferer} value=#{toPathPiece referer}>
^{authActiveWidget}
|]
formResult authActiveRes $ \authTagActive -> do
setSessionJson SessionActiveAuthTags authTagActive
modifySessionJson SessionInactiveAuthTags . fmap $ Set.filter (not . authTagIsActive authTagActive)
addMessageI Success MsgAuthPredsActiveChanged
redirect $ fromMaybe AuthPredsR mReferer
siteLayoutMsg MsgAuthPredsActive $ do
setTitleI MsgAuthPredsActive
$(widgetFile "authpreds")

6
src/Handler/Sheet.hs
View File

@ -123,7 +123,6 @@ makeSheetForm msId template = identifyForm FIDsheet $ \html -> do
<*> aopt (multiFileField $ oldFileIds SheetMarking) (fslI MsgSheetMarking
& setTooltip MsgSheetMarkingTip) (sfMarkingF <$> template)
<*> aopt htmlField (fslI MsgSheetMarking) (sfMarkingText <$> template)
<* submitButton
return $ case result of
FormSuccess sheetResult
| errorMsgs <- validateSheet mr sheetResult
@ -200,11 +199,12 @@ getSheetListR tid ssh csh = do
let stats = sheetTypeSum sheetType in -- for statistics over all shown rows
case mbSub of
Nothing -> cellTell mempty $ stats Nothing
(Just (Entity sid Submission{..})) ->
(Just (Entity sid sub@Submission{..})) ->
let mkCid = encrypt sid
mkRoute = do
cid' <- mkCid
return $ CSubmissionR tid ssh csh sheetName cid' CorrectionR
mTuple mA mB = (,) <$> mA <*> mB -- Hamlet does not support enough haskell-syntax for this
acell = anchorCellM mkRoute $(widgetFile "widgets/rating/rating")
in cellTell acell $ stats submissionRatingPoints
@ -787,7 +787,7 @@ postSCorrR = getSCorrR
getSCorrR tid ssh csh shn = do
Entity shid Sheet{..} <- runDB $ fetchSheet tid ssh csh shn
((res,formWidget), formEnctype) <- runFormPost . identifyForm FIDcorrectors . renderAForm FormStandard $ formToAForm (correctorForm shid) <* submitButton
((res,formWidget), formEnctype) <- runFormPost . identifyForm FIDcorrectors . renderAForm FormStandard $ formToAForm (correctorForm shid)
case res of
FormFailure errs -> mapM_ (addMessage Error . toHtml) errs

9
src/Handler/SystemMessage.hs
View File

@ -3,7 +3,6 @@ module Handler.SystemMessage where
import Import
import qualified Data.Map.Lazy as Map
import qualified Data.Text as Text
import qualified Data.Set as Set
@ -16,13 +15,7 @@ import Utils.Lens
import qualified Database.Esqueleto as E
htmlField' :: Field (HandlerT UniWorX IO) Html
htmlField' = htmlField
{ fieldParse = \vs fis -> fieldParse htmlField (map Text.strip vs) fis
}
-- htmlField' moved to Handler.Utils.Form/Fields
getMessageR, postMessageR :: CryptoUUIDSystemMessage -> Handler Html
getMessageR = postMessageR

33
src/Handler/Term.hs
View File

@ -3,14 +3,16 @@ module Handler.Term where
import Import
import Handler.Utils
import Handler.Utils.Table.Cells
import Handler.Utils.Form.MassInput
import qualified Data.Map as Map
-- import qualified Data.Text as T
import Yesod.Form.Bootstrap3
-- import Colonnade hiding (bool)
import Utils.Lens
import qualified Database.Esqueleto as E
import qualified Data.Set as Set
-- | Default start day of term for season,
-- @True@: start of term, @False@: end of term
defaultDay :: Bool -> Season -> Day
@ -148,7 +150,7 @@ getTermShowR = do
setTitleI MsgTermsHeading
$(widgetFile "terms")
getTermEditR :: Handler Html
getTermEditR, postTermEditR :: Handler Html
getTermEditR = do
mbLastTerm <- runDB $ selectFirst [] [Desc TermName]
let template = case mbLastTerm of
@ -164,18 +166,18 @@ getTermEditR = do
, tftEnd = Just $ defaultDay False seas & setYear yr'
}
termEditHandler template
postTermEditR :: Handler Html
postTermEditR = termEditHandler mempty
getTermEditExistR :: TermId -> Handler Html
getTermEditExistR tid = do
getTermEditExistR, postTermEditExistR :: TermId -> Handler Html
getTermEditExistR = postTermEditExistR
postTermEditExistR tid = do
term <- runDB $ get tid
termEditHandler $ termToTemplate term
termEditHandler :: TermFormTemplate -> Handler Html
termEditHandler term = do
Just eHandler <- getCurrentRoute
((result, formWidget), formEnctype) <- runFormPost $ newTermForm term
case result of
(FormSuccess res) -> do
@ -194,7 +196,7 @@ termEditHandler term = do
defaultLayout $ do
setTitleI MsgTermEditHeading
wrapForm formWidget def
{ formAction = Just $ SomeRoute TermEditR
{ formAction = Just $ SomeRoute eHandler
, formEncoding = formEnctype
}
@ -247,14 +249,21 @@ termToTemplate (Just Term{..}) = TermFormTemplate
newTermForm :: TermFormTemplate -> Form Term
newTermForm template html = do
mr <- getMessageRender
let
tidForm
| Just tid <- tftName template
= aforced termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) tid
| otherwise
= areq termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) Nothing
holidayForm = formToAForm . over (mapped._2) pure $ massInputList dayField (const $ "" & addPlaceholder (mr MsgTermHolidayPlaceholder)) (const Nothing) (fslI MsgTermHolidays) True (tftHolidays template) mempty
(result, widget) <- flip (renderAForm FormStandard) html $ Term
<$> areq termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) (tftName template)
<$> tidForm
<*> areq dayField (fslI MsgTermStartDay & setTooltip MsgTermStartDayTooltip) (tftStart template)
<*> areq dayField (fslI MsgTermEndDay & setTooltip MsgTermEndDayTooltip) (tftEnd template)
<*> pure [] -- TODO: List of Day field required, must probably be done as its own form and then combined
<*> (Set.toList . Set.fromList <$> holidayForm)
<*> areq dayField (fslI MsgTermLectureStart) (tftLectureStart template)
<*> areq dayField (fslI MsgTermLectureEnd & setTooltip MsgTermLectureEndTooltip) (tftLectureEnd template)
<*> areq checkBoxField (bfs ("Aktiv" :: Text)) (tftActive template)
<*> areq checkBoxField (fslI MsgTermActive) (tftActive template)
return $ case result of
FormSuccess termResult
| errorMsgs <- validateTerm termResult

87
src/Handler/Users.hs
View File

@ -16,6 +16,8 @@ import qualified Data.Map as Map
import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E
import Handler.Profile (makeProfileData)
hijackUserForm :: CryptoUUIDUser -> Form ()
hijackUserForm cID csrf = do
@ -161,7 +163,7 @@ postAdminUserR uuid = do
uid <- decrypt uuid
let fromSchoolList = Set.fromList . map (userAdminSchool . entityVal)
let unValueRights (school, E.Value isAdmin, E.Value isLecturer) = (school,isAdmin,isLecturer)
(User{..}, fromSchoolList -> adminSchools, fmap unValueRights -> userRights) <- runDB $ (,,)
(user@User{..}, fromSchoolList -> adminSchools, fmap unValueRights -> userRights) <- runDB $ (,,)
<$> get404 uid
<*> selectList [UserAdminUser ==. adminId] []
<*> E.select ( E.from $ \school -> do
@ -176,7 +178,7 @@ postAdminUserR uuid = do
)
-- above data is needed for both form generation and result evaluation
let userRightsForm :: Form [(SchoolId, Bool, Bool)]
userRightsForm csrf = do
userRightsForm = identifyForm FIDuserRights $ \csrf -> do
boxRights <- forM userRights $ \(school@(Entity sid _), isAdmin, isLecturer) ->
if Set.member sid adminSchools
then do
@ -213,5 +215,84 @@ postAdminUserR uuid = do
formResult result userRightsAction
let heading =
[whamlet|_{MsgAccessRightsFor} ^{nameWidget userDisplayName userSurname}|]
siteLayout heading
-- Delete Button needed in data-delete
(btnWgt, btnEnctype) <- generateFormPost (identifyForm FIDUserDelete buttonForm :: Form ButtonDelete)
let btnForm = wrapForm btnWgt def
{ formAction = Just $ SomeRoute $ AdminUserDeleteR uuid
, formEncoding = btnEnctype
, formSubmit = FormNoSubmit
}
userDataWidget <- runDB $ makeProfileData $ Entity uid user
siteLayout heading $ do
let deleteWidget = $(widgetFile "widgets/data-delete/data-delete")
$(widgetFile "adminUser")
postAdminUserDeleteR :: CryptoUUIDUser -> Handler Html
postAdminUserDeleteR uuid = do
uid <- decrypt uuid
((btnResult,_), _) <- runFormPost (identifyForm FIDUserDelete buttonForm :: Form ButtonDelete)
case btnResult of
(FormSuccess BtnDelete) -> do
User{..} <- runDB $ get404 uid
-- clearCreds False -- Logout-User
((deletedSubmissions,groupSubmissions),deletedSubmissionGroups) <- runDB $ deleteUser uid
-- addMessageIHamlet
$(addMessageFile Success "templates/deletedUser.hamlet") -- USE THIS ONE
-- addMessageI Success $ MsgDeleteUser deletedSubmissions
-- when (groupSubmissions > 0) $ addMessageI Info $ MsgDeleteUserGroupSubmissions groupSubmissions
defaultLayout
$(widgetFile "deletedUser")
-- (FormSuccess BtnAbort ) -> do
-- addMessageI Info MsgAborted
-- redirect ProfileDataR
_other -> getAdminUserR uuid
deleteUser :: UserId -> DB ((Int,Int),Int64) -- TODO: Restrict deletions for lecturers, tutors and students in course that won't allow deregistration
deleteUser duid = do
-- E.deleteCount for submissions is not cascading, hence we first select and then delete manually
-- We delete all files tied to submissions where the user is the lone submissionUser
-- Do not deleteCascade submissions where duid is the corrector:
updateWhere [SubmissionRatingBy ==. Just duid] [SubmissionRatingBy =. Nothing]
groupSubmissions <- selectSubmissionsWhere (\numBuddies -> numBuddies E.>. E.val (0::Int64))
singleSubmissions <- selectSubmissionsWhere (\numBuddies -> numBuddies E.==. E.val (0::Int64))
deleteCascade duid
forM_ singleSubmissions $ \(E.Value submissionId) -> do
deleteFileIds <- map E.unValue <$> getSubmissionFiles submissionId
deleteCascade submissionId
deleteCascadeWhere [FileId <-. deleteFileIds] -- TODO: throws exception for de-duplicated files
deletedSubmissionGroups <- deleteSingleSubmissionGroups
return ((length singleSubmissions, length groupSubmissions),deletedSubmissionGroups)
where
selectSubmissionsWhere :: (E.SqlExpr (E.Value Int64) -> E.SqlExpr (E.Value Bool)) -> DB [E.Value (Key Submission)]
selectSubmissionsWhere whereBuddies = E.select $ E.from $ \(submission `E.InnerJoin` suser) -> do
E.on $ submission E.^. SubmissionId E.==. suser E.^. SubmissionUserSubmission
let numBuddies = E.sub_select $ E.from $ \subUsers -> do
E.where_ $ subUsers E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
E.&&. subUsers E.^. SubmissionUserUser E.!=. E.val duid
return E.countRows
E.where_ $ suser E.^. SubmissionUserUser E.==. E.val duid
E.&&. whereBuddies numBuddies
return $ submission E.^. SubmissionId
getSubmissionFiles :: SubmissionId -> DB [E.Value (Key File)]
getSubmissionFiles subId = E.select $ E.from $ \file -> do
E.where_ $ E.exists $ E.from $ \submissionFile ->
E.where_ $ submissionFile E.^. SubmissionFileSubmission E.==. E.val subId
E.&&. submissionFile E.^. SubmissionFileFile E.==. file E.^. FileId
return $ file E.^. FileId
deleteSingleSubmissionGroups = E.deleteCount $ E.from $ \submissionGroup -> do
E.where_ $ E.exists $ E.from $ \subGroupUser ->
E.where_ $ subGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
E.&&. subGroupUser E.^. SubmissionGroupUserUser E.==. E.val duid
E.where_ $ E.notExists $ E.from $ \subGroupUser ->
E.where_ $ subGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
E.&&. subGroupUser E.^. SubmissionGroupUserUser E.!=. E.val duid

91
src/Handler/Utils.hs
View File

@ -7,10 +7,11 @@ import Import
import qualified Data.Text as T
-- import qualified Data.Set (Set)
import qualified Data.Set as Set
import Data.CaseInsensitive (CI, original)
import Data.CaseInsensitive (original)
-- import qualified Data.CaseInsensitive as CI
import Language.Haskell.TH (Q, Exp)
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (qRunIO)
-- import Language.Haskell.TH.Datatype
import Text.Hamlet (shamletFile)
@ -24,9 +25,14 @@ import Handler.Utils.Zip as Handler.Utils
import Handler.Utils.Rating as Handler.Utils hiding (extractRatings)
-- import Handler.Utils.Submission as Handler.Utils
import Handler.Utils.Sheet as Handler.Utils
import Handler.Utils.Templates as Handler.Utils
import Handler.Utils.Mail as Handler.Utils
import System.Directory (listDirectory)
import System.FilePath.Posix (takeBaseName)
import qualified Data.List as List
import qualified Data.List.NonEmpty as NonEmpty
downloadFiles :: (MonadHandler m, HandlerSite m ~ UniWorX) => m Bool
downloadFiles = do
@ -44,13 +50,22 @@ simpleLink :: Widget -> Route UniWorX -> Widget
simpleLink lbl url = [whamlet|<a href=@{url}>^{lbl}|]
-- | toWidget-Version of @nameHtml@, for convenience
nameWidget :: Text -> Text -> Widget
nameWidget :: Text -- ^ userDisplayName
-> Text -- ^ userSurname
-> Widget
nameWidget displayName surname = toWidget $ nameHtml displayName surname
-- | toWidget-Version of @nameEmailHtml@, for convenience
nameEmailWidget :: CI Text -> Text -> Text -> Widget
nameEmailWidget :: UserEmail -- ^ userEmail
-> Text -- ^ userDisplayName
-> Text -- ^ userSurname
-> Widget
nameEmailWidget email displayName surname = toWidget $ nameEmailHtml email displayName surname
-- | uncurried Version for @nameEmailWidget@ needed in hamlet, where TH cannot be used
nameEmailWidget' :: (UserEmail, Text, Text)-> Widget
nameEmailWidget' = $(uncurryN 3) nameEmailWidget
-- | Show user's displayName, highlighting the surname if possible.
-- Otherwise appends the surname in parenthesis
nameHtml :: Text -> Text -> Html
@ -72,20 +87,47 @@ nameHtml displayName surname
-- | Like nameHtml just show a users displayname with hightlighted surname,
-- but also wrap the name with a mailto-link
nameEmailHtml :: CI Text -> Text -> Text -> Html
nameEmailHtml :: UserEmail -> Text -> Text -> Html
nameEmailHtml email displayName surname =
wrapMailto email $ nameHtml displayName surname
-- | Wrap mailto around given Html using single hamlet-file for consistency
wrapMailto :: CI Text -> Html -> Html
wrapMailto :: UserEmail -> Html -> Html
wrapMailto (original -> email) linkText
| null email = linkText
| otherwise = $(shamletFile "templates/widgets/link-email.hamlet")
-- | Just show an email address in a standard way, for convenience inside hamlet files.
mailtoHtml :: CI Text -> Html
mailtoHtml :: UserEmail -> Html
mailtoHtml email = wrapMailto email $ toHtml email
-- | Generic i18n text for "edited at sometime by someone"
editedByW :: SelDateTimeFormat -> UTCTime -> Text -> Widget
editedByW fmt tm usr = do
ft <- handlerToWidget $ formatTime fmt tm
[whamlet|_{MsgEditedBy usr ft}|]
-- | Prefix a message with a short course id,
-- eg. for window title bars, etc.
-- This function should help to make this consistent everywhere
prependCourseTitle :: (RenderMessage UniWorX msg) =>
TermId -> SchoolId -> CourseShorthand -> msg -> UniWorXMessages
prependCourseTitle tid ssh csh msg = UniWorXMessages
[ SomeMessage $ toPathPiece tid
, SomeMessage dashText
, SomeMessage $ toPathPiece ssh
, SomeMessage dashText
, SomeMessage csh
, SomeMessage colonText
, SomeMessage msg
]
where
dashText :: Text
dashText = "-"
colonText :: Text
colonText = ":"
warnTermDays :: TermId -> [Maybe UTCTime] -> DB ()
warnTermDays tid times = do
Term{..} <- get404 tid
@ -100,11 +142,30 @@ warnTermDays tid times = do
forM_ outoftermdays $ warnI MsgDayIsOutOfTerm
-- | Add language dependent template files
-- For large files which are translated as a whole.
-- Argument musst be a directory under templates,
-- which contains a file for each language,
-- eg. /templates/imprint/de.hamlet and /templates/imprint/en.hamlet
--
-- For large files which are translated as a whole.
--
-- Argument musst be a directory under @/templates@,
-- which contains a file for each language,
-- eg. @imprint@ for choosing between
-- @/templates/imprint/de.hamlet@, @/templates/imprint/de-at.hamlet@,
-- and @/templates/imprint/en.hamlet@
--
-- Dependency detection cannot work properly (no `addDependentFile`-equivalent
-- for directories)
-- @$ stack clean@ is required so new translations show up
i18nWidgetFile :: FilePath -> Q Exp
i18nWidgetFile =
-- TODO write code to distinguish languages here
widgetFile . (</> "de")
i18nWidgetFile basename = do
-- Construct list of available translations (@de@, @en@, ...) at compile time
let i18nDirectory = "templates" </> basename
availableFiles <- qRunIO $ listDirectory i18nDirectory
let availableTranslations = sortWith (NTop . flip List.elemIndex (NonEmpty.toList appLanguages)) . List.nub $ pack . takeBaseName <$> availableFiles
availableTranslations' <- maybe (fail $ "‘" <> i18nDirectory <> "’ is empty") return $ NonEmpty.nonEmpty availableTranslations
-- Dispatch to correct language (depending on user settings via `selectLanguage`) at run time
ws <- newName "ws" -- Name for dispatch function
letE
[ funD ws $ [ clause [litP $ stringL l] (normalB . widgetFile $ basename </> l) []
| l <- unpack <$> NonEmpty.toList availableTranslations' -- One function definition for every available language
] ++ [ clause [wildP] (normalB [e| error "selectLanguage returned an invalid translation" |]) [] ] -- Fallback mostly there so compiler does not complain about non-exhaustive pattern match
] [e|selectLanguage availableTranslations' >>= $(varE ws)|]

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

@ -1,3 +1,13 @@
{-|
Module : Handler.Utils.Delete
Description : Generic deletion from database after confirmation
`postDeleteR`, `getDeleteR`, and `deleteR` provide handlers for calling
`deleteCascade` on a `Set` of Record-`Key`s after asking for confirmation, which
currently entails asking the user to copy a text, which is dependent on the
records to be deleted (i.e. a comma-separated list of user names), into a
`Textarea`.
-}
module Handler.Utils.Delete
( DeleteRoute(..)
, deleteR

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

@ -12,7 +12,7 @@ import Handler.Utils.DateTime
import Import hiding (cons)
import qualified Data.Char as Char
import qualified Data.Text as Text
import qualified Data.CaseInsensitive as CI
-- import Yesod.Core
@ -45,10 +45,13 @@ import Utils.Lens
import Data.Aeson (eitherDecodeStrict')
import Data.Aeson.Text (encodeToLazyText)
import Data.Proxy
----------------------------
-- Buttons (new version ) --
----------------------------
-- NOTE: ButtonSubmit is defined in Utils.Form !
data ButtonDelete = BtnDelete
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
@ -61,6 +64,23 @@ embedRenderMessage ''UniWorX ''ButtonDelete id
instance Button UniWorX ButtonDelete where
btnClasses BtnDelete = [BCIsButton, BCDanger]
data ButtonSave = BtnSave
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
instance Universe ButtonSave
instance Finite ButtonSave
-- | Save-Button as AForm
saveButton :: (Button (HandlerSite m) ButtonSave, MonadHandler m) => AForm m ()
saveButton = combinedButtonFieldF_ (Proxy @ButtonSave) ""
nullaryPathPiece ''ButtonSave $ camelToPathPiece' 1
embedRenderMessage ''UniWorX ''ButtonSave id
instance Button UniWorX ButtonSave where
btnClasses BtnSave = [BCIsButton, BCPrimary]
data ButtonRegister = BtnRegister | BtnDeregister
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
instance Universe ButtonRegister
@ -118,22 +138,20 @@ linkButton lbl cls url = do
|]
-- buttonForm :: (Button UniWorX a, Finite a) => Markup -> MForm (HandlerT UniWorX IO) (FormResult a, Widget)
buttonForm :: (Button UniWorX a, Finite a) => Form a
buttonForm csrf = do
(res, ($ []) -> fViews) <- aFormToForm . disambiguateButtons $ combinedButtonFieldF ""
return (res, [whamlet|
$newline never
#{csrf}
$forall bView <- fViews
^{fvInput bView}
|])
------------
-- Fields --
------------
-- | add some additional text immediately after the field widget; probably not a good idea to use
annotateField :: ToWidget (HandlerSite m) wgt => wgt -> Field m a -> Field m a
annotateField ann field@Field{fieldView=fvf} =
let fvf' idt nmt atts ei bl =
[whamlet|
^{fvf idt nmt atts ei bl}
^{ann}
|]
in field { fieldView=fvf'}
-- ciField moved to Utils.Form
routeField :: ( Monad m
@ -141,6 +159,12 @@ routeField :: ( Monad m
) => Field m (Route UniWorX)
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' = htmlField
{ fieldParse = \vs fis -> fieldParse htmlField (map Text.strip vs) fis
}
natFieldI :: (Monad m, Integral i, RenderMessage (HandlerSite m) msg, RenderMessage (HandlerSite m) FormMessage) => msg -> Field m i
natFieldI msg = checkBool (>= 0) msg intField

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

@ -3,10 +3,11 @@
module Handler.Utils.Form.MassInput
( MassInput(..)
, massInput
, massInputList
, BoxDimension(..)
, IsBoxCoord(..), boxDimension
, Liveliness(..)
, ListLength(..), ListPosition(..)
, ListLength(..), ListPosition(..), miDeleteList
) where
import Import
@ -29,7 +30,6 @@ import Data.List (genericLength, genericIndex, iterate)
import Control.Monad.Trans.Maybe
import Control.Monad.Reader.Class (MonadReader(local))
import Control.Monad.Fix
data BoxDimension x = forall n. (Enum n, Num n) => BoxDimension (Lens' x n)
@ -96,6 +96,13 @@ instance Liveliness ListLength where
max' = Set.lookupMax ns
liveCoord (ListPosition n) = prism' (\(ListLength l) -> n < l) (bool (Just 0) (1 <$ guard (n == 0)))
miDeleteList :: Applicative m => ListLength -> ListPosition -> m (Map ListPosition ListPosition)
miDeleteList l pos
-- Close gap left by deleted position with values from further down the list; try prohibiting certain deletions by utilising `guard`
| l >= 2 = pure . Map.fromSet (\pos' -> bool pos' (succ pos') $ pos' >= pos) $ Set.fromList [0..fromIntegral (l - 2)]
| otherwise = pure Map.empty
data ButtonMassInput coord
= MassInputAddDimension Natural coord
| MassInputDeleteCell coord
@ -185,7 +192,7 @@ data MassInput handler liveliness cellData cellResult = MassInput
-> Natural -- Zero-based dimension index @dimIx@
-> (Text -> Text) -- Nudge deterministic field ids
-> FieldView UniWorX -- Submit button
-> Maybe (Markup -> MForm handler (FormResult (liveliness -> (BoxCoord liveliness, cellData)), Widget)) -- ^ Construct a Cell-Addition Widget
-> Maybe (Markup -> MForm handler (FormResult (Map (BoxCoord liveliness) cellData -> FormResult (Map (BoxCoord liveliness) cellData)), Widget)) -- ^ Construct a Cell-Addition Widget
, miCell :: BoxCoord liveliness -- Position
-> cellData -- @cellData@ from @miAdd@
-> Maybe cellResult -- Initial result from Argument to @massInput@
@ -198,13 +205,14 @@ data MassInput handler liveliness cellData cellResult = MassInput
-> Natural
-> liveliness
-> Bool -- ^ Decide whether an addition-operation should be permitted
, miButtonAction :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) -- ^ Override form-tag route for `massInput`-Buttons to keep the user closer to the Widget, the `PathPiece` Argument is to be used for constructiong a `Fragment`
}
massInput :: forall handler cellData cellResult liveliness.
( MonadHandler handler, HandlerSite handler ~ UniWorX
, ToJSON cellData, FromJSON cellData
, Liveliness liveliness
, MonadFix handler, MonadLogger handler
, MonadLogger handler
)
=> MassInput handler liveliness cellData cellResult
-> FieldSettings UniWorX
@ -215,6 +223,10 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
let initialShape = fmap fst <$> initialResult
miName <- maybe newFormIdent return fsName
fvId <- maybe newIdent return fsId
miAction <- traverse toTextUrl $ miButtonAction fvId
let addFormAction = maybe id (addAttr "formaction") miAction
let
shapeName :: MassInputFieldName (BoxCoord liveliness)
shapeName = MassInputShape{..}
@ -230,19 +242,21 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
| otherwise -> throwM MassInputInvalidShape
sentLiveliness <- maybe (throwM MassInputInvalidShape) return $ Map.keysSet sentShape' ^? liveCoords :: MForm handler liveliness
let addForm :: [BoxDimension (BoxCoord liveliness)] -> MForm handler (Map (Natural, BoxCoord liveliness) (FormResult (Maybe (liveliness -> (BoxCoord liveliness, cellData))), Maybe Widget))
let addForm :: [BoxDimension (BoxCoord liveliness)] -> MForm handler (Map (Natural, BoxCoord liveliness) (FormResult (Maybe (Map (BoxCoord liveliness) cellData -> FormResult (Map (BoxCoord liveliness) cellData))), Maybe Widget))
addForm = addForm' boxOrigin . zip [0..]
where
addForm' _ [] = return Map.empty
addForm' miCoord ((dimIx, _) : remDims) = do
let nudgeAddWidgetName :: Text -> Text
nudgeAddWidgetName miAddWidgetField = toPathPiece MassInputAddWidget{..}
(btnRes', btnView) <- mopt (buttonField $ MassInputAddDimension dimIx miCoord) ("" & addName MassInputAddButton{..}) Nothing
let btnRes
| FormSuccess Nothing <- btnRes' = FormMissing
| FormSuccess (Just x) <- btnRes' = FormSuccess x
| otherwise = error "Value of btnRes should only be inspected if FormSuccess" <$ btnRes'
addRes' <- over (mapped . _Just . _1) (btnRes *>) . local (bool id (set _1 Nothing) $ is _FormMissing btnRes) . traverse ($ mempty) $
(btnRes', btnView) <- mopt (buttonField $ MassInputAddDimension dimIx miCoord) ("" & addName MassInputAddButton{..} & addFormAction) Nothing
let btnRes = do
Just x <- btnRes'
return x
wBtnRes res = do
guard $ isn't _FormMissing btnRes
res
addRes' <- over (mapped . _Just . _1) wBtnRes . local (bool id (set _1 Nothing) $ is _FormMissing btnRes) . traverse ($ mempty) $
miAdd miCoord dimIx nudgeAddWidgetName btnView
let dimRes' = Map.singleton (dimIx, miCoord) (maybe (Nothing <$ btnRes) (fmap Just) $ fmap fst addRes', fmap snd addRes')
case remDims of
@ -254,9 +268,15 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
return $ dimRes' `Map.union` fold dimRess
addResults <- addForm boxDimensions
let
addResults' :: Map (Natural, BoxCoord liveliness) (FormResult (Maybe (Map (BoxCoord liveliness) cellData)))
addResults' = flip Map.mapWithKey (fst <$> addResults) $ \(dimIx, miCoord) -> \case
FormSuccess (Just mkResult)
| miAllowAdd miCoord dimIx sentLiveliness -> Just <$> mkResult sentShape'
other -> Nothing <$ other
let addShape
| [((dimIx, miCoord), FormSuccess (Just mkResult))] <- Map.toList . Map.filter (is $ _FormSuccess . _Just) $ fmap fst addResults
= Just $ maybe id (uncurry Map.insert) (mkResult sentLiveliness <$ guard (miAllowAdd miCoord dimIx sentLiveliness)) sentShape'
= Just $ maybe id Map.union (formResultToMaybe $ mkResult sentShape' <* guard (miAllowAdd miCoord dimIx sentLiveliness)) sentShape'
| otherwise = Nothing
addedShape <- if
@ -267,11 +287,10 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
let
delForm :: BoxCoord liveliness -> MaybeT (MForm handler) (FormResult (Map (BoxCoord liveliness) (BoxCoord liveliness)), FieldView UniWorX)
delForm miCoord = do
(delRes, delView) <- lift $ mpreq (buttonField $ MassInputDeleteCell miCoord) ("" & addName MassInputDeleteButton{..}) Nothing
-- dollar comment causes build error somehow $ logDebugS "delForm" . tshow $ fmap toPathPiece delRes
(delRes, delView) <- lift $ mopt (buttonField $ MassInputDeleteCell miCoord) ("" & addName MassInputDeleteButton{..} & addFormAction) Nothing
shapeUpdate <- miDelete addedLiveliness miCoord
guard $ isJust (Map.keysSet shapeUpdate ^? liveCoords :: Maybe liveliness)
return (shapeUpdate <$ delRes, delView)
return (shapeUpdate <$ assertM (is _Just) delRes, delView)
delResults <- fmap (Map.mapMaybe id) . sequence $ Map.fromSet (runMaybeT . delForm) (Map.keysSet addedShape)
let
@ -306,12 +325,8 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
| otherwise = prevEnv
justAdded :: Set (BoxCoord liveliness)
justAdded = Set.fromList . mapMaybe (addedCoord . fst) $ Map.elems addResults
where
addedCoord res
| FormSuccess (Just mkResult) <- res
= Just . fst $ mkResult sentLiveliness
| otherwise = Nothing
justAdded = Map.keysSet shape Set.\\ Map.keysSet sentShape'
restrictJustAdded :: BoxCoord liveliness -> Maybe a -> Maybe a
restrictJustAdded miCoord env = env <* guard (not $ Set.member miCoord justAdded)
@ -321,9 +336,11 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
nudgeCellName miCellField = toPathPiece (MassInputCell{..} :: MassInputFieldName (BoxCoord liveliness))
local (over _1 (applyDelShapeUpdate . restrictJustAdded miCoord)) $ (cData, ) <$> miCell miCoord cData (fmap snd . Map.lookup miCoord =<< initialResult) nudgeCellName mempty
let result :: FormResult (Map (BoxCoord liveliness) (cellData, cellResult))
result
| shapeChanged = FormMissing
| otherwise = traverse (\(cData, (cResult, _)) -> (cData, ) <$> cResult) cellResults
result = do
FormSuccess () <|> void (asum $ Map.elems addResults')
FormSuccess () <|> void (asum . Map.elems $ fst <$> delResults)
guard $ not shapeChanged
for cellResults $ \(cData, (cResult, _)) -> (cData, ) <$> cResult
let miWidget' :: BoxCoord liveliness -> [(Natural, BoxDimension (BoxCoord liveliness))] -> Widget
miWidget' _ [] = mempty
@ -343,7 +360,6 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
miWidget = miWidget' boxOrigin $ zip [0..] boxDimensions
MsgRenderer mr <- getMsgRenderer
fvId <- maybe newIdent return fsId
let
fvLabel = toHtml $ mr fsLabel
@ -351,3 +367,29 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
fvInput = $(widgetFile "widgets/massinput/massinput")
fvErrors = Nothing
in return (result, FieldView{..})
-- | Wrapper around `massInput` for the common case, that we just want an arbitrary list of single fields without any constraints
massInputList :: forall handler cellResult.
( MonadHandler handler, HandlerSite handler ~ UniWorX
, MonadLogger handler
)
=> Field handler cellResult
-> (ListPosition -> FieldSettings UniWorX)
-> (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX))
-> FieldSettings UniWorX
-> Bool
-> Maybe [cellResult]
-> (Markup -> MForm handler (FormResult [cellResult], FieldView UniWorX))
massInputList field fieldSettings miButtonAction miSettings miRequired miPrevResult = over (mapped . _1 . mapped) (map snd . Map.elems) . massInput
MassInput { miAdd = \_ _ _ submitBtn -> Just $ \csrf ->
return (FormSuccess $ \pRes -> FormSuccess $ Map.singleton (maybe 0 succ . fmap fst $ Map.lookupMax pRes) (), toWidget csrf >> fvInput submitBtn)
, miCell = \pos () iRes nudge csrf ->
over _2 (\FieldView{..} -> $(widgetFile "widgets/massinput/list/cell")) <$> mreq field (fieldSettings pos & addName (nudge "field")) iRes
, miDelete = miDeleteList
, miAllowAdd = \_ _ _ -> True
, miButtonAction
}
miSettings
miRequired
(Map.fromList . zip [0..] . map ((), ) <$> miPrevResult)

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

@ -462,10 +462,10 @@ sinkSubmission userId mExists isUpdate = do
case isUpdate of
False -> lift . insert_ $ SubmissionEdit userId now submissionId
True -> do
Submission{submissionRatingTime} <- lift $ getJust submissionId
when (isNothing submissionRatingTime) $ tellSt mempty { sinkSubmissionNotifyRating = Any True }
lift $ update submissionId [ SubmissionRatingBy =. Just userId, SubmissionRatingTime =. Just now ]
-- TODO: Should submissionRatingAssigned change here if userId changes?
Submission{submissionRatingTime, submissionRatingBy} <- lift $ getJust submissionId
when (submissionRatingBy == Just userId) $ do
when (isNothing submissionRatingTime) $ tellSt mempty { sinkSubmissionNotifyRating = Any True }
lift $ update submissionId [ SubmissionRatingTime =. Just now ]
tellSt $ mempty{ sinkSubmissionTouched = Any True }
finalize :: SubmissionSinkState -> YesodJobDB UniWorX ()

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

@ -57,6 +57,10 @@ sqlCell act = mempty & cellContents .~ lift act
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 = cell . toWidget . isBad
-- | Maybe display a exclamation icon
isNewCell :: (IsDBTable m a) => Bool -> DBCell m a
isNewCell = cell . toWidget . isNew

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

@ -66,8 +66,8 @@ sortUserDisplayName queryUser = ("user-display-name", SortColumn $ queryUser >>>
defaultSortingByName :: PSValidator m x -> PSValidator m x
defaultSortingByName =
defaultSorting [SortAscBy "user-surname", SortAscBy "user-display-name"] -- old way, requiring two exta sorters
-- defaultSorting [SortAscBy "user-name"] -- new way, untested, working with single sorter
-- defaultSorting [SortAscBy "user-surname", SortAscBy "user-display-name"] -- old way, requiring two exta sorters
defaultSorting [SortAscBy "user-name"] -- new way, untested, working with single sorter
-- | Alias for sortUserName for consistency
fltrUserNameLink :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d) => (a -> E.SqlExpr (Entity User)) -> (d, FilterColumn t)

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

@ -595,7 +595,7 @@ instance Monoid x => Monoid (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]
instance IsDBTable m a => IsString (DBCell m a) where
fromString = cell . fromString
-- | DB-backed tables with pagination, may short-circuit a handler
dbTable :: forall m x. IsDBTable m x => PSValidator m x -> DBTable m x -> DB (DBResult m x)
dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> dbtIdent), dbtStyle = DBStyle{..}, .. } = do
let
@ -639,7 +639,6 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
(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 & addAutosubmit & addName (wIdent "pagesize") & addClass "select--pagesize") (Just referencePagesize)
<* autosubmitButton
return (filterRes', pagesizeRes')
let
@ -754,7 +753,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
, formAction = Just . SomeRoute $ rawAction :#: wIdent "table-wrapper"
, formEncoding = pagesizeEnc
, formAttrs = [("class", "pagesize")]
, formSubmit = FormNoSubmit
, formSubmit = FormAutoSubmit
, formAnchor = Just $ wIdent "pagesize-form"
}
uiLayout table = dbsFilterLayout filterWdgt filterEnc (SomeRoute $ rawAction :#: wIdent "table-wrapper") $(widgetFile "table/layout")

26
src/Handler/Utils/Templates.hs
View File

@ -1,26 +0,0 @@
module Handler.Utils.Templates where
import Data.Either (isLeft)
import Import.NoFoundation
modal :: WidgetT site IO () -> Either (SomeRoute site) (WidgetT site IO ()) -> WidgetT site IO ()
modal modalTrigger modalContent = do
let modalDynamic = isLeft modalContent
modalId <- newIdent
triggerId <- newIdent
$(widgetFile "widgets/modal/modal")
case modalContent of
Left route -> do
route' <- toTextUrl route
[whamlet|
$newline never
<a .modal__trigger href=#{route'} ##{triggerId}>
<span .modal__trigger-label>^{modalTrigger}
|]
Right _ ->
[whamlet|
$newline never
<div .modal__trigger ##{triggerId}>
<span .modal__trigger-label>^{modalTrigger}
|]

7
src/Handler/Utils/TermCandidates.hs
View File

@ -180,5 +180,8 @@ conflicts = E.select $ E.from $ \studyTerms -> do
E.where_ $ studyTerms E.^. StudyTermsName E.==. E.just (candidateTwo E.^. StudyTermCandidateName)
return studyTerms
-- | retrieve all incidence keys having containing a certain @StudyTermKey @
getIncidencesFor :: [Key StudyTerms] -> DB [E.Value TermCandidateIncidence]
getIncidencesFor stks = E.select $ E.distinct $ E.from $ \candidate -> do
E.where_ $ candidate E.^. StudyTermCandidateKey `E.in_` E.valList (unStudyTermsKey <$> stks)
return $ candidate E.^. StudyTermCandidateIncidence

4
src/Import/NoFoundation.hs
View File

@ -15,6 +15,7 @@ import Yesod.Auth as Import
import Yesod.Core.Types as Import (loggerSet)
import Yesod.Default.Config2 as Import
import Utils as Import
import Utils.Modal as Import
import Yesod.Core.Json as Import (provideJson)
import Yesod.Core.Types.Instances as Import ()
@ -41,7 +42,8 @@ import GHC.Exts as Import (IsList)
import Data.Hashable as Import
import Data.List.NonEmpty as Import (NonEmpty(..))
import Data.Text.Encoding.Error as Import(UnicodeException(..))
import Data.List.NonEmpty.Instances as Import ()
import Data.Text.Encoding.Error as Import(UnicodeException(..))
import Data.Semigroup as Import (Semigroup)
import Data.Monoid as Import (Last(..), First(..))
import Data.Monoid.Instances as Import ()

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

@ -16,10 +16,11 @@ import Data.Bitraversable
dispatchJobHelpRequest :: Either (Maybe Address) UserId
-> UTCTime
-> Maybe Text -- ^ Help Subject
-> Text -- ^ Help Request
-> Maybe Text -- ^ Referer
-> Handler ()
dispatchJobHelpRequest jSender jRequestTime jHelpRequest jReferer = do
dispatchJobHelpRequest jSender jRequestTime jHelpSubject jHelpRequest jReferer = do
supportAddress <- getsYesod $ appMailSupport . appSettings
userInfo <- bitraverse return (runDB . getEntity) jSender
let userAddress = either
@ -28,8 +29,9 @@ dispatchJobHelpRequest jSender jRequestTime jHelpRequest jReferer = do
userInfo
mailT def $ do
_mailTo .= [supportAddress]
whenIsJust userAddress $ addMailHeader "Reply-To" . renderAddress
setSubjectI MsgMailSubjectSupport
whenIsJust userAddress (_mailFrom .=)
replaceMailHeader "Auto-Submitted" $ Just "no"
setSubjectI $ maybe MsgMailSubjectSupport MsgMailSubjectSupportCustom jHelpSubject
setDate jRequestTime
rtime <- formatTimeMail SelFormatDateTime jRequestTime
addPart ($(ihamletFile "templates/mail/support.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))

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

@ -22,6 +22,7 @@ dispatchNotificationCorrectionsAssigned nUser nSheet jRecipient = do
]
return (course, sheet, nbrSubs)
when (nbrSubs > 0) . userMailT jRecipient $ do
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
setSubjectI $ MsgMailSubjectCorrectionsAssigned courseShorthand sheetName
MsgRenderer mr <- getMailMsgRenderer

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

@ -19,6 +19,7 @@ dispatchNotificationCorrectionsNotDistributed nSheet jRecipient = do
]
return (course, sheet, nbrSubs)
when (nbrSubs > 0) . userMailT jRecipient $ do
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
setSubjectI $ MsgMailSubjectSubmissionsUnassigned courseShorthand sheetName
MsgRenderer mr <- getMailMsgRenderer
let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm

1
src/Jobs/Handler/SendNotification/SheetActive.hs
View File

@ -17,6 +17,7 @@ dispatchNotificationSheetActive nSheet jRecipient = userMailT jRecipient $ do
sheet <- getJust nSheet
course <- belongsToJust sheetCourse sheet
return (course, sheet)
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
setSubjectI $ MsgMailSubjectSheetActive courseShorthand sheetName
MsgRenderer mr <- getMailMsgRenderer

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

@ -20,6 +20,7 @@ dispatchNotificationSheetSoonInactive nSheet jRecipient = userMailT jRecipient $
sheet <- getJust nSheet
course <- belongsToJust sheetCourse sheet
return (course, sheet)
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
setSubjectI $ MsgMailSubjectSheetSoonInactive courseShorthand sheetName
MsgRenderer mr <- getMailMsgRenderer
@ -45,6 +46,7 @@ dispatchNotificationSheetInactive nSheet jRecipient = userMailT jRecipient $ do
-- E.distinctOn [E.don (subUser E.^. SubmissionUserUser)] -- Not necessary due to UniqueSubmisionUser
return (E.countRows :: E.SqlExpr (E.Value Int64))
return (course, sheet, nrSubs, nrSubmitters)
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
setSubjectI $ MsgMailSubjectSheetInactive courseShorthand sheetName
MsgRenderer mr <- getMailMsgRenderer

1
src/Jobs/Handler/SendNotification/SubmissionRated.hs
View File

@ -22,6 +22,7 @@ dispatchNotificationSubmissionRated nSubmission jRecipient = userMailT jRecipien
course <- belongsToJust sheetCourse sheet
corrector <- traverse getJust submissionRatingBy
return (course, sheet, submission, corrector)
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
setSubjectI $ MsgMailSubjectSubmissionRated courseShorthand
csid <- encrypt nSubmission

1
src/Jobs/Handler/SendNotification/UserRightsUpdate.hs
View File

@ -19,6 +19,7 @@ dispatchNotificationUserRightsUpdate nUser _originalRights jRecipient = userMai
adminSchools <- getSchoolsOf nUser UserAdminSchool UserAdminUser
lecturerSchools <- getSchoolsOf nUser UserLecturerSchool UserLecturerUser
return (user,adminSchools,lecturerSchools)
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
setSubjectI $ MsgMailSubjectUserRightsUpdate userDisplayName
-- MsgRenderer mr <- getMailMsgRenderer
addAlternatives $ do

1
src/Jobs/Handler/SendTestEmail.hs
View File

@ -13,6 +13,7 @@ import Utils.Lens
dispatchJobSendTestEmail :: Email -> MailContext -> Handler ()
dispatchJobSendTestEmail jEmail jMailContext = mailT jMailContext $ do
_mailTo .= [Address Nothing jEmail]
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
setSubjectI MsgMailTestSubject
now <- liftIO getCurrentTime
nDT <- formatTimeMail SelFormatDateTime now

5
src/Jobs/Types.hs
View File

@ -17,7 +17,10 @@ data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notifica
| JobQueueNotification { jNotification :: Notification }
| JobHelpRequest { jSender :: Either (Maybe Address) UserId
, jRequestTime :: UTCTime
, jHelpRequest :: Text, jReferer :: Maybe Text }
, jHelpSubject :: Maybe Text
, jHelpRequest :: Text
, jReferer :: Maybe Text
}
| JobSetLogSettings { jInstance :: InstanceId, jLogSettings :: LogSettings }
| JobDistributeCorrections { jSheet :: SheetId }
deriving (Eq, Ord, Show, Read, Generic, Typeable)

16
src/Mail.hs
View File

@ -27,7 +27,7 @@ module Mail
, setSubjectI, setMailObjectId, setMailObjectId'
, setDate, setDateCurrent
, setMailSmtpData
, _mailFrom, _mailTo, _mailCc, _mailBcc, _mailHeaders, _mailParts
, _mailFrom, _mailTo, _mailCc, _mailBcc, _mailHeaders, _mailHeader, _mailParts
, _partType, _partEncoding, _partFilename, _partHeaders, _partContent
) where
@ -99,9 +99,18 @@ import Data.Universe.Instances.Reverse.Hashable ()
import GHC.Exts (IsList)
import Control.Monad.Trans.Maybe (MaybeT(..))
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
makeLenses_ ''Mail
makeLenses_ ''Part
_mailHeader :: CI ByteString -> Traversal' Mail Text
_mailHeader hdrName = _mailHeaders . traverse . filtered (views _1 $ (== hdrName) . CI.mk) . _2
newtype MailT m a = MailT { _unMailT :: RWST MailContext MailSmtpData Mail m a }
deriving newtype ( MonadTrans, Monad, Functor, MonadFail, Applicative, Alternative, MonadPlus
@ -443,7 +452,10 @@ setDate time = do
setMailSmtpData :: (MonadHandler m, YesodMail (HandlerSite m)) => MailT m ()
setMailSmtpData = do
Address _ from <- use _mailFrom
Just (Address _ from) <- runMaybeT $ asum
[ MaybeT . preuses (_mailHeader "Sender") $ fromString . unpack
, use _mailFrom
]
recps <- Set.fromList . map addressEmail . concat <$> forM [_mailTo, _mailCc, _mailBcc] use
tell $ mempty { smtpRecipients = recps }

14
src/Model/Types.hs
View File

@ -772,6 +772,20 @@ instance FromJSON AuthTagActive where
derivePersistFieldJSON ''AuthTagActive
data LecturerType = CourseLecturer | CourseAssistant
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
instance Universe LecturerType
instance Finite LecturerType
nullaryPathPiece ''LecturerType $ camelToPathPiece' 1
deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece' 1
} ''LecturerType
derivePersistFieldJSON ''LecturerType
-- Type synonyms
type Email = Text

33
src/Utils.hs
View File

@ -85,11 +85,6 @@ getMsgRenderer = do
return $ MsgRenderer (mr . SomeMessage :: forall msg. RenderMessage site msg => msg -> Text)
instance Monad FormResult where
FormMissing >>= _ = FormMissing
(FormFailure errs) >>= _ = FormFailure errs
(FormSuccess a) >>= f = f a
guardAuthResult :: MonadHandler m => AuthResult -> m ()
guardAuthResult AuthenticationRequired = notAuthenticated
guardAuthResult (Unauthorized t) = permissionDenied t
@ -145,8 +140,13 @@ hasTickmark :: Bool -> Markup
hasTickmark True = [shamlet|<i .fas .fa-check>|]
hasTickmark False = mempty
isBad :: Bool -> Markup
-- ^ Display an icon that denotes that something™ is bad
isBad True = [shamlet|<i .fas .fa-bolt>|] -- or times?!
isBad False = mempty
isNew :: Bool -> Markup
isNew True = [shamlet|<i .fas .fa-exclamation>|]
isNew True = [shamlet|<i .fas .fa-seedling>|] -- was exclamation
isNew False = mempty
@ -325,6 +325,14 @@ mergeAttrs = mergeAttrs' `on` sort
mergeAttrs' xs1 [] = xs1
-- | Copied form Util from package ghc
partitionWith :: (a -> Either b c) -> [a] -> ([b], [c])
-- ^ Uses a function to determine which of two output lists an input element should join
partitionWith _ [] = ([],[])
partitionWith f (x:xs) = case f x of
Left b -> (b:bs, cs)
Right c -> (bs, c:cs)
where (bs,cs) = partitionWith f xs
----------
-- Sets --
@ -447,6 +455,9 @@ instance Ord a => Ord (NTop (Maybe a)) where
exceptTMaybe :: Monad m => ExceptT e m a -> MaybeT m a
exceptTMaybe = MaybeT . fmap (either (const Nothing) Just) . runExceptT
formResultToMaybe :: Alternative m => FormResult a -> m a
formResultToMaybe (FormSuccess x) = pure x
formResultToMaybe _ = empty
------------
-- Either --
@ -532,10 +543,11 @@ ifM c m m' =
do b <- c
if b then m else m'
-- | @ifNotM mc = ifM (not <$> mc)@
-- | @ifNotM mc = ifM (not <$> mc)@ from Agda.Utils.Monad
ifNotM :: Monad m => m Bool -> m a -> m a -> m a
ifNotM c = flip $ ifM c
-- | Monadic boolean function, copied from Andreas Abel's utility function
and2M, or2M :: Monad m => m Bool -> m Bool -> m Bool
and2M ma mb = ifM ma mb (return False)
or2M ma = ifM ma (return True)
@ -575,7 +587,8 @@ mconcatMapM f = foldM (\x my -> mappend x <$> my) mempty . map f . Fold.toList
mconcatForM :: (Monoid b, Monad m, Foldable f) => f a -> (a -> m b) -> m b
mconcatForM = flip mconcatMapM
findM :: (Monad m, Foldable f) => (a -> MaybeT m b) -> f a -> m (Maybe b)
findM f = runMaybeT . Fold.foldr (\x as -> f x <|> as) mzero
-----------------
-- Alternative --
@ -605,9 +618,9 @@ modifySessionJson (toPathPiece -> key) f = lookupSessionJson key >>= maybe (dele
tellSessionJson :: (PathPiece k, FromJSON v, ToJSON v, MonadHandler m, Monoid v) => k -> v -> m ()
tellSessionJson key val = modifySessionJson key $ Just . (`mappend` val) . fromMaybe mempty
getSessionJson :: (PathPiece k, FromJSON v, MonadHandler m) => k -> m (Maybe v)
takeSessionJson :: (PathPiece k, FromJSON v, MonadHandler m) => k -> m (Maybe v)
-- ^ `lookupSessionJson` followed by `deleteSession`
getSessionJson key = lookupSessionJson key <* deleteSession (toPathPiece key)
takeSessionJson key = lookupSessionJson key <* deleteSession (toPathPiece key)
--------------------
-- GET Parameters --

29
src/Utils/Form.hs
View File

@ -3,6 +3,7 @@
module Utils.Form where
import ClassyPrelude.Yesod hiding (addMessage, cons, Proxy(..), identifyForm)
import Yesod.Core.Instances ()
import Settings
import Utils.Parameters
@ -98,6 +99,11 @@ addAttrs attr valus fs = fs { fsAttrs = newAttrs $ fsAttrs fs }
| attr==a = ( a, T.intercalate " " $ v : valus ) : t
| otherwise = p : newAttrs t
addPlaceholder :: Text -> FieldSettings site -> FieldSettings site
addPlaceholder placeholder fs = fs { fsAttrs = (placeholderAttr, placeholder) : filter ((/= placeholderAttr) . fst) (fsAttrs fs) }
where
placeholderAttr = "placeholder"
addClass :: Text -> FieldSettings site -> FieldSettings site
addClass = addAttr "class"
@ -107,6 +113,9 @@ addClasses = addAttrs "class"
addName :: PathPiece p => p -> FieldSettings site -> FieldSettings site
addName nm fs = fs { fsName = Just $ toPathPiece nm }
addId :: PathPiece p => p -> FieldSettings site -> FieldSettings site
addId fid fs = fs { fsId = Just $ toPathPiece fid }
addNameClass :: Text -> Text -> FieldSettings site -> FieldSettings site
addNameClass gName gClass fs = fs { fsName = Just gName, fsAttrs = ("class",gClass) : fsAttrs fs }
@ -176,7 +185,10 @@ data FormIdentifier
| FIDDBTable
| FIDDelete
| FIDCourseRegister
| FIDuserRights
| FIDcUserNote
| FIDAdminDemo
| FIDUserDelete
deriving (Eq, Ord, Read, Show)
instance PathPiece FormIdentifier where
@ -198,7 +210,7 @@ identifyForm' resLens identVal form fragment = do
|]
-- Check if we got its value back.
hasIdent <- (== Just identVal) <$> lookupGlobalPostParamForm PostFormIdentifier
hasIdent <- (== Just identVal) <$> lookupGlobalPostParamForm PostFormIdentifier
-- Run the form proper (with our hidden <input>). If the
-- data is missing, then do not provide any params to the
@ -210,7 +222,7 @@ identifyForm' resLens identVal form fragment = do
identifyForm :: (Monad m, PathPiece ident, Eq ident) => ident -> (Html -> MForm m (FormResult a, widget)) -> (Html -> MForm m (FormResult a, widget))
identifyForm = identifyForm' id
{- Hinweise zur Erinnerung:
- identForm primär, wenn es mehr als ein Formular pro Handler gibt
@ -240,6 +252,7 @@ data ButtonMessage = MsgAmbiguousButtons
| MsgMultipleButtonValues
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
-- | Default button for submitting. Required in Foundation for Login, other Buttons defined in Handler.Utils.Form
data ButtonSubmit = BtnSubmit
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
@ -303,6 +316,7 @@ combinedButtonFieldF :: forall m a.
) => FieldSettings (HandlerSite m) -> AForm m [Maybe a]
combinedButtonFieldF = combinedButtonField (universeF :: [a])
-- | Ensures that only a single button press is accepted at once
disambiguateButtons :: forall m a.
( MonadHandler m
, RenderMessage (HandlerSite m) ButtonMessage
@ -341,6 +355,17 @@ submitButtonView = do
fieldView bField btnId "" mempty (Right BtnSubmit) False
buttonForm :: (Button site a, Finite a) => Html -> MForm (HandlerT site IO) (FormResult a, WidgetT site IO ())
buttonForm csrf = do
(res, ($ []) -> fViews) <- aFormToForm . disambiguateButtons $ combinedButtonFieldF ""
return (res, [whamlet|
$newline never
#{csrf}
$forall bView <- fViews
^{fvInput bView}
|])
-------------------
-- Custom Fields --
-------------------

42
src/Utils/Modal.hs Normal file
View File

@ -0,0 +1,42 @@
module Utils.Modal
( Modal(..)
, customModal
, modal
) where
import ClassyPrelude.Yesod
import Control.Lens
import Control.Lens.Extras (is)
import Utils.Route
import Settings (widgetFile)
data Modal site = Modal
{ modalTriggerId
, modalId :: Maybe Text
, modalTrigger :: Maybe Text {- Dynamic URL -} -> Text {- TriggerId -} -> WidgetT site IO ()
, modalContent :: Either (SomeRoute site) (WidgetT site IO ())
}
customModal :: Modal site -> WidgetT site IO ()
customModal Modal{..} = do
let isDynamic = is _Left modalContent
modalId' <- maybe newIdent return modalId
triggerId' <- maybe newIdent return modalTriggerId
$(widgetFile "widgets/modal/modal")
route <- for (modalContent ^? _Left) toTextUrl
modalTrigger route triggerId'
-- | Create a link to a modal
modal :: WidgetT site IO () -- ^ Widget that represents the link
-> Either (SomeRoute site) (WidgetT site IO ()) -- ^ Modal contant: either dynamic link or static widget
-> WidgetT site IO () -- ^ result widget
modal modalTrigger' modalContent = customModal Modal{..}
where
modalTriggerId = Nothing
modalId = Nothing
modalTrigger mRoute triggerId = $(widgetFile "widgets/modal/trigger")

10
src/Utils/TH.hs
View File

@ -24,7 +24,7 @@ projNI n i = do
x <- newName "x"
let rhs = varE x
let pat = tupP $ replicate (pred i) wildP ++ varP x : replicate (n-i) wildP
lamE [pat] rhs
lam1E pat rhs
-- | Generic projections N-tuples that are actually left-associative pairs
@ -83,6 +83,14 @@ uncurryN n = do
return $ LamE pat rhs
afterN :: Int -> ExpQ -- apply a function after another of arity N, i.e. $(afterN 1) = (.)
afterN n = do
f <- newName "f"
g <- newName "g"
--let rhs = [|$(curryN n) (g . ($(uncurryN n) f))|]
lamE [varP g, varP f] [|$(curryN n) $(varE g) . $(uncurryN n) $(varE f)|]
-- Special Show-Instances for Themes
deriveShowWith :: (String -> String) -> Name -> Q [Dec]
deriveShowWith = deriveSimpleWith ''Show 'show

38
src/Yesod/Core/Instances.hs
View File

@ -4,6 +4,7 @@ module Yesod.Core.Instances
(
) where
import Prelude (errorWithoutStackTrace)
import ClassyPrelude.Yesod
import Utils (assertM')
@ -14,6 +15,12 @@ import Data.ByteString.Builder (toLazyByteString)
import System.FilePath ((</>))
import Data.Aeson
import Control.Monad.Fix
import Control.Monad.Fail (MonadFail)
import qualified Control.Monad.Fail as MonadFail
import Control.Monad.Except (MonadError(..))
import Data.Functor.Extend
instance (RenderRoute site, ParseRoute site) => PathPiece (Route site) where
@ -39,3 +46,34 @@ instance (RenderRoute site, ParseRoute site) => FromJSON (Route site) where
instance (RenderRoute site, ParseRoute site) => ToJSON (Route site) where
toJSON = String . toPathPiece
instance Monad FormResult where
(FormSuccess a) >>= f = f a
FormMissing >>= _ = FormMissing
(FormFailure errs) >>= _ = FormFailure errs
fail = MonadFail.fail
instance MonadFail FormResult where
fail _ = FormMissing
instance MonadError [Text] FormResult where
throwError = FormFailure
catchError a@(FormSuccess _) _ = a
catchError FormMissing _ = FormMissing
catchError (FormFailure errs) h = h errs
instance MonadPlus FormResult
instance MonadFix FormResult where
mfix f = let a = f (unSuccess a) in a
where unSuccess (FormSuccess x) = x
unSuccess FormMissing = errorWithoutStackTrace "mfix FormResult: FormMissing"
unSuccess (FormFailure _) = errorWithoutStackTrace "mfix FormResult: FormFailure"
instance Extend FormResult where
duplicated (FormSuccess x) = FormSuccess $ FormSuccess x
duplicated FormMissing = FormMissing
duplicated (FormFailure errs) = FormFailure errs

2
src/index.md
View File

@ -86,7 +86,7 @@ Handler.Utils.Table.Pagination.Types
Handler.Utils.Table.Cells
: extends dbTable with UniWorX specific functions, such as special courseCell
Handler.Utils.Templates
Utils.Modal
: Modals
Handler.Utils.Zip

17
static/css/utils/inputs.scss
View File

@ -25,27 +25,26 @@
color: var(--color-fontsec);
}
.form-group__label {
.form-group-label {
font-weight: 600;
padding-top: 6px;
}
.form-group__hint {
.form-group-label__hint {
margin-top: 7px;
color: var(--color-fontsec);
font-size: 0.9rem;
}
.form-group--required {
.form-group__label::after {
.form-group-label__caption::after {
content: ' *';
color: var(--color-error);
}
}
.form-group--optional {
.form-group__label::after {
.form-group-label__caption::after {
content: '';
}
}
@ -66,6 +65,14 @@
input, textarea {
border-color: var(--color-error) !important;
}
.form-error {
display: block;
}
}
.form-error {
display: none;
}
@media (max-width: 768px) {

43
static/js/utils/form.js
View File

@ -8,6 +8,9 @@
var AUTOSUBMIT_BUTTON_SELECTOR = '[type="submit"][data-autosubmit]';
var AJAX_SUBMIT_FLAG = 'ajaxSubmit';
var FORM_GROUP_CLASS = 'form-group';
var FORM_GROUP_WITH_ERRORS_CLASS = 'form-group--has-error';
function formValidator(inputs) {
var done = true;
inputs.forEach(function(inp) {
@ -20,8 +23,15 @@
}
window.utils.form = function(form, options) {
options = options || {};
if (form.classList.contains(JS_INITIALIZED)) {
// dont initialize form if it is in a modal and is not forced
if (form.closest('.modal') && !options.force) {
return false;
}
// dont initialize form if already initialized and should not be force-initialized
if (form.classList.contains(JS_INITIALIZED) && !options.force) {
return false;
}
@ -45,6 +55,12 @@
// inputs
utilInstances.push(window.utils.setup('inputs', form, options));
// form group errors
var formGroups = Array.from(form.querySelectorAll('.' + FORM_GROUP_CLASS));
formGroups.forEach(function(formGroup) {
utilInstances.push(window.utils.setup('errorRemover', formGroup, options));
});
form.classList.add(JS_INITIALIZED);
function destroyUtils() {
@ -158,4 +174,29 @@
destroy: function() {},
};
};
// listens for focus events and removes any errors on an input
window.utils.errorRemover = function(formGroup, options) {
var inputElement = formGroup.querySelector('input:not([type="hidden"]), textarea, select');
if (!inputElement) {
return false;
}
inputElement.addEventListener('focus', focusListener);
function focusListener() {
var hasError = formGroup.classList.contains(FORM_GROUP_WITH_ERRORS_CLASS);
if (hasError) {
formGroup.classList.remove(FORM_GROUP_WITH_ERRORS_CLASS);
}
}
return {
scope: formGroup,
destroy: function() {
inputElement.removeEventListener('focus', focusListener);
},
};
};
})();

31
static/js/utils/inputs.js
View File

@ -3,37 +3,37 @@
window.utils = window.utils || {};
var JS_INITIALIZED_CLASS = 'js-initialized';
function isNotInitialized(element) {
return !element.classList.contains(JS_INITIALIZED_CLASS);
}
var JS_INITIALIZED_CLASS = 'js-inputs-initialized';
window.utils.inputs = function(wrapper, options) {
options = options || {};
var utilInstances = [];
if (wrapper.classList.contains(JS_INITIALIZED_CLASS) && !options.force) {
return false;
}
// checkboxes
var checkboxes = Array.from(wrapper.querySelectorAll('input[type="checkbox"]'));
checkboxes.filter(isNotInitialized).forEach(function(checkbox) {
checkboxes.forEach(function(checkbox) {
utilInstances.push(window.utils.setup('checkbox', checkbox));
});
// radios
var radios = Array.from(wrapper.querySelectorAll('input[type="radio"]'));
radios.filter(isNotInitialized).forEach(function(radio) {
radios.forEach(function(radio) {
utilInstances.push(window.utils.setup('radio', radio));
});
// file-uploads
var fileUploads = Array.from(wrapper.querySelectorAll('input[type="file"]'));
fileUploads.filter(isNotInitialized).forEach(function(input) {
fileUploads.forEach(function(input) {
utilInstances.push(window.utils.setup('fileUpload', input, options));
});
// file-checkboxes
var fileCheckboxes = Array.from(wrapper.querySelectorAll('.file-checkbox'));
fileCheckboxes.filter(isNotInitialized).forEach(function(input) {
fileCheckboxes.forEach(function(input) {
utilInstances.push(window.utils.setup('fileCheckbox', input, options));
});
@ -45,6 +45,8 @@
});
}
wrapper.classList.add(JS_INITIALIZED_CLASS);
return {
scope: wrapper,
destroy: destroyUtils,
@ -74,7 +76,6 @@
if (!i18n) {
throw new Error('window.utils.fileUpload(input, options) needs to be passed i18n object via options');
}
input.classList.add(JS_INITIALIZED_CLASS);
function renderFileList(files) {
fileList.innerHTML = '';
@ -166,8 +167,6 @@
cont = cont.parentNode;
}
addListener(cont);
input.classList.add(JS_INITIALIZED_CLASS);
cont.classList.add(JS_INITIALIZED_CLASS);
}
setup();
@ -190,7 +189,6 @@
labelEl.setAttribute('for', input.id);
wrapperEl.appendChild(input);
wrapperEl.appendChild(labelEl);
input.classList.add(JS_INITIALIZED_CLASS);
if (siblingEl) {
parentEl.insertBefore(wrapperEl, siblingEl);
@ -219,7 +217,6 @@
wrapperEl.appendChild(siblingEl);
}
input.classList.add(JS_INITIALIZED_CLASS);
parentEl.appendChild(wrapperEl);
}
@ -233,8 +230,6 @@
window.utils.implicitSubmit = function(input, options) {
var submit = options.submit;
console.log('implicitSubmit', input, submit);
if (!submit) {
throw new Error('window.utils.implicitSubmit(input, options) needs to be passed a submit element via options');
}
@ -247,7 +242,7 @@
};
input.addEventListener('keypress', doSubmit);
return {
scope: input,
destroy: function() {

2
static/js/utils/modal.js
View File

@ -75,7 +75,7 @@
function setupForm() {
var form = modalElement.querySelector('form');
if (form) {
utilInstances.push(window.utils.setup('form', form, { headers: MODAL_HEADERS }));
utilInstances.push(window.utils.setup('form', form, { headers: MODAL_HEADERS, force: true }));
}
}

3
static/js/utils/setup.js
View File

@ -37,6 +37,9 @@
if (isAlreadySetup) {
console.warn('Trying to setup a JS utility that\'s already been set up', { utility: utilName, scope, options });
if (!options.force) {
return false;
}
}
}

11
templates/adminTest.hamlet
View File

@ -1,17 +1,14 @@
<div .container>
<h1>Uni2work - Admin Demopage
<section>
<p data-tooltip="Solch ein Tooltip kann mit dem <em>data-tooltip</em> Attribut erzeugt werden. Funktioniert aber nur in Block-Elementen die einen sinnvollen Wrapper haben.">
Diese interne Seite dient lediglich zum Testen diverser Funktionalitäten
und zur Demonstration der verschiedenen Hilfsfunktionen/Module.
Der Handler sollte jeweils aktuelle Beispiele für alle möglichen Funktionalitäten enthalten, so dass man immer weiß, wo man nachschlagen kann.
<div .container.js-show-hide>
<section>
<h2 .js-show-hide__toggle>Teilweise funktionierende Abschnitte
<ul .js-show-hide__target>
<ul>
<li .list-group-item>
<a href=@{UsersR}>Benutzer Verwaltung
@ -22,7 +19,7 @@
<li .list-group-item>
<a href=@{CourseNewR}>Kurse anlegen
<div .container>
<section>
<h2>Funktionen zum Testen
<ul>

13
templates/adminUser.hamlet
View File

@ -1,4 +1,11 @@
<p>
$# Does not use link-email.hamlet, but should
<section>
^{mailtoHtml userEmail}
^{form}
^{form}
<section>
^{userDataWidget}
<h3>
^{modal "Benutzer löschen" (Right deleteWidget)}
Achtung, dieser Link löscht momentan noch den kompletten Benutzer
unwiderruflich aus der Live-Datenbank mit
<code>DELETE CASCADE uid
\ Klausurdaten müssen jedoch langfristig gespeichert werden!

7
templates/course-participants.hamlet Normal file
View File

@ -0,0 +1,7 @@
$# Shows all participants of a course, but no homework statistics
$# Should at some point allow email messaging
$#
$# participantTable : widget table
^{participantTable}
_{MsgCourseMembersCountOf (fromIntegral numParticipants) (courseCapacity course)}.

49
templates/course-user.hamlet Normal file
View File

@ -0,0 +1,49 @@
<section>
<div .profile>
<dl .deflist.profile-dl>
<dt .deflist__dt> _{MsgEMail}
<dd .deflist__dd> #{mailtoHtml userEmail}
<dt .deflist__dt> _{MsgMatrikelNr}
<dd .deflist__dd>
$maybe matnr <- userMatrikelnummer
#{matnr}
$nothing
_{MsgNoMatrikelKnown}
<dt .deflist__dt>_{MsgRegisteredHeader}
<dd .deflist__dd>
<div .course__registration>
<a id="register-form">
<form method=post action=@{currentRoute}#register-form enctype=#{registerEnctype}>
^{registerView}
$maybe date <- mRegAt
_{MsgRegisteredSince date}
<dt .deflist__dt> _{MsgStudyTerms}
<dd .deflist__dd>
$if null studies
_{MsgNoStudyTermsKnown}
$else
<div .scrolltable>
<table .table.table--striped.table--hover.table--condensed>
<tr .table__row>
<th .table__th>_{MsgStudyTerm}
<th .table__th>_{MsgStudyFeatureDegree}
<th .table__th>_{MsgStudyFeatureType}
<th .table__th>_{MsgStudyFeatureAge}
<th .table__th>_{MsgStudyFeatureValid}
<th .table__th>_{MsgStudyFeatureUpdate}
$forall ((Entity _ StudyFeatures{..}), (Entity _ degree), (Entity _ field)) <- studies
$with _ <- notUsedT studyFeaturesUser
<tr.table__row>
<td .table__td>_{field}#{notUsedT studyFeaturesField}
<td .table__td>_{degree}#{notUsedT studyFeaturesDegree}
<td .table__td>_{studyFeaturesType}
<td .table__td>#{display studyFeaturesSemester}
<td .table__td>#{hasTickmark studyFeaturesValid}
<td .table__td>^{formatTimeW SelFormatDate studyFeaturesUpdated}
<section>
<a id="note-form">
<form method=post action=@{currentRoute}#note-form enctype=#{noteEnctype}>
^{noteView}

14
templates/course.hamlet
View File

@ -19,8 +19,18 @@
<dd .deflist__dd>
<div>
<ul .list--inline .list--comma-separated>
$forall (E.Value displayname, E.Value surname, E.Value email) <- lecturers
<li>^{nameEmailWidget email displayname surname}
$forall lect <- lecturers
<li>^{nameEmailWidget' lect}
$with numassi <- length assistants
$if numassi > 1
<dt .deflist__dt>_{MsgAssistantsFor}
$else
<dt .deflist__dt>_{MsgAssistantFor}
<dd .deflist__dd>
<div>
<ul .list--inline .list--comma-separated>
$forall assi <- assistants
<li>^{nameEmailWidget' assi}
$maybe link <- courseLinkExternal course
<dt .deflist__dt>Website

17
templates/default-layout.lucius
View File

@ -474,7 +474,7 @@ ul.list--inline {
/* DEFINITION LIST */
.deflist {
display: grid;
grid-template-columns: 100% ;
grid-template-columns: 100%;
}
.deflist__dt,
.deflist__dd {
@ -488,6 +488,10 @@ ul.list--inline {
.deflist__dd {
font-size: 18px;
margin-bottom: 10px;
> p {
margin-top: 0;
}
}
@media (min-width: 768px) {
@ -507,7 +511,6 @@ ul.list--inline {
.deflist__dt,
.deflist__dd {
border-bottom: 1px solid #d3d3d3;
padding: 12px 0;
margin: 0;
font-size: 16px;
@ -527,17 +530,15 @@ ul.list--inline {
}
section {
padding-bottom: 20px;
margin-bottom: 20px;
padding-bottom: 30px;
border-bottom: 1px solid #d3d3d3;
+ section {
margin-top: 20px;
padding-top: 20px;
margin-top: 20px;
}
section {
border-bottom: none;
&:last-child {
border-bottom: none;
}
}

6
templates/deletedUser.hamlet
View File

@ -1,6 +1,10 @@
<div .container>
<h1>
_{MsgUserAccountDeleted userDisplayName}
<div .container>
#{nameEmailHtml userEmail userDisplayName userSurname}
<div .container>
#{mailtoHtml userEmail}
<div .container>
#{display deletedSubmissions} Abgaben wurden unwiederruflich gelöscht.
$if groupSubmissions > 0
@ -12,5 +16,3 @@
$if deletedSubmissionGroups > 0
<div .container>
#{display deletedSubmissionGroups} benannte Abgabengruppen wurden gelöscht, da diese dadurch leer wurden.
<div .container>
Good Bye!

3
templates/featureList.hamlet
View File

@ -6,7 +6,6 @@
<h4>
aus UniWorX bekannt:
<ul>
<li> Studiengänge von Benutzern werden noch ignoriert
<li> Übungsgruppen
<li> Klausuren
<li> Zentralanmeldungen
@ -14,7 +13,7 @@
<h4>
neue geplante Features:
<ul>
<li> Stundenplan/Kalender mit Veranstaltungen und Klausuren
<li> Stundenplan/Kalender mit allen Veranstaltungen und Klausuren
<li> Vollständige Vorlesungshomepages
<li> Vollständige Internationalisierung deutsch/englisch/...

2
templates/help.hamlet
View File

@ -1,3 +1,3 @@
<p>
_{MsgHelpIntroduction}
^{form}
^{formWidget}

5
templates/home.hamlet
View File

@ -1,5 +0,0 @@
<div .container>
<h2>
Kurse mit offener Registrierung
<div .container>
^{courseTable}

3
templates/home/openCourses.hamlet Normal file
View File

@ -0,0 +1,3 @@
<section>
<h2>_{MsgHomeOpenCourses}
^{courseTable}

3
templates/home/upcomingSheets.hamlet Normal file
View File

@ -0,0 +1,3 @@
<section>
<h2>_{MsgHomeUpcomingSheets}
^{sheetTable}

17
templates/homeUser.hamlet
View File

@ -1,17 +0,0 @@
<div .container>
<h2>
Anstehende Übungsblätter
<div .container>
^{sheetTable}
<!--
<div .container>
<h1>
Anstehende Klausuren
TODO
<div .container>
<h1>
Anstehende Kursanmeldungen
TODO
-->

103
templates/info-lecturer/de.hamlet
View File

@ -1,47 +1,18 @@
$newline text
<section>
UniWorX erfahrene Veranstalter finden
hier die wichtigsten Neuerungen.
UniWorX erfahrene Veranstalter finden
hier die wichtigsten Neuerungen.
<section>
<h2>Bekannte Probleme in Bearbeitung
<dl .deflist>
<dt .deflist__dt>Derzeit keine bekannt.
$#
$# MOVE ITEM TO SECTION "VERANSTALTUNGEN", once it is implemented:
$#
<dt .deflist__dt> Kurs Assistenten
<dd .deflist__dd>
Momentan ist leider nur ein Dozent/Veranstalter pro Kurs erlaubt.
<p>
<h4>Folgendes ist in Vorbereitung:
Kurs-Veranstalter dürfen <em>beliebige</em> Personen
ebenfalls zu Veranstaltern des Kurses machen.
Innerhalb des Kurses haben alle Kurs-Veranstalter die
gleichen Befugnisse und können insbesondere auch die
Liste der Veranstalter dieses Kurses bearbeiten.
<p>
<h4>Unterschied zu UniWorX:
In Uni2work gibt es die Rollen "Dozent"
und "Veranstalter":
Dozenten dürfen im Wesentlichen neue Kurse erstellen.
Veranstalter haben vollen Zugriff auf einen speziellen Kurs.
Die Dozenten Berechtigung wird nach Instituten unterschieden.
<p>
In UniWorX gab es die Rolle "Assistent",
d.h. alle "Veranstalter" mussten auch "Dozent" sein;
eine Unterscheidung nach Instituten gab es nicht.
<dt .deflist__dt> Kurs Teilnehmer
<dd .deflist__dd>
Anzeige und Benachrichtigung angemeldeter
Kurs-Teilnehmer ist leider noch nicht fertig implementiert.
Voraussichtlich vor Start des Sommersemesters 2019 verfügbar.
<section>
<h2>Veranstaltungen
@ -74,6 +45,54 @@ hier die wichtigsten Neuerungen.
<dt .deflist__dt> Kurs Passwort
<dd .deflist__dd> Die Anmeldung zum Kurs kann durch ein Passwort geschützt werden.
<dt .deflist__dt> Kurs Assistenten
<dd .deflist__dd>
<p>
Kurs-Veranstalter dürfen <em>beliebige</em> Personen
ebenfalls zu Veranstaltern des Kurses machen.
Innerhalb des Kurses haben alle Kurs-Veranstalter die
gleichen Befugnisse und können insbesondere auch die
Liste der Veranstalter dieses Kurses bearbeiten.
<p>
<h4>Unterschied zu UniWorX:
In Uni2work gibt es die Rollen "Dozent"
und "Assistent":
Dozenten dürfen im Wesentlichen neue Kurse erstellen.
Die Dozenten Berechtigung wird nach Instituten unterschieden.
Assistenten haben nur Zugriff auf einen speziellen Kurs,
aber innerhalb dieses Kurses die gleichen Rechte wie Dozenten.
<p>
In UniWorX gab es die Rolle "Assistent",
d.h. alle "Veranstalter" mussten auch "Dozent" sein;
eine Unterscheidung nach Instituten gab es nicht.
<dt .deflist__dt> Kurs Teilnehmer
<dd .deflist__dd>
<p>
Für die Teilnehmer eines Kurses werden nun Studiengangsinformationen angzeigt.
Studierende mit mehreren simultanen Studiengängen müssen bei der
Kursanmeldung ein Hauptfach auswählen, was die Notenmeldung beschleunigen kann.
<p>
Falls Anstatt eines Studienganges oder eines Studienabschlusses nur eine
Nummer angzeigt wird, so hat Uni2work die Zuordnung dieser Schlüsselnummern
leider noch nicht erlernt. Dies muss leider sukzessive erfolgen, da wir
von der Studentenkanzelei keine aktuelle und vollständige Schlüsselzuordnung
bekommen können.
<dt .deflist__dt> Aus Studentensicht
<dd .deflist__dd>
<p>
UniWorX hatte spezielle Links "Aus Studentensicht", welche in Uni2work überflüssig geworden sind.
Stattdessen kann man sich in Uni2work #
<a href=@{AuthPredsR}>Berechtigungen hier temporär selbst entziehen
. Um die eigene Veranstaltung aus Sicht eines Teilnehmers zu sehen, deaktiviert man #
die Berechtigungsprüfungen "_{MsgAuthTagLecturer}" und/oder "_{MsgAuthTagCorrector}"
<section>
<h2>Übungsbetrieb
@ -108,14 +127,18 @@ hier die wichtigsten Neuerungen.
<dt .deflist__dt> Lösungshinweise
<dd .deflist__dd>
Zusätzlich zu Aufgabe und Lösung können Hinweise ab einem
Datum vor Abgabfrist freigeschaltet werden,
Datum vor Ende des Abgabezeitraums freigeschaltet werden,
z.B. Lösungen zu Präsenzaufgaben.
<dt .deflist__dt> Sichtbarkeit
<dd .deflist__dd>
Übungsblätter können bis zu einem Datum vor den Teilnehmern versteckt werden.
<p>
Die Aufgabenstellung ist erst mit Eröffnung der Abgabe erhältlich,
Übungsblätter können bis zu einem Datum "Sichtabr ab" vor allen Teilnehmern versteckt werden.
Das kann nützlich sein, um Tutoren und Korrektoren ein provisorisches Übungsblatt verfügbar zu machen,
dessen Bewertungsmodalitäten und Fristen sich noch ändern können.
<p>
Erst wenn das Blatt sichtbar wird, sehen die Teilnehmer in Ihrer Übersichtsliste.
Alle Dateien zur Aufgabenstellung sind aber erst mit Beginn des Abgabezeitraums erhältlich,
so wie bisher in UniWorX auch.
<dt .deflist__dt> Zeitstempel
@ -173,4 +196,4 @@ hier die wichtigsten Neuerungen.
Planmäßige Wartungen werden ohne Ankündigung
immer um 2:00h nachts durchgeführt.
Es wird daher empfohlen, keine kritischen Abgabefristen
um oder kurz nach dieser Zeit einzustellen.
um oder kurz nach dieser Zeit einzustellen.

45
templates/profileData.hamlet
View File

@ -7,7 +7,7 @@
<dt .deflist__dt> _{MsgMatrikelNr}
<dd .deflist__dd> #{matnr}
<dt .deflist__dt> _{MsgEMail}
<dd .deflist__dd> #{display userEmail}
<dd .deflist__dd> #{mailtoHtml userEmail}
<dt .deflist__dt> _{MsgIdent}
<dd .deflist__dd> #{display userIdent}
<dt .deflist__dt> _{MsgLastLogin}
@ -17,7 +17,7 @@
$nothing
_{MsgNever}
$if not $ null admin_rights
<dt .deflist__dt> Administrator
<dt .deflist__dt>_{MsgAdminFor}
<dd .deflist__dd>
<ul .list-ul>
$forall (E.Value institute) <- admin_rights
@ -25,7 +25,7 @@
<a href=@{SchoolShowR $ SchoolKey institute}>
#{display institute}
$if not $ null lecturer_rights
<dt .deflist__dt> Lehrberechtigt
<dt .deflist__dt>_{MsgLecturerFor}
<dd .deflist__dd>
<ul .list-ul>
$forall (E.Value institute) <- lecturer_rights
@ -45,13 +45,12 @@
<div .scrolltable>
<table .table.table--striped.table--hover.table--condensed>
<tr .table__row>
<th .table__th> Studiengang
<th .table__th> Abschluss
<th .table__th> Studienart
<th .table__th> Semester
<th .table__th> Aktiv
<th .table__th> Update
<th .table__th>_{MsgStudyTerm}
<th .table__th>_{MsgStudyFeatureDegree}
<th .table__th>_{MsgStudyFeatureType}
<th .table__th>_{MsgStudyFeatureAge}
<th .table__th>_{MsgStudyFeatureValid}
<th .table__th>_{MsgStudyFeatureUpdate}
$forall ((Entity _ StudyFeatures{..}), (Entity _ degree), (Entity _ field)) <- studies
$with _ <- notUsedT studyFeaturesUser
@ -115,20 +114,28 @@
<a href=@{CorrectionsR}>Auflistung aller tatsächlich zugewiesenen Korrekturen
.
<h2>
^{modal "Alle Benutzerbezogenen Daten löschen" (Right delWdgt)}
<p>
<h4>Hinweise:
<section>
<h2>_{MsgRemarks}
<ul>
<li>
Sichern Sie Ihre Daten! Während des Testbetriebs von Uni2work
könnten Daten unabsichtlich unwidderuflich gelöscht werden.
Sichern Sie bitte Ihre Daten! Die Uni2work Datenbank wird täglich gesichert;
dennoch können wir Probleme während des Testbetriebs noch nicht gänzlich ausschließen.
<li>
Nicht aufgeführt sind Zeitstempel mit Benutzerinformationen, z.B. bei der Editierung und Korrektur von Übungen, Übungsgruppenleiterschaft, Raumbuchungen, etc.
<li>
Benutzerdaten bleiben so lange gespeichert, bis ein Institutsadministrator über die Exmatrikulation informiert wurde. Dann wird der Account gelöscht.
Abgaben/Bonuspunkte werden unwiderruflich gelöscht.
Klausurnoten verbleiben aus statistischen Gründen anonymisiert im System.
Sie können die
<a href=@{HelpR}>
Löschung Ihre Daten über eine Supportanfrage beantragen
. Ihre Daten werden dann nach Ablauf einer Frist gelöscht.
Daten, welche keiner gesetzlichen Aufbewahrungsfrist unterliegen
(z.B. Klausurnoten) verbleiben im System bis zur Ablauf der Aufbewahrungsfrist.
<p>
Benutzerdaten bleiben prinzipiell so lange gespeichert,
bis ein Institutsadministrator über die Exmatrikulation informiert wurde.
Dann wird der Account mit einer angemessenen zeitverzögerung gelöscht.
Anonymisierte Klausurnoten verbleiben aus statistischen Gründen dauerhaft im System.
<li>
Bei gemeinsamen Gruppenabgaben wird nur die Zuordnung zu diesem Benutzer gelöscht.
Die Abgabe selbst wird erst gelöscht, wenn alle Benutzer einer Abgabe deren Löschung veranlasst haben.

1
templates/table/layout-filter-default.lucius
View File

@ -1,4 +1,3 @@
.table-filter {
border-bottom: 1px solid #d3d3d3;
margin-bottom: 13px;
}

2
templates/versionHistory.hamlet
View File

@ -7,7 +7,7 @@
<h2>
Bekannte Bugs
<h3>
Stand: Februar 2019
Stand: März 2019
<ul>
<li>
Login ist u.U. anders als im alten System, z.B. momentan geht nur <span style="font-family:monospace">@campus.lmu.de</span> aber nicht die Abkürzung <span style="font-family:monospace">@lmu.de</span>

9
templates/widgets/aform/aform.hamlet
View File

@ -3,7 +3,7 @@ $newline never
$case formLayout
$of FormDBTablePagesize
$forall view <- fieldViews
<label .form-group__label.label-pagesize for=#{fvId view}>#{fvLabel view}
<label .form-group-label.label-pagesize for=#{fvId view}>#{fvLabel view}
^{fvInput view}
$of _
$forall view <- fieldViews
@ -13,10 +13,11 @@ $case formLayout
$else
<div .form-group :fvRequired view:.form-group--required :not $ fvRequired view:.form-group--optional :isJust $ fvErrors view:.form-group--has-error>
$if not (Blaze.null $ fvLabel view)
<label .form-group__label for=#{fvId view}>
#{fvLabel view}
<label .form-group-label for=#{fvId view}>
<span .form-group-label__caption>
#{fvLabel view}
$maybe hint <- fvTooltip view
<div .form-group__hint>^{hint}
<div .form-group-label__hint>^{hint}
<div .form-group__input>
^{fvInput view}
$maybe err <- fvErrors view

25
templates/widgets/data-delete/data-delete.hamlet
View File

@ -1,15 +1,21 @@
<h2>
Sind Sie sich absolut sicher, alle Ihre in Uni2work gespeicherten Daten zu löschen?
Sind Sie sich absolut sicher
Benutzer ^{nameEmailWidget userEmail userDisplayName userSurname} zu löschen?
<p>
Während der Testphase von Uni2work können Sie hiermit
Ihren Account bei Uni2work vollständig löschen.
Mit Ihrem Campus-Account können Sie sich aber danach
jederzeit erneut einloggen, wodurch wieder ein leerer Account erstellt wird.
Während der Testphase von Uni2work
werden Benutzer hiermit vollständig aus der Live-Datenbank mit
<code>DELETE CASCADE uid
gelöscht.
Klausurdaten müssen jedoch unbedingt 5 Jahre bis nach Exmatrikulation
aufbewahrt werden!
<p>
Benutzer können sich mit Ihrem Campus-Account
natürlich jederzeit erneut einloggen, wodurch wieder ein leerer Account erstellt wird.
<p>
Hochgeladene Hausaufgaben-Dateien werden unabhhängig vom Urherber nur dann gelöscht,
wenn die Dateien ausschließlich Ihnen zugeordnet sind.
wenn die Dateien ausschließlich diesem Benutzer zugeordnet waren.
Dateien aus Gruppenabgaben werden also erst dann gelöscht,
wenn alle Gruppenmitglieder Ihren Account gelöscht haben.
wenn die Accounts alle Gruppenmitglieder gelöscht wurden.
<p>
<em>Achtung:
Auch abgegebene Hausübungen werden gelöscht!
@ -18,9 +24,4 @@
(Verbuchte Noten sollten dadurch nicht betroffen sein, aber in einem etwaigen
Streitfall konnen die per Uni2work verwalteten Hausaufgaben dann
auch nicht mehr rekonstruiert/berücksichtigt werden.)
<p>
<em>Nach der Testphase von Uni2work wird das Löschen eines Accounts etwas
eingeschränkt werden, da z.B. Klausurnoten 5 Jahre bis nach Exmatrikulation
aufbewahrt werden müssen.
^{btnForm}

32
templates/widgets/form/form.hamlet
View File

@ -1,17 +1,19 @@
$newline never
$# Wrapper for all kinds of forms
<form ##{formId} method=#{decodeUtf8 (renderStdMethod formMethod)} action=#{fromMaybe "" formActionUrl} enctype=#{formEncoding} *{formAttrs}>
$# Distinguish different falvours of submit button layouts here:
$case formSubmit
$of FormNoSubmit
^{formWidget}
$of FormSubmit
^{formWidget}
^{submitButtonView}
$of FormDualSubmit
^{submitButtonView}
^{formWidget}
^{submitButtonView}
$of FormAutoSubmit
<button type=submit data-autosubmit>
^{btnLabel BtnSubmit}
<section>
<form ##{formId} method=#{decodeUtf8 (renderStdMethod formMethod)} action=#{fromMaybe "" formActionUrl} enctype=#{formEncoding} *{formAttrs}>
$# Distinguish different falvours of submit button layouts here:
$case formSubmit
$of FormNoSubmit
^{formWidget}
$of FormSubmit
^{formWidget}
^{submitButtonView}
$of FormDualSubmit
^{submitButtonView}
^{formWidget}
^{submitButtonView}
$of FormAutoSubmit
^{formWidget}
<button type=submit data-autosubmit>
^{btnLabel BtnSubmit}

3
templates/widgets/massinput/list/cell.hamlet Normal file
View File

@ -0,0 +1,3 @@
$newline never
#{csrf}
^{fvInput}

3
templates/widgets/modal/modal.hamlet
View File

@ -1,4 +1,5 @@
<div .modal.js-modal #modal-#{modalId} data-trigger=#{triggerId} data-closeable :modalDynamic:data-dynamic>
$newline never
<div .modal.js-modal #modal-#{modalId'} data-trigger=#{triggerId'} data-closeable :isDynamic:data-dynamic>
$case modalContent
$of Right content
<div .modal__content>

5
templates/widgets/modal/modal.julius
View File

@ -1,8 +1,5 @@
document.addEventListener('DOMContentLoaded', function() {
var modalIdent = #{String modalId};
var selector = '#modal-' + modalIdent;
var modal = document.querySelector(selector);
var modal = document.querySelector('#modal-' + #{String modalId'});
if (modal) {
window.utils.setup('modal', modal);
}

7
templates/widgets/modal/trigger.hamlet Normal file
View File

@ -0,0 +1,7 @@
$newline never
$maybe route <- mRoute
<a .modal__trigger href=#{route} ##{triggerId}>
<span .modal__trigger-label>^{modalTrigger'}
$nothing
<div .modal__trigger ##{triggerId}>
<span .modal__trigger-label>^{modalTrigger'}

3
templates/widgets/navbar/item.hamlet Normal file
View File

@ -0,0 +1,3 @@
<a .navbar__link-wrapper href=#{route} ##{menuIdent}>
<i .fas.fa-#{fromMaybe "none" menuItemIcon}>
<div .navbar__link-label>_{SomeMessage menuItemLabel}

27
templates/widgets/navbar/navbar.hamlet
View File

@ -8,34 +8,31 @@ $newline never
<li .navbar__list-item.navbar__list-item--favorite>
<a .navbar__link-wrapper href="#">
<i .fas.fa-star>
<div .navbar__link-label> Favorites
<div .navbar__link-label>_{MsgNavigationFavourites}
$forall (MenuItem{menuItemType, menuItemRoute, menuItemIcon, menuItemLabel, menuItemModal}, menuIdent, route) <- menuTypes
$forall (menuItem@MenuItem{menuItemType, menuItemRoute, menuItemModal}, menuIdent, _) <- menuTypes
$case menuItemType
$of NavbarAside
<li .navbar__list-item :highlight (urlRoute menuItemRoute):.navbar__list-item--active>
$if menuItemModal
<div .modal.js-modal #modal-#{menuIdent} data-trigger=#{menuIdent} data-closeable data-dynamic>
<a .navbar__link-wrapper href=#{route} ##{menuIdent}>
<i .fas.fa-#{fromMaybe "none" menuItemIcon}>
<div .navbar__link-label>_{SomeMessage menuItemLabel}
^{navbarModal (menuItem, menuIdent)}
$else
^{navbarItem (menuItem, menuIdent)}
$of _
<ul .navbar__list.list--inline>
$forall (MenuItem{menuItemType, menuItemRoute, menuItemIcon, menuItemLabel, menuItemModal}, menuIdent, route) <- menuTypes
$forall (menuItem@MenuItem{menuItemType, menuItemRoute, menuItemModal}, menuIdent, _) <- menuTypes
$case menuItemType
$of NavbarRight
<li .navbar__list-item :highlight (urlRoute menuItemRoute):.navbar__list-item--active>
$if menuItemModal
<div .modal.js-modal #modal-#{menuIdent} data-trigger=#{menuIdent} data-closeable data-dynamic>
<a .navbar__link-wrapper href=#{route} ##{menuIdent}>
<i .fas.fa-#{fromMaybe "none" menuItemIcon}>
<div .navbar__link-label>_{SomeMessage menuItemLabel}
^{navbarModal (menuItem, menuIdent)}
$else
^{navbarItem (menuItem, menuIdent)}
$of NavbarSecondary
<li .navbar__list-item :highlight (urlRoute menuItemRoute):.navbar__list-item--active>
$if menuItemModal
<div .modal.js-modal #modal-#{menuIdent} data-trigger=#{menuIdent} data-closeable data-dynamic>
<a .navbar__link-wrapper href=#{route} ##{menuIdent}>
<i .fas.fa-#{fromMaybe "none" menuItemIcon}>
<div .navbar__link-label>_{SomeMessage menuItemLabel}
^{navbarModal (menuItem, menuIdent)}
$else
^{navbarItem (menuItem, menuIdent)}
$of _

6
templates/widgets/rating/rating.hamlet
View File

@ -1,8 +1,10 @@
$# Display Rating, expects
$# sub :: Submission
$# submissionRatingDone :: Submission -> Bool
$# submissionRatingPoints :: Maybe points
$maybe points <- submissionRatingPoints
$maybe grading <- preview _grading sheetType
$if submissionRatingDone sub
$maybe (grading, points) <- mTuple (preview _grading sheetType) submissionRatingPoints
$case grading
$of Points{..}
_{MsgAchievedOf points maxPoints}

2
test.sh
View File

@ -1,3 +1,3 @@
#!/usr/bin/env bash
exec -- stack build --test --fast --flag uniworx:dev --flag uniworx:library-only ${@}
exec -- stack build --test --coverage --fast --flag uniworx:dev --flag uniworx:library-only ${@}

16
test/Database.hs
View File

@ -390,8 +390,8 @@ fillDb = do
insert_ $ CourseEdit jost now ffp
void . insert $ DegreeCourse ffp sdBsc sdInf
void . insert $ DegreeCourse ffp sdMst sdInf
void . insert $ Lecturer jost ffp
void . insert $ Lecturer gkleen ffp
void . insert $ Lecturer jost ffp CourseLecturer
void . insert $ Lecturer gkleen ffp CourseAssistant
adhoc <- insert $ Sheet ffp "AdHoc-Gruppen" Nothing NotGraded (Arbitrary 3) Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions False
insert_ $ SheetEdit gkleen now adhoc
feste <- insert $ Sheet ffp "Feste Gruppen" Nothing NotGraded RegisteredGroups Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions False
@ -421,7 +421,7 @@ fillDb = do
}
insert_ $ CourseEdit fhamann now eip
void . insert' $ DegreeCourse eip sdBsc sdInf
void . insert' $ Lecturer fhamann eip
void . insert' $ Lecturer fhamann eip CourseLecturer
-- interaction design
ixd <- insert' Course
{ courseName = "Interaction Design (User Experience Design I & II)"
@ -439,7 +439,7 @@ fillDb = do
}
insert_ $ CourseEdit fhamann now ixd
void . insert' $ DegreeCourse ixd sdBsc sdInf
void . insert' $ Lecturer fhamann ixd
void . insert' $ Lecturer fhamann ixd CourseAssistant
-- concept development
ux3 <- insert' Course
{ courseName = "Concept Development (User Experience Design III)"
@ -457,7 +457,7 @@ fillDb = do
}
insert_ $ CourseEdit fhamann now ux3
void . insert' $ DegreeCourse ux3 sdBsc sdInf
void . insert' $ Lecturer fhamann ux3
void . insert' $ Lecturer fhamann ux3 CourseAssistant
-- promo
pmo <- insert' Course
{ courseName = "Programmierung und Modellierung"
@ -475,7 +475,7 @@ fillDb = do
}
insert_ $ CourseEdit jost now pmo
void . insert $ DegreeCourse pmo sdBsc sdInf
void . insert $ Lecturer jost pmo
void . insert $ Lecturer jost pmo CourseAssistant
void . insertMany $ map (\(u,sf) -> CourseParticipant pmo u now sf)
[(fhamann , Nothing)
,(maxMuster , Just sfMMp)
@ -534,5 +534,5 @@ fillDb = do
insert_ $ CourseEdit gkleen now dbs
void . insert' $ DegreeCourse dbs sdBsc sdInf
void . insert' $ DegreeCourse dbs sdBsc sdMath
void . insert' $ Lecturer gkleen dbs
void . insert' $ Lecturer jost dbs
void . insert' $ Lecturer gkleen dbs CourseLecturer
void . insert' $ Lecturer jost dbs CourseAssistant

6
test/Model/TypesSpec.hs
View File

@ -140,6 +140,10 @@ instance Arbitrary AuthenticationMode where
shrink AuthLDAP = []
shrink (AuthPWHash _) = [AuthLDAP]
instance Arbitrary LecturerType where
arbitrary = genericArbitrary
shrink = genericShrink
spec :: Spec
@ -199,6 +203,8 @@ spec = do
[ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, finiteLaws, hashableLaws, jsonLaws, pathPieceLaws, jsonKeyLaws ]
lawsCheckHspec (Proxy @AuthTagActive)
[ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
lawsCheckHspec (Proxy @LecturerType)
[ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, finiteLaws, jsonLaws, pathPieceLaws, persistFieldLaws ]
describe "TermIdentifier" $ do
it "has compatible encoding/decoding to/from Text" . property $