diff --git a/CHANGELOG.md b/CHANGELOG.md index 3660df080..8bf5c370c 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,40 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +## [4.6.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v4.5.0...v4.6.0) (2019-07-26) + + +### Features + +* **exam-users:** allow missing columns in csv import ([e242013](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/e242013)) + + + +## [4.5.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v4.4.0...v4.5.0) (2019-07-26) + + +### Bug Fixes + +* fix merge ([38afa90](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/38afa90)) +* **csv-import:** fix incorrect map merge ([0d283fd](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/0d283fd)) +* **dbtable-ui:** fix position of submit button for pagesize ([cf35118](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/cf35118)) +* **merge:** fix build ([0bd0260](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/0bd0260)) + + +### Features + +* **alert-icons:** add custom icons for alerts ([bc67500](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/bc67500)) +* **alerticons:** allow alerts to have custom icons ([d70a958](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/d70a958)) +* **alerts js:** support custom icons in Alerts HTTP-Header ([8833cb5](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/8833cb5)) +* **corrections assignment:** add convenience to table header ([56c2fcc](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/56c2fcc)) +* **course enrolement:** show proper icons in alerts ([b2b3895](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/b2b3895)) +* **exam-users:** provide better table defaults ([a689d19](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/a689d19)) +* **exams:** csv-based grade upload ([932145c](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/932145c)) +* **exams:** show exam results ([b8b308d](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/b8b308d)) +* **users:** store first names and titles ([ceed070](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/ceed070)) + + + ## [4.4.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v4.3.0...v4.4.0) (2019-07-24) diff --git a/is-clean.sh b/is-clean.sh new file mode 100755 index 000000000..b63b54f46 --- /dev/null +++ b/is-clean.sh @@ -0,0 +1,21 @@ +#!/usr/bin/env bash + +set -e + +if [ -n "$(git status --porcelain)" ]; then + echo "Working directory isn't clean" >&2 + exit 1 +fi + +if [ "$(git rev-parse --abbrev-ref HEAD)" != "master" ]; then + echo "Not on master" >&2 + exit 1 +fi + +ourHash=$(git rev-parse HEAD) +theirHash=$(git ls-remote origin -h refs/heads/master | awk '{ print $1; }') + +if [ "$theirHash" != "$ourHash" ]; then + echo "Local HEAD is not up to date with remote master" >&2 + exit 1 +fi diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 7ee1af4aa..833df71e9 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -312,6 +312,10 @@ UnauthorizedTutorialTutor: Sie sind nicht Tutor für dieses Tutorium. UnauthorizedCourseTutor: Sie sind nicht Tutor für diesen Kurs. UnauthorizedTutor: Sie sind nicht Tutor. UnauthorizedTutorialRegisterGroup: Sie sind bereits in einem Tutorium mit derselben Registrierungs-Gruppe. +UnauthorizedLDAP: Angegebener Nutzer meldet sich nicht mit Campus-Kennung an. +UnauthorizedPWHash: Angegebener Nutzer meldet sich nicht mit Uni2work-Kennung an. + +UnauthorizedPasswordResetToken: Dieses Authorisierungs-Token kann nicht mehr zum Passwort ändern benutzt werden EMail: E-Mail EMailUnknown email@UserEmail: E-Mail #{email} gehört zu keinem bekannten Benutzer. @@ -502,7 +506,9 @@ NoUpcomingExams: In den nächsten 14 Tagen gibt es keine Klausur mit offener Reg AdminHeading: Administration AdminUserHeading: Benutzeradministration -AccessRightsFor: Berechtigungen für +AdminUserRightsHeading: Benutzerrechte +AdminUserAuthHeading: Benutzer-Authentifizierung +AdminUserHeadingFor: Benuterprofil für AdminFor: Administrator LecturerFor: Dozent LecturersFor: Dozenten @@ -651,6 +657,13 @@ MailUserRightsIntro name@Text email@UserEmail: #{name} <#{email}> hat folgende U MailNoLecturerRights: Sie haben derzeit keine Dozenten-Rechte. MailLecturerRights n@Int: Als Dozent dürfen Sie Veranstaltungen innerhalb #{pluralDE n "Ihres Instituts" "Ihrer Institute"} anlegen. +MailSubjectUserAuthModeUpdate: Änderung Ihres Uni2work-Anmeldemodus +UserAuthModePWHashChangedToLDAP: Sie melden sich nun mit Ihrer Campus-Kennung an +UserAuthModeLDAPChangedToPWHash: Sie melden sich nun mit einer Uni2work-internen Kennung an +NewPasswordLinkTip: Das Passwort Ihrer Uni2work-internen Kennung können Sie auf der folgenden Seite setzen: +NewPasswordLink: Neues Passwort setzen +AuthPWHashTip: Sie müssen nun das mit "Uni2work-Login" beschriftete Login-Formular verwenden. Stellen Sie bitte sicher, dass Sie ein Passwort gesetzt haben, bevor Sie versuchen sich anzumelden. +PasswordResetEmailIncoming: Einen Link um ihr Passwort zu setzen bzw. zu ändern bekommen Sie, aus Sicherheitsgründen, in einer separaten E-Mail. MailEditNotifications: Benachrichtigungen ein-/ausschalten MailSubjectSupport: Supportanfrage @@ -672,6 +685,8 @@ MailSubjectExamRegistrationInvitation tid@TermId ssh@SchoolId csh@CourseShorthan MailSubjectSubmissionUserInvitation tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName: [#{tid}-#{ssh}-#{csh}] Einladung zu einer Abgabe für #{shn} +MailSubjectPasswordReset: Uni2work-Passwort ändern bzw. setzen + SheetGrading: Bewertung SheetGradingPoints maxPoints@Points: #{maxPoints} Punkte SheetGradingPassPoints maxPoints@Points passingPoints@Points: Bestanden ab #{passingPoints} von #{maxPoints} Punkten @@ -720,6 +735,13 @@ NotificationTriggerSheetInactive: Abgabezeitraum eines meiner Übungsblätter is NotificationTriggerCorrectionsAssigned: Mir wurden Abgaben zur Korrektur zugeteilt NotificationTriggerCorrectionsNotDistributed: Nicht alle Abgaben eines meiner Übungsblätter konnten einem Korrektor zugeteilt werden NotificationTriggerUserRightsUpdate: Meine Berechtigungen wurden geändert +NotificationTriggerUserAuthModeUpdate: Mein Anmelde-Modus wurde geändert + +NotificationTriggerKindAll: Für alle Benutzer +NotificationTriggerKindCourseParticipant: Für Kursteilnehmer +NotificationTriggerKindCorrector: Für Korrektoren +NotificationTriggerKindLecturer: Für Dozenten +NotificationTriggerKindAdmin: Für Administratoren CorrCreate: Abgaben erstellen UnknownPseudonymWord pseudonymWord@Text: Unbekanntes Pseudonym-Wort "#{pseudonymWord}" @@ -836,6 +858,7 @@ MenuTermShow: Semester MenuSubmissionDelete: Abgabe löschen MenuUsers: Benutzer MenuUserNotifications: Benachrichtigungs-Einstellungen +MenuUserPassword: Passwort MenuAdminTest: Admin-Demo MenuMessageList: Systemnachrichten MenuAdminErrMsg: Fehlermeldung entschlüsseln @@ -882,6 +905,7 @@ MenuExamNew: Neue Klausur anlegen MenuExamEdit: Bearbeiten MenuExamUsers: Teilnehmer MenuExamAddMembers: Klausurteilnehmer hinzufügen +MenuLecturerInvite: Dozenten hinzufügen 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 @@ -909,6 +933,8 @@ AuthTagRated: Korrektur ist bewertet AuthTagUserSubmissions: Abgaben erfolgen durch Kursteilnehmer AuthTagCorrectorSubmissions: Abgaben erfolgen durch Korrektoren AuthTagSelf: Nutzer greift nur auf eigene Daten zu +AuthTagIsLDAP: Nutzer meldet sich mit Campus-Kennung an +AuthTagIsPWHash: Nutzer meldet sich mit Uni2work-Kennung an AuthTagAuthentication: Nutzer ist angemeldet, falls erforderlich AuthTagRead: Zugriff ist nur lesend AuthTagWrite: Zugriff ist i.A. schreibend @@ -1239,8 +1265,9 @@ Proportion c@Text of@Text prop@Rational: #{c}/#{of} (#{rationalToFixed2 (100 * p CsvColumnsExplanationsLabel: Spalten CsvColumnsExplanationsTip: Bedeutung der in der CSV-Datei enthaltenen Spalten -CsvColumnExamUserSurname: Nachname des Teilnehmers -CsvColumnExamUserName: Voller Name des Teilnehmers (inkl. Nachname) +CsvColumnExamUserSurname: Nachname(n) des Teilnehmers +CsvColumnExamUserFirstName: Vorname(n) des Teilnehmers +CsvColumnExamUserName: Voller Name des Teilnehmers (gewöhnlicherweise inkl. Vor- und Nachname(n)) CsvColumnExamUserMatriculation: Matrikelnummer des Teilnehmers CsvColumnExamUserField: Hauptfach, mit dem der Teilnehmer seine Kursanmeldung assoziiert hat CsvColumnExamUserDegree: Abschluss, den der Teilnehmer im assoziierten Hauptfach anstrebt @@ -1250,6 +1277,7 @@ CsvColumnExamUserExercisePoints: Anzahl von Punkten, die der Teilnehmer im Übun CsvColumnExamUserExercisePointsMax: Maximale Anzahl von Punkten, die der Teilnehmer im Übungsbetrieb bis zu seinem Klausurtermin erreichen hätte können CsvColumnExamUserExercisePasses: Anzahl von Übungsblättern, die der Teilnehmer bestanden hat CsvColumnExamUserExercisePassesMax: Maximale Anzahl von Übungsblättern, die der Teilnehmer bis zu seinem Klausurtermin bestehen hätte können +CsvColumnExamUserResult: Erreichte Klausurleistung; "passed", "failed", "no-show", "voided", oder eine Note ("1.0", "1.3", "1.7", ..., "4.0", "5.0") Action: Aktion @@ -1263,6 +1291,7 @@ ExamUserCsvRegister: Kursteilnehmer zur Klausur anmelden ExamUserCsvAssignOccurrence: Teilnehmern einen anderen Termin/Raum zuweisen ExamUserCsvDeregister: Teilnehmer von der Klausur abmelden ExamUserCsvSetCourseField: Kurs-assoziiertes Hauptfach ändern +ExamUserCsvSetResult: Ergebnis eintragen ExamUserCsvExceptionNoMatchingUser: Kursteilnehmer konnte nicht eindeutig identifiziert werden ExamUserCsvExceptionNoMatchingStudyFeatures: Das angegebene Studienfach konnte keinem Hauptfach des Kursteilnehmers zugeordnet werden @@ -1270,4 +1299,47 @@ ExamUserCsvExceptionNoMatchingOccurrence: Raum/Termin konnte nicht eindeutig ide TableHeadingFilter: Filter TableHeadingCsvImport: CSV-Import -TableHeadingCsvExport: CSV-Export \ No newline at end of file +TableHeadingCsvExport: CSV-Export + +ExamResultAttended: Teilgenommen +ExamResultNoShow: Nicht erschienen +ExamResultVoided: Entwertet +ExamResultNone: Kein Klausurergebnis + +BtnAuthLDAP: Auf Campus-Kennung umstellen +BtnAuthPWHash: Auf Uni2work-Kennung umstellen +BtnPasswordReset: Passwort zurücksetzen + +AuthLDAPLookupFailed: Nutzer konnte aufgrund eines LDAP-Fehlers nicht nachgeschlagen werden +AuthLDAPInvalidLookup: Bestehender Nutzer konnte nicht eindeutig einem LDAP-Eintrag zugeordnet werden +AuthLDAPAlreadyConfigured: Nutzer meldet sich bereits per Campus-Kennung an +AuthLDAPConfigured: Nutzer meldet sich nun per Campus-Kennung an + +AuthPWHashAlreadyConfigured: Nutzer meldet sich bereits per Uni2work-Kennung an +AuthPWHashConfigured: Nutzer meldet sich nun per Uni2work-Kennung an + +PasswordResetQueued: Link zum Passwort-Zurücksetzen versandt +ResetPassword: Uni2work-Passwort ändern bzw. setzen + +AuthMode: Authentifizierung +AuthLDAP: Campus +AuthPWHash pwHash@Text: Uni2work +CurrentPassword: Aktuelles Passwort +NewPassword: Neues Passwort +NewPasswordRepeat: Wiederholung +CurrentPasswordInvalid: Aktuelles Passwort ist inkorrekt +PasswordRepeatInvalid: Wiederholung stimmt nicht mit neuem Passwort überein +UserPasswordHeadingFor: Passwort ändern für +PasswordChangedSuccess: Passwort erfolgreich geändert + +LecturerInviteSchool: Institut +LecturerInviteField: Einzuladende EMail Addressen +LecturerInviteHeading: Dozenten hinzufügen + +LecturersInvited n@Int: #{n} #{pluralDE n "Dozent" "Dozenten"} per EMail eingeladen +LecturersAdded n@Int: #{n} #{pluralDE n "Dozent" "Dozenten"} eingetragen + +MailSubjectSchoolLecturerInvitation school@SchoolName: Einladung zum Dozent für „#{school}“ +MailSchoolLecturerInviteHeading school@SchoolName: Einladung zum Dozent für „#{school}“ +SchoolLecturerInviteExplanation: Sie wurden eingeladen, Dozent für ein Institut zu sein. Sie können, nachdem Sie die Einladung annehmen, eigenständig neue Kurse anlegen. +SchoolLecturerInvitationAccepted school@SchoolName: Einladung zum Dozent für „#{school}“ angenommen diff --git a/models/users b/models/users index f0b3e683e..33a92adf1 100644 --- a/models/users +++ b/models/users @@ -16,6 +16,8 @@ User json -- Each Uni2work user has a corresponding row in this table; create email (CI Text) -- Case-insensitive eMail address displayName Text -- we only show LDAP-DisplayName, and highlight LDAP-Surname within (appended if not contained) surname Text -- Display user names always through 'nameWidget displayName surname' + firstName Text -- For export in tables, pre-split firstName from displayName + title Text Maybe -- For upcoming name customisation maxFavourites Int default=12 -- max number of rows with this userId in table "CourseFavourite"; for convenience links; user-defined theme Theme default='Default' -- Color-theme of the frontend; user-defined dateTimeFormat DateTimeFormat "default='%a %d %b %Y %R'" -- preferred Date+Time display format for user; user-defined diff --git a/package-lock.json b/package-lock.json index a25132e3e..ff669ca94 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "4.4.0", + "version": "4.6.0", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 4a1187eba..de7966735 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "4.4.0", + "version": "4.6.0", "description": "", "keywords": [], "author": "", @@ -20,7 +20,7 @@ "frontend:test:watch": "karma start --conf karma.conf.js --single-run false", "frontend:build": "webpack", "frontend:build:watch": "webpack --watch", - "prerelease": "npm run test", + "prerelease": "./is-clean.sh && npm run test", "release": "standard-version -a", "postrelease": "git push --follow-tags origin master" }, diff --git a/package.yaml b/package.yaml index 1acd174c5..a935edb8d 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 4.4.0 +version: 4.6.0 dependencies: # Due to a bug in GHC 8.0.1, we block its usage @@ -133,6 +133,7 @@ dependencies: - cassava - cassava-conduit - constraints + - memory other-extensions: - GeneralizedNewtypeDeriving diff --git a/routes b/routes index 9629b00d1..46dd746fc 100644 --- a/routes +++ b/routes @@ -24,6 +24,9 @@ -- !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 -- +-- !is-ldap -- user has authentication mode set to LDAP +-- !is-pw-hash -- user has authentication mode set to PWHash +-- -- !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) @@ -45,6 +48,9 @@ /users/#CryptoUUIDUser/delete AdminUserDeleteR POST /users/#CryptoUUIDUser/hijack AdminHijackUserR POST !adminANDno-escalation /users/#CryptoUUIDUser/notifications UserNotificationR GET POST !self +/users/#CryptoUUIDUser/password UserPasswordR GET POST !selfANDis-pw-hash +!/users/lecturer-invite/new AdminNewLecturerInviteR GET POST +!/users/lecturer-invite AdminLecturerInviteR GET POST /admin AdminR GET /admin/features AdminFeaturesR GET POST /admin/test AdminTestR GET POST diff --git a/src/Control/Concurrent/Async/Lifted/Safe/Utils.hs b/src/Control/Concurrent/Async/Lifted/Safe/Utils.hs index f7f395b64..27dc86127 100644 --- a/src/Control/Concurrent/Async/Lifted/Safe/Utils.hs +++ b/src/Control/Concurrent/Async/Lifted/Safe/Utils.hs @@ -1,15 +1,17 @@ module Control.Concurrent.Async.Lifted.Safe.Utils - ( allocateLinkedAsync + ( allocateAsync, allocateLinkedAsync ) where import ClassyPrelude hiding (cancel) +import Control.Lens import Control.Concurrent.Async.Lifted.Safe import Control.Monad.Trans.Resource -allocateLinkedAsync :: forall m a. - MonadResource m - => IO a -> m (Async a) -allocateLinkedAsync act = allocate (async act) cancel >>= (\(_k, a) -> a <$ link a) +allocateLinkedAsync, allocateAsync :: forall m a. + MonadResource m + => IO a -> m (Async a) +allocateAsync = fmap (view _2) . flip allocate cancel . async +allocateLinkedAsync = uncurry (<$) . (id &&& link) <=< allocateAsync diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 323137301..5a032a6de 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -11,8 +11,10 @@ module Database.Esqueleto.Utils , mkContainsFilter, mkContainsFilterWith , mkExistsFilter , anyFilter, allFilter + , orderByList , orderByOrd, orderByEnum , lower, ciEq + , selectExists ) where @@ -171,12 +173,16 @@ allFilter fltrs needle criterias = F.foldr aux true fltrs aux fltr acc = fltr needle criterias E.&&. acc +orderByList :: PersistField a => [a] -> E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value Int) +orderByList vals + = let sortUni = zip [1..] vals -- memoize this, might not work due to polymorphism + in \x -> E.case_ [ (x E.==. E.val u, E.val i) | (i,u) <- sortUni ] (E.val . succ $ List.length vals) + orderByOrd :: (Ord a, Finite a, PersistField a) => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value Int) -orderByOrd = let sortUni = zip [1..] $ List.sort universeF in -- memoize this, might not work due to polymorphism - \x -> E.case_ [ (x E.==. E.val u, E.val i) | (i,u) <- sortUni ] (E.val (-1)) +orderByOrd = orderByList $ List.sort universeF orderByEnum :: (Enum a, Finite a, PersistField a) => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value Int) -orderByEnum x = E.case_ [ (x E.==. E.val u, E.val $ fromEnum u) | u <- universeF ] (E.val (-1)) +orderByEnum = orderByList $ List.sortOn fromEnum universeF lower :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) @@ -184,3 +190,12 @@ lower = E.unsafeSqlFunction "LOWER" ciEq :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value Bool) ciEq a b = lower a E.==. lower b + + +selectExists :: forall m a. MonadIO m => E.SqlQuery a -> E.SqlReadT m Bool +selectExists query = do + res <- E.select . return . E.exists $ void query + + case res of + [E.Value b] -> return b + _other -> error "SELECT EXISTS ... returned zero or more than one rows" diff --git a/src/Foundation.hs b/src/Foundation.hs index 6f1d4681b..8998e23cc 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -33,6 +33,7 @@ import qualified Data.ByteString.Base64.URL as Base64 (encode) import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as Lazy.ByteString +import qualified Data.ByteString as ByteString import qualified Data.Text as Text import qualified Data.Text.Encoding as Text @@ -295,6 +296,7 @@ embedRenderMessage ''UniWorX ''UploadModeDescr id embedRenderMessage ''UniWorX ''SecretJSONFieldException id embedRenderMessage ''UniWorX ''AFormMessage $ concat . drop 2 . splitCamel +embedRenderMessage ''UniWorX ''AuthenticationMode id newtype SheetTypeHeader = SheetTypeHeader SheetType embedRenderMessageVariant ''UniWorX ''SheetTypeHeader ("SheetType" <>) @@ -334,6 +336,23 @@ instance RenderMessage UniWorX StudyDegreeTerm where instance RenderMessage UniWorX ExamGrade where renderMessage _ _ = pack . (showFixed False :: Deci -> String) . fromRational . review numberGrade +instance RenderMessage UniWorX ExamPassed where + renderMessage foundation ls = \case + ExamPassed True -> mr MsgExamPassed + ExamPassed False -> mr MsgExamNotPassed + where + mr :: RenderMessage UniWorX msg => msg -> Text + mr = renderMessage foundation ls + +instance RenderMessage UniWorX a => RenderMessage UniWorX (ExamResult' a) where + renderMessage foundation ls = \case + ExamAttended{..} -> mr examResult + ExamNoShow -> mr MsgExamResultNoShow + ExamVoided -> mr MsgExamResultVoided + where + mr :: RenderMessage UniWorX msg => msg -> Text + mr = renderMessage foundation ls + -- ToMessage instances for converting raw numbers to Text (no internationalization) @@ -983,6 +1002,7 @@ tagAccessPredicate AuthSelf = APHandler $ \mAuthId route _ -> exceptT return ret AdminUserDeleteR cID -> return cID AdminHijackUserR cID -> return cID UserNotificationR cID -> return cID + UserPasswordR cID -> return cID CourseR _ _ _ (CUserR cID) -> return cID _other -> throwError =<< $unsupportedAuthPredicate AuthSelf route referencedUser' <- decrypt referencedUser @@ -991,6 +1011,34 @@ tagAccessPredicate AuthSelf = APHandler $ \mAuthId route _ -> exceptT return ret | uid == referencedUser' -> return Authorized Nothing -> return AuthenticationRequired _other -> unauthorizedI MsgUnauthorizedSelf +tagAccessPredicate AuthIsLDAP = APDB $ \_ route _ -> exceptT return return $ do + referencedUser <- case route of + AdminUserR cID -> return cID + AdminUserDeleteR cID -> return cID + AdminHijackUserR cID -> return cID + UserNotificationR cID -> return cID + UserPasswordR cID -> return cID + CourseR _ _ _ (CUserR cID) -> return cID + _other -> throwError =<< $unsupportedAuthPredicate AuthIsLDAP route + referencedUser' <- decrypt referencedUser + maybeTMExceptT (unauthorizedI MsgUnauthorizedLDAP) $ do + User{..} <- MaybeT $ get referencedUser' + guard $ userAuthentication == AuthLDAP + return Authorized +tagAccessPredicate AuthIsPWHash = APDB $ \_ route _ -> exceptT return return $ do + referencedUser <- case route of + AdminUserR cID -> return cID + AdminUserDeleteR cID -> return cID + AdminHijackUserR cID -> return cID + UserNotificationR cID -> return cID + UserPasswordR cID -> return cID + CourseR _ _ _ (CUserR cID) -> return cID + _other -> throwError =<< $unsupportedAuthPredicate AuthIsPWHash route + referencedUser' <- decrypt referencedUser + maybeTMExceptT (unauthorizedI MsgUnauthorizedPWHash) $ do + User{..} <- MaybeT $ get referencedUser' + guard $ is _AuthPWHash userAuthentication + return Authorized tagAccessPredicate AuthAuthentication = APDB $ \mAuthId route _ -> case route of MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do smId <- decrypt cID @@ -1784,8 +1832,18 @@ pageActions (AdminR) = , menuItemAccessCallback' = return True } ] -pageActions (AdminUserR cID) = [ - MenuItem +pageActions (UsersR) = + [ MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuLecturerInvite + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute AdminNewLecturerInviteR + , menuItemModal = True + , menuItemAccessCallback' = return True + } + ] +pageActions (AdminUserR cID) = + [ MenuItem { menuItemType = PageActionPrime , menuItemLabel = MsgMenuUserNotifications , menuItemIcon = Nothing @@ -1793,6 +1851,17 @@ pageActions (AdminUserR cID) = [ , menuItemModal = True , menuItemAccessCallback' = return True } + , MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuUserPassword + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ UserPasswordR cID + , menuItemModal = True + , menuItemAccessCallback' = do + uid <- decrypt cID + User{userAuthentication} <- runDB $ get404 uid + return $ is _AuthPWHash userAuthentication + } ] pageActions (InfoR) = [ MenuItem @@ -2731,7 +2800,9 @@ instance YesodAuth UniWorX where userMatrikelnummer' = lookup (Attr "LMU-Stud-Matrikelnummer") ldapData userEmail' = lookup (Attr "mail") ldapData userDisplayName' = lookup (Attr "displayName") ldapData + userFirstName' = lookup (Attr "givenName") ldapData userSurname' = lookup (Attr "sn") ldapData + userTitle' = lookup (Attr "title") ldapData userAuthentication | isPWHash = error "PWHash should only work for users that are already known" @@ -2750,12 +2821,26 @@ instance YesodAuth UniWorX where -> return userDisplayName | otherwise -> throwError $ ServerError "Could not retrieve user name" + userFirstName <- if + | Just [bs] <- userFirstName' + , Right userFirstName <- Text.decodeUtf8' bs + -> return userFirstName + | otherwise + -> throwError $ ServerError "Could not retrieve user given name" userSurname <- if | Just [bs] <- userSurname' , Right userSurname <- Text.decodeUtf8' bs -> return userSurname | otherwise -> throwError $ ServerError "Could not retrieve user surname" + userTitle <- if + | maybe True (all ByteString.null) userTitle' + -> return Nothing + | Just [bs] <- userTitle' + , Right userTitle <- Text.decodeUtf8' bs + -> return $ Just userTitle + | otherwise + -> throwError $ ServerError "Could not retrieve user title" userMatrikelnummer <- if | Just [bs] <- userMatrikelnummer' , Right userMatrikelnummer <- Text.decodeUtf8' bs diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index f7c226ee7..c7e8c7cb6 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -1,1450 +1,20 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Handler.Course where +module Handler.Course + ( module Handler.Course + ) where import Import -import Utils.Lens -import Utils.Form --- import Utils.DB -import Handler.Utils -import Handler.Utils.Course -import Handler.Utils.Tutorial -import Handler.Utils.Communication -import Handler.Utils.Delete -import Handler.Utils.Database -import Handler.Utils.Table.Cells -import Handler.Utils.Table.Columns -import Handler.Utils.Invitations -import Database.Persist.Sql (deleteWhereCount) -import qualified Database.Esqueleto.Utils as E -import Database.Esqueleto.Utils.TH --- import Data.Time -import qualified Data.CaseInsensitive as CI -import Data.Function ((&)) --- import Yesod.Form.Bootstrap3 - -import Data.Maybe (fromJust) -import qualified Data.Set as Set -import Data.Map ((!)) -import qualified Data.Map as Map - -import qualified Database.Esqueleto as E - -import Text.Blaze.Html.Renderer.Text (renderHtml) - -import Jobs.Queue - -import Data.Aeson hiding (Result(..)) - -import Text.Hamlet (ihamlet) - -import Control.Monad.Trans.Writer (WriterT, execWriterT) -import Control.Monad.Except (MonadError(..)) - -import Generics.Deriving.Monoid (memptydefault, mappenddefault) - - --- Dedicated CourseRegistrationButton -data ButtonCourseRegister = BtnCourseRegister | BtnCourseDeregister - deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) -instance Universe ButtonCourseRegister -instance Finite ButtonCourseRegister -nullaryPathPiece ''ButtonCourseRegister $ camelToPathPiece' 1 -embedRenderMessage ''UniWorX ''ButtonCourseRegister id -instance Button UniWorX ButtonCourseRegister where - btnClasses BtnCourseRegister = [BCIsButton, BCPrimary] - btnClasses BtnCourseDeregister = [BCIsButton, BCDanger] - - btnLabel BtnCourseRegister = [whamlet|#{iconEnrol True} _{MsgBtnCourseRegister}|] - btnLabel BtnCourseDeregister = [whamlet|#{iconEnrol False} _{MsgBtnCourseDeregister}|] - - --- NOTE: Outdated way to use dbTable; see ProfileDataR Handler for a more recent method. -type CourseTableData = DBRow (Entity Course, Int, Bool, Entity School) - -colCourse :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) -colCourse = sortable (Just "course") (i18nCell MsgCourse) - $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } -> - anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) - [whamlet|_{courseName}|] - --- colCourseDescr :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) --- colCourseDescr = sortable (Just "course") (i18nCell MsgCourse) $ do --- course <- view $ _dbrOutput . _1 . _entityVal --- return $ courseCell course - -colDescription :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) -colDescription = sortable Nothing mempty - $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } -> - case courseDescription of - Nothing -> mempty - (Just descr) -> cell $ modal (toWidget $ hasComment True) (Right $ toWidget descr) - -colCShort :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) -colCShort = sortable (Just "cshort") (i18nCell MsgCourseShort) - $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } -> - anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|_{courseShorthand}|] - --- colCShortDescr :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) --- colCShortDescr = sortable (Just "cshort") (i18nCell MsgCourseShort) --- $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } -> mappend --- ( anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseShorthand}|] ) --- ( case courseDescription of --- Nothing -> mempty --- (Just descr) -> cell --- [whamlet| --- $newline never ---
--- ^{modal "Beschreibung" (Right $ toWidget descr)} --- |] --- ) - -colTerm :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) -colTerm = sortable (Just "term") (i18nCell MsgTerm) - $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } -> - anchorCell (TermCourseListR courseTerm) [whamlet|#{courseTerm}|] - -colSchool :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) -colSchool = sortable (Just "school") (i18nCell MsgCourseSchool) - $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, Entity _ School{..}) } -> - anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|_{schoolName}|] - -colSchoolShort :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) -colSchoolShort = sortable (Just "schoolshort") (i18nCell MsgCourseSchoolShort) - $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, Entity _ School{..}) } -> - anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|_{schoolShorthand}|] - -colRegFrom :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) -colRegFrom = sortable (Just "register-from") (i18nCell MsgRegisterFrom) - $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } -> - maybe mempty dateTimeCell courseRegisterFrom - -- cell $ traverse (formatTime SelFormatDateTime) courseRegisterFrom >>= maybe mempty toWidget - -colRegTo :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) -colRegTo = sortable (Just "register-to") (i18nCell MsgRegisterTo) - $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } -> - maybe mempty dateTimeCell courseRegisterTo - -colMembers :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) -colMembers = sortable (Just "members") (i18nCell MsgCourseMembers) - $ \DBRow{ dbrOutput=(Entity _ Course{..}, currentParticipants, _, _) } -> i18nCell $ case courseCapacity of - Nothing -> MsgCourseMembersCount currentParticipants - Just limit -> MsgCourseMembersCountLimited currentParticipants limit - -colRegistered :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) -colRegistered = sortable (Just "registered") (i18nCell MsgRegistered) - $ \DBRow{ dbrOutput=(_, _, registered, _) } -> tickmarkCell registered - -type CourseTableExpr = E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity School) - -course2Participants :: CourseTableExpr -> E.SqlExpr (E.Value Int) -course2Participants (course `E.InnerJoin` _school) = E.sub_select . E.from $ \courseParticipant -> do - E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId - return (E.countRows :: E.SqlExpr (E.Value Int)) - -course2Registered :: Maybe UserId -> CourseTableExpr -> E.SqlExpr (E.Value Bool) -course2Registered muid (course `E.InnerJoin` _school) = E.exists . E.from $ \courseParticipant -> - E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId - E.&&. E.just (courseParticipant E.^. CourseParticipantUser) E.==. E.val muid - -makeCourseTable :: ( IsDBTable m x, ToSortable h, Functor h, DBResult m x ~ ((), Widget) ) - => _ -> Colonnade h CourseTableData (DBCell m x) -> PSValidator m x -> DB Widget -makeCourseTable whereClause colChoices psValidator = do - muid <- lift maybeAuthId - let dbtSQLQuery :: CourseTableExpr -> E.SqlQuery _ - dbtSQLQuery qin@(course `E.InnerJoin` school) = do - E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId - let participants = course2Participants qin - let registered = course2Registered muid qin - E.where_ $ whereClause (course, participants, registered) - return (course, participants, registered, school) - dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CourseTableData - dbtProj = traverse $ \(course, E.Value participants, E.Value registered, school) -> return (course, participants, registered, school) - snd <$> dbTable psValidator DBTable - { dbtSQLQuery - , dbtRowKey = \(course `E.InnerJoin` _) -> course E.^. CourseId - , dbtColonnade = colChoices - , dbtProj - , dbtSorting = Map.fromList -- OverloadedLists does not work with the templates here - [ ( "course", SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseName) - , ( "cshort", SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseShorthand) - , ( "term" , SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseTerm) - , ( "school", SortColumn $ \(_course `E.InnerJoin` school) -> school E.^. SchoolName) - , ( "schoolshort", SortColumn $ \(_course `E.InnerJoin` school) -> school E.^. SchoolShorthand) - , ( "register-from", SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseRegisterFrom) - , ( "register-to", SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseRegisterTo) - , ( "members", SortColumn course2Participants ) - , ( "registered", SortColumn $ course2Registered muid) - ] - , dbtFilter = Map.fromList -- OverloadedLists does not work with the templates here - [ ( "course", FilterColumn $ \(course `E.InnerJoin` _school:: CourseTableExpr) criterias -> if - | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool) - | otherwise -> course E.^. CourseName `E.in_` E.valList (Set.toList criterias) - ) - , ( "cshort", FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) criterias -> if - | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool) - | otherwise -> course E.^. CourseShorthand `E.in_` E.valList (Set.toList criterias) - ) - , ( "term" , FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) criterias -> if - | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool) - | otherwise -> course E.^. CourseTerm `E.in_` E.valList (Set.toList criterias) - ) --- , ( "school", FilterColumn $ \(_course `E.InnerJoin` school :: CourseTableExpr) criterias -> if --- | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool) --- | otherwise -> school E.^. SchoolName `E.in_` E.valList (Set.toList criterias) --- ) - , ( "school", FilterColumn $ \(_course `E.InnerJoin` school :: CourseTableExpr) -> - emptyOrIn $ school E.^. SchoolName -- TODO: Refactor all?! - ) - , ( "schoolshort", FilterColumn $ \(_course `E.InnerJoin` school :: CourseTableExpr) criterias -> if - | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool) - | otherwise -> school E.^. SchoolShorthand `E.in_` E.valList (Set.toList criterias) - ) - , ( "registered", FilterColumn $ \tExpr criterion -> case getLast (criterion :: Last Bool) of - Nothing -> E.val True :: E.SqlExpr (E.Value Bool) - Just needle -> course2Registered muid tExpr E.==. E.val needle - ) - , ( "search", FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) criterion -> case getLast (criterion :: Last Text) of - Nothing -> E.val True :: E.SqlExpr (E.Value Bool) - Just needle -> (E.castString (course E.^. CourseName) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)) - E.||. (E.castString (course E.^. CourseShorthand) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)) - E.||. (E.castString (course E.^. CourseDescription) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)) - ) - ] - , dbtFilterUI = \mPrev -> mconcat $ catMaybes - [ Just $ prismAForm (singletonFilter "search") mPrev $ aopt textField (fslI MsgCourseFilterSearch) - , muid $> prismAForm (singletonFilter "registered" . maybePrism _PathPiece) mPrev (aopt boolField (fslI MsgCourseFilterRegistered)) - ] - , dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } - , dbtParams = def - , dbtIdent = "courses" :: Text - , dbtCsvEncode = noCsvEncode - , dbtCsvDecode = Nothing - } - -getCourseListR :: Handler Html -getCourseListR = do - muid <- maybeAuthId - let colonnade = widgetColonnade $ mconcat - [ colCourse -- colCourseDescr - , colDescription - , colSchoolShort - , colTerm - , colCShort - , maybe mempty (const colRegistered) muid - ] - whereClause = const $ E.val True - validator = def - & defaultSorting [SortDescBy "term",SortAscBy "course"] - coursesTable <- runDB $ makeCourseTable whereClause colonnade validator - defaultLayout $ do - setTitleI MsgCourseListTitle - $(widgetFile "courses") - -getTermCurrentR :: Handler Html -getTermCurrentR = do - termIds <- runDB $ selectKeysList [TermActive ==. True] [Desc TermName] - case fromNullable termIds of - Nothing -> notFound - (Just (maximum -> tid)) -> - redirect $ TermCourseListR tid -- redirect avoids problematic breadcrumbs, headings, etc. - -getTermSchoolCourseListR :: TermId -> SchoolId -> Handler Html -getTermSchoolCourseListR tid ssh = do - void . runDB $ get404 tid -- Just ensure the term exists - School{schoolName=school} <- runDB $ get404 ssh -- Just ensure the term exists - muid <- maybeAuthId - let colonnade = widgetColonnade $ mconcat - [ dbRow - , colCShort - , colDescription - , colRegFrom - , colRegTo - , colMembers - , maybe mempty (const colRegistered) muid - ] - whereClause (course, _, _) = - course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - validator = def - & defaultSorting [SortAscBy "cshort"] - coursesTable <- runDB $ makeCourseTable whereClause colonnade validator - defaultLayout $ do - setTitleI $ MsgTermSchoolCourseListTitle tid school - $(widgetFile "courses") - - -getTermCourseListR :: TermId -> Handler Html -getTermCourseListR tid = do - void . runDB $ get404 tid -- Just ensure the term exists - muid <- maybeAuthId - let colonnade = widgetColonnade $ mconcat - [ dbRow - , colCShort - , colDescription - , colSchoolShort - , colRegFrom - , colRegTo - , colMembers - , maybe mempty (const colRegistered) muid - ] - whereClause (course, _, _) = course E.^. CourseTerm E.==. E.val tid - validator = def - & defaultSorting [SortAscBy "cshort"] - coursesTable <- runDB $ makeCourseTable whereClause colonnade validator - defaultLayout $ do - setTitleI . MsgTermCourseListTitle $ tid - $(widgetFile "courses") - -getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html -getCShowR tid ssh csh = do - mbAid <- maybeAuthId - (cid,course,schoolName,participants,registration,defSFid,lecturers,assistants,correctors,tutors) <- 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 - E.on $ E.just (course E.^. CourseId) E.==. participant E.?. CourseParticipantCourse - E.&&. E.val mbAid E.==. participant E.?. CourseParticipantUser - E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId - E.where_ $ course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - E.limit 1 -- we know that there is at most one match, but we tell the DB this info too - let numParticipants = E.sub_select . E.from $ \part -> do - E.where_ $ part E.^. CourseParticipantCourse E.==. course E.^. CourseId - 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 - 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 ( 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 - correctors <- fmap (map $(unValueN 3)) . lift . E.select $ E.from $ \(sheet `E.InnerJoin` sheetCorrector `E.InnerJoin` user) -> E.distinctOnOrderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName, E.asc $ user E.^. UserEmail ] $ do - E.on $ sheetCorrector E.^. SheetCorrectorUser E.==. user E.^. UserId - E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId - E.where_ $ sheet E.^. SheetCourse E.==. E.val cid - E.orderBy [ E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName ] - return ( user E.^. UserEmail, user E.^. UserDisplayName, user E.^. UserSurname ) - tutors <- fmap (map $(unValueN 3)) . lift . E.select $ E.from $ \(tutorial `E.InnerJoin` tutor `E.InnerJoin` user) -> E.distinctOnOrderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName, E.asc $ user E.^. UserEmail ] $ do - E.on $ tutor E.^. TutorUser E.==. user E.^. UserId - E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId - E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid - E.orderBy [ E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName ] - return ( user E.^. UserEmail, user E.^. UserDisplayName, user E.^. UserSurname ) - return (cid,course,schoolName,participants,registration,entityKey <$> defSFid,lecturers,assistants,correctors,tutors) - - mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course - mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course - mDereg <- traverse (formatTime SelFormatDateTime) $ courseDeregisterUntil course - mRegAt <- traverse (formatTime SelFormatDateTime) $ courseParticipantRegistration <$> registration - (regWidget, regEnctype) <- generateFormPost $ courseRegisterForm mbAid registration defSFid $ courseRegisterSecret course - let regForm = wrapForm regWidget def - { formAction = Just . SomeRoute $ CourseR tid ssh csh CRegisterR - , formEncoding = regEnctype - , formSubmit = FormNoSubmit - } - registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True - - let - tutorialDBTable = DBTable{..} - where - dbtSQLQuery tutorial = do - E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid - return tutorial - dbtRowKey = (E.^. TutorialId) - dbtProj = return - dbtColonnade = dbColonnade $ mconcat - [ sortable (Just "type") (i18nCell MsgTutorialType) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> textCell $ CI.original tutorialType - , sortable (Just "name") (i18nCell MsgTutorialName) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> indicatorCell <> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) [whamlet|#{tutorialName}|] - , sortable Nothing (i18nCell MsgTutorialTutors) $ \DBRow{ dbrOutput = Entity tutid _ } -> sqlCell $ do - tutTutors <- fmap (map $(unValueN 3)) . E.select . E.from $ \(tutor `E.InnerJoin` user) -> do - E.on $ tutor E.^. TutorUser E.==. user E.^. UserId - E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid - return (user E.^. UserEmail, user E.^. UserDisplayName, user E.^. UserSurname) - return [whamlet| - $newline never -