diff --git a/ChangeLog.md b/ChangeLog.md index 3e3d9dfe8..59d7755a2 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,5 @@ * Version 30.01.2019 - + Designänderungen * Version 16.01.2019 @@ -7,7 +7,7 @@ Links für Bequemlichkeiten hinzugefügt (z.B. aktuelles Übungsblatt) Liste zugewiesener Abgaben lassen sich nun filtern - + Bugfix: Wenn zwischen Anzeige und Empfang eines Tabellen-Formulars Zeilen verschwinden wird nun eine sinnvolle Fehlermeldung angezeigt * Version 30.11.2018 @@ -65,11 +65,6 @@ Bugfixes, wählbares Format für Datum - * Version 04.07.2018 - - Hinweis eingefügt, dass alle Daten des Systems spätestens im Dezember 2018 - gelöscht werden. - * Version 03.07.2018 Willkommen bei Uni2work aka "You-need-to-work!" diff --git a/assets/favicon-0.png b/assets/favicon-0.png new file mode 100644 index 000000000..68830769b Binary files /dev/null and b/assets/favicon-0.png differ diff --git a/assets/favicon-5.png b/assets/favicon-5.png new file mode 100644 index 000000000..5fb1fc327 Binary files /dev/null and b/assets/favicon-5.png differ diff --git a/assets/logo-o2.svg b/assets/logo-o2.svg new file mode 100644 index 000000000..80620673b --- /dev/null +++ b/assets/logo-o2.svg @@ -0,0 +1,4 @@ + + + + diff --git a/assets/logo.png b/assets/logo.png new file mode 100644 index 000000000..4ef03212e Binary files /dev/null and b/assets/logo.png differ diff --git a/config/settings.yml b/config/settings.yml index 7c561ddfb..3211d42db 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -27,6 +27,7 @@ notification-rate-limit: 3600 notification-collate-delay: 300 notification-expiration: 259201 session-timeout: 7200 +maximum-content-length: 52428800 log-settings: detailed: "_env:DETAILED_LOGGING:false" diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index e6e4663c5..b7ceb8948 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -7,6 +7,7 @@ BtnHijack: Sitzung übernehmen Aborted: Abgebrochen Registered: Angemeldet +RegisteredHeader: Anmeldung RegisteredSince date@Text: Angemeldet seit #{date} RegisterFrom: Anmeldungen von RegisterTo: Anmeldungen bis @@ -29,6 +30,16 @@ InvalidInput: Eingaben bitte korrigieren. Term: Semester TermPlaceholder: W/S + vierstellige Jahreszahl +TermStartDay: Erster Tag +TermStartDayTooltip: Üblicherweise immer 1.April oder 1.Oktober +TermEndDay: Letzter Tag +TermEndDayTooltip: Üblicherweise immer 30.September oder 31.März +TermLectureStart: Beginn Vorlesungen +TermLectureEnd: Ende Vorlesungen +TermLectureEndTooltip: Meistens dauer das Sommersemester 14 Wochen und das Wintersemester 15 Wochen. +TermActive: Aktiv + + SchoolListHeading: Übersicht über verwaltete Institute SchoolHeading school@SchoolName: Übersicht #{display school} @@ -37,7 +48,7 @@ LectureStart: Beginn Vorlesungen Course: Kurs CourseShort: Kürzel CourseCapacity: Kapazität -CourseCapacityTip: Falls angegeben wird die Anzahl an Kursanmeldungen, die zugelassen werden, beschränkt +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 @@ -63,20 +74,23 @@ CourseMembersCountLimited num@Int64 max@Int64: #{display num}/#{display max} CourseName: Name CourseDescription: Beschreibung CourseDescriptionTip: Beliebiges HTML-Markup ist gestattet -CourseHomepage: Homepage +CourseHomepageExternal: Externe Homepage CourseShorthand: Kürzel -CourseShorthandUnique: Muss innerhalb des Semesters eindeutig sein +CourseShorthandUnique: Muss innerhalb Institut und Semester eindeutig sein CourseSemester: Semester CourseSchool: Institut CourseSchoolShort: Fach CourseSecretTip: Anmeldung zum Kurs erfordert Eingabe des Passworts, sofern gesetzt -CourseRegisterFromTip: Ohne Datum ist keine eigenständige Anmeldung von Studierenden möglich -CourseRegisterToTip: Anmeldung darf auch ohne Begrenzung möglich sein -CourseDeregisterUntilTip: Abmeldung darf auch ohne Begrenzung möglich sein +CourseSecretFormat: beliebige Zeichenkette +CourseRegisterFromTip: Ohne Datum ist KEINE eigenständige Anmeldung von Studierenden möglich +CourseRegisterToTip: Anmeldung darf auch unbegrenzt offen bleiben +CourseDeregisterUntilTip: Abmeldung darf auch unbegrenzt erlaubt bleiben CourseFilterSearch: Volltext-Suche CourseFilterRegistered: Registriert +CourseFilterNone: Egal CourseDeleteQuestion: Wollen Sie den unten aufgeführten Kurs wirklich löschen? CourseDeleted: Kurs gelöscht +CourseUserNote: Notiz NoSuchTerm tid@TermId: Semester #{display tid} gibt es nicht. NoSuchSchool ssh@SchoolId: Institut #{display ssh} gibt es nicht. @@ -208,6 +222,7 @@ CorByProportionOnly proportion@Rational: #{display proportion} Anteile CorByProportionIncludingTutorial proportion@Rational: #{display proportion} Anteile - Tutorium CorByProportionExcludingTutorial proportion@Rational: #{display proportion} Anteile + Tutorium +RowCount count@Int64: #{display count} #{pluralDE count "Eintrag" "Einträge"} insgesamt DeleteRow: Zeile entfernen ProportionNegative: Anteile dürfen nicht negativ sein CorrectorUpdated: Korrektor erfolgreich aktualisiert @@ -220,8 +235,12 @@ HomeHeading: Aktuelle Termine LoginHeading: Authentifizierung LoginTitle: Authentifizierung ProfileHeading: Benutzereinstellungen +ProfileFor: Benutzereinstellungen für ProfileDataHeading: Gespeicherte Benutzerdaten +InfoHeading: Informationen +VersionHeading: Versionsgeschichte ImpressumHeading: Impressum +DataProtHeading: Datenschutzerklärung SystemMessageHeading: Uni2work Statusmeldung SystemMessageListHeading: Uni2work Statusmeldungen @@ -241,7 +260,7 @@ MultiFileUploadInfo: (Mehrere Dateien mit Shift oder Strg auswählen) NrColumn: Nr SelectColumn: Auswahl -DBTablePagesize: Einträge +DBTablePagesize: Einträge pro Seite DBTablePagesizeAll: Alle CorrDownload: Herunterladen @@ -322,17 +341,25 @@ MultiSinkException name@Text error@Text: In Abgabe #{name} ist ein Fehler aufget NoTableContent: Kein Tabelleninhalt NoUpcomingSheetDeadlines: Keine anstehenden Übungsblätter +AdminUserHeading: Benutzeradministration +AccessRightsFor: Berechtigungen für AdminFor: Administrator LecturerFor: Dozent LecturersFor: Dozenten +ForSchools n@Int: für #{pluralDE n "Institut" "Institute"} UserListTitle: Komprehensive Benutzerliste +AccessRightsSaved: Berechtigungsänderungen wurden gespeichert. +Date: Datum DateTimeFormat: Datums- und Uhrzeitformat DateFormat: Datumsformat TimeFormat: Uhrzeitformat DownloadFiles: Dateien automatisch herunterladen DownloadFilesTip: Wenn gesetzt werden Dateien von Abgaben und Übungsblättern automatisch als Download behandelt, ansonsten ist das Verhalten browserabhängig (es können z.B. PDFs im Browser geöffnet werden). NotificationSettings: Erwünschte Benachrichtigungen +FormNotifications: Benachrichtigungen +FormBehaviour: Verhalten +FormCosmetics: Oberfläche ActiveAuthTags: Aktivierte Authorisierungsprädikate @@ -400,11 +427,17 @@ 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 -MailSheetInactiveIntro courseName@Text termDesc@Text sheetName@SheetName: Die Abgabefirst für #{sheetName} im Kurs #{courseName} (#{termDesc}) beendet. +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 MailCorrectionsAssignedIntro courseName@Text termDesc@Text sheetName@SheetName n@Int: #{display n} #{pluralDE n "Abgabe wurde" "Abgaben wurden"} Ihnen zur Korrektur für #{sheetName} im Kurs #{courseName} (#{termDesc}) zugeteilt. +MailSubjectUserRightsUpdate name@Text: Berechtigungen für #{name} aktualisiert +MailUserRightsIntro name@Text email@UserEmail: #{name} <#{email}> hat folgende Uni2work Berechtigungen: +MailNoLecturerRights: Sie haben derzeit keine Dozenten-Rechte. +MailLecturerRights n@Int: Als Dozent dürfen Sie Veranstaltungen innerhalb #{pluralDE n "Ihres Instituts" "Ihrer Institute"} anlegen. + + MailEditNotifications: Benachrichtigungen ein-/ausschalten MailSubjectSupport: Supportanfrage @@ -453,6 +486,7 @@ NotificationTriggerSheetSoonInactive: Ich kann ein Übungsblatt bald nicht mehr NotificationTriggerSheetInactive: Abgabefrist 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 CorrCreate: Abgaben erstellen UnknownPseudonymWord pseudonymWord@Text: Unbekanntes Pseudonym-Wort "#{pseudonymWord}" @@ -475,6 +509,7 @@ CorrGrade: Korrekturen eintragen UserAccountDeleted name@Text: Konto für #{name} wurde gelöscht! +HelpTitle : Hilfe HelpAnswer: Antworten an HelpUser: Meinen Benutzeraccount HelpAnonymous: Keine Antwort (Anonym) @@ -484,6 +519,9 @@ 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. HelpSent: Ihre Supportanfrage wurde weitergeleitet. +InfoLecturerTitle: Hinweise für Veranstalter + + SystemMessageFrom: Sichtbar ab SystemMessageTo: Sichtbar bis SystemMessageAuthenticatedOnly: Nur angemeldet @@ -546,12 +584,16 @@ ErrorCryptoIdMismatch: Verschlüsselte Id der Abgabe passte nicht zu anderen Dat InvalidRoute: Konnte URL nicht interpretieren MenuHome: Aktuell -MenuVersion: Impressum +MenuInformation: Informationen +MenuImpressum: Impressum +MenuDataProt: Datenschutz +MenuVersion: Versionsgeschichte MenuHelp: Hilfe MenuProfile: Anpassen MenuLogin: Login MenuLogout: Logout MenuCourseList: Kurse +MenuCourseMembers: Kursteilnehmer MenuTermShow: Semester MenuSubmissionDelete: Abgabe löschen MenuUsers: Benutzer @@ -582,12 +624,14 @@ MenuSheetClone: Als neues Übungsblatt klonen MenuCorrectionsUpload: Korrekturen hochladen MenuCorrectionsCreate: Abgaben registrieren MenuCorrectionsGrade: Abgaben bewerten +MenuAuthPreds: Authorisierungseinstellungen +AuthPredsInfo: Um eigene Veranstaltungen aus Sicht der Teilnehmer anzusehen, können Veranstalter und Korrektoren hier die Prüfung ihrer erweiterten Berechtigungen temporär deaktivieren. Abgewählte Prädikate schlagen immer fehl. Abgewählte Prädikate werden also nicht geprüft um Zugriffe zu gewähren, welche andernfalls nicht erlaubt wären. Diese Einstellungen gelten nur temporär bis Ihre Sitzung abgelaufen ist, d.h. bis ihr Browser-Cookie abgelaufen ist. Durch Abwahl von Prädikaten kann man sich höchstens temporär aussperren. AuthPredsActive: Aktive Authorisierungsprädikate AuthPredsActiveChanged: Authorisierungseinstellungen für aktuelle Sitzung gespeichert AuthTagFree: Seite ist universell zugänglich AuthTagAdmin: Nutzer ist Administrator -AuthTagNoEscalation: Nutzer-Rechte werden nicht erweitert +AuthTagNoEscalation: Nutzer-Rechte werden nicht auf fremde Institute ausgeweitet AuthTagDeprecated: Seite ist nicht überholt AuthTagDevelopment: Seite ist nicht in Entwicklung AuthTagLecturer: Nutzer ist Dozent @@ -602,7 +646,7 @@ AuthTagOwner: Nutzer ist Besitzer AuthTagRated: Korrektur ist bewertet AuthTagUserSubmissions: Abgaben erfolgen durch Kursteilnehmer AuthTagCorrectorSubmissions: Abgaben erfolgen durch Korrektoren -AuthTagAuthentication: Authentifizierung erfüllt Anforderungen +AuthTagAuthentication: Nutzer ist angemeldet, falls erforderlich AuthTagRead: Zugriff ist nur lesend AuthTagWrite: Zugriff ist i.A. schreibend diff --git a/models/schools b/models/schools index 625235f2f..6b73e1c27 100644 --- a/models/schools +++ b/models/schools @@ -1,7 +1,7 @@ School json name (CI Text) - shorthand (CI Text) + shorthand (CI Text) -- SchoolKey :: SchoolShorthand -> SchoolId UniqueSchool name UniqueSchoolShorthand shorthand -- required for Normalisation of CI Text - Primary shorthand -- newtype Key School = SchoolKey { unSchoolKey :: SchoolShorthand } + Primary shorthand -- newtype Key School = SchoolKey { unSchoolKey :: SchoolShorthand } deriving Eq Show Generic diff --git a/models/users b/models/users index 5ac4a6a3c..f93b954d4 100644 --- a/models/users +++ b/models/users @@ -1,3 +1,4 @@ +-- Some comments needes User json ident (CI Text) authentication AuthenticationMode @@ -24,19 +25,19 @@ UserLecturer user UserId school SchoolId UniqueSchoolLecturer user school -StudyFeatures +StudyFeatures -- Abschluss, Studiengang, Haupt/Nebenfachh und Fachsemester user UserId degree StudyDegreeId field StudyTermsId type StudyFieldType semester Int -- UniqueUserSubject user degree field -- There exists a counterexample -StudyDegree +StudyDegree -- Studienabschluss key Int shorthand Text Maybe name Text Maybe Primary key -StudyTerms +StudyTerms -- Studiengang key Int shorthand Text Maybe name Text Maybe diff --git a/package.yaml b/package.yaml index 57b4b508d..138efc9ac 100644 --- a/package.yaml +++ b/package.yaml @@ -115,6 +115,7 @@ dependencies: - directory-tree - lifted-base - lattices + - hsass other-extensions: - GeneralizedNewtypeDeriving diff --git a/routes b/routes index 1c1535769..1a9f35659 100644 --- a/routes +++ b/routes @@ -10,22 +10,23 @@ -- Admins always have access to entities within their assigned schools. -- -- Access Tags: --- !free -- free for all --- !lecturer -- lecturer for this course (or the school, if route is not connected to a course) --- !corrector -- corrector for this sheet (or the submission, if route is connected to a submission, or the course, if route is not connected to a sheet, or any course, if route is not connected to a course) --- !registered -- participant for this course (no effect outside of courses) --- !participant -- connected with a given course (not necessarily registered), i.e. has a submission, is a corrector, etc. (no effect outside of courses) --- !owner -- part of the group of owners of this submission --- !capacity -- course this route is associated with has at least one unit of participant capacity --- !empty -- course this route is associated with has no participants whatsoever +-- !free -- free for all +-- !lecturer -- lecturer for this course (or for any school, if route is not connected to a course) +-- !corrector -- corrector for this sheet (or the submission, if route is connected to a submission, or the course, if route is not connected to a sheet, or any course, if route is not connected to a course) +-- !registered -- participant for this course (no effect outside of courses) +-- !participant -- connected with a given course (not necessarily registered), i.e. has a submission, is a corrector, etc. (no effect outside of courses) +-- !owner -- part of the group of owners of this submission +-- !capacity -- course this route is associated with has at least one unit of participant capacity +-- !empty -- course this route is associated with has no participants whatsoever -- --- !materials -- only if course allows all materials to be free (no meaning outside of courses) --- !time -- access depends on time somehow --- !read -- only if it is read-only access (i.e. GET but not POST) --- !write -- only if it is write access (i.e. POST only, included for completeness) +-- !materials -- only if course allows all materials to be free (no meaning outside of courses) +-- !time -- access depends on time somehow +-- !read -- only if it is read-only access (i.e. GET but not POST) +-- !write -- only if it is write access (i.e. POST only, included for completeness) -- --- !deprecated -- like free, but logs and gives a warning; entirely disabled in production --- !development -- like free, but only for development builds +-- !no-escalation -- +-- !deprecated -- like free, but logs and gives a warning; entirely disabled in production +-- !development -- like free, but only for development builds /static StaticR EmbeddedStatic appStatic !free /auth AuthR Auth getAuth !free @@ -35,24 +36,29 @@ / HomeR GET !free /users UsersR GET -- no tags, i.e. admins only -/users/#CryptoUUIDUser AdminUserR GET !development +/users/#CryptoUUIDUser AdminUserR GET POST !development /users/#CryptoUUIDUser/hijack AdminHijackUserR POST !adminANDno-escalation /admin/test AdminTestR GET POST /admin/errMsg AdminErrMsgR GET POST -/info VersionR GET !free + +/info InfoR GET !free +/info/lecturer InfoLecturerR GET !lecturer +/info/data DataProtR GET !free +/impressum ImpressumR GET !free +/version VersionR GET !free + /help HelpR GET POST !free -/profile ProfileR GET POST !free -/profile/data ProfileDataR GET POST !free - -/authpreds AuthPredsR GET POST !free +/user ProfileR GET POST !free +/user/profile ProfileDataR GET POST !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 TermCourseListR GET !free -!/term/#TermId/#SchoolId TermSchoolCourseListR GET !free +!/term/#TermId/#SchoolId TermSchoolCourseListR GET !free /school SchoolListR GET !development /school/#SchoolId SchoolShowR GET !development diff --git a/shell.nix b/shell.nix index 931e7ade0..e6178f7b0 100644 --- a/shell.nix +++ b/shell.nix @@ -1,11 +1,8 @@ -{ nixpkgs ? import {}, compiler ? null }: +{ nixpkgs ? import , compiler ? null }: let - inherit (nixpkgs) pkgs; - - haskellPackages = if isNull compiler - then pkgs.haskellPackages - else pkgs.haskell.packages."${compiler}"; + inherit (nixpkgs {}) pkgs; + haskellPackages = if isNull compiler then pkgs.haskellPackages else pkgs.haskell.packages."${compiler}"; drv = haskellPackages.callPackage ./uniworx.nix {}; @@ -26,21 +23,29 @@ let shellHook = '' export PROMPT_INFO="${oldAttrs.name}" - pgDir=$(mktemp -d) - pgSockDir=$(mktemp -d) - pgLogFile=$(mktemp) - initdb --no-locale -D ''${pgDir} - pg_ctl start -D ''${pgDir} -l ''${pgLogFile} -w -o "-k ''${pgSockDir} -c listen_addresses=''' -c hba_file='${postgresHba}' -c unix_socket_permissions=0700" - export PGHOST=''${pgSockDir} PGLOG=''${pgLogFile} - psql -f ${postgresSchema} postgres - printf "Postgres logfile is %s\nPostgres socket directory is %s\n" ''${pgLogFile} ''${pgSockDir} + if [[ -z "$PGHOST" ]]; then + set -xe - cleanup() { - pg_ctl stop -D ''${pgDir} - rm -rvf ''${pgDir} ''${pgSockDir} ''${pgLogFile} - } + pgDir=$(mktemp -d) + pgSockDir=$(mktemp -d) + pgLogFile=$(mktemp) + initdb --no-locale -D ''${pgDir} + pg_ctl start -D ''${pgDir} -l ''${pgLogFile} -w -o "-k ''${pgSockDir} -c listen_addresses=''' -c hba_file='${postgresHba}' -c unix_socket_permissions=0700" + export PGHOST=''${pgSockDir} PGLOG=''${pgLogFile} + psql -f ${postgresSchema} postgres + printf "Postgres logfile is %s\nPostgres socket directory is %s\n" ''${pgLogFile} ''${pgSockDir} - trap cleanup EXIT + cleanup() { + set +e -x + pg_ctl stop -D ''${pgDir} + rm -rvf ''${pgDir} ''${pgSockDir} ''${pgLogFile} + set +x + } + + trap cleanup EXIT + + set +xe + fi ${oldAttrs.shellHook} ''; diff --git a/src/Auth/Dummy.hs b/src/Auth/Dummy.hs index e7033f3d8..cdb8db1e8 100644 --- a/src/Auth/Dummy.hs +++ b/src/Auth/Dummy.hs @@ -7,7 +7,7 @@ import Import.NoFoundation import Database.Persist.Sql (SqlBackendCanRead) import Utils.Form - + import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI @@ -54,4 +54,4 @@ dummyLogin = AuthPlugin{..} apDispatch _ _ = notFound apLogin toMaster = do (login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard dummyForm - $(widgetFile "widgets/dummy-login-form") + $(widgetFile "widgets/dummy-login-form/dummy-login-form") diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index cd2a9a037..861c03620 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -36,7 +36,7 @@ data CampusMessage = MsgCampusIdentNote | MsgCampusSubmit | MsgCampusInvalidCredentials deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) - + findUser :: LdapConf -> Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry] findUser LdapConf{..} ldap campusIdent = Ldap.search ldap ldapBase userSearchSettings userFilter @@ -48,7 +48,7 @@ findUser LdapConf{..} ldap campusIdent = Ldap.search ldap ldapBase userSearchSet , Ldap.time ldapSearchTimeout , Ldap.derefAliases Ldap.DerefAlways ] - + userPrincipalName :: Ldap.Attr userPrincipalName = Ldap.Attr "userPrincipalName" @@ -105,7 +105,7 @@ campusLogin conf@LdapConf{..} pool = AuthPlugin{..} apDispatch _ _ = notFound apLogin toMaster = do (login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard campusForm - $(widgetFile "widgets/campus-login-form") + $(widgetFile "widgets/campus-login/campus-login-form") data CampusUserException = CampusUserLdapError LdapPoolError | CampusUserHostNotResolved String diff --git a/src/Auth/PWHash.hs b/src/Auth/PWHash.hs index 68df34703..74c4e67a3 100644 --- a/src/Auth/PWHash.hs +++ b/src/Auth/PWHash.hs @@ -35,7 +35,7 @@ hashForm = HashLogin <*> areq passwordField (fslpI MsgPWHashPassword "Passwort") Nothing <* submitButton - + hashLogin :: ( YesodAuth site , YesodPersist site , SqlBackendCanRead (YesodPersistBackend site) @@ -90,5 +90,5 @@ hashLogin pwHashAlgo = AuthPlugin{..} apDispatch _ _ = notFound apLogin toMaster = do (login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard hashForm - $(widgetFile "widgets/hash-login-form") + $(widgetFile "widgets/hash-login-form/hash-login-form") diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs new file mode 100644 index 000000000..41464cc00 --- /dev/null +++ b/src/Database/Esqueleto/Utils.hs @@ -0,0 +1,45 @@ +module Database.Esqueleto.Utils where + +import ClassyPrelude.Yesod hiding (isInfixOf, (||.)) +import Data.Foldable as F +import Database.Esqueleto as E + + +-- +-- Description : Convenience for using @Esqueleto@, +-- intended to be imported qualified +-- just like Esqueleto + + +-- ezero = E.val (0 :: Int64) + +-- | Often needed with this concrete type +true :: E.SqlExpr (E.Value Bool) +true = E.val True + +-- | Often needed with this concrete type +false :: E.SqlExpr (E.Value Bool) +false = E.val False + +-- | Check if the first string is contained in the text derived from the second argument +isInfixOf :: (E.Esqueleto query expr backend, E.SqlString s2) => + Text -> expr (E.Value s2) -> expr (E.Value Bool) +isInfixOf needle strExpr = E.castString strExpr `E.ilike` (E.%) E.++. E.val needle E.++. (E.%) + +hasInfix :: (E.Esqueleto query expr backend, E.SqlString s2) => + expr (E.Value s2) -> Text -> expr (E.Value Bool) +hasInfix = flip isInfixOf + +-- | Given a test and a set of values, check whether anyone succeeds the test +-- WARNING: SQL leaves it explicitely unspecified whether || is short curcuited (i.e. lazily evaluated) +any :: Foldable f => + (a -> SqlExpr (E.Value Bool)) -> f a -> SqlExpr (E.Value Bool) +any test = F.foldr (\needle acc -> acc ||. test needle) false + +-- | Given a test and a set of values, check whether all succeeds the test +-- WARNING: SQL leaves it explicitely unspecified whether && is short curcuited (i.e. lazily evaluated) +all :: Foldable f => + (a -> SqlExpr (E.Value Bool)) -> f a -> SqlExpr (E.Value Bool) +all test = F.foldr (\needle acc -> acc &&. test needle) true + + diff --git a/src/Foundation.hs b/src/Foundation.hs index 6f69c53b6..047e3f670 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -78,6 +78,8 @@ import qualified Crypto.Saltine.Core.SecretBox as SecretBox import qualified Database.Memcached.Binary.IO as Memcached import Data.Bits (Bits(zeroBits)) +import Network.Wai.Parse (lbsBackEnd) + instance DisplayAble b => DisplayAble (E.CryptoID a b) where display = display . ciphertext @@ -157,6 +159,19 @@ pluralDE num singularForm pluralForm | num == 1 = singularForm | otherwise = pluralForm +noneOneMoreDE :: (Eq a, Num a) + => a -- ^ Count + -> Text -- ^ None + -> Text -- ^ Singular + -> Text -- ^ Plural + -> Text +noneOneMoreDE num noneText singularForm pluralForm + | num == 0 = noneText + | num == 1 = singularForm + | otherwise = pluralForm + + + -- Messages creates type UniWorXMessage and RenderMessage UniWorX instance mkMessage "UniWorX" "messages/uniworx" "de" mkMessageVariant "UniWorX" "Campus" "messages/campus" "de" @@ -254,6 +269,11 @@ uniworxMessages = UniWorXMessages . map SomeMessage data MenuType = NavbarAside | NavbarRight | NavbarSecondary | PageActionPrime | PageActionSecondary | Footer deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) +instance Universe MenuType +instance Finite MenuType + +makePrisms ''MenuType + data MenuItem = MenuItem { menuItemLabel :: UniWorXMessage , menuItemIcon :: Maybe Text -- currently from: https://fontawesome.com/icons?d=gallery @@ -263,6 +283,8 @@ data MenuItem = MenuItem , menuItemType :: MenuType } +makeLenses_ ''MenuItem + instance RedirectUrl UniWorX MenuItem where toTextUrl MenuItem{..} = toTextUrl menuItemRoute instance HasRoute UniWorX MenuItem where @@ -423,6 +445,7 @@ tagAccessPredicate AuthLecturer = APDB $ \route _ -> case route of return (E.countRows :: E.SqlExpr (E.Value Int64)) guardMExceptT (c>0) (unauthorizedI MsgUnauthorizedLecturer) return Authorized + -- lecturer for any school will do _ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserLecturerUser ==. authId] [] @@ -479,20 +502,20 @@ tagAccessPredicate AuthTime = APDB $ \route _ -> case route of return Authorized CourseR tid ssh csh CRegisterR -> do + now <- liftIO getCurrentTime mbc <- getBy $ TermSchoolCourseShort tid ssh csh mAid <- lift maybeAuthId registered <- case (mbc,mAid) of (Just (Entity cid _), Just uid) -> isJust <$> (getBy $ UniqueParticipant uid cid) _ -> return False - cTime <- (NTop . Just) <$> liftIO getCurrentTime case mbc of (Just (Entity _ Course{courseRegisterFrom, courseRegisterTo})) | not registered - , courseRegisterFrom <= nBot cTime - , NTop courseRegisterTo >= cTime -> return Authorized + , maybe False (now >=) courseRegisterFrom -- Nothing => no registration allowed + , maybe True (now <=) courseRegisterTo -> return Authorized (Just (Entity _ Course{courseDeregisterUntil})) | registered - , NTop courseDeregisterUntil >= cTime -> return Authorized + , maybe True (now <=) courseDeregisterUntil -> return Authorized _other -> unauthorizedI MsgUnauthorizedCourseTime MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do @@ -745,7 +768,7 @@ instance Yesod UniWorX where (getCachedDate, _) <- clientSessionDateCacher appSessionTimeout return . Just $ clientSessionBackend appSessionKey getCachedDate - maximumContentLength _ _ = Just $ 50 * 2^20 + maximumContentLength UniWorX{appSettings=AppSettings{appMaximumContentLength}} _ = appMaximumContentLength -- Yesod Middleware allows you to run code before and after each handler function. -- The defaultYesodMiddleware adds the response header "Vary: Accept, Accept-Language" and performs authorization checks. @@ -828,7 +851,7 @@ instance Yesod UniWorX where NotAuthenticated -> [whamlet|

_{MsgErrorResponseNotAuthenticated}|] PermissionDenied err' -> [whamlet|

#{err'}|] BadMethod method -> [whamlet|

_{MsgErrorResponseBadMethod (decodeUtf8 method)}|] - fmap toTypedContent . siteLayout (Just . toHtml . mr $ ErrorResponseTitle err) $ do + fmap toTypedContent . siteLayout (toWgt . mr $ ErrorResponseTitle err) $ do toWidget [cassius| .errMsg @@ -837,7 +860,7 @@ instance Yesod UniWorX where |] errPage - defaultLayout = siteLayout Nothing + defaultLayout = siteLayout' Nothing -- The page to be redirected to when authentication is required. authRoute _ = Just $ AuthR LoginR @@ -870,6 +893,8 @@ instance Yesod UniWorX where . runIdentity $ sourceList (Lazy.ByteString.toChunks content) $$ sinkHash + fileUpload _site _length = FileUploadMemory lbsBackEnd + -- What messages should be logged. The following includes all messages when -- in development, and warnings and errors in production. shouldLog _ _ _ = error "Must use shouldLogIO" @@ -880,9 +905,21 @@ instance Yesod UniWorX where makeLogger = readTVarIO . snd . appLogger -siteLayout :: Maybe Html -- ^ Optionally override `pageHeading` +siteLayoutMsg :: (RenderMessage site msg, site ~ UniWorX) => msg -> Widget -> Handler Html +siteLayoutMsg msg widget = do + mr <- getMessageRender + siteLayout (toWgt $ mr msg) widget + +siteLayoutMsg' :: (RenderMessage site msg, site ~ UniWorX) => msg -> Widget -> Handler Html +siteLayoutMsg' = siteLayout . i18nHeading + +siteLayout :: Widget -- ^ `pageHeading` -> Widget -> Handler Html -siteLayout headingOverride widget = do +siteLayout = siteLayout' . Just + +siteLayout' :: Maybe Widget -- ^ Optionally override `pageHeading` + -> Widget -> Handler Html +siteLayout' headingOverride widget = do master <- getYesod let AppSettings { appUserDefaults = UserDefaultConf{..}, .. } = appSettings master @@ -949,45 +986,65 @@ siteLayout headingOverride widget = do -- you to use normal widget features in default-layout. navbar :: Widget - navbar = $(widgetFile "widgets/navbar") + navbar = $(widgetFile "widgets/navbar/navbar") asidenav :: Widget - asidenav = $(widgetFile "widgets/asidenav") + asidenav = $(widgetFile "widgets/asidenav/asidenav") footer :: Widget - footer = $(widgetFile "widgets/footer") + footer = $(widgetFile "widgets/footer/footer") + alerts :: Widget + alerts = $(widgetFile "widgets/alerts/alerts") contentHeadline :: Maybe Widget - contentHeadline = (toWidget <$> headingOverride) <|> (pageHeading =<< mcurrentRoute) + contentHeadline = headingOverride <|> (pageHeading =<< mcurrentRoute) breadcrumbsWgt :: Widget - breadcrumbsWgt = $(widgetFile "widgets/breadcrumbs") - pageactionprime :: Widget - pageactionprime = $(widgetFile "widgets/pageactionprime") -- TODO: rename, since it also shows secondary pageActions now + breadcrumbsWgt = $(widgetFile "widgets/breadcrumbs/breadcrumbs") + pageaction :: Widget + pageaction = $(widgetFile "widgets/pageaction/pageaction") -- functions to determine if there are page-actions (primary or secondary) - isPageAction :: MenuType -> Bool - isPageAction PageActionPrime = True - isPageAction PageActionSecondary = True - isPageAction _ = False - hasPageActions :: Bool - hasPageActions = any (isPageAction . menuItemType . view _1) menuTypes + hasPageActions, hasSecondaryPageActions, hasPrimaryPageActions :: Bool + hasPageActions = hasPrimaryPageActions || hasSecondaryPageActions + hasSecondaryPageActions = any (is _PageActionSecondary) $ toListOf (traverse . _1 . _menuItemType) menuTypes + hasPrimaryPageActions = any (is _PageActionPrime) $ toListOf (traverse . _1 . _menuItemType) menuTypes pc <- widgetToPageContent $ do - addStylesheetRemote "https://fonts.googleapis.com/css?family=Source+Sans+Pro:300,400,600,800,900|Roboto:300,400,600" - addScript $ StaticR js_zepto_js - addScript $ StaticR js_fetchPolyfill_js - addScript $ StaticR js_urlPolyfill_js - addScript $ StaticR js_featureChecker_js - addScript $ StaticR js_flatpickr_js - addScript $ StaticR js_tabber_js - addStylesheet $ StaticR css_flatpickr_css - addStylesheet $ StaticR css_tabber_css + -- 3rd party + addScript $ StaticR js_vendor_flatpickr_js + addScript $ StaticR js_vendor_zepto_js + addStylesheet $ StaticR css_vendor_flatpickr_css + addStylesheet $ StaticR css_vendor_fontawesome_css + -- fonts addStylesheet $ StaticR css_fonts_css - addStylesheet $ StaticR css_fontawesome_css + -- polyfills + addScript $ StaticR js_polyfills_fetchPolyfill_js + addScript $ StaticR js_polyfills_urlPolyfill_js + -- JavaScript utils + addScript $ StaticR js_utils_alerts_js + addScript $ StaticR js_utils_asidenav_js + addScript $ StaticR js_utils_asyncForm_js + addScript $ StaticR js_utils_asyncTable_js + addScript $ StaticR js_utils_asyncTableFilter_js + addScript $ StaticR js_utils_checkAll_js + addScript $ StaticR js_utils_httpClient_js + addScript $ StaticR js_utils_form_js + addScript $ StaticR js_utils_inputs_js + addScript $ StaticR js_utils_modal_js + addScript $ StaticR js_utils_setup_js + addScript $ StaticR js_utils_showHide_js + addScript $ StaticR js_utils_tabber_js + addStylesheet $ StaticR css_utils_alerts_scss + addStylesheet $ StaticR css_utils_asidenav_scss + addStylesheet $ StaticR css_utils_asyncForm_scss + addStylesheet $ StaticR css_utils_asyncTable_scss + addStylesheet $ StaticR css_utils_asyncTableFilter_scss + addStylesheet $ StaticR css_utils_checkbox_scss + addStylesheet $ StaticR css_utils_form_scss + addStylesheet $ StaticR css_utils_inputs_scss + addStylesheet $ StaticR css_utils_modal_scss + addStylesheet $ StaticR css_utils_radio_scss + addStylesheet $ StaticR css_utils_showHide_scss + addStylesheet $ StaticR css_utils_tabber_scss + addStylesheet $ StaticR css_utils_tooltip_scss + -- widgets $(widgetFile "default-layout") - $(widgetFile "standalone/modal") - $(widgetFile "standalone/showHide") - $(widgetFile "standalone/inputs") - $(widgetFile "standalone/tooltip") - $(widgetFile "standalone/tabber") - $(widgetFile "standalone/alerts") - $(widgetFile "standalone/datepicker") withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet") @@ -1018,25 +1075,35 @@ applySystemMessages = liftHandlerT . runDB . runConduit $ selectSource [] [] .| -- Define breadcrumbs. instance YesodBreadcrumbs UniWorX where - breadcrumb (AuthR _) = return ("Login" , Just HomeR) - breadcrumb HomeR = return ("Uni2work", Nothing) - breadcrumb UsersR = return ("Benutzer", Just HomeR) - breadcrumb AdminTestR = return ("Test" , Just HomeR) - breadcrumb (AdminUserR _) = return ("Users" , Just UsersR) - breadcrumb VersionR = return ("Impressum" , Just HomeR) + breadcrumb (AuthR _) = return ("Login" , Just HomeR) + breadcrumb HomeR = return ("Uni2work" , Nothing) + breadcrumb UsersR = return ("Benutzer" , Just HomeR) + breadcrumb AdminTestR = return ("Test" , Just HomeR) + breadcrumb (AdminUserR _) = return ("Users" , Just UsersR) - breadcrumb ProfileR = return ("Profile" , Just HomeR) - breadcrumb ProfileDataR = return ("Data" , Just ProfileR) + breadcrumb InfoR = return ("Information" , Nothing) + breadcrumb InfoLecturerR = return ("Veranstalter" , Just InfoR) + breadcrumb DataProtR = return ("Datenschutz" , Just InfoR) + breadcrumb ImpressumR = return ("Impressum" , Just InfoR) + breadcrumb VersionR = return ("Versionsgeschichte", Just InfoR) + + + breadcrumb HelpR = return ("Hilfe" , Just HomeR) + + + breadcrumb ProfileR = return ("User" , Just HomeR) + breadcrumb ProfileDataR = return ("Profile" , Just ProfileR) + breadcrumb AuthPredsR = return ("Authentifizierung", Just ProfileR) breadcrumb TermShowR = return ("Semester" , Just HomeR) breadcrumb TermCurrentR = return ("Aktuell" , Just TermShowR) breadcrumb TermEditR = return ("Neu" , Just TermCurrentR) breadcrumb (TermEditExistR tid) = return ("Editieren" , Just $ TermCourseListR tid) - breadcrumb (TermCourseListR (unTermKey -> tid)) = getMessageRender <&> \mr -> (mr $ ShortTermIdentifier tid, Nothing) + breadcrumb (TermCourseListR (unTermKey -> tid)) = getMessageRender <&> \mr -> (mr $ ShortTermIdentifier tid, Just CourseListR) breadcrumb (TermSchoolCourseListR tid ssh) = return (CI.original $ unSchoolKey ssh, Just $ TermCourseListR tid) - breadcrumb CourseListR = return ("Kurse" , Just HomeR) + breadcrumb CourseListR = return ("Kurse" , Nothing) breadcrumb CourseNewR = return ("Neu" , Just CourseListR) breadcrumb (CourseR tid ssh csh CShowR) = return (CI.original csh, Just $ TermSchoolCourseListR tid ssh) -- (CourseR tid ssh csh CRegisterR) -- is POST only @@ -1086,18 +1153,34 @@ submissionList tid csh shn uid = E.select . E.from $ \(course `E.InnerJoin` shee defaultLinks :: (MonadHandler m, HandlerSite m ~ UniWorX) => m [MenuItem] defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the header. [ return MenuItem - { menuItemType = NavbarAside + { menuItemType = NavbarAside , menuItemLabel = MsgMenuHome - , menuItemIcon = Just "home" + , menuItemIcon = Just "home" , menuItemRoute = SomeRoute HomeR , menuItemModal = False , menuItemAccessCallback' = return True } , return MenuItem - { menuItemType = Footer - , menuItemLabel = MsgMenuVersion - , menuItemIcon = Just "book" - , menuItemRoute = SomeRoute VersionR + { menuItemType = Footer + , menuItemLabel = MsgMenuDataProt + , menuItemIcon = Just "shield" + , menuItemRoute = SomeRoute DataProtR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + , return MenuItem + { menuItemType = Footer + , menuItemLabel = MsgMenuImpressum + , menuItemIcon = Just "file-signature" + , menuItemRoute = SomeRoute ImpressumR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + , return MenuItem + { menuItemType = Footer + , menuItemLabel = MsgMenuInformation + , menuItemIcon = Just "info" + , menuItemRoute = SomeRoute InfoR , menuItemModal = False , menuItemAccessCallback' = return True } @@ -1105,7 +1188,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the mCurrentRoute <- getCurrentRoute return MenuItem - { menuItemType = NavbarRight + { menuItemType = NavbarRight , menuItemLabel = MsgMenuHelp , menuItemIcon = Just "question" , menuItemRoute = SomeRoute (HelpR, catMaybes [(toPathPiece GetReferer, ) . toPathPiece <$> mCurrentRoute]) @@ -1113,57 +1196,57 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , menuItemAccessCallback' = return True } , return MenuItem - { menuItemType = NavbarRight + { menuItemType = NavbarRight , menuItemLabel = MsgMenuProfile - , menuItemIcon = Just "cogs" + , menuItemIcon = Just "cogs" , menuItemRoute = SomeRoute ProfileR , menuItemModal = False , menuItemAccessCallback' = isJust <$> maybeAuthPair } , return MenuItem - { menuItemType = NavbarSecondary + { menuItemType = NavbarSecondary , menuItemLabel = MsgMenuLogin - , menuItemIcon = Just "sign-in-alt" + , menuItemIcon = Just "sign-in-alt" , menuItemRoute = SomeRoute $ AuthR LoginR , menuItemModal = True , menuItemAccessCallback' = isNothing <$> maybeAuthPair } , return MenuItem - { menuItemType = NavbarSecondary + { menuItemType = NavbarSecondary , menuItemLabel = MsgMenuLogout - , menuItemIcon = Just "sign-out-alt" + , menuItemIcon = Just "sign-out-alt" , menuItemRoute = SomeRoute $ AuthR LogoutR , menuItemModal = False , menuItemAccessCallback' = isJust <$> maybeAuthPair } , return MenuItem - { menuItemType = NavbarAside - , menuItemLabel = MsgMenuCourseList - , menuItemIcon = Just "calendar-alt" - , menuItemRoute = SomeRoute CourseListR - , menuItemModal = False - , menuItemAccessCallback' = return True - } - , return MenuItem - { menuItemType = NavbarAside + { menuItemType = NavbarAside , menuItemLabel = MsgMenuTermShow - , menuItemIcon = Just "graduation-cap" + , menuItemIcon = Just "calendar-alt" -- SJ wrote: calendar icon, since Term will be repleaced with TimeTable in the future; arguably Term is more calendar-like than courses anyway!!! , menuItemRoute = SomeRoute TermShowR , menuItemModal = False , menuItemAccessCallback' = return True } , return MenuItem - { menuItemType = NavbarAside + { menuItemType = NavbarAside + , menuItemLabel = MsgMenuCourseList + , menuItemIcon = Just "graduation-cap" + , menuItemRoute = SomeRoute CourseListR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + , return MenuItem + { menuItemType = NavbarAside , menuItemLabel = MsgMenuCorrections - , menuItemIcon = Just "check" + , menuItemIcon = Just "check" , menuItemRoute = SomeRoute CorrectionsR , menuItemModal = False , menuItemAccessCallback' = return True } , return MenuItem - { menuItemType = NavbarAside + { menuItemType = NavbarAside , menuItemLabel = MsgMenuUsers - , menuItemIcon = Just "users" + , menuItemIcon = Just "users" , menuItemRoute = SomeRoute UsersR , menuItemModal = False , menuItemAccessCallback' = return True -- Creates a LOOP: (Authorized ==) <$> isAuthorized UsersR False @@ -1180,14 +1263,15 @@ pageActions :: Route UniWorX -> [MenuItem] -} pageActions (HomeR) = [ --- NavbarAside $ MenuItem --- { menuItemLabel = "Benutzer" --- , menuItemIcon = Just "users" --- , menuItemRoute = UsersR --- , menuItemAccessCallback' = return True --- } --- , MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgInfoLecturerTitle + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute InfoLecturerR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + , MenuItem { menuItemType = PageActionPrime , menuItemLabel = MsgMenuAdminTest , menuItemIcon = Just "screwdriver" @@ -1212,6 +1296,36 @@ pageActions (HomeR) = , menuItemAccessCallback' = return True } ] +pageActions (InfoR) = [ + MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgInfoLecturerTitle + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute InfoLecturerR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + ] +pageActions (VersionR) = [ + MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgInfoLecturerTitle + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute InfoLecturerR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + ] +pageActions (HelpR) = [ + -- MenuItem + -- { menuItemType = PageActionPrime + -- , menuItemLabel = MsgInfoLecturerTitle + -- , menuItemIcon = Nothing + -- , menuItemRoute = SomeRoute InfoLecturerR + -- , menuItemModal = False + -- , menuItemAccessCallback' = return True + -- } + ] pageActions (ProfileR) = [ MenuItem { menuItemType = PageActionPrime @@ -1221,6 +1335,14 @@ pageActions (ProfileR) = , menuItemModal = False , menuItemAccessCallback' = return True } + , MenuItem + { menuItemType = PageActionSecondary + , menuItemLabel = MsgMenuAuthPreds + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute AuthPredsR + , menuItemModal = True + , menuItemAccessCallback' = return True + } ] pageActions TermShowR = [ MenuItem @@ -1260,6 +1382,16 @@ pageActions (CourseListR) = , menuItemAccessCallback' = return True } ] +pageActions (CourseNewR) = [ + MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgInfoLecturerTitle + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute InfoLecturerR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + ] pageActions (CourseR tid ssh csh CShowR) = [ MenuItem { menuItemType = PageActionPrime @@ -1281,6 +1413,14 @@ pageActions (CourseR tid ssh csh CShowR) = } ] ++ pageActions (CourseR tid ssh csh SheetListR) ++ [ MenuItem + { menuItemType = PageActionSecondary + , menuItemLabel = MsgMenuCourseMembers + , menuItemIcon = Just "user-graduate" + , menuItemRoute = SomeRoute $ CourseR tid ssh csh CUsersR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + , MenuItem { menuItemType = PageActionSecondary , menuItemLabel = MsgMenuCourseEdit , menuItemIcon = Nothing @@ -1474,7 +1614,7 @@ pageActions (CSubmissionR tid ssh csh shn cid SubShowR) = , MenuItem { menuItemType = PageActionSecondary , menuItemLabel = MsgMenuSubmissionDelete - , menuItemIcon = Nothing + , menuItemIcon = Just "trash" , menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid SubDelR , menuItemModal = False , menuItemAccessCallback' = return True @@ -1586,6 +1726,7 @@ pageActions _ = [] i18nHeading :: (MonadWidget m, RenderMessage site msg, HandlerSite m ~ site) => msg -> m () i18nHeading msg = liftWidgetT $ toWidget =<< getMessageRender <*> pure msg +-- | only used in defaultLayout; better use siteLayout instead! pageHeading :: Route UniWorX -> Maybe Widget pageHeading (AuthR _) = Just $ i18nHeading MsgLoginHeading @@ -1593,14 +1734,22 @@ pageHeading HomeR = Just $ i18nHeading MsgHomeHeading pageHeading UsersR = Just $ i18nHeading MsgUsers +pageHeading (AdminUserR _) + = Just $ i18nHeading MsgAdminUserHeading pageHeading (AdminTestR) = Just $ [whamlet|Internal Code Demonstration Page|] -pageHeading (AdminUserR _) - = Just $ [whamlet|User Display for Admin|] pageHeading (AdminErrMsgR) = Just $ i18nHeading MsgErrMsgHeading -pageHeading (VersionR) + +pageHeading (InfoR) + = Just $ i18nHeading MsgInfoHeading +pageHeading (DataProtR) + = Just $ i18nHeading MsgDataProtHeading +pageHeading (ImpressumR) = Just $ i18nHeading MsgImpressumHeading +pageHeading (VersionR) + = Just $ i18nHeading MsgVersionHeading + pageHeading (HelpR) = Just $ i18nHeading MsgHelpRequest diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 17bc943b9..501cc97b9 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -54,6 +54,24 @@ emailTestForm = (,) SelFormatDate -> d SelFormatTime -> t +makeDemoForm :: Int -> Form (Int,Bool,Double) +makeDemoForm n = identifyForm "adminTestForm" $ \html -> do -- Important: used identForm instead! + (result, widget) <- flip (renderAForm FormStandard) html $ (,,) + <$> areq (minIntField n "Zahl") (fromString $ "Ganzzahl > " ++ show n) Nothing + <* aformSection MsgFormBehaviour + <*> areq checkBoxField "Muss nächste Zahl größer sein?" (Just True) + <*> areq doubleField "Fliesskommazahl" Nothing + <* submitButton + return $ case result of + FormSuccess fsres + | errorMsgs <- validateResult fsres + , not $ null errorMsgs -> (FormFailure errorMsgs, widget) + _otherwise -> (result, widget) + where + validateResult :: (Int,Bool,Double) -> [Text] + validateResult (i,True,d) | fromIntegral i >= d = [tshow d <> " ist nicht größer als " <> tshow i, "Zweite Fehlermeldung", "Dritte Fehlermeldung"] + validateResult _other = [] + getAdminTestR, postAdminTestR :: Handler Html -- Demo Page. Referenzimplementierungen sollte hier gezeigt werden! getAdminTestR = postAdminTestR @@ -66,7 +84,7 @@ postAdminTestR = do _other -> addMessage Warning "KEIN Knopf erkannt" ((emailResult, emailWidget), emailEnctype) <- runFormPost . identifyForm "email" $ renderAForm FormStandard emailTestForm - case emailResult of + case emailResult of (FormSuccess (email, ls)) -> do jId <- runDB $ do jId <- queueJob $ JobSendTestEmail email ls @@ -77,24 +95,47 @@ postAdminTestR = do (FormFailure errs) -> forM_ errs $ addMessage Error . toHtml let emailWidget' = [whamlet| -

+ ^{emailWidget} |] - - defaultLayout $ - -- setTitle "Uni2work Admin Testpage" + + + let demoFormAction (_i,_b,_d) = addMessage Info "All ok." + ((demoResult, formWidget),formEnctype) <- runFormPost $ makeDemoForm 7 + formResult demoResult demoFormAction + let actionUrl = AdminTestR + let showDemoResult = [whamlet| + $maybe (i,b,d) <- formResult' demoResult + Received values: +