diff --git a/.hlint.yaml b/.hlint.yaml index ecd17c599..6b2cec643 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -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 ++" } diff --git a/ChangeLog.md b/ChangeLog.md index c1ce2db41..f35e0e155 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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) diff --git a/FragenSJ.txt b/FragenSJ.txt deleted file mode 100644 index 6ddd8de2b..000000000 --- a/FragenSJ.txt +++ /dev/null @@ -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!!! diff --git a/PageActionPrime.txt b/PageActionPrime.txt new file mode 100644 index 000000000..39562d190 --- /dev/null +++ b/PageActionPrime.txt @@ -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 + diff --git a/build.sh b/build.sh index 13a8b2490..962ccc1ee 100755 --- a/build.sh +++ b/build.sh @@ -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. diff --git a/db.sh b/db.sh index 8861a2ac4..b05463c3a 100755 --- a/db.sh +++ b/db.sh @@ -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 -- $@ diff --git a/hlint.sh b/hlint.sh new file mode 100755 index 000000000..0dbb0fa1b --- /dev/null +++ b/hlint.sh @@ -0,0 +1,3 @@ +#!/usr/bin/env bash + +exec -- ./test.sh uniworx:test:hlint diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 2297642d8..a33c06e1c 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -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 \ No newline at end of file diff --git a/models/courses b/models/courses index fb9b06462..4fcf67d65 100644 --- a/models/courses +++ b/models/courses @@ -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 diff --git a/package.yaml b/package.yaml index 83b3b006e..c2a1ebf61 100644 --- a/package.yaml +++ b/package.yaml @@ -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: diff --git a/routes b/routes index 9b15ab3b9..d558de967 100644 --- a/routes +++ b/routes @@ -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 diff --git a/shell.nix b/shell.nix index e6178f7b0..f98506e41 100644 --- a/shell.nix +++ b/shell.nix @@ -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}" diff --git a/src/Application.hs b/src/Application.hs index 1dd037aba..20824d216 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -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 diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index 45ced319f..2131bf527 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -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 diff --git a/src/Data/List/NonEmpty/Instances.hs b/src/Data/List/NonEmpty/Instances.hs new file mode 100644 index 000000000..f151b6c18 --- /dev/null +++ b/src/Data/List/NonEmpty/Instances.hs @@ -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|] diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 2dab7cf8d..6c89e6c96 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -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 \ No newline at end of file + 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 \ No newline at end of file diff --git a/src/Database/Esqueleto/Utils/TH.hs b/src/Database/Esqueleto/Utils/TH.hs index 5596f31ee..218c96d70 100644 --- a/src/Database/Esqueleto/Utils/TH.hs +++ b/src/Database/Esqueleto/Utils/TH.hs @@ -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) diff --git a/src/Foundation.hs b/src/Foundation.hs index 000f3f153..e689643da 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -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 diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index d7cd7071f..4d53f5eed 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -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 = diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 9381e0829..42c21d62a 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -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 diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index bee19eaba..98016ca8e 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -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|
@@ -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| -

^{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 +
+ _{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" diff --git a/src/Handler/Help.hs b/src/Handler/Help.hs new file mode 100644 index 000000000..d29b7f214 --- /dev/null +++ b/src/Handler/Help.hs @@ -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 ] + } diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 7b60a6da3..dba365b9c 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -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 UniWorX|] - 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 - - ^{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") diff --git a/src/Handler/Info.hs b/src/Handler/Info.hs new file mode 100644 index 000000000..9790ed143 --- /dev/null +++ b/src/Handler/Info.hs @@ -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 UniWorX|] + 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") + diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index ea492e87b..5de418a34 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -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 + + ^{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") diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index e378a74d5..cc5bc7718 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -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 diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs index de4f2a193..c80ab32c0 100644 --- a/src/Handler/SystemMessage.hs +++ b/src/Handler/SystemMessage.hs @@ -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 diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index 31ab90653..98085d947 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -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 diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 5bd4c7ed6..a9ddbcb7f 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -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 + diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 5e0a8418c..46abeddd5 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -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|^{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") \ No newline at end of file +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)|] diff --git a/src/Handler/Utils/Delete.hs b/src/Handler/Utils/Delete.hs index 3f4937fb7..c6de2dec9 100644 --- a/src/Handler/Utils/Delete.hs +++ b/src/Handler/Utils/Delete.hs @@ -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 diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 4be31478d..932044f62 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -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 diff --git a/src/Handler/Utils/Form/MassInput.hs b/src/Handler/Utils/Form/MassInput.hs index 7bca43b7f..690d10506 100644 --- a/src/Handler/Utils/Form/MassInput.hs +++ b/src/Handler/Utils/Form/MassInput.hs @@ -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) diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 124da1b83..67c8fab75 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -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 () diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 7abd6b4d7..28b3df6b2 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -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 diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index 52e8b5dfe..25279fb96 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -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) diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 3fa9e880c..81ca65bd4 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -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") diff --git a/src/Handler/Utils/Templates.hs b/src/Handler/Utils/Templates.hs deleted file mode 100644 index f29d79fba..000000000 --- a/src/Handler/Utils/Templates.hs +++ /dev/null @@ -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 - - ^{modalTrigger} - |] - Right _ -> - [whamlet| - $newline never -

- ^{modalTrigger} - |] diff --git a/src/Handler/Utils/TermCandidates.hs b/src/Handler/Utils/TermCandidates.hs index 5eeba9a56..c986ed61b 100644 --- a/src/Handler/Utils/TermCandidates.hs +++ b/src/Handler/Utils/TermCandidates.hs @@ -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 diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 39de96dd7..457682087 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -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 () diff --git a/src/Jobs/Handler/HelpRequest.hs b/src/Jobs/Handler/HelpRequest.hs index 1ec904e2b..2b92c0e2b 100644 --- a/src/Jobs/Handler/HelpRequest.hs +++ b/src/Jobs/Handler/HelpRequest.hs @@ -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)) diff --git a/src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs b/src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs index 51ec02f77..6a9e6ace9 100644 --- a/src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs +++ b/src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs @@ -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 diff --git a/src/Jobs/Handler/SendNotification/CorrectionsNotDistributed.hs b/src/Jobs/Handler/SendNotification/CorrectionsNotDistributed.hs index cb24f7e04..959cedad0 100644 --- a/src/Jobs/Handler/SendNotification/CorrectionsNotDistributed.hs +++ b/src/Jobs/Handler/SendNotification/CorrectionsNotDistributed.hs @@ -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 diff --git a/src/Jobs/Handler/SendNotification/SheetActive.hs b/src/Jobs/Handler/SendNotification/SheetActive.hs index 91a8fc716..fc2c5a185 100644 --- a/src/Jobs/Handler/SendNotification/SheetActive.hs +++ b/src/Jobs/Handler/SendNotification/SheetActive.hs @@ -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 diff --git a/src/Jobs/Handler/SendNotification/SheetInactive.hs b/src/Jobs/Handler/SendNotification/SheetInactive.hs index 7112e5c39..ed76be1b3 100644 --- a/src/Jobs/Handler/SendNotification/SheetInactive.hs +++ b/src/Jobs/Handler/SendNotification/SheetInactive.hs @@ -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 diff --git a/src/Jobs/Handler/SendNotification/SubmissionRated.hs b/src/Jobs/Handler/SendNotification/SubmissionRated.hs index 78083d83f..1cb3e1d50 100644 --- a/src/Jobs/Handler/SendNotification/SubmissionRated.hs +++ b/src/Jobs/Handler/SendNotification/SubmissionRated.hs @@ -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 diff --git a/src/Jobs/Handler/SendNotification/UserRightsUpdate.hs b/src/Jobs/Handler/SendNotification/UserRightsUpdate.hs index aaf50ac72..3e9d2c4a8 100644 --- a/src/Jobs/Handler/SendNotification/UserRightsUpdate.hs +++ b/src/Jobs/Handler/SendNotification/UserRightsUpdate.hs @@ -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 diff --git a/src/Jobs/Handler/SendTestEmail.hs b/src/Jobs/Handler/SendTestEmail.hs index 5c5cd0900..979ec218d 100644 --- a/src/Jobs/Handler/SendTestEmail.hs +++ b/src/Jobs/Handler/SendTestEmail.hs @@ -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 diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 151d0e404..dc29a9e7a 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -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) diff --git a/src/Mail.hs b/src/Mail.hs index c125bf88d..008af9987 100644 --- a/src/Mail.hs +++ b/src/Mail.hs @@ -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 } diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 52fd5ed32..775900850 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -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 diff --git a/src/Utils.hs b/src/Utils.hs index 3e38f9dd9..961aa288e 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -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||] hasTickmark False = mempty +isBad :: Bool -> Markup +-- ^ Display an icon that denotes that something™ is bad +isBad True = [shamlet||] -- or times?! +isBad False = mempty + isNew :: Bool -> Markup -isNew True = [shamlet||] +isNew True = [shamlet||] -- 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 -- diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 2dfe53cd3..96dec5423 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -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 ). 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 -- ------------------- diff --git a/src/Utils/Modal.hs b/src/Utils/Modal.hs new file mode 100644 index 000000000..5dd4ccd3e --- /dev/null +++ b/src/Utils/Modal.hs @@ -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") diff --git a/src/Utils/TH.hs b/src/Utils/TH.hs index b12d90359..5e7b1f36d 100644 --- a/src/Utils/TH.hs +++ b/src/Utils/TH.hs @@ -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 diff --git a/src/Yesod/Core/Instances.hs b/src/Yesod/Core/Instances.hs index 0b0f139c4..6512c936a 100644 --- a/src/Yesod/Core/Instances.hs +++ b/src/Yesod/Core/Instances.hs @@ -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 diff --git a/src/index.md b/src/index.md index 17798d0df..d90c78eb2 100644 --- a/src/index.md +++ b/src/index.md @@ -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 diff --git a/static/css/utils/inputs.scss b/static/css/utils/inputs.scss index 6bf5286e3..15b8bb47e 100644 --- a/static/css/utils/inputs.scss +++ b/static/css/utils/inputs.scss @@ -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) { diff --git a/static/js/utils/form.js b/static/js/utils/form.js index e45fd56c0..77437a3e1 100644 --- a/static/js/utils/form.js +++ b/static/js/utils/form.js @@ -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); + }, + }; + }; })(); diff --git a/static/js/utils/inputs.js b/static/js/utils/inputs.js index fd4ad906e..3a9f7ebc4 100644 --- a/static/js/utils/inputs.js +++ b/static/js/utils/inputs.js @@ -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() { diff --git a/static/js/utils/modal.js b/static/js/utils/modal.js index 5c6c1ec43..a5971edf7 100644 --- a/static/js/utils/modal.js +++ b/static/js/utils/modal.js @@ -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 })); } } diff --git a/static/js/utils/setup.js b/static/js/utils/setup.js index e9afb216b..bb3bb0e3d 100644 --- a/static/js/utils/setup.js +++ b/static/js/utils/setup.js @@ -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; + } } } diff --git a/templates/adminTest.hamlet b/templates/adminTest.hamlet index 75622355e..7e59d9599 100644 --- a/templates/adminTest.hamlet +++ b/templates/adminTest.hamlet @@ -1,17 +1,14 @@ -
-

Uni2work - Admin Demopage - +

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

+

Teilweise funktionierende Abschnitte -