From 222d566bdaa84382b24299d6e9179eb2ebb09564 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel <> Date: Fri, 24 Jul 2020 18:52:54 +0200 Subject: [PATCH 01/62] feat(course-visibility): add visibleFrom,visibleTo add visibleFrom and visibleTo to model, add fields (CEditR), add info (CShowR) --- messages/uniworx/de-de-formal.msg | 9 ++++++++- messages/uniworx/en-eu.msg | 7 +++++++ models/courses.model | 2 ++ package-lock.json | 3 +-- src/Handler/Course/Edit.hs | 12 ++++++++++++ src/Handler/Course/Show.hs | 1 + templates/course.hamlet | 19 +++++++++++++++++++ 7 files changed, 50 insertions(+), 3 deletions(-) diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index e54dde4cd..6beb6b500 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -53,6 +53,9 @@ RegisterTo: Anmeldungen bis DeRegUntil: Abmeldungen bis RegisterRetry: Sie wurden noch nicht angemeldet. Drücken Sie dazu den Knopf "Anmelden" +CourseVisibleFrom: Sichtbar ab +CourseVisibleTo: Sichtbar bis + CourseRegistrationInterval: Anmeldung CourseDirectRegistrationInterval: Direkte Anmeldung CourseDeregisterUntil time@Text: Abmeldung nur bis #{time} @@ -112,6 +115,8 @@ CourseNoCapacity: In diesem Kurs sind keine Plätze mehr frei. TutorialNoCapacity: In dieser Übung sind keine Plätze mehr frei. ExamOccurrenceNoCapacity: Zu diesem Termin/Raum sind keine Plätze mehr frei. CourseNotEmpty: In diesem Kurs sind momentan Teilnehmer angemeldet. +CourseVisibility: Sichtbarkeit +CourseInvisible: Dieser Kurs ist momentan nicht sichtbar. TODO CourseRegistration: Kursanmeldung CourseRegisterOpen: Anmeldung möglich CourseRegisterOk: Erfolgreich zum Kurs angemeldet @@ -158,6 +163,8 @@ CourseSchoolShort: Institut CourseSchoolMultipleTip: Es stehen für Sie mehrere Institute zur Auswahl. Stellen Sie bitte sicher, dass Sie das für den Kurs korrekte Institut wählen. CourseSecretTip: Anmeldung zum Kurs erfordert Eingabe des Passworts, sofern gesetzt CourseSecretFormat: beliebige Zeichenkette +CourseVisibleFromTip: Ab diesem Zeitpunkt können andere Nutzer (außer Verwalter dieses Kurses) den Kurs sehen. Ohne Datum ist der Kurs nie für andere Nutzer sichtbar. +CourseVisibleToTip: Der Kurs ist ab "Sichtbar ab" bis zu diesem Zeitpunkt für andere Nutzer sichtbar. Ohne Datum bleibt ein sichtbarer Kurs unbegrenzt sichtbar. CourseRegisterFromTip: Ohne Datum ist keine eigenständige Anmeldung von Studierenden erlaubt. CourseRegisterToTip: Darf auch unbegrenzt offen bleiben CourseDeregisterUntilTip: Abmeldung ist ab "Anmeldungen von" bis zu diesem Zeitpunkt erlaubt. Die Abmeldung darf auch unbegrenzt erlaubt bleiben. @@ -2664,4 +2671,4 @@ SubmissionDoneNever: Nie SubmissionDoneByFile: Je nach Bewertungsdatei SubmissionDoneAlways: Immer CorrUploadSubmissionDoneMode: Bewertung abgeschlossen -CorrUploadSubmissionDoneModeTip: Sollen hochgeladene Korrekturen als abgeschlossen markiert werden? Bewertungen sind erst für Studierende sichtbar und zählen gegen Examboni, wenn sie abgeschlossen sind. \ No newline at end of file +CorrUploadSubmissionDoneModeTip: Sollen hochgeladene Korrekturen als abgeschlossen markiert werden? Bewertungen sind erst für Studierende sichtbar und zählen gegen Examboni, wenn sie abgeschlossen sind. diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 30a50e075..0687468c0 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -53,6 +53,9 @@ RegisterTo: Enrolment ends DeRegUntil: Deregistration until RegisterRetry: You haven't been enrolled. Press "Enrol for course" to enrol +CourseVisibleFrom: Visible from +CourseVisibleTo: Visible to + CourseRegistrationInterval: Enrolment CourseDirectRegistrationInterval: Direct enrolment CourseDeregisterUntil time: Deregistration only until #{time} @@ -112,6 +115,8 @@ CourseNoCapacity: Course has reached maximum capacity TutorialNoCapacity: Tutorial has reached maximum capacity ExamOccurrenceNoCapacity: Occurrence/Room has reached maximum capacity CourseNotEmpty: There are currently no participants enrolled for this course. +CourseVisibility: Visibility +CourseInvisible: This course is currently invisible. TODO CourseRegistration: Enrolment CourseRegisterOpen: Enrolment is allowed CourseRegisterOk: Successfully enrolled for course @@ -158,6 +163,8 @@ CourseSchoolShort: Department CourseSchoolMultipleTip: You may select from among multiple departments. Please ensure that you select the appropriate department for your course. CourseSecretTip: Enrollment for this course will require the password, if set CourseSecretFormat: Arbitrary string +CourseVisibleFromTip: Other users will only be able to see the course from this date onward. When left empty nobody except administrators of this course will be able to see the course. +CourseVisibleToTip: Other users will be able to see the course from "Visible From" up to this date. When left empty visible courses will remain visible indefinitely. CourseRegisterFromTip: When left empty students will not be able to enrol themselves CourseRegisterToTip: May be left empty to allow enrolment indefinitely CourseDeregisterUntilTip: Participants may deregister from immediately after registration starts up to this time. May be left empty to allow deregistration indefinitely. diff --git a/models/courses.model b/models/courses.model index db9ba46e0..708064a28 100644 --- a/models/courses.model +++ b/models/courses.model @@ -12,6 +12,8 @@ Course -- Information about a single course; contained info is always visible school SchoolId capacity Int Maybe -- number of allowed enrolements, if restricted -- canRegisterNow = maybe False (<= currentTime) registerFrom && maybe True (>= currentTime) registerTo + visibleFrom UTCTime Maybe default=now() -- course may be visible from a given day onwards or always hidden + visibleTo UTCTime Maybe -- course may be hidden from a given date onwards registerFrom UTCTime Maybe -- enrolement allowed from a given day onwwards or prohibited registerTo UTCTime Maybe -- enrolement may be prohibited from a given date onwards deregisterUntil UTCTime Maybe -- unenrolement may be prohibited from a given date onwards diff --git a/package-lock.json b/package-lock.json index fdd0d86eb..e60ada17e 100644 --- a/package-lock.json +++ b/package-lock.json @@ -10943,8 +10943,7 @@ "lodash.debounce": { "version": "4.0.8", "resolved": "https://registry.npmjs.org/lodash.debounce/-/lodash.debounce-4.0.8.tgz", - "integrity": "sha1-gteb/zCmfEAF/9XiUVMArZyk168=", - "dev": true + "integrity": "sha1-gteb/zCmfEAF/9XiUVMArZyk168=" }, "lodash.defaults": { "version": "4.2.0", diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index 03d867a6b..74f30ccb7 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -46,6 +46,8 @@ data CourseForm = CourseForm , cfAppRatingsVisible :: Bool , cfCapacity :: Maybe Int , cfSecret :: Maybe Text + , cfVisFrom :: Maybe UTCTime + , cfVisTo :: Maybe UTCTime , cfRegFrom :: Maybe UTCTime , cfRegTo :: Maybe UTCTime , cfDeRegUntil :: Maybe UTCTime @@ -77,6 +79,8 @@ courseToForm cEnt@(Entity cid Course{..}) lecs lecInvites alloc = CourseForm , cfAppText = courseApplicationsText , cfAppFiles = courseApplicationsFiles , cfAppRatingsVisible = courseApplicationsRatingsVisible + , cfVisFrom = courseVisibleFrom + , cfVisTo = courseVisibleTo , cfRegFrom = courseRegisterFrom , cfRegTo = courseRegisterTo , cfDeRegUntil = courseDeregisterUntil @@ -286,6 +290,10 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB & setTooltip MsgCourseCapacityTip) (cfCapacity <$> template) <*> aopt (textField & cfStrip) (fslpI MsgCourseSecret (mr MsgCourseSecretFormat) & setTooltip MsgCourseSecretTip) (cfSecret <$> template) + <*> aopt utcTimeField (fslpI MsgCourseVisibleFrom (mr MsgDate) + & setTooltip MsgCourseVisibleFromTip) (cfVisFrom <$> template) + <*> aopt utcTimeField (fslpI MsgCourseVisibleTo (mr MsgDate) + & setTooltip MsgCourseVisibleToTip) (cfVisTo <$> template) <*> aopt utcTimeField (fslpI MsgRegisterFrom (mr MsgDate) & setTooltip MsgCourseRegisterFromTip) (deepAlt (cfRegFrom <$> template) newRegFrom) <*> aopt utcTimeField (fslpI MsgRegisterTo (mr MsgDate) @@ -456,6 +464,8 @@ courseEditHandler miButtonAction mbCourseForm = do , courseApplicationsText = cfAppText , courseApplicationsFiles = cfAppFiles , courseApplicationsRatingsVisible = cfAppRatingsVisible + , courseVisibleFrom = cfVisFrom + , courseVisibleTo = cfVisTo , courseRegisterFrom = cfRegFrom , courseRegisterTo = cfRegTo , courseDeregisterUntil = cfDeRegUntil @@ -504,6 +514,8 @@ courseEditHandler miButtonAction mbCourseForm = do , courseApplicationsText = cfAppText , courseApplicationsFiles = cfAppFiles , courseApplicationsRatingsVisible = cfAppRatingsVisible + , courseVisibleFrom = cfVisFrom + , courseVisibleTo = cfVisTo , courseRegisterFrom = cfRegFrom , courseRegisterTo = cfRegTo , courseDeregisterUntil = cfDeRegUntil diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index d8cd57425..03be86723 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -219,6 +219,7 @@ getCShowR tid ssh csh = do hiddenEventNotes = all (\(_,CourseEvent{..}) -> is _Nothing courseEventNote) events mayCreateNews <- hasWriteAccessTo $ CourseR tid ssh csh CNewsNewR mayCreateEvents <- hasWriteAccessTo $ CourseR tid ssh csh CEventsNewR + mayEditCourse <- hasWriteAccessTo $ CourseR tid ssh csh CEditR siteLayout (toWgt $ courseName course) $ do setTitleI $ prependCourseTitle tid ssh csh (""::Text) diff --git a/templates/course.hamlet b/templates/course.hamlet index 71192130c..da5dedc5b 100644 --- a/templates/course.hamlet +++ b/templates/course.hamlet @@ -116,6 +116,7 @@ $# #{summary} #{iconLink} \ #{link} + $# $if NTop (Just 0) < NTop (courseCapacity course)
_{MsgCourseParticipantsHeading}
@@ -123,6 +124,20 @@ $# $if NTop (Just 0) < NTop (courseCapacity course) _{MsgCourseParticipantsCountOf participants capacity} $nothing _{MsgCourseParticipantsCount participants} + + $if mayEditCourse +
+ $if isJust (courseVisibleTo course) + _{MsgCourseVisibility} + $else + _{MsgCourseVisibleFrom} +
+ $maybe visFrom <- courseVisibleFrom course +

+ ^{formatTimeRangeW SelFormatDateTime visFrom (courseVisibleTo course)} + $nothing + _{MsgCourseInvisible} + $maybe (Allocation{allocationName, allocationRegisterByCourse}, url) <- mAllocation'

_{MsgCourseAllocation}
@@ -148,6 +163,7 @@ $# $if NTop (Just 0) < NTop (courseCapacity course) $maybe dereg <- mDereg

_{MsgCourseDeregisterUntil dereg} + $maybe aInst <- courseApplicationsInstructions course

$if courseApplicationsRequired course @@ -189,6 +205,7 @@ $# $if NTop (Just 0) < NTop (courseCapacity course) $nothing _{MsgNoSubmissionGroup} + $if registrationOpen || isJust registration
_{MsgCourseRegistration} @@ -210,6 +227,7 @@ $# $if NTop (Just 0) < NTop (courseCapacity course) $if isJust registration

_{MsgCourseRegistrationDeleteToEdit} +

_{MsgCourseMaterial}
@@ -217,6 +235,7 @@ $# $if NTop (Just 0) < NTop (courseCapacity course) _{MsgCourseMaterialFree} $else _{MsgCourseMaterialNotFree} + $if hasExams
_{MsgCourseExams}
From 39683928ecac97c8b4b157a81fa4bc059aacce62 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel <> Date: Fri, 24 Jul 2020 20:19:34 +0200 Subject: [PATCH 02/62] refactor(course-visibility): enhance visibility info on CShowR --- src/Handler/Course/Show.hs | 2 ++ templates/course.hamlet | 16 ++++++++-------- 2 files changed, 10 insertions(+), 8 deletions(-) diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index 03be86723..5e446f648 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -217,6 +217,8 @@ getCShowR tid ssh csh = do , all (notElem pathSeparator . view _2) fs ] hiddenEventNotes = all (\(_,CourseEvent{..}) -> is _Nothing courseEventNote) events + courseVisFrom = courseVisibleFrom course + courseVisTo = courseVisibleTo course mayCreateNews <- hasWriteAccessTo $ CourseR tid ssh csh CNewsNewR mayCreateEvents <- hasWriteAccessTo $ CourseR tid ssh csh CEventsNewR mayEditCourse <- hasWriteAccessTo $ CourseR tid ssh csh CEditR diff --git a/templates/course.hamlet b/templates/course.hamlet index da5dedc5b..e0f8e3269 100644 --- a/templates/course.hamlet +++ b/templates/course.hamlet @@ -127,16 +127,16 @@ $# $if NTop (Just 0) < NTop (courseCapacity course) $if mayEditCourse
- $if isJust (courseVisibleTo course) - _{MsgCourseVisibility} - $else + $if isJust courseVisFrom && isNothing courseVisTo _{MsgCourseVisibleFrom} + $else + _{MsgCourseVisibility}
- $maybe visFrom <- courseVisibleFrom course -

- ^{formatTimeRangeW SelFormatDateTime visFrom (courseVisibleTo course)} - $nothing - _{MsgCourseInvisible} +

+ $maybe visFrom <- courseVisFrom + ^{formatTimeRangeW SelFormatDateTime visFrom courseVisTo} + $nothing + _{MsgCourseInvisible} $maybe (Allocation{allocationName, allocationRegisterByCourse}, url) <- mAllocation'

_{MsgCourseAllocation} From 6c0adde5db117e6ad12167ebbb05a948e5c857c9 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel <> Date: Fri, 24 Jul 2020 20:37:32 +0200 Subject: [PATCH 03/62] feat(course-visibility): add invisible icon to CShowR title --- src/Handler/Course/Show.hs | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index 5e446f648..68012e885 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -210,6 +210,8 @@ getCShowR tid ssh csh = do (Any hasExams, examTable) <- runDB . mkExamTable $ Entity cid course + now <- liftIO getCurrentTime + let visibleNews = any (view _3) news showNewsFiles fs = and [ not $ null fs @@ -219,11 +221,22 @@ getCShowR tid ssh csh = do hiddenEventNotes = all (\(_,CourseEvent{..}) -> is _Nothing courseEventNote) events courseVisFrom = courseVisibleFrom course courseVisTo = courseVisibleTo course + courseIsVisible + | Just visFrom <- courseVisFrom, Just visTo <- courseVisTo = visFrom <= now && now <= visTo + | Just visFrom <- courseVisFrom = visFrom <= now + | otherwise = False mayCreateNews <- hasWriteAccessTo $ CourseR tid ssh csh CNewsNewR mayCreateEvents <- hasWriteAccessTo $ CourseR tid ssh csh CEventsNewR mayEditCourse <- hasWriteAccessTo $ CourseR tid ssh csh CEditR - siteLayout (toWgt $ courseName course) $ do + let heading = [whamlet| + $newline never + ^{courseName course} + $if not courseIsVisible + \ #{iconInvisible} + |] + + siteLayout heading $ do setTitleI $ prependCourseTitle tid ssh csh (""::Text) $(widgetFile "course") From 7af82bcb67d0ec6ae33aa82067b3d1f4de0d74de Mon Sep 17 00:00:00 2001 From: Sarah Vaupel <> Date: Fri, 24 Jul 2020 20:51:50 +0200 Subject: [PATCH 04/62] feat(course-visibility): reorder course form --- src/Handler/Course/Edit.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index 74f30ccb7..4b0fa3107 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -36,6 +36,8 @@ data CourseForm = CourseForm , cfTerm :: TermId , cfDesc :: Maybe Html , cfLink :: Maybe Text + , cfVisFrom :: Maybe UTCTime + , cfVisTo :: Maybe UTCTime , cfMatFree :: Bool , cfAllocation :: Maybe AllocationCourseForm , cfAppRequired :: Bool @@ -46,8 +48,6 @@ data CourseForm = CourseForm , cfAppRatingsVisible :: Bool , cfCapacity :: Maybe Int , cfSecret :: Maybe Text - , cfVisFrom :: Maybe UTCTime - , cfVisTo :: Maybe UTCTime , cfRegFrom :: Maybe UTCTime , cfRegTo :: Maybe UTCTime , cfDeRegUntil :: Maybe UTCTime @@ -277,7 +277,11 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB (cfDesc <$> template) <*> aopt (urlField & cfStrip) (fslpI MsgCourseHomepageExternal (mr MsgCourseHomepageExternalPlaceholder)) (cfLink <$> template) - <*> apopt checkBoxField (fslI MsgMaterialFree) (cfMatFree <$> template) + <*> aopt utcTimeField (fslpI MsgCourseVisibleFrom (mr MsgDate) + & setTooltip MsgCourseVisibleFromTip) (cfVisFrom <$> template) + <*> aopt utcTimeField (fslpI MsgCourseVisibleTo (mr MsgDate) + & setTooltip MsgCourseVisibleToTip) (cfVisTo <$> template) + <*> apopt checkBoxField (fslI MsgMaterialFree) (cfMatFree <$> template) <* aformSection MsgCourseFormSectionRegistration <*> allocationForm <*> apopt checkBoxField (fslI MsgCourseApplicationRequired & setTooltip MsgCourseApplicationRequiredTip) (cfAppRequired <$> template) @@ -290,10 +294,6 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB & setTooltip MsgCourseCapacityTip) (cfCapacity <$> template) <*> aopt (textField & cfStrip) (fslpI MsgCourseSecret (mr MsgCourseSecretFormat) & setTooltip MsgCourseSecretTip) (cfSecret <$> template) - <*> aopt utcTimeField (fslpI MsgCourseVisibleFrom (mr MsgDate) - & setTooltip MsgCourseVisibleFromTip) (cfVisFrom <$> template) - <*> aopt utcTimeField (fslpI MsgCourseVisibleTo (mr MsgDate) - & setTooltip MsgCourseVisibleToTip) (cfVisTo <$> template) <*> aopt utcTimeField (fslpI MsgRegisterFrom (mr MsgDate) & setTooltip MsgCourseRegisterFromTip) (deepAlt (cfRegFrom <$> template) newRegFrom) <*> aopt utcTimeField (fslpI MsgRegisterTo (mr MsgDate) From f50641519794bb3b3b293d56474b5c3babdd56f7 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel <> Date: Fri, 24 Jul 2020 21:52:24 +0200 Subject: [PATCH 05/62] chore(course-visibility): reformulate tips --- messages/uniworx/de-de-formal.msg | 2 +- messages/uniworx/en-eu.msg | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 6beb6b500..ba5bfa67f 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -163,7 +163,7 @@ CourseSchoolShort: Institut CourseSchoolMultipleTip: Es stehen für Sie mehrere Institute zur Auswahl. Stellen Sie bitte sicher, dass Sie das für den Kurs korrekte Institut wählen. CourseSecretTip: Anmeldung zum Kurs erfordert Eingabe des Passworts, sofern gesetzt CourseSecretFormat: beliebige Zeichenkette -CourseVisibleFromTip: Ab diesem Zeitpunkt können andere Nutzer (außer Verwalter dieses Kurses) den Kurs sehen. Ohne Datum ist der Kurs nie für andere Nutzer sichtbar. +CourseVisibleFromTip: Ab diesem Zeitpunkt ist der Kurs für andere Nutzer sichtbar. Ohne Datum ist der Kurs nie für andere Nutzer sichtbar. Verwalter, Tutoren, Korrektoren und angemeldete Teilnehmer dieses Kurses sind nicht betroffen. CourseVisibleToTip: Der Kurs ist ab "Sichtbar ab" bis zu diesem Zeitpunkt für andere Nutzer sichtbar. Ohne Datum bleibt ein sichtbarer Kurs unbegrenzt sichtbar. CourseRegisterFromTip: Ohne Datum ist keine eigenständige Anmeldung von Studierenden erlaubt. CourseRegisterToTip: Darf auch unbegrenzt offen bleiben diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 0687468c0..5bff66280 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -163,7 +163,7 @@ CourseSchoolShort: Department CourseSchoolMultipleTip: You may select from among multiple departments. Please ensure that you select the appropriate department for your course. CourseSecretTip: Enrollment for this course will require the password, if set CourseSecretFormat: Arbitrary string -CourseVisibleFromTip: Other users will only be able to see the course from this date onward. When left empty nobody except administrators of this course will be able to see the course. +CourseVisibleFromTip: The course will be visible to others from this date onward. When left empty the course will never be visible to other users. Does not affect administrators, tutors, correctors and enroled participants of this course. CourseVisibleToTip: Other users will be able to see the course from "Visible From" up to this date. When left empty visible courses will remain visible indefinitely. CourseRegisterFromTip: When left empty students will not be able to enrol themselves CourseRegisterToTip: May be left empty to allow enrolment indefinitely From b7535d764d04814f522dfcb7d677a9b48b54e4ff Mon Sep 17 00:00:00 2001 From: Sarah Vaupel <> Date: Sat, 25 Jul 2020 15:10:14 +0200 Subject: [PATCH 06/62] chore: update db fill --- test/Database/Fill.hs | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index bd02521e3..2db12951e 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -546,6 +546,8 @@ fillDb = do , courseTerm = TermKey $ seasonTerm True Summer , courseSchool = ifi , courseCapacity = Just 20 + , courseVisibleFrom = Just now + , courseVisibleTo = Nothing , courseRegisterFrom = Just $ termTime True Summer (-2) False Monday toMidnight , courseRegisterTo = Just $ termTime True Summer 0 True Sunday beforeMidnight , courseDeregisterUntil = Nothing @@ -658,6 +660,8 @@ fillDb = do , courseTerm = TermKey $ seasonTerm False Winter , courseSchool = ifi , courseCapacity = Just 20 + , courseVisibleFrom = Just now + , courseVisibleTo = Nothing , courseRegisterFrom = Just $ termTime False Winter (-4) False Monday toMidnight , courseRegisterTo = Nothing , courseDeregisterUntil = Nothing @@ -682,6 +686,8 @@ fillDb = do , courseTerm = TermKey $ seasonTerm True Summer , courseSchool = ifi , courseCapacity = Just 20 + , courseVisibleFrom = Just now + , courseVisibleTo = Nothing , courseRegisterFrom = Just $ termTime True Summer 0 False Monday toMidnight , courseRegisterTo = Just $ termTime True Summer (-2) True Sunday beforeMidnight , courseDeregisterUntil = Nothing @@ -706,6 +712,8 @@ fillDb = do , courseTerm = TermKey $ seasonTerm True Winter , courseSchool = ifi , courseCapacity = Just 30 + , courseVisibleFrom = Just now + , courseVisibleTo = Nothing , courseRegisterFrom = Nothing , courseRegisterTo = Nothing , courseDeregisterUntil = Nothing @@ -730,6 +738,8 @@ fillDb = do , courseTerm = TermKey $ seasonTerm True Summer , courseSchool = ifi , courseCapacity = Just 50 + , courseVisibleFrom = Just now + , courseVisibleTo = Nothing , courseRegisterFrom = Just $ termTime True Summer (-2) False Monday toMidnight , courseRegisterTo = Nothing , courseDeregisterUntil = Nothing @@ -898,6 +908,8 @@ fillDb = do , courseTerm = TermKey $ seasonTerm False Winter , courseSchool = ifi , courseCapacity = Just 50 + , courseVisibleFrom = Just now + , courseVisibleTo = Nothing , courseRegisterFrom = Nothing , courseRegisterTo = Nothing , courseDeregisterUntil = Nothing @@ -1028,6 +1040,8 @@ fillDb = do , courseTerm = TermKey $ seasonTerm False Winter , courseSchool = ifi , courseCapacity = Just 50 + , courseVisibleFrom = Just now + , courseVisibleTo = Nothing , courseRegisterFrom = Nothing , courseRegisterTo = Nothing , courseDeregisterUntil = Nothing @@ -1098,6 +1112,8 @@ fillDb = do , courseTerm = TermKey $ seasonTerm False Winter , courseSchool = ifi , courseCapacity = Just 50 + , courseVisibleFrom = Just now + , courseVisibleTo = Nothing , courseRegisterFrom = Nothing , courseRegisterTo = Nothing , courseDeregisterUntil = Nothing @@ -1153,6 +1169,8 @@ fillDb = do , courseTerm = TermKey $ seasonTerm False Winter , courseSchool = ifi , courseCapacity = Just cap + , courseVisibleFrom = Just now + , courseVisibleTo = Nothing , courseRegisterFrom = Nothing , courseRegisterTo = Nothing , courseDeregisterUntil = Nothing From 24f12896e084e9180800a0080077d90005801642 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel <> Date: Sat, 25 Jul 2020 15:10:59 +0200 Subject: [PATCH 07/62] feat(course-visibility): no invisible courses in course list --- src/Handler/Course/List.hs | 41 ++++++++++++++++++++++++++++++++++++-- 1 file changed, 39 insertions(+), 2 deletions(-) diff --git a/src/Handler/Course/List.hs b/src/Handler/Course/List.hs index 794fa74a7..50e6ec153 100644 --- a/src/Handler/Course/List.hs +++ b/src/Handler/Course/List.hs @@ -69,6 +69,35 @@ course2Registered muid (course `E.InnerJoin` _school) = E.exists . E.from $ \cou E.&&. E.just (courseParticipant E.^. CourseParticipantUser) E.==. E.val muid E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive +-- Is this user affiliated with the course in any way (except for being registered)? +course2Affiliated :: Maybe UserId -> CourseTableExpr -> E.SqlExpr (E.Value Bool) +course2Affiliated muid (course `E.InnerJoin` _school) = (E.exists (E.from (\(user `E.InnerJoin` lecturer) -> do + E.on (user E.^. UserId E.==. lecturer E.^. LecturerUser) + E.where_ (E.just (user E.^. UserId) E.==. E.val muid + E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId) + )) + ) E.||. (E.exists (E.from (\(user `E.InnerJoin` (tutor `E.InnerJoin` tutorial)) -> do + E.on (user E.^. UserId E.==. tutor E.^. TutorUser) + E.on (tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId) + E.where_ (E.just (user E.^. UserId) E.==. E.val muid + E.&&. tutorial E.^. TutorialCourse E.==. course E.^. CourseId) + )) + ) E.||. (E.exists (E.from (\(user `E.InnerJoin` (sheetCorrector `E.InnerJoin` sheet)) -> do + E.on (user E.^. UserId E.==. sheetCorrector E.^. SheetCorrectorUser) + E.on (sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId) + E.where_ (E.just (user E.^. UserId) E.==. E.val muid + E.&&. sheet E.^. SheetCourse E.==. course E.^. CourseId) + )) + ) + --) E.||. (E.exists (E.from (\(user `E.InnerJoin` (submissionUser `E.InnerJoin` (submission `E.InnerJoin` sheet))) -> do + -- E.on (user E.^. UserId E.==. submissionUser E.^. SubmissionUserUser) + -- E.on (submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId) + -- E.on (submission E.^. SubmissionSheet E.==. sheet E.^. SheetId) + -- E.where_ (E.just (user E.^. UserId) E.==. E.val muid + -- E.&&. sheet E.^. SheetCourse E.==. course E.^. CourseId) + -- )) + --) + 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 @@ -79,7 +108,8 @@ makeCourseTable whereClause colChoices psValidator = 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) + let affiliated = course2Affiliated muid qin + E.where_ $ whereClause (course, participants, registered, affiliated) return (course, participants, registered, school) lecturerQuery cid (user `E.InnerJoin` lecturer) = do E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser @@ -191,6 +221,7 @@ makeCourseTable whereClause colChoices psValidator = do getCourseListR :: Handler Html getCourseListR = do muid <- maybeAuthId + now <- liftIO getCurrentTime let colonnade = widgetColonnade $ mconcat [ colCourse -- colCourseDescr , colDescription @@ -199,7 +230,13 @@ getCourseListR = do , colCShort , maybe mempty (const colRegistered) muid ] - whereClause = const $ E.val True + mnow = E.val $ Just now + whereClause (course, _, registered, affiliated) = registered E.||. affiliated + E.||. (E.isJust (course E.^. CourseVisibleFrom) + E.&&. course E.^. CourseVisibleFrom E.<=. mnow + E.&&. (E.isNothing (course E.^. CourseVisibleTo) + E.||. mnow E.<=. course E.^. CourseVisibleTo) + ) validator = def & defaultSorting [SortDescBy "term",SortAscBy "course"] coursesTable <- runDB $ makeCourseTable whereClause colonnade validator From cbb8e7217d2ec256fff0b09eed1665c7f7d30c1b Mon Sep 17 00:00:00 2001 From: Sarah Vaupel <> Date: Sat, 25 Jul 2020 15:15:16 +0200 Subject: [PATCH 08/62] fix(course-visibility): show icon to lecturers only --- src/Handler/Course/Show.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index 68012e885..3165bf4b0 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -232,7 +232,7 @@ getCShowR tid ssh csh = do let heading = [whamlet| $newline never ^{courseName course} - $if not courseIsVisible + $if not courseIsVisible && mayEditCourse \ #{iconInvisible} |] From 17dbccf2a343cf1571ef0aaf07d6064bf3a2a216 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel <> Date: Sat, 25 Jul 2020 16:38:23 +0200 Subject: [PATCH 09/62] feat(course-visibility): display icon in course list for lecturers --- src/Handler/Course/List.hs | 31 ++++++++++++++------- src/Handler/Utils/Table/Pagination.hs | 8 ++++-- templates/table/course/course-teaser.hamlet | 2 ++ 3 files changed, 29 insertions(+), 12 deletions(-) diff --git a/src/Handler/Course/List.hs b/src/Handler/Course/List.hs index 50e6ec153..7b065505b 100644 --- a/src/Handler/Course/List.hs +++ b/src/Handler/Course/List.hs @@ -22,39 +22,39 @@ import qualified Database.Esqueleto.Utils as E -- NOTE: Outdated way to use dbTable; see ProfileDataR Handler for a more recent method. -type CourseTableData = DBRow (Entity Course, Int, Bool, Entity School, [Entity User], Maybe (Entity Allocation)) +type CourseTableData = DBRow (Entity Course, Int, Bool, Entity School, [Entity User], Maybe (Entity Allocation), Bool) colCourse :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) colCourse = sortable (Just "course") (i18nCell MsgCourse) - $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _, _, _) } -> + $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _, _, _, _) } -> anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|_{courseName}|] colDescription :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) colDescription = sortable Nothing mempty - $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _, _, _) } -> + $ \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{..}, _, _, _, _, _) } -> + $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _, _, _, _) } -> anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|_{courseShorthand}|] colTerm :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) colTerm = sortable (Just "term") (i18nCell MsgTerm) - $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _, _, _) } -> + $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _, _, _, _) } -> anchorCell (TermCourseListR courseTerm) [whamlet|#{courseTerm}|] colSchoolShort :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) colSchoolShort = sortable (Just "schoolshort") (i18nCell MsgCourseSchoolShort) - $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, Entity _ School{..}, _, _) } -> + $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, Entity _ School{..}, _, _, _) } -> anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|_{schoolShorthand}|] colRegistered :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) colRegistered = sortable (Just "registered") (i18nCell MsgRegistered) - $ \DBRow{ dbrOutput=(_, _, registered, _, _, _) } -> tickmarkCell registered + $ \DBRow{ dbrOutput=(_, _, registered, _, _, _, _) } -> tickmarkCell registered type CourseTableExpr = E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity School) @@ -115,12 +115,18 @@ makeCourseTable whereClause colChoices psValidator = do E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser E.where_ $ cid E.==. lecturer E.^. LecturerCourse E.&&. lecturer E.^. LecturerType E.==. E.val CourseLecturer return user + isLecturerQuery cid (user `E.InnerJoin` lecturer) = do + E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser + E.where_ $ cid E.==. lecturer E.^. LecturerCourse + E.&&. E.just (user E.^. UserId) E.==. E.val muid + return user dbtProj :: DBRow _ -> DB CourseTableData dbtProj = traverse $ \(course, E.Value participants, E.Value registered, school) -> do lecturerList <- E.select $ E.from $ lecturerQuery $ E.val $ entityKey course courseAlloc <- getBy (UniqueAllocationCourse $ entityKey course) >>= traverse (getJustEntity . allocationCourseAllocation . entityVal) - return (course, participants, registered, school, lecturerList, courseAlloc) + isLecturerList <- E.select $ E.from $ isLecturerQuery $ E.val $ entityKey course + return (course, participants, registered, school, lecturerList, courseAlloc, not $ null isLecturerList) snd <$> dbTable psValidator DBTable { dbtSQLQuery , dbtRowKey = \(course `E.InnerJoin` _) -> course E.^. CourseId @@ -209,8 +215,13 @@ makeCourseTable whereClause colChoices psValidator = do ] , dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout - , dbsTemplate = DBSTCourse (_dbrOutput . _1) (_dbrOutput . _5) (_dbrOutput . _3) (_dbrOutput . _4) (_dbrOutput . _6 . _Just) - -- ^ course ^ lecturer list ^ isRegistered ^ school ^ allocation + , dbsTemplate = DBSTCourse + (_dbrOutput . _1) -- course + (_dbrOutput . _5) -- lecturer list + (_dbrOutput . _3) -- isRegistered + (_dbrOutput . _4) -- school + (_dbrOutput . _6 . _Just) -- allocation + (_dbrOutput . _7) -- isLecturer } , dbtParams = def , dbtIdent = "courses" :: Text diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 9a22aab88..e9ca08981 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -529,7 +529,7 @@ data DBStyle r = DBStyle } data DBSTemplateMode r = DBSTDefault { dbstmNumber :: Int64 -> Bool, dbstmShowNumber :: Int64 -> Bool } - | DBSTCourse (Lens' r (Entity Course)) (Lens' r [Entity User]) (Lens' r Bool) (Lens' r (Entity School)) (Traversal' r (Entity Allocation)) + | DBSTCourse (Lens' r (Entity Course)) (Lens' r [Entity User]) (Lens' r Bool) (Lens' r (Entity School)) (Traversal' r (Entity Allocation)) (Lens' r Bool) instance Default (DBStyle r) where def = DBStyle @@ -1323,13 +1323,17 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db DBSTDefault{} -> return $(widgetFile "table/cell/header") in do wHeaders <- maybe (return Nothing) (fmap Just . genHeaders (dbtColonnade ^. _Cornice)) pSortable + now <- liftIO getCurrentTime case dbsTemplate of - DBSTCourse c l r s a -> do + DBSTCourse c l r s a l' -> do wRows <- forM rows $ \row' -> let Course{..} = row' ^. c . _entityVal lecturerUsers = row' ^. l courseLecturers = userSurname . entityVal <$> lecturerUsers isRegistered = row' ^. r + isLecturer = row' ^. l' + nmnow = NTop $ Just now + courseIsVisible = NTop courseVisibleFrom <= nmnow && nmnow <= NTop courseVisibleTo courseSchoolName = schoolName $ row' ^. s . _entityVal courseSemester = (termToText . unTermKey) courseTerm courseAllocation = row' ^? a diff --git a/templates/table/course/course-teaser.hamlet b/templates/table/course/course-teaser.hamlet index 72e49742e..5db2cf4b0 100644 --- a/templates/table/course/course-teaser.hamlet +++ b/templates/table/course/course-teaser.hamlet @@ -9,6 +9,8 @@
_{courseName} + $if not courseIsVisible && isLecturer + \ #{iconInvisible} $if isRegistered
_{MsgRegistered} From 96869079902aa9ae000246effe2125af60ecfb46 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel <> Date: Sat, 25 Jul 2020 17:10:15 +0200 Subject: [PATCH 10/62] chore(course-visibility): add more description --- messages/uniworx/de-de-formal.msg | 4 ++-- messages/uniworx/en-eu.msg | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index ba5bfa67f..7ef9afe0a 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -116,7 +116,7 @@ TutorialNoCapacity: In dieser Übung sind keine Plätze mehr frei. ExamOccurrenceNoCapacity: Zu diesem Termin/Raum sind keine Plätze mehr frei. CourseNotEmpty: In diesem Kurs sind momentan Teilnehmer angemeldet. CourseVisibility: Sichtbarkeit -CourseInvisible: Dieser Kurs ist momentan nicht sichtbar. TODO +CourseInvisible: Dieser Kurs ist momentan nur für Dozenten, Assistenten, Tutoren, Korrektoren und angemeldete Teilnehmer sichtbar. CourseRegistration: Kursanmeldung CourseRegisterOpen: Anmeldung möglich CourseRegisterOk: Erfolgreich zum Kurs angemeldet @@ -163,7 +163,7 @@ CourseSchoolShort: Institut CourseSchoolMultipleTip: Es stehen für Sie mehrere Institute zur Auswahl. Stellen Sie bitte sicher, dass Sie das für den Kurs korrekte Institut wählen. CourseSecretTip: Anmeldung zum Kurs erfordert Eingabe des Passworts, sofern gesetzt CourseSecretFormat: beliebige Zeichenkette -CourseVisibleFromTip: Ab diesem Zeitpunkt ist der Kurs für andere Nutzer sichtbar. Ohne Datum ist der Kurs nie für andere Nutzer sichtbar. Verwalter, Tutoren, Korrektoren und angemeldete Teilnehmer dieses Kurses sind nicht betroffen. +CourseVisibleFromTip: Ab diesem Zeitpunkt ist der Kurs für andere Nutzer sichtbar. Ohne Datum ist der Kurs nie für andere Nutzer sichtbar. Dozenten, Assistenten, Tutoren, Korrektoren und angemeldete Teilnehmer dieses Kurses sind nicht betroffen. CourseVisibleToTip: Der Kurs ist ab "Sichtbar ab" bis zu diesem Zeitpunkt für andere Nutzer sichtbar. Ohne Datum bleibt ein sichtbarer Kurs unbegrenzt sichtbar. CourseRegisterFromTip: Ohne Datum ist keine eigenständige Anmeldung von Studierenden erlaubt. CourseRegisterToTip: Darf auch unbegrenzt offen bleiben diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 5bff66280..bbdfa4e5f 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -116,7 +116,7 @@ TutorialNoCapacity: Tutorial has reached maximum capacity ExamOccurrenceNoCapacity: Occurrence/Room has reached maximum capacity CourseNotEmpty: There are currently no participants enrolled for this course. CourseVisibility: Visibility -CourseInvisible: This course is currently invisible. TODO +CourseInvisible: This course is currently only visible to lecturers, assistants, tutors, correctors and enrolled participants. CourseRegistration: Enrolment CourseRegisterOpen: Enrolment is allowed CourseRegisterOk: Successfully enrolled for course @@ -163,7 +163,7 @@ CourseSchoolShort: Department CourseSchoolMultipleTip: You may select from among multiple departments. Please ensure that you select the appropriate department for your course. CourseSecretTip: Enrollment for this course will require the password, if set CourseSecretFormat: Arbitrary string -CourseVisibleFromTip: The course will be visible to others from this date onward. When left empty the course will never be visible to other users. Does not affect administrators, tutors, correctors and enroled participants of this course. +CourseVisibleFromTip: The course will be visible to others from this date onward. When left empty the course will never be visible to other users. Does not affect lecturers, assistants, tutors, correctors and enrolled participants of this course. CourseVisibleToTip: Other users will be able to see the course from "Visible From" up to this date. When left empty visible courses will remain visible indefinitely. CourseRegisterFromTip: When left empty students will not be able to enrol themselves CourseRegisterToTip: May be left empty to allow enrolment indefinitely From d86fed7a32badfe75ef124145e1c59086771c164 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel <> Date: Sat, 25 Jul 2020 18:20:00 +0200 Subject: [PATCH 11/62] feat(course-visibility): hide invisible courses from favourites + icon --- src/Foundation.hs | 27 +++++++++++++++------- templates/widgets/asidenav/asidenav.hamlet | 7 ++++-- 2 files changed, 24 insertions(+), 10 deletions(-) diff --git a/src/Foundation.hs b/src/Foundation.hs index 284fe8ae1..30498f0f3 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1977,6 +1977,8 @@ siteLayout' headingOverride widget = do -- isParent r = r == (fst parents) isAuth <- isJust <$> maybeAuthId + + now <- liftIO getCurrentTime -- Lookup Favourites & Theme if possible (favourites', maxFavouriteTerms, currentTheme) <- do @@ -2021,7 +2023,14 @@ siteLayout' headingOverride widget = do E.where_ $ ((isFavourite E.||. isAssociated) E.&&. notBlacklist) E.||. isCurrent - return (course, reason) + E.where_ $ (E.isJust (course E.^. CourseVisibleFrom) + E.&&. course E.^. CourseVisibleFrom E.<=. E.val (Just now) + E.&&. (E.isNothing (course E.^. CourseVisibleTo) + E.||. E.val (Just now) E.<=. course E.^. CourseVisibleTo + ) + ) E.||. isAssociated + + return (course, reason, isLecturer) return ( favCourses , maybe userDefaultMaxFavouriteTerms userMaxFavouriteTerms $ view _2 <$> muid @@ -2029,9 +2038,9 @@ siteLayout' headingOverride widget = do ) let favouriteTerms :: [TermIdentifier] - favouriteTerms = take maxFavouriteTerms . Set.toDescList $ foldMap (\(Entity _ Course{..}, _) -> Set.singleton $ unTermKey courseTerm) favourites' + favouriteTerms = take maxFavouriteTerms . Set.toDescList $ foldMap (\(Entity _ Course{..}, _, _) -> Set.singleton $ unTermKey courseTerm) favourites' - favourites <- fmap catMaybes . forM favourites' $ \(Entity cId c@Course{..}, E.Value mFavourite) + favourites <- fmap catMaybes . forM favourites' $ \(Entity cId c@Course{..}, E.Value mFavourite, E.Value isLecturer) -> let courseRoute = CourseR courseTerm courseSchool courseShorthand CShowR favouriteReason = fromMaybe FavouriteCurrent mFavourite in runMaybeT . guardOnM (unTermKey courseTerm `elem` favouriteTerms) . lift $ do @@ -2053,7 +2062,7 @@ siteLayout' headingOverride widget = do $logDebugS "FavouriteQuickActions" $ tshow cK <> " Done." return items $logDebugS "FavouriteQuickActions" $ tshow cK <> " returning " <> tshow (is _Just items) - return (c, courseRoute, items, favouriteReason) + return (c, courseRoute, items, favouriteReason, isLecturer) nav'' <- mconcat <$> sequence [ defaultLinks @@ -2085,10 +2094,10 @@ siteLayout' headingOverride widget = do navItems = map (view _2) favourites ++ toListOf (folded . typesUsing @NavChildren @NavLink . to urlRoute) nav highR = find (`elem` navItems) . uncurry (++) $ partition (`elem` map (view _2) favourites) crumbs highlightNav = (||) <$> navForceActive <*> highlight - favouriteTermReason :: TermIdentifier -> FavouriteReason -> [(Course, Route UniWorX, Maybe [(Text, Text)], FavouriteReason)] + favouriteTermReason :: TermIdentifier -> FavouriteReason -> [(Course, Route UniWorX, Maybe [(Text, Text)], FavouriteReason, Bool)] favouriteTermReason tid favReason' = favourites - & filter (\(Course{..}, _, _, favReason) -> unTermKey courseTerm == tid && favReason == favReason') - & sortOn (\(Course{..}, _, _, _) -> courseName) + & filter (\(Course{..}, _, _, favReason, _) -> unTermKey courseTerm == tid && favReason == favReason') + & sortOn (\(Course{..}, _, _, _, _) -> courseName) -- We break up the default layout into two components: -- default-layout is the contents of the body tag, and @@ -2187,7 +2196,9 @@ siteLayout' headingOverride widget = do isNavHeaderSecondary = has $ _1 . _navHeaderRole . only NavHeaderSecondary asidenav :: Widget asidenav = $(widgetFile "widgets/asidenav/asidenav") - where logo = preEscapedToMarkup $ decodeUtf8 $(embedFile "assets/lmu/logo.svg") + where + logo = preEscapedToMarkup $ decodeUtf8 $(embedFile "assets/lmu/logo.svg") + courseIsVisible Course{courseVisibleFrom,courseVisibleTo} = NTop courseVisibleFrom <= NTop (Just now) && NTop (Just now) <= NTop courseVisibleTo footer :: Widget footer = $(widgetFile "widgets/footer/footer") where isNavFooter = has $ _1 . _NavFooter diff --git a/templates/widgets/asidenav/asidenav.hamlet b/templates/widgets/asidenav/asidenav.hamlet index c27bd7696..d765c5b66 100644 --- a/templates/widgets/asidenav/asidenav.hamlet +++ b/templates/widgets/asidenav/asidenav.hamlet @@ -21,11 +21,14 @@ $newline never

_{favReason}