diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 494f7490a..ae182100e 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,9 @@ 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 nur für Dozenten, Assistenten, Tutoren, Korrektoren, angemeldete Teilnehmer und Bewerber sichtbar. +CourseInvisibleOverridenByAllocation: Da die Zentralanmeldung, an welcher der Kurs teilnimmt aktuell offen für Bewerbungen ist, wird die Kurssichtbarkeit während der Bewerbungsphase forciert. Außerhalb der Bewerbungsphase ist der Kurs nur für Dozenten, Assistenten, Tutoren, Korrektoren, angemeldete Teilnehmer und Bewerber sichtbar. CourseRegistration: Kursanmeldung CourseRegisterOpen: Anmeldung möglich CourseRegisterOk: Erfolgreich zum Kurs angemeldet @@ -158,6 +164,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 ist der Kurs für andere Nutzer sichtbar. Ohne Datum ist der Kurs nie für andere Nutzer sichtbar. Dozenten, Assistenten, Tutoren, Korrektoren, angemeldete Teilnehmer sowie Bewerber dieses Kurses sind nicht betroffen. Nimmt der Kurs an einer Zentralanmeldung teil wird die Kurssichtbarkeit während der Bewerbungsphase forciert. +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. @@ -263,6 +271,7 @@ CourseLecturerEmail: E-Mail CourseLecturer: Dozent CourseAssistant: Assistent CourseLecturerAlreadyAdded: Dieser Nutzer ist bereits als Kursverwalter eingetragen +CourseVisibilityEndMustBeAfterStart: Ende des Sichtbarkeitszeitraums muss nach dem Anfang liegen CourseRegistrationEndMustBeAfterStart: Ende des Anmeldezeitraums muss nach dem Anfang liegen CourseDeregistrationEndMustBeAfterStart: Ende des Abmeldezeitraums muss nach dem Anfang des Anmeldezeitraums liegen CourseUserMustBeLecturer: Aktueller Benutzer muss als Kursverwalter eingetragen sein @@ -270,6 +279,7 @@ CourseAllocationRequiresCapacity: Bei Teilnahme an einer Zentralanmeldung muss e CourseAllocationTermMustMatch: Kurs-Semester muss mit Semester der Zentralanmeldung übereinstimmen CourseAllocationCapacityMayNotBeChanged: Kapazität eines Kurses, der an einer Zentralanmeldung teilnimmt, darf nicht nachträglich verändert werden CourseShorthandTooLong: Lange Kurskürzel können zu Problemen bei der Darstellung und der Kommunikation mit den Studierenden führen. Bitte wählen Sie ein weniger langes Kürzel, falls möglich. +CourseNotAlwaysVisibleDuringRegistration: Um Studierenden über den gesamten Anmeldezeitraum hinweg die Anmeldung zum Kurs zu ermöglichen, sollte der Kurs auch über den gesamten Anmeldezeitraum hinweg sichtbar sein (dies ist aktuell nicht gegeben). CourseLecturerRightsIdentical: Alle Sorten von Kursverwalter haben identische Rechte. @@ -468,7 +478,8 @@ UnauthorizedParticipant: Angegebener Benutzer ist nicht als Teilnehmer dieser Ve UnauthorizedParticipantSelf: Sie sind kein Teilnehmer dieser Veranstaltung. UnauthorizedApplicant: Angegebener Benutzer hat sich nicht für diese Veranstaltung beworben. UnauthorizedApplicantSelf: Sie sind kein Bewerber für diese Veranstaltung. -UnauthorizedCourseTime: Dieses Kurs erlaubt momentan keine Anmeldungen. +UnauthorizedCourseTime: Dieser Kurs ist momentan nicht freigegeben. +UnauthorizedCourseRegistrationTime: Dieses Kurs erlaubt momentan keine Anmeldungen. UnauthorizedAllocationRegisterTime: Diese Zentralanmeldung erlaubt momentan keine Bewerbungen. UnauthorizedSheetTime: Dieses Übungsblatt ist momentan nicht freigegeben. UnauthorizedApplicationTime: Diese Bewerbung ist momentan nicht freigegeben. @@ -1440,6 +1451,7 @@ AuthTagTutorControl: Tutoren haben Kontrolle über ihre Tutorium AuthTagTime: Zeitliche Einschränkungen sind erfüllt AuthTagStaffTime: Zeitliche Einschränkungen für Lehrbeteiligte sind erfüllt AuthTagAllocationTime: Zeitliche Einschränkungen durch Zentralanmeldung sind erfüllt +AuthTagCourseTime: Zeitliche Einschränkungen für Kurssichtbarkeit sind erfüllt AuthTagCourseRegistered: Nutzer ist Kursteilnehmer AuthTagAllocationRegistered: Nutzer nimmt an der Zentralanmeldung teil AuthTagTutorialRegistered: Nutzer ist Tutoriumsteilnehmer @@ -2367,6 +2379,7 @@ CourseDeregisterNoShow: „Nicht erschienen“ bei Abmeldung CourseDeregisterNoShowTip: Soll, wenn sich Teilnehmer selbstständig abmelden, für alle Prüfungen dieses Kurses „nicht erschienen“ als Prüfungsleistung eingetragen werden? Dies geschieht einmalig bei der Abmeldung (sofern nicht bereits eine Prüfungsleistung existiert) und automatisch beim Anlegen von neuen Prüfungen. CourseDeregistrationAllocationShouldLog: Selbstverschuldet CourseDeregistrationAllocationShouldLogTip: Falls der Platz des Studierenden, der abgemeldet wird, aus einer Zentralanmeldung stammt, ist vorgesehen einen permanenten Eintrag im System zu speichern, der den Studierenden u.U. bei zukünftigen Zentralanmeldungen benachteiligt. Als Kursverwalter haben Sie die Möglichkeit dies zu unterbinden, wenn der Studierende gute Gründe vorweisen kann, warum seine Abmeldung nicht selbstverschuldet ist. +CourseDeregistrationFromInvisibleCourse: Dieser Kurs ist nur für angemeldete Teilnehmer und Bewerber sichtbar. Wenn Sie sich jetzt abmelden, können Sie danach nicht wieder auf den Kurs zugreifen! MailSubjectAllocationResults allocation@AllocationName: Plätze für Zentralanmeldung „#{allocation}“ wurden verteilt AllocationResultsLecturer: Im Rahmen der oben genannten Zentralanmeldung wurden Plätze zugewiesen, wie folgt: @@ -2670,4 +2683,4 @@ CorrUploadSubmissionDoneModeTip: Sollen hochgeladene Korrekturen als abgeschloss AdminCrontabNotGenerated: (Noch) keine Crontab generiert CronMatchAsap: ASAP -CronMatchNone: Nie \ No newline at end of file +CronMatchNone: Nie diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 192c8a8d6..6a41d64b5 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,9 @@ 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 only visible to lecturers, assistants, tutors, correctors, enrolled participants and applicants. +CourseInvisibleOverridenByAllocation: Because the allocation this course participates in is currently open for application, the course is forced to be visible. After the application phase, the course will only be visible to lecturers, assistants, tutors, correctors, enrolled participants and applicants. CourseRegistration: Enrolment CourseRegisterOpen: Enrolment is allowed CourseRegisterOk: Successfully enrolled for course @@ -158,6 +164,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: The course will be visible to others from this date onward. When left empty the course will never be visible to other users. This does not affect lecturers, assistants, tutors, correctors, enrolled participants and applicants of/to this course. If the course participates in a central allocation, the course visibility will be forced during the application phase. +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. @@ -262,13 +270,15 @@ CourseLecturerEmail: Email CourseLecturer: Lecturer CourseAssistant: Assistant CourseLecturerAlreadyAdded: This user is already configured as a course administrator -CourseRegistrationEndMustBeAfterStart: The end of the registration period must be before its start +CourseVisibilityEndMustBeAfterStart: The end of the visibility period must be after its start +CourseRegistrationEndMustBeAfterStart: The end of the registration period must be after its start CourseDeregistrationEndMustBeAfterStart: The end of the deregistration period must be after the start of the registration period CourseUserMustBeLecturer: The current user needs to be a course administrator CourseAllocationRequiresCapacity: Course capacity needs to be specified if the course participates in a central allocation CourseAllocationTermMustMatch: Course semester needs to match the semester of the central allocation CourseAllocationCapacityMayNotBeChanged: The capacity of a course that participates in a central allocation must not be altered CourseShorthandTooLong: Long course shorthands may lead to display issues and might complicate communication with students. Please choose a more concise shorthand if possible. +CourseNotAlwaysVisibleDuringRegistration: To allow for students to register, the course should also be visible during the entire registration period (which is currently not the case). CourseLecturerRightsIdentical: All sorts of course administrators have the same permissions. @@ -466,7 +476,8 @@ UnauthorizedParticipant: The specified user is no participant of this course. UnauthorizedParticipantSelf: You are no participant of this course. UnauthorizedApplicant: The specified user is no applicant for this course. UnauthorizedApplicantSelf: You are no applicant for this course. -UnauthorizedCourseTime: This course does not currently allow enrollment. +UnauthorizedCourseTime: This course is not currently available. +UnauthorizedCourseRegistrationTime: This course does not currently allow enrollment. UnauthorizedAllocationRegisterTime: This central allocation does not currently allow applications. UnauthorizedSheetTime: This sheet is not currently available. UnauthorizedApplicationTime: This allocation is not currently available. @@ -1440,6 +1451,7 @@ AuthTagTutorControl: Tutors have control over their tutorial AuthTagTime: Time restrictions are fulfilled AuthTagStaffTime: Time restrictions wrt. staff are fulfilled AuthTagAllocationTime: Time restrictions due to a central allocation are fulfilled +AuthTagCourseTime: Time restrictions wrt. course visibility are fulfilled AuthTagCourseRegistered: User is enrolled in course AuthTagAllocationRegistered: User participates in central allocation AuthTagTutorialRegistered: User is tutorial participant @@ -2367,6 +2379,7 @@ CourseDeregisterNoShow: Record “no show” when deregistering CourseDeregisterNoShowTip: Should “no show” be recorded as the exam achievement for all exams associated with this course automatically whenever a course participant deregisters themselves? This would be done once upon deregistration (if no other achievement exists for the given exam) and automatically whenever a new exam is created. CourseDeregistrationAllocationShouldLog: Self imposed CourseDeregistrationAllocationShouldLogTip: If the participant was enrolled in this course due to a central allocation, it is intended that a permanent record be made that might affect the student negatively in future central allocations. As a course administrator you have the right to prevent this if the participant can present good reasons why them leaving the course is not self imposed. +CourseDeregistrationFromInvisibleCourse: This course is only visible to enrolled participants and applicants. If you deregister now, you will not be able to access the course again! MailSubjectAllocationResults allocation: Placements have been made for the central allocation “#{allocation}” AllocationResultsLecturer: In the course of the central allocations placements have been made as follows: 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 97223ff05..db0d4db57 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/routes b/routes index e28cbc4d0..d8ae9561b 100644 --- a/routes +++ b/routes @@ -125,10 +125,10 @@ /course/ CourseListR GET !free !/course/new CourseNewR GET POST !lecturer /course/#TermId/#SchoolId/#CourseShorthand CourseR !lecturer: - / CShowR GET !free + / CShowR GET !tutor !corrector !exam-corrector !course-registered !course-time !evaluation !exam-office !allocation-admin /favourite CFavouriteR POST - /register CRegisterR GET POST !timeANDcapacityANDallocation-timeAND¬course-registered !timeANDallocation-timeAND¬exam-resultANDcourse-registered !lecturerANDallocation-time - /register-template CRegisterTemplateR GET !free + /register CRegisterR GET POST !timeANDcapacityANDallocation-timeAND¬course-registeredANDcourse-time !timeANDallocation-timeAND¬exam-resultANDcourse-registered !lecturerANDallocation-time + /register-template CRegisterTemplateR GET !course-time /edit CEditR GET POST /lecturer-invite CLecInviteR GET POST /delete CDeleteR GET POST !lecturerANDemptyANDallocation-time @@ -142,18 +142,18 @@ /exam-office CExamOfficeR GET POST !course-registered /subs CCorrectionsR GET POST /subs/assigned CAssignR GET POST - /sheet SheetListR GET !course-registered !materials !corrector !tutor + /sheet SheetListR GET !course-registered !materialsANDcourse-time !corrector !tutor /sheet/new SheetNewR GET POST - /sheet/current SheetCurrentR GET !course-registered !materials !corrector !tutor + /sheet/current SheetCurrentR GET !course-registered !materialsANDcourse-time !corrector !tutor /sheet/unassigned SheetOldUnassignedR GET /sheet/#SheetName SheetR: - /show SShowR GET !timeANDcourse-registered !timeANDmaterials !corrector !timeANDtutor - /show/download SArchiveR GET !timeANDcourse-registeredANDexam-registered !timeANDmaterialsANDexam-registered !corrector !timeANDtutor + /show SShowR GET !timeANDcourse-registered !timeANDmaterialsANDcourse-time !corrector !timeANDtutor + /show/download SArchiveR GET !timeANDcourse-registeredANDexam-registered !timeANDmaterialsANDexam-registeredANDcourse-time !corrector !timeANDtutor /edit SEditR GET POST /delete SDelR GET POST /subs SSubsR GET POST -- for lecturer only !/subs/new SubmissionNewR GET POST !timeANDcourse-registeredANDuser-submissionsANDsubmission-groupANDexam-registered - !/subs/own SubmissionOwnR GET !free -- just redirect + !/subs/own SubmissionOwnR GET !free !/subs/assign SAssignR GET POST !lecturerANDtime /subs/#CryptoFileNameSubmission SubmissionR: / SubShowR GET POST !ownerANDtimeANDuser-submissionsANDsubmission-groupANDexam-registered !ownerANDread !correctorANDread @@ -168,14 +168,14 @@ /corrector-invite/ SCorrInviteR GET POST !/#SheetFileType SZipR GET !timeANDcourse-registeredANDexam-registered !timeANDmaterialsANDexam-registered !corrector !timeANDtutor !/#SheetFileType/*FilePath SFileR GET !timeANDcourse-registeredANDexam-registered !timeANDmaterialsANDexam-registered !corrector !timeANDtutor - /file MaterialListR GET !course-registered !materials !corrector !tutor + /file MaterialListR GET !course-registered !materialsANDcourse-time !corrector !tutor /file/new MaterialNewR GET POST /file/#MaterialName MaterialR: /edit MEditR GET POST /delete MDelR GET POST - /show MShowR GET !timeANDcourse-registered !timeANDmaterials !corrector !tutor - !/download MArchiveR GET !timeANDcourse-registered !timeANDmaterials !corrector !tutor - !/download/*FilePath MFileR GET !timeANDcourse-registered !timeANDmaterials !corrector !tutor + /show MShowR GET !timeANDcourse-registered !timeANDmaterialsANDcourse-time !corrector !tutor + !/download MArchiveR GET !timeANDcourse-registered !timeANDmaterialsANDcourse-time !corrector !tutor + !/download/*FilePath MFileR GET !timeANDcourse-registered !timeANDmaterialsANDcourse-time !corrector !tutor /tuts CTutorialListR GET !tutor -- THIS route is used to check for overall course tutor access! /tuts/new CTutorialNewR GET POST /tuts/#TutorialName TutorialR: @@ -185,10 +185,10 @@ /register TRegisterR POST !timeANDcapacityANDcourse-registeredANDregister-group !timeANDtutorial-registered /communication TCommR GET POST !tutor /tutor-invite TInviteR GET POST !tutorANDtutor-control - /exams CExamListR GET !free + /exams CExamListR GET !tutor !corrector !exam-corrector !course-registered !course-time !exam-office /exams/new CExamNewR GET POST /exams/#ExamName ExamR: - /show EShowR GET !time !exam-office + /show EShowR GET !timeANDtutor !timeANDcorrector !timeANDexam-corrector !timeANDcourse-registered !timeANDcourse-time !exam-office /edit EEditR GET POST /corrector-invite ECInviteR GET POST /users EUsersR GET POST diff --git a/src/Foundation.hs b/src/Foundation.hs index 1388997c0..439368913 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -75,6 +75,7 @@ import Handler.Utils.ExamOffice.Course import Handler.Utils.Profile import Handler.Utils.Routes import Handler.Utils.Memcached +import Utils.Course (courseIsVisible) import Utils.Form import Utils.Sheet import Utils.SystemMessage @@ -532,6 +533,11 @@ tagAccessPredicate AuthExamOffice = APDB $ \mAuthId route _ -> case route of E.where_ $ examOfficeExternalExamResultAuth (E.val authId) eexamResult guardMExceptT hasUsers $ unauthorizedI MsgUnauthorizedExternalExamExamOffice return Authorized + CourseR _ ssh _ _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isExamOffice <- lift . existsBy $ UniqueUserFunction authId ssh SchoolExamOffice + guardMExceptT isExamOffice $ unauthorizedI MsgUnauthorizedExamExamOffice + return Authorized _other -> $cachedHereBinary mAuthId . exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId isExamOffice <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolExamOffice] @@ -543,6 +549,11 @@ tagAccessPredicate AuthEvaluation = APDB $ \mAuthId route _ -> case route of isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolEvaluation guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedEvaluation return Authorized + CourseR _ ssh _ _ -> $cachedHereBinary(mAuthId, ssh) . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolEvaluation + guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedEvaluation + return Authorized _other -> $cachedHereBinary mAuthId . exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId isEvaluation <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolEvaluation] @@ -554,6 +565,11 @@ tagAccessPredicate AuthAllocationAdmin = APDB $ \mAuthId route _ -> case route o isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolAllocation guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedAllocationAdmin return Authorized + CourseR _ ssh _ _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolAllocation + guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedAllocationAdmin + return Authorized _other -> $cachedHereBinary mAuthId . exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId isEvaluation <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAllocation] @@ -654,12 +670,23 @@ tagAccessPredicate AuthExamCorrector = APDB $ \mAuthId route _ -> case route of authId <- maybeExceptT AuthenticationRequired $ return mAuthId isCorrector <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examCorrector) -> do E.on $ examCorrector E.^. ExamCorrectorExam E.==. exam E.^. ExamId - E.&&. examCorrector E.^. ExamCorrectorUser E.==. E.val authId E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId - 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.&&. exam E.^. ExamName E.==. E.val examn + E.where_ $ examCorrector E.^. ExamCorrectorUser E.==. E.val authId + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.&&. exam E.^. ExamName E.==. E.val examn + guardMExceptT isCorrector $ unauthorizedI MsgUnauthorizedExamCorrector + return Authorized + CourseR tid ssh csh _ -> $cachedHereBinary (tid, ssh, csh) . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isCorrector <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examCorrector) -> do + E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse + E.on $ exam E.^. ExamId E.==. examCorrector E.^. ExamCorrectorExam + E.where_ $ examCorrector E.^. ExamCorrectorUser E.==. E.val authId + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh guardMExceptT isCorrector $ unauthorizedI MsgUnauthorizedExamCorrector return Authorized r -> $unsupportedAuthPredicate AuthExamCorrector r @@ -828,7 +855,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of , maybe True (now <=) courseRegisterTo -> return Authorized (Just (Entity cid Course{courseDeregisterUntil})) | registered - -> maybeT (unauthorizedI MsgUnauthorizedCourseTime) $ do + -> maybeT (unauthorizedI MsgUnauthorizedCourseRegistrationTime) $ do guard $ maybe True (now <=) courseDeregisterUntil forM_ mAuthId $ \uid -> do exams <- lift . E.select . E.from $ \exam -> do @@ -849,8 +876,8 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of forM_ tutorials $ \(E.Value deregUntil) -> guard $ NTop (Just now) <= NTop deregUntil return Authorized - _other -> unauthorizedI MsgUnauthorizedCourseTime - + _other -> unauthorizedI MsgUnauthorizedCourseRegistrationTime + CApplicationR tid ssh csh _ _ -> maybeT (unauthorizedI MsgUnauthorizedApplicationTime) $ do Entity course Course{..} <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh allocationCourse <- $cachedHereBinary course . lift . getBy $ UniqueAllocationCourse course @@ -971,6 +998,17 @@ tagAccessPredicate AuthAllocationTime = APDB $ \mAuthId route _ -> case route of cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh Entity _ AllocationCourse{..} <- MaybeT . getBy $ UniqueAllocationCourse cid (cid,) <$> MaybeT (get allocationCourseAllocation) +tagAccessPredicate AuthCourseTime = APDB $ \_mAuthId route _ -> case route of + CourseR tid ssh csh _ -> exceptT return return $ do + now <- liftIO getCurrentTime + courseVisible <- $cachedHereBinary (tid, ssh, csh) . lift . E.selectExists . E.from $ \course -> do + 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.&&. courseIsVisible now course Nothing + guardMExceptT courseVisible (unauthorizedI MsgUnauthorizedCourseTime) + return Authorized + r -> $unsupportedAuthPredicate AuthCourseTime r tagAccessPredicate AuthCourseRegistered = APDB $ \mAuthId route _ -> case route of CourseR tid ssh csh _ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId @@ -1460,7 +1498,7 @@ authTagSpecificity = comparing $ NTop . flip findIndex eqClasses . elem [ [ AuthFree, AuthDeprecated, AuthDevelopment ] -- Route wide , [ AuthRead, AuthWrite, AuthToken ] -- Request wide , [ AuthAdmin ] -- Site wide - , [ AuthLecturer, AuthCourseRegistered, AuthParticipant, AuthTime, AuthMaterials, AuthUserSubmissions, AuthCorrectorSubmissions, AuthCapacity, AuthEmpty ] ++ [ AuthSelf, AuthNoEscalation ] ++ [ AuthAuthentication ] -- Course/User/SystemMessage wide + , [ AuthLecturer, AuthCourseRegistered, AuthParticipant, AuthCourseTime, AuthTime, AuthMaterials, AuthUserSubmissions, AuthCorrectorSubmissions, AuthCapacity, AuthEmpty ] ++ [ AuthSelf, AuthNoEscalation ] ++ [ AuthAuthentication ] -- Course/User/SystemMessage wide , [ AuthCorrector ] ++ [ AuthTutor ] ++ [ AuthTutorialRegistered, AuthRegisterGroup ] -- Tutorial/Material/Sheet wide , [ AuthOwner, AuthRated ] -- Submission wide ] @@ -1961,12 +1999,14 @@ siteLayout' headingOverride widget = do -- isParent r = r == (fst parents) isAuth <- isJust <$> maybeAuthId + + now <- liftIO getCurrentTime -- Lookup Favourites & Theme if possible (favourites', maxFavouriteTerms, currentTheme) <- do muid <- maybeAuthPair - favCourses <- runDB . E.select . E.from $ \(course `E.LeftOuterJoin` courseFavourite) -> do + favCourses'' <- runDB . E.select . E.from $ \(course `E.LeftOuterJoin` courseFavourite) -> do E.on $ E.just (course E.^. CourseId) E.==. courseFavourite E.?. CourseFavouriteCourse E.&&. courseFavourite E.?. CourseFavouriteUser E.==. E.val (view _1 <$> muid) @@ -1997,6 +2037,7 @@ siteLayout' headingOverride widget = do E.&&. tutorial E.^. TutorialCourse E.==. course E.^. CourseId E.where_ $ E.just (tutor E.^. TutorUser) E.==. E.val (view _1 <$> muid) isAssociated = isParticipant E.||. isLecturer E.||. isCorrector E.||. isTutor + courseVisible = courseIsVisible now course Nothing reason = E.case_ [ E.when_ isCurrent E.then_ . E.just $ E.val FavouriteCurrent @@ -2005,7 +2046,14 @@ siteLayout' headingOverride widget = do E.where_ $ ((isFavourite E.||. isAssociated) E.&&. notBlacklist) E.||. isCurrent - return (course, reason) + return (course, reason, courseVisible) + + favCourses' <- forM favCourses'' $ \(course@(Entity _ Course{..}), reason, E.Value courseVisible) -> do + mayView <- hasReadAccessTo $ CourseR courseTerm courseSchool courseShorthand CShowR + mayEdit <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR + return (course, reason, courseVisible, mayView, mayEdit) + + let favCourses = favCourses' & filter (\(_, _, _, mayView, _) -> mayView) return ( favCourses , maybe userDefaultMaxFavouriteTerms userMaxFavouriteTerms $ view _2 <$> muid @@ -2013,9 +2061,9 @@ siteLayout' headingOverride widget = do ) let favouriteTerms :: [TermIdentifier] - 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) + 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, courseVisible, mayView, mayEdit) -> let courseRoute = CourseR courseTerm courseSchool courseShorthand CShowR favouriteReason = fromMaybe FavouriteCurrent mFavourite in runMaybeT . guardOnM (unTermKey courseTerm `elem` favouriteTerms) . lift $ do @@ -2037,7 +2085,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, courseVisible, mayView, mayEdit) nav'' <- mconcat <$> sequence [ defaultLinks @@ -2069,10 +2117,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, Bool, 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 @@ -2171,7 +2219,8 @@ 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") footer :: Widget footer = $(widgetFile "widgets/footer/footer") where isNavFooter = has $ _1 . _NavFooter diff --git a/src/Handler/Allocation/List.hs b/src/Handler/Allocation/List.hs index 549209bf8..c2bc4faea 100644 --- a/src/Handler/Allocation/List.hs +++ b/src/Handler/Allocation/List.hs @@ -6,6 +6,8 @@ module Handler.Allocation.List import Import +import Utils.Course (mayViewCourse) + import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E import Handler.Utils.Table.Columns @@ -23,18 +25,23 @@ queryAllocation = id countCourses :: (Num n, PersistField n) - => (E.SqlExpr (Entity AllocationCourse) -> E.SqlExpr (E.Value Bool)) + => Maybe UserId -> AuthTagActive -> UTCTime + -> (E.SqlExpr (Entity AllocationCourse) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity Allocation) -> E.SqlExpr (E.Value n) -countCourses addWhere allocation = E.subSelectCount . E.from $ \allocationCourse -> +countCourses muid ata now addWhere allocation = E.subSelectCount . E.from $ \allocationCourse -> E.where_ $ allocationCourse E.^. AllocationCourseAllocation E.==. allocation E.^. AllocationId - E.&&. addWhere allocationCourse - -queryAvailable :: Getter AllocationTableExpr (E.SqlExpr (E.Value Natural)) -queryAvailable = queryAllocation . to (countCourses $ const E.true) - -queryApplied :: UserId -> Getter AllocationTableExpr (E.SqlExpr (E.Value Natural)) -queryApplied uid = queryAllocation . to (\allocation -> countCourses (addWhere allocation) allocation) + E.&&. E.exists (E.from $ \course -> E.where_ $ + course E.^. CourseId E.==. allocationCourse E.^. AllocationCourseCourse + E.&&. mayViewCourse muid ata now course (Just (allocation E.^. AllocationId)) + ) E.&&. addWhere allocationCourse + +queryAvailable :: Maybe UserId -> AuthTagActive -> UTCTime + -> Getter AllocationTableExpr (E.SqlExpr (E.Value Natural)) +queryAvailable muid ata now = queryAllocation . to (countCourses muid ata now $ const E.true) + +queryApplied :: AuthTagActive -> UTCTime -> UserId -> Getter AllocationTableExpr (E.SqlExpr (E.Value Natural)) +queryApplied ata now uid = queryAllocation . to (\allocation -> countCourses (Just uid) ata now (addWhere allocation) allocation) where addWhere allocation allocationCourse = E.exists . E.from $ \courseApplication -> @@ -61,13 +68,14 @@ allocationLink Allocation{..} = SomeRoute $ AllocationR allocationTerm allocatio getAllocationListR :: Handler Html getAllocationListR = do muid <- maybeAuthId + ata <- getSessionActiveAuthTags now <- liftIO getCurrentTime let dbtSQLQuery :: AllocationTableExpr -> E.SqlQuery _ dbtSQLQuery = runReaderT $ (,,) <$> view queryAllocation - <*> view queryAvailable - <*> view (maybe (to . const $ E.val 0) queryApplied muid) + <*> view (queryAvailable muid ata now) + <*> view (maybe (to . const $ E.val 0) (queryApplied ata now) muid) dbtProj :: DBRow _ -> DB AllocationTableData dbtProj = return . over (_dbrOutput . _2) E.unValue . over (_dbrOutput . _3) E.unValue @@ -91,10 +99,10 @@ getAllocationListR = do [ sortTerm $ queryAllocation . to (E.^. AllocationTerm) , sortSchoolShort $ queryAllocation . to (E.^. AllocationSchool) , sortAllocationName $ queryAllocation . to (E.^. AllocationName) - , singletonMap "available" . SortColumn $ view queryAvailable + , singletonMap "available" . SortColumn $ view (queryAvailable muid ata now) , if | Just uid <- muid - -> singletonMap "applied" . SortColumn . view $ queryApplied uid + -> singletonMap "applied" . SortColumn . view $ queryApplied ata now uid | otherwise -> mempty ] diff --git a/src/Handler/Allocation/Show.hs b/src/Handler/Allocation/Show.hs index c374501e0..1df2e5506 100644 --- a/src/Handler/Allocation/Show.hs +++ b/src/Handler/Allocation/Show.hs @@ -3,18 +3,23 @@ module Handler.Allocation.Show ) where import Import + +import Utils.Course + import Handler.Utils import Handler.Allocation.Register import Handler.Allocation.Application import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E getAShowR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html getAShowR tid ssh ash = do muid <- maybeAuthId now <- liftIO getCurrentTime + ata <- getSessionActiveAuthTags let resultCourse :: Simple Field1 a (Entity Course) => Lens' a (Entity Course) @@ -25,6 +30,8 @@ getAShowR tid ssh ash = do resultHasTemplate = _3 . _Value resultIsRegistered :: Simple Field4 a (E.Value Bool) => Lens' a Bool resultIsRegistered = _4 . _Value + resultCourseVisible :: Simple Field5 a (E.Value Bool) => Lens' a Bool + resultCourseVisible = _5 . _Value (Entity aId Allocation{..}, School{..}, isAnyLecturer, courses, registration) <- runDB $ do alloc@(Entity aId Allocation{allocationSchool}) <- getBy404 $ TermSchoolAllocationShort tid ssh ash @@ -32,17 +39,20 @@ getAShowR tid ssh ash = do courses <- E.select . E.from $ \((allocationCourse `E.InnerJoin` course) `E.LeftOuterJoin` courseApplication `E.LeftOuterJoin` registration) -> do E.on $ registration E.?. CourseParticipantCourse E.==. E.just (course E.^. CourseId) - E.&&. registration E.?. CourseParticipantUser E.==. E.val muid - E.&&. registration E.?. CourseParticipantState E.==. E.just (E.val CourseParticipantActive) + E.&&. registration E.?. CourseParticipantUser E.==. E.val muid + E.&&. registration E.?. CourseParticipantState E.==. E.just (E.val CourseParticipantActive) E.on $ courseApplication E.?. CourseApplicationCourse E.==. E.just (course E.^. CourseId) - E.&&. courseApplication E.?. CourseApplicationUser E.==. E.val muid - E.&&. courseApplication E.?. CourseApplicationAllocation E.==. E.just (E.just $ E.val aId) + E.&&. courseApplication E.?. CourseApplicationUser E.==. E.val muid + E.&&. courseApplication E.?. CourseApplicationAllocation E.==. E.just (E.just $ E.val aId) E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId E.where_ $ allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId + E.&&. ( E.isJust (courseApplication E.?. CourseApplicationId) + E.||. mayViewCourse muid ata now course (Just $ E.val aId) + ) E.orderBy [E.asc $ course E.^. CourseName] let hasTemplate = E.exists . E.from $ \courseAppInstructionFile -> E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. course E.^. CourseId - return (course, courseApplication, hasTemplate, E.not_ . E.isNothing $ registration E.?. CourseParticipantId) + return (course, courseApplication, hasTemplate, E.not_ . E.isNothing $ registration E.?. CourseParticipantId, courseIsVisible now course (Just (E.val aId))) registration <- fmap join . for muid $ getBy . UniqueAllocationUser aId @@ -77,8 +87,10 @@ getAShowR tid ssh ash = do hasApplicationTemplate = cEntry ^. resultHasTemplate mApp = cEntry ^? resultCourseApplication isRegistered = cEntry ^. resultIsRegistered + courseVisible = cEntry ^. resultCourseVisible cID <- encrypt cid :: WidgetFor UniWorX CryptoUUIDCourse mayApply <- hasWriteAccessTo . AllocationR tid ssh ash $ AApplyR cID + mayEdit <- hasWriteAccessTo $ CourseR tid ssh courseShorthand CEditR isLecturer <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR mApplyFormView <- liftHandler . for muid $ \uid -> generateFormPost . applicationForm (Just aId) cid uid $ ApplicationFormMode True mayApply isLecturer tRoute <- case mApp of diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index 2bc825445..09e032bbb 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 @@ -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 @@ -102,6 +106,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB -- TODO: Refactor to avoid the four repeated calls to liftHandler and three runDBs -- let editCid = cfCourseId =<< template -- possible start for refactoring + now <- liftIO getCurrentTime MsgRenderer mr <- getMsgRenderer uid <- liftHandler requireAuthId @@ -190,13 +195,15 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB unliftEither (Right (lid , lType )) = (Right lid , Just lType) unliftEither (Left (lEmail, mLType)) = (Left lEmail, mLType ) - (newRegFrom,newRegTo,newDeRegUntil) <- case template of - (Just cform) | (Just _cid) <- cfCourseId cform -> return (Nothing,Nothing,Nothing) + (newVisFrom,newRegFrom,newRegTo,newDeRegUntil) <- case template of + (Just cform) | (Just _cid) <- cfCourseId cform -> return (Nothing,Nothing,Nothing,Nothing) _allIOtherCases -> do mbLastTerm <- liftHandler $ runDB $ selectFirst [TermActive ==. True] [Desc TermName] - return ( Just . toMidnight . termStart . entityVal <$> mbLastTerm + return ( Just $ Just now + , Just . toMidnight . termStart . entityVal <$> mbLastTerm , Just . beforeMidnight . termEnd . entityVal <$> mbLastTerm - , Just . beforeMidnight . termEnd . entityVal <$> mbLastTerm ) + , Just . beforeMidnight . termEnd . entityVal <$> mbLastTerm + ) let allocationForm :: AForm Handler (Maybe AllocationCourseForm) @@ -214,7 +221,6 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB E.||. allocation E.^. AllocationSchool `E.in_` E.valList adminSchools return (allocation, alreadyParticipates) - now <- liftIO getCurrentTime let allocationEnabled :: Entity Allocation -> Bool allocationEnabled (Entity _ Allocation{..}) @@ -273,7 +279,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) (deepAlt (cfVisFrom <$> template) newVisFrom) + <*> 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) @@ -319,6 +329,8 @@ validateCourse = do | otherwise -> return Nothing + guardValidation MsgCourseVisibilityEndMustBeAfterStart + $ NTop cfVisFrom <= NTop cfVisTo guardValidation MsgCourseRegistrationEndMustBeAfterStart $ NTop cfRegFrom <= NTop cfRegTo guardValidation MsgCourseDeregistrationEndMustBeAfterStart @@ -335,7 +347,9 @@ validateCourse = do warnValidation MsgCourseShorthandTooLong $ length (CI.original cfShort) <= 10 - + warnValidation MsgCourseNotAlwaysVisibleDuringRegistration + $ NTop cfVisFrom <= NTop cfRegFrom && NTop cfRegTo <= NTop cfVisTo + getCourseNewR :: Handler Html -- call via toTextUrl getCourseNewR = do @@ -456,6 +470,8 @@ courseEditHandler miButtonAction mbCourseForm = do , courseApplicationsText = cfAppText , courseApplicationsFiles = cfAppFiles , courseApplicationsRatingsVisible = cfAppRatingsVisible + , courseVisibleFrom = cfVisFrom + , courseVisibleTo = cfVisTo , courseRegisterFrom = cfRegFrom , courseRegisterTo = cfRegTo , courseDeregisterUntil = cfDeRegUntil @@ -504,6 +520,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/List.hs b/src/Handler/Course/List.hs index 794fa74a7..a996fc3e5 100644 --- a/src/Handler/Course/List.hs +++ b/src/Handler/Course/List.hs @@ -10,6 +10,7 @@ import Import import Data.Maybe (fromJust) +import Utils.Course import Utils.Form -- import Utils.DB import Handler.Utils hiding (colSchoolShort) @@ -22,75 +23,75 @@ 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) course2Participants :: CourseTableExpr -> E.SqlExpr (E.Value Int) -course2Participants (course `E.InnerJoin` _school) = E.subSelectCount . E.from $ \courseParticipant -> - E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId - E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive +course2Participants (course `E.InnerJoin` _school) = numCourseParticipants $ course E.^. CourseId -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 - E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive +course2Registered :: Maybe UserId -> AuthTagActive -> CourseTableExpr -> E.SqlExpr (E.Value Bool) +course2Registered muid ata (course `E.InnerJoin` _school) = isCourseParticipant muid ata $ 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 muid <- lift maybeAuthId now <- liftIO getCurrentTime + ata <- getSessionActiveAuthTags 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) + let registered = course2Registered muid ata qin + let mayView = mayViewCourse muid ata now course Nothing + E.where_ $ whereClause (course, participants, registered, mayView) return (course, participants, registered, school) lecturerQuery cid (user `E.InnerJoin` lecturer) = 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 + isEditorQuery course user = E.where_ $ mayEditCourse' muid ata course + E.&&. E.just (user E.^. UserId) E.==. E.val muid 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) + isEditorList <- E.select $ E.from $ isEditorQuery course + return (course, participants, registered, school, lecturerList, courseAlloc, not $ null isEditorList) snd <$> dbTable psValidator DBTable { dbtSQLQuery , dbtRowKey = \(course `E.InnerJoin` _) -> course E.^. CourseId @@ -105,7 +106,7 @@ makeCourseTable whereClause colChoices psValidator = do , ( "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) + , ( "registered", SortColumn $ course2Registered muid ata) ] , dbtFilter = Map.fromList -- OverloadedLists does not work with the templates here [ ( "course", FilterColumn $ \(course `E.InnerJoin` _school:: CourseTableExpr) criterias -> if @@ -160,7 +161,7 @@ makeCourseTable whereClause colChoices psValidator = do ) , ( "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 + Just needle -> course2Registered muid ata 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) @@ -179,8 +180,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) -- mayEditCourse } , dbtParams = def , dbtIdent = "courses" :: Text @@ -199,7 +205,7 @@ getCourseListR = do , colCShort , maybe mempty (const colRegistered) muid ] - whereClause = const $ E.val True + whereClause (_, _, _, mayView) = mayView validator = def & defaultSorting [SortDescBy "term",SortAscBy "course"] coursesTable <- runDB $ makeCourseTable whereClause colonnade validator diff --git a/src/Handler/Course/Register.hs b/src/Handler/Course/Register.hs index 117f99b38..e0cd7f593 100644 --- a/src/Handler/Course/Register.hs +++ b/src/Handler/Course/Register.hs @@ -10,12 +10,15 @@ import Import import Handler.Utils +import Utils.Course + import qualified Data.Text as Text import qualified Data.Conduit.List as C import Database.Persist.Sql (transactionUndo) import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E -- Dedicated CourseRegistrationButton @@ -47,6 +50,9 @@ courseRegisterForm :: (MonadHandler m, HandlerSite m ~ UniWorX) => Entity Course -- ^ `CourseRegisterForm` for current user courseRegisterForm (Entity cid Course{..}) = liftHandler $ do muid <- maybeAuthId + ata <- getSessionActiveAuthTags + now <- liftIO getCurrentTime + (registration, application) <- runDB $ do registration <- fmap join . for muid $ fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy . flip UniqueParticipant cid application <- fmap (listToMaybe =<<) . for muid $ \uid -> selectList [CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid, CourseApplicationAllocation ==. Nothing] [] @@ -141,10 +147,23 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do | otherwise -> aFormToWForm $ fileUploadForm False (fslI . mkFs) courseApplicationsFiles + mayViewCourseAfterDeregistration <- liftHandler . runDB $ E.selectExists . E.from $ \course -> E.where_ $ + course E.^. CourseId E.==. E.val cid + E.&&. ( isSchoolAdminLike muid ata (course E.^. CourseSchool) + E.||. mayEditCourse muid ata course + E.||. courseIsVisible now course Nothing + E.||. isCourseLecturer muid ata (course E.^. CourseId) + E.||. isCourseTutor muid ata (course E.^. CourseId) + E.||. isCourseSheetCorrector muid ata (course E.^. CourseId) + E.||. isCourseExamCorrector muid ata (course E.^. CourseId) + ) + when (is _Just $ registration >>= courseParticipantAllocated . entityVal) $ wformMessage =<< messageIconI Warning IconExamRegisterFalse MsgCourseDeregistrationAllocationLog when (is _Just (registration >>= courseParticipantAllocated . entityVal) && courseDeregisterNoShow) $ wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationNoShow + when (isRegistered && not mayViewCourseAfterDeregistration) $ + wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationFromInvisibleCourse return $ CourseRegisterForm <$ secretRes @@ -246,7 +265,13 @@ postCRegisterR tid ssh csh = do BtnCourseRetractApplication -> runDB $ do deleteApplications uid cid addMessageIconI Info IconApplyFalse MsgCourseRetractApplyOk - redirect $ CourseR tid ssh csh CShowR + muid <- maybeAuthId + ata <- getSessionActiveAuthTags + now <- liftIO getCurrentTime + courseVisible <- runDB . E.selectExists . E.from $ \c -> E.where_ $ + c E.^. CourseId E.==. E.val cid + E.&&. mayViewCourse muid ata now c Nothing + redirect $ bool NewsR (CourseR tid ssh csh CShowR) courseVisible deleteApplications :: UserId -> CourseId -> DB () deleteApplications uid cid = do diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index 0ea29fc68..619c79818 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -5,6 +5,7 @@ module Handler.Course.Show import Import +import Utils.Course import Utils.Form import Handler.Utils import qualified Database.Esqueleto.Utils as E @@ -26,8 +27,9 @@ import Handler.Exam.List (mkExamTable) getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCShowR tid ssh csh = do mbAid <- maybeAuthId - (cid,course,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news,events,submissionGroup) <- runDB . maybeT notFound $ do - [(E.Entity cid course, E.Value schoolName, E.Value participants, fmap entityVal -> registration)] + now <- liftIO getCurrentTime + (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen) <- runDB . maybeT notFound $ do + [(E.Entity cid course, E.Value courseVisible, E.Value schoolName, E.Value participants, fmap entityVal -> registration, E.Value hasAllocationRegistrationOpen)] <- lift . E.select . E.from $ \((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do E.on $ E.just (course E.^. CourseId) E.==. participant E.?. CourseParticipantCourse @@ -42,7 +44,7 @@ getCShowR tid ssh csh = do numParticipants = E.subSelectCount . E.from $ \part -> E.where_ $ part E.^. CourseParticipantCourse E.==. course E.^. CourseId E.&&. part E.^. CourseParticipantState E.==. E.val CourseParticipantActive - return (course,school E.^. SchoolName, numParticipants, participant) + return (course, courseIsVisible now course Nothing, school E.^. SchoolName, numParticipants, participant, courseAllocationRegistrationOpen now (course E.^. CourseId) Nothing) 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 @@ -86,9 +88,9 @@ getCShowR tid ssh csh = do & over (mapped . _1) E.unValue & over (mapped . _2) E.unValue lastEditText <- formatTime SelFormatDateTime $ maybe id max (guardOn visible =<< courseNewsVisibleFrom) courseNewsLastEdit - mayEdit <- hasWriteAccessTo $ CNewsR tid ssh csh cID CNEditR + mayEditNews <- hasWriteAccessTo $ CNewsR tid ssh csh cID CNEditR mayDelete <- hasWriteAccessTo $ CNewsR tid ssh csh cID CNDeleteR - return (cID, n, visible, files, lastEditText, mayEdit, mayDelete) + return (cID, n, visible, files, lastEditText, mayEditNews, mayDelete) events' <- fmap (sortOn $ courseEventTime . entityVal) . lift $ selectList [ CourseEventCourse ==. cid ] [] events <- mapM (\(Entity evId ev) -> (, ev) <$> encrypt evId) events' @@ -104,7 +106,7 @@ getCShowR tid ssh csh = do return $ submissionGroup E.^. SubmissionGroupName let submissionGroup = guardOnM (hasSubmissionGroups && is _Just registration) submissionGroup' - return (cid,course,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news,events,submissionGroup) + return (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen) let mDereg' = maybe id min (allocationOverrideDeregister =<< mAllocation) <$> courseDeregisterUntil course mDereg <- traverse (formatTime SelFormatDateTime) mDereg' @@ -216,10 +218,19 @@ getCShowR tid ssh csh = do , all (notElem pathSeparator . view _2) fs ] hiddenEventNotes = all (\(_,CourseEvent{..}) -> is _Nothing courseEventNote) events + Course{courseVisibleFrom,courseVisibleTo} = course mayCreateNews <- hasWriteAccessTo $ CourseR tid ssh csh CNewsNewR mayCreateEvents <- hasWriteAccessTo $ CourseR tid ssh csh CEventsNewR + mayEdit <- hasWriteAccessTo $ CourseR tid ssh csh CEditR - siteLayout (toWgt $ courseName course) $ do + let heading = [whamlet| + $newline never + ^{courseName course} + $if not courseVisible && mayEdit + \ #{iconInvisible} + |] + + siteLayout heading $ do setTitleI $ prependCourseTitle tid ssh csh (""::Text) $(widgetFile "course") diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index aae806f26..d4173fcc7 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -28,23 +28,34 @@ import Handler.Submission.Upload import Import -import Handler.Utils - import qualified Database.Esqueleto as E getSubmissionOwnR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html +-- For security reasons (unauthorized users not being allowed to have +-- guesses about which sheets/courses exist confirmed) this handlers +-- behaviour may not allow users to distinguish between: +-- - course does not exist (answers 404) +-- - course exists but sheet does not (answers 404) +-- - course and sheet exist but user has no submission (answers 404) +-- - course and sheet exist, user has submission, but is not +-- authorized to know course/sheet/submission exists (impossible, +-- because @!ownerANDread@ is sufficient for access to `SubShowR`; +-- having access to `SubShowR` allows user to determine +-- course/sheet from url) getSubmissionOwnR tid ssh csh shn = do authId <- requireAuthId - sid <- runDB $ do - shid <- fetchSheetId tid ssh csh shn - submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do - E.on (submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission) - E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val authId - E.&&. submission E.^. SubmissionSheet E.==. E.val shid + sid <- runDB . maybeT notFound $ do + submissions <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) -> do + E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission + E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet + E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse + E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val authId + E.&&. sheet E.^. SheetName E.==. E.val shn + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseTerm E.==. E.val tid return $ submission E.^. SubmissionId - case submissions of - (E.Value sid : _) -> return sid - [] -> notFound + hoistMaybe $ submissions ^? _head . _Value cID <- encrypt sid - redirect $ CSubmissionR tid ssh csh shn cID SubShowR + redirectAccess $ CSubmissionR tid ssh csh shn cID SubShowR diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index 329dcf839..f44ce3030 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -5,7 +5,11 @@ module Handler.Term ) where import Import + +import Utils.Course (mayViewCourse) + import Handler.Utils + import qualified Data.Map as Map import qualified Database.Esqueleto as E @@ -62,11 +66,15 @@ validateTerm = do getTermShowR :: Handler Html getTermShowR = do + muid <- maybeAuthId + now <- liftIO getCurrentTime + ata <- getSessionActiveAuthTags table <- runDB $ let termDBTable = DBTable{..} where dbtSQLQuery term = return (term, courseCount) where courseCount = E.subSelectCount . E.from $ \course -> E.where_ $ term E.^. TermId E.==. course E.^. CourseTerm + E.&&. mayViewCourse muid ata now course Nothing dbtRowKey = (E.^. TermId) dbtProj = return . dbrOutput dbtColonnade = widgetColonnade $ mconcat diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 06c7666b4..7b20b4bc0 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -529,7 +529,13 @@ 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)) -- course + (Lens' r [Entity User]) -- lecturers + (Lens' r Bool) -- isRegistered + (Lens' r (Entity School)) -- school + (Traversal' r (Entity Allocation)) -- allocation + (Lens' r Bool) -- mayEditCourse instance Default (DBStyle r) where def = DBStyle @@ -1323,13 +1329,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 e -> do wRows <- forM rows $ \row' -> let Course{..} = row' ^. c . _entityVal lecturerUsers = row' ^. l courseLecturers = userSurname . entityVal <$> lecturerUsers isRegistered = row' ^. r + mayEdit = row' ^. e + 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/src/Model/Types/Security.hs b/src/Model/Types/Security.hs index 8507da7d0..27490f784 100644 --- a/src/Model/Types/Security.hs +++ b/src/Model/Types/Security.hs @@ -66,6 +66,7 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä | AuthTime | AuthStaffTime | AuthAllocationTime + | AuthCourseTime | AuthMaterials | AuthOwner | AuthRated @@ -121,6 +122,9 @@ instance Binary AuthTagActive where derivePersistFieldJSON ''AuthTagActive +getSessionActiveAuthTags :: MonadHandler m => m AuthTagActive +getSessionActiveAuthTags = fromMaybe def <$> lookupSessionJson SessionActiveAuthTags + data PredLiteral a = PLVariable { plVar :: a } | PLNegated { plVar :: a } deriving (Eq, Ord, Read, Show, Generic, Typeable) diff --git a/src/Utils/Course.hs b/src/Utils/Course.hs new file mode 100644 index 000000000..23a270169 --- /dev/null +++ b/src/Utils/Course.hs @@ -0,0 +1,161 @@ +module Utils.Course + ( mayViewCourse, mayViewCourse', mayEditCourse, mayEditCourse' + , isSchoolAdmin, isSchoolAdminLike + , isCourseLecturer, isCourseTutor, isCourseSheetCorrector, isCourseExamCorrector + , isCourseParticipant, isCourseApplicant + , isCourseAssociated + , courseIsVisible, courseIsVisible' + , courseAllocationRegistrationOpen + , numCourseParticipants + ) where + +import Import.NoFoundation + +import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E + + +mayViewCourse :: Maybe UserId -> AuthTagActive -> UTCTime -> E.SqlExpr (Entity Course) -> Maybe (E.SqlExpr (E.Value AllocationId)) -> E.SqlExpr (E.Value Bool) +mayViewCourse muid ata now course maid = + isSchoolAdminLike muid ata (course E.^. CourseSchool) + E.||. mayEditCourse muid ata course + E.||. isCourseAssociated muid ata (course E.^. CourseId) maid + E.||. courseIsVisible now course maid + +mayViewCourse' :: Maybe UserId -> AuthTagActive -> UTCTime -> Entity Course -> Maybe AllocationId -> E.SqlExpr (E.Value Bool) +mayViewCourse' muid ata now c@(Entity cid Course{courseSchool}) maid = + isSchoolAdminLike muid ata (E.val courseSchool) + E.||. mayEditCourse' muid ata c + E.||. isCourseAssociated muid ata (E.val cid) (E.val <$> maid) + E.||. courseIsVisible' now c maid + + +mayEditCourse :: Maybe UserId -> AuthTagActive -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value Bool) +mayEditCourse muid ata course = + isSchoolAdmin muid ata (course E.^. CourseSchool) + E.||. isCourseLecturer muid ata (course E.^. CourseId) + +mayEditCourse' :: Maybe UserId -> AuthTagActive -> Entity Course -> E.SqlExpr (E.Value Bool) +mayEditCourse' muid ata (Entity cid Course{..}) = + isSchoolAdmin muid ata (E.val courseSchool) + E.||. isCourseLecturer muid ata (E.val cid) + + +isSchoolAdmin :: Maybe UserId -> AuthTagActive -> E.SqlExpr (E.Value SchoolId) -> E.SqlExpr (E.Value Bool) +isSchoolAdmin muid AuthTagActive{..} ssh + | Just uid <- muid, authTagIsActive AuthAdmin = E.exists . E.from $ \(user `E.InnerJoin` userFunction) -> do + E.on $ user E.^. UserId E.==. userFunction E.^. UserFunctionUser + E.where_ $ user E.^. UserId E.==. E.val uid + E.&&. userFunction E.^. UserFunctionSchool E.==. ssh + E.&&. userFunction E.^. UserFunctionFunction E.==. E.val SchoolAdmin + | otherwise = E.false + +isSchoolAdminLike :: Maybe UserId -> AuthTagActive -> E.SqlExpr (E.Value SchoolId) -> E.SqlExpr (E.Value Bool) +isSchoolAdminLike muid ata@AuthTagActive{..} ssh + | Just uid <- muid = isSchoolAdmin muid ata ssh E.||. (E.exists . E.from $ \(user `E.InnerJoin` userFunction) -> do + E.on $ user E.^. UserId E.==. userFunction E.^. UserFunctionUser + E.where_ $ user E.^. UserId E.==. E.val uid + E.&&. userFunction E.^. UserFunctionSchool E.==. ssh + E.&&. ( (userFunction E.^. UserFunctionFunction E.==. E.val SchoolEvaluation + E.&&. E.val (authTagIsActive AuthEvaluation)) + E.||. (userFunction E.^. UserFunctionFunction E.==. E.val SchoolExamOffice + E.&&. E.val (authTagIsActive AuthExamOffice)) + E.||. (userFunction E.^. UserFunctionFunction E.==. E.val SchoolAllocation + E.&&. E.val (authTagIsActive AuthAllocationAdmin)) + ) + ) + | otherwise = E.false + +isCourseLecturer :: Maybe UserId -> AuthTagActive -> E.SqlExpr (E.Value CourseId) -> E.SqlExpr (E.Value Bool) +isCourseLecturer muid AuthTagActive{..} cid + | Just uid <- muid, authTagIsActive AuthLecturer = E.exists . E.from $ \(user `E.InnerJoin` lecturer) -> do + E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser + E.where_ $ user E.^. UserId E.==. E.val uid + E.&&. lecturer E.^. LecturerCourse E.==. cid + | otherwise = E.false + +isCourseTutor :: Maybe UserId -> AuthTagActive -> E.SqlExpr (E.Value CourseId) -> E.SqlExpr (E.Value Bool) +isCourseTutor muid AuthTagActive{..} cid + | Just uid <- muid, authTagIsActive AuthTutor = E.exists . E.from $ \(tutor `E.InnerJoin` tutorial) -> do + E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId + E.where_ $ tutor E.^. TutorUser E.==. E.val uid + E.&&. tutorial E.^. TutorialCourse E.==. cid + | otherwise = E.false + +isCourseSheetCorrector :: Maybe UserId -> AuthTagActive -> E.SqlExpr (E.Value CourseId) -> E.SqlExpr (E.Value Bool) +isCourseSheetCorrector muid AuthTagActive{..} cid + | Just uid <- muid, authTagIsActive AuthCorrector = E.exists . E.from $ \(sheetCorrector `E.InnerJoin` sheet) -> do + E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId + E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid + E.&&. sheet E.^. SheetCourse E.==. cid + | otherwise = E.false + +isCourseExamCorrector :: Maybe UserId -> AuthTagActive -> E.SqlExpr (E.Value CourseId) -> E.SqlExpr (E.Value Bool) +isCourseExamCorrector muid AuthTagActive{..} cid + | Just uid <- muid, authTagIsActive AuthExamCorrector = E.exists . E.from $ \(examCorrector `E.InnerJoin` exam) -> do + E.on $ examCorrector E.^. ExamCorrectorExam E.==. exam E.^. ExamId + E.where_ $ examCorrector E.^. ExamCorrectorUser E.==. E.val uid + E.&&. exam E.^. ExamCourse E.==. cid + | otherwise = E.false + +isCourseParticipant :: Maybe UserId -> AuthTagActive -> E.SqlExpr (E.Value CourseId) -> E.SqlExpr (E.Value Bool) +isCourseParticipant muid AuthTagActive{..} cid + | Just uid <- muid, authTagIsActive AuthCourseRegistered = E.exists . E.from $ \courseParticipant -> E.where_ $ + courseParticipant E.^. CourseParticipantUser E.==. E.val uid + E.&&. courseParticipant E.^. CourseParticipantCourse E.==. cid + E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive + E.&&. E.val (authTagIsActive AuthCourseRegistered) + | otherwise = E.false + +isCourseApplicant :: Maybe UserId -> AuthTagActive -> E.SqlExpr (E.Value CourseId) -> Maybe (E.SqlExpr (E.Value AllocationId)) -> E.SqlExpr (E.Value Bool) +isCourseApplicant muid AuthTagActive{..} cid maid + | Just uid <- muid, authTagIsActive AuthApplicant = E.exists . E.from $ \courseApplication -> E.where_ $ + courseApplication E.^. CourseApplicationUser E.==. E.val uid + E.&&. courseApplication E.^. CourseApplicationCourse E.==. cid + E.&&. maybe E.true + (\aid -> E.just aid E.==. courseApplication E.^. CourseApplicationAllocation) + maid + | otherwise = E.false + +isCourseAssociated :: Maybe UserId -> AuthTagActive -> E.SqlExpr (E.Value CourseId) -> Maybe (E.SqlExpr (E.Value AllocationId)) -> E.SqlExpr (E.Value Bool) +isCourseAssociated muid ata cid maid = + isCourseLecturer muid ata cid + E.||. isCourseTutor muid ata cid + E.||. isCourseSheetCorrector muid ata cid + E.||. isCourseExamCorrector muid ata cid + E.||. isCourseParticipant muid ata cid + E.||. isCourseApplicant muid ata cid maid + + +courseIsVisible :: UTCTime -> E.SqlExpr (Entity Course) -> Maybe (E.SqlExpr (E.Value AllocationId)) -> E.SqlExpr (E.Value Bool) +courseIsVisible now course maid = + (E.maybe E.false (\visibleFrom -> visibleFrom E.<=. E.val now) (course E.^. CourseVisibleFrom) + E.&&. E.maybe E.true (\visibleTo -> E.val now E.<=. visibleTo) (course E.^. CourseVisibleTo) + ) E.||. courseAllocationRegistrationOpen now (course E.^. CourseId) maid + +courseIsVisible' :: UTCTime -> Entity Course -> Maybe AllocationId -> E.SqlExpr (E.Value Bool) +courseIsVisible' now (Entity cid Course{..}) maid = + E.val (NTop courseVisibleFrom <= now' && now' <= NTop courseVisibleTo) + E.||. courseAllocationRegistrationOpen now (E.val cid) (E.val <$> maid) + where now' = NTop $ Just now + + +courseAllocationRegistrationOpen :: UTCTime -> E.SqlExpr (E.Value CourseId) -> Maybe (E.SqlExpr (E.Value AllocationId)) -> E.SqlExpr (E.Value Bool) +courseAllocationRegistrationOpen now cid maid = E.exists . E.from $ \(allocationCourse `E.InnerJoin` allocation) -> do + E.on $ allocationCourse E.^. AllocationCourseAllocation E.==. allocation E.^. AllocationId + E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. cid + E.&&. E.maybe + E.true + (\registerFrom -> registerFrom E.<=. E.val now) + (allocation E.^. AllocationRegisterFrom) + E.&&. E.maybe + E.true + (\registerTo -> E.val now E.<=. registerTo) + (allocation E.^. AllocationRegisterTo) + E.&&. maybe E.true (\aid -> aid E.==. allocation E.^. AllocationId) maid + + +numCourseParticipants :: E.SqlExpr (E.Value CourseId) -> E.SqlExpr (E.Value Int) +numCourseParticipants cid = E.subSelectCount . E.from $ \courseParticipant -> + E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. cid + E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive diff --git a/templates/allocation/show/course.hamlet b/templates/allocation/show/course.hamlet index ef2a7341f..b5314cb99 100644 --- a/templates/allocation/show/course.hamlet +++ b/templates/allocation/show/course.hamlet @@ -12,6 +12,8 @@ $if is _Just muid _{MsgAllocationNoApplication} #{courseName} + $if not courseVisible && mayEdit + \ #{iconInvisible} $if hasApplicationTemplate || is _Just courseApplicationsInstructions
_{MsgCourseApplicationInstructionsApplication} diff --git a/templates/course.hamlet b/templates/course.hamlet index 71192130c..db30a590b 100644 --- a/templates/course.hamlet +++ b/templates/course.hamlet @@ -8,7 +8,7 @@ $newline never
$if not (null news)