From 64c45c515ece92cc8822b31aaba0d9ccddede4e1 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 29 Apr 2019 00:20:34 +0200 Subject: [PATCH 01/26] Tutorials --- db.sh | 2 + messages/uniworx/de.msg | 81 +++- models/rooms | 32 -- models/tutorials | 27 +- package.yaml | 1 + routes | 26 +- src/Application.hs | 1 + src/Database/Esqueleto/Utils.hs | 12 +- src/Foundation.hs | 174 +++++++- src/Handler/Admin.hs | 2 +- src/Handler/Corrections.hs | 2 +- src/Handler/Course.hs | 157 +++++++- src/Handler/Tutorial.hs | 376 ++++++++++++++++++ src/Handler/Utils/Communication.hs | 3 +- src/Handler/Utils/DateTime.hs | 5 + src/Handler/Utils/Delete.hs | 2 +- src/Handler/Utils/Form.hs | 33 +- src/Handler/Utils/Form/MassInput.hs | 88 +++- src/Handler/Utils/Form/Occurences.hs | 122 ++++++ src/Handler/Utils/Sheet.hs | 2 +- src/Handler/Utils/Submission.hs | 29 +- src/Handler/Utils/Table/Cells.hs | 20 + src/Handler/Utils/Table/Pagination.hs | 57 ++- src/Handler/Utils/Tutorial.hs | 47 +++ src/Handler/Utils/Zip.hs | 2 +- src/Import/NoFoundation.hs | 11 +- src/Jobs.hs | 1 - src/Jobs/Crontab.hs | 1 - src/Jobs/Queue.hs | 4 +- src/Model.hs | 1 + src/Model/Migration.hs | 17 + src/Model/Types.hs | 56 ++- src/Time/Types/Instances.hs | 19 + src/Utils/Form.hs | 21 +- src/Utils/Lens.hs | 11 + src/Utils/Occurences.hs | 84 ++++ static/css/utils/tooltip.scss | 8 + static/js/utils/form.js | 4 + templates/course.hamlet | 59 ++- templates/tutorial-edit.hamlet | 2 + templates/tutorial-list.hamlet | 2 + templates/tutorial-new.hamlet | 2 + templates/tutorial-participants.hamlet | 2 + templates/tutorial/tutorMassInput/add.hamlet | 6 + .../tutorial/tutorMassInput/cellKnown.hamlet | 3 + .../tutorial/tutorMassInput/layout.hamlet | 11 + templates/widgets/occurence/cell.hamlet | 12 + .../occurence/cell/except-no-occur.hamlet | 2 + .../occurence/cell/except-occur.hamlet | 2 + .../widgets/occurence/cell/weekly.hamlet | 2 + .../widgets/occurence/form/except-add.hamlet | 5 + .../occurence/form/except-layout.hamlet | 11 + .../occurence/form/except-no-occur.hamlet | 5 + .../occurence/form/except-occur.hamlet | 5 + .../occurence/form/scheduled-add.hamlet | 5 + .../occurence/form/scheduled-layout.hamlet | 11 + .../widgets/occurence/form/weekly.hamlet | 5 + test/Database.hs | 37 +- 58 files changed, 1566 insertions(+), 164 deletions(-) delete mode 100644 models/rooms create mode 100644 src/Handler/Tutorial.hs create mode 100644 src/Handler/Utils/Form/Occurences.hs create mode 100644 src/Handler/Utils/Tutorial.hs create mode 100644 src/Time/Types/Instances.hs create mode 100644 src/Utils/Occurences.hs create mode 100644 templates/tutorial-edit.hamlet create mode 100644 templates/tutorial-list.hamlet create mode 100644 templates/tutorial-new.hamlet create mode 100644 templates/tutorial-participants.hamlet create mode 100644 templates/tutorial/tutorMassInput/add.hamlet create mode 100644 templates/tutorial/tutorMassInput/cellKnown.hamlet create mode 100644 templates/tutorial/tutorMassInput/layout.hamlet create mode 100644 templates/widgets/occurence/cell.hamlet create mode 100644 templates/widgets/occurence/cell/except-no-occur.hamlet create mode 100644 templates/widgets/occurence/cell/except-occur.hamlet create mode 100644 templates/widgets/occurence/cell/weekly.hamlet create mode 100644 templates/widgets/occurence/form/except-add.hamlet create mode 100644 templates/widgets/occurence/form/except-layout.hamlet create mode 100644 templates/widgets/occurence/form/except-no-occur.hamlet create mode 100644 templates/widgets/occurence/form/except-occur.hamlet create mode 100644 templates/widgets/occurence/form/scheduled-add.hamlet create mode 100644 templates/widgets/occurence/form/scheduled-layout.hamlet create mode 100644 templates/widgets/occurence/form/weekly.hamlet diff --git a/db.sh b/db.sh index b05463c3a..3d80bf68f 100755 --- a/db.sh +++ b/db.sh @@ -1,4 +1,6 @@ #!/usr/bin/env bash # Options: see /test/Database.hs (Main) +set -e + stack build --fast --flag uniworx:-library-only --flag uniworx:dev stack exec uniworxdb -- $@ diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 2198f54b8..801076f6a 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -69,10 +69,12 @@ CourseShort: Kürzel CourseCapacity: Kapazität CourseCapacityTip: Anzahl erlaubter Kursanmeldungen, leer lassen für unbeschränkte Kurskapazität CourseNoCapacity: In diesem Kurs sind keine Plätze mehr frei. +TutorialNoCapacity: In dieser Übung sind keine Plätze mehr frei. CourseNotEmpty: In diesem Kurs sind momentan Teilnehmer angemeldet. CourseRegisterOk: Anmeldung erfolgreich CourseDeregisterOk: Erfolgreich abgemeldet CourseStudyFeature: Assoziiertes Hauptfach +CourseTutorial: Tutorium CourseStudyFeatureTooltip: Korrekte Angabe kann Notenweiterleitungen beschleunigen CourseSecretWrong: Falsches Kennwort CourseSecret: Zugangspasswort @@ -120,6 +122,9 @@ CourseUserNoteDeleted: Teilnehmernotiz gelöscht CourseUserDeregister: Abmelden CourseUsersDeregistered count@Int64: #{show count} Teilnehmer abgemeldet CourseUserSendMail: Mitteilung verschicken +TutorialUserDeregister: Vom Tutorium Abmelden +TutorialUserSendMail: Mitteilung verschicken +TutorialUsersDeregistered count@Int64: #{show count} Tutorium-Teilnehmer abgemeldet CourseLecturers: Kursverwalter CourseLecturer: Dozent @@ -231,6 +236,7 @@ UnauthorizedRegistered: Sie sind nicht als Teilnehmer für diese Veranstaltung r UnauthorizedParticipant: Angegebener Benutzer ist nicht als Teilnehmer dieser Veranstaltung registriert. UnauthorizedCourseTime: Dieses Kurs erlaubt momentan keine Anmeldungen. UnauthorizedSheetTime: Dieses Übungsblatt ist momentan nicht freigegeben. +UnauthorizedTutorialTime: Dieses Tutorium erlaubt momentan keine Anmeldungen. UnauthorizedSubmissionOwner: Sie sind an dieser Abgabe nicht beteiligt. UnauthorizedSubmissionRated: Diese Abgabe ist noch nicht korrigiert. UnauthorizedSubmissionCorrector: Sie sind nicht der Korrektor für diese Abgabe. @@ -248,6 +254,10 @@ UnauthorizedDisabledTag authTag@AuthTag: Authorisierungsprädikat "#{toPathPiece UnknownAuthPredicate tag@String: Authorisierungsprädikat "#{tag}" ist dem System nicht bekannt UnauthorizedRedirect: Die angeforderte Seite existiert nicht oder Sie haben keine Berechtigung, die angeforderte Seite zu sehen. UnauthorizedSelf: Aktueller Nutzer ist nicht angegebener Benutzer. +UnauthorizedTutorialTutor: Sie sind nicht Tutor für dieses Tutorium. +UnauthorizedCourseTutor: Sie sind nicht Tutor für diesen Kurs. +UnauthorizedTutor: Sie sind nicht Tutor. +UnauthorizedTutorialRegisterGroup: Sie sind bereits in einem Tutorium mit derselben Registrierungs-Gruppe. EMail: E-Mail EMailUnknown email@UserEmail: E-Mail #{email} gehört zu keinem bekannten Benutzer. @@ -408,6 +418,8 @@ LecturerFor: Dozent LecturersFor: Dozenten AssistantFor: Assistent AssistantsFor: Assistenten +TutorsFor n@Int: #{pluralDE n "Tutor" "Tutoren"} +CorrectorsFor n@Int: #{pluralDE n "Korrektor" "Korrektoren"} ForSchools n@Int: für #{pluralDE n "Institut" "Institute"} UserListTitle: Komprehensive Benutzerliste AccessRightsSaved: Berechtigungsänderungen wurden gespeichert. @@ -711,6 +723,8 @@ MenuCorrections: Korrekturen MenuCorrectionsOwn: Meine Korrekturen MenuSubmissions: Abgaben MenuSheetList: Übungsblätter +MenuTutorialList: Tutorien +MenuTutorialNew: Neues Tutorium anlegen MenuSheetNew: Neues Übungsblatt anlegen MenuSheetCurrent: Aktuelles Übungsblatt MenuSheetOldUnassigned: Abgaben ohne Korrektor @@ -727,6 +741,8 @@ MenuCorrectionsUpload: Korrekturen hochladen MenuCorrectionsCreate: Abgaben registrieren MenuCorrectionsGrade: Abgaben bewerten MenuAuthPreds: Authorisierungseinstellungen +MenuTutorialDelete: Tutorium löschen +MenuTutorialEdit: Tutorium editieren AuthPredsInfo: Um eigene Veranstaltungen aus Sicht der Teilnehmer anzusehen, können Veranstalter und Korrektoren hier die Prüfung ihrer erweiterten Berechtigungen temporär deaktivieren. Abgewählte Prädikate schlagen immer fehl. Abgewählte Prädikate werden also nicht geprüft um Zugriffe zu gewähren, welche andernfalls nicht erlaubt wären. Diese Einstellungen gelten nur temporär bis Ihre Sitzung abgelaufen ist, d.h. bis ihr Browser-Cookie abgelaufen ist. Durch Abwahl von Prädikaten kann man sich höchstens temporär aussperren. AuthPredsActive: Aktive Authorisierungsprädikate @@ -739,9 +755,12 @@ AuthTagDeprecated: Seite ist nicht überholt AuthTagDevelopment: Seite ist nicht in Entwicklung AuthTagLecturer: Nutzer ist Dozent AuthTagCorrector: Nutzer ist Korrektor +AuthTagTutor: Nutzer ist Tutor AuthTagTime: Zeitliche Einschränkungen sind erfüllt -AuthTagRegistered: Nutzer ist Kursteilnehmer +AuthTagCourseRegistered: Nutzer ist Kursteilnehmer +AuthTagTutorialRegistered: Nutzer ist Tutoriumsteilnehmer AuthTagParticipant: Nutzer ist mit Kurs assoziiert +AuthTagRegisterGroup: Nutzer ist nicht Mitglied eines anderen Tutoriums mit der selben Registrierungs-Gruppe AuthTagCapacity: Kapazität ist ausreichend AuthTagEmpty: Kurs hat keine Teilnehmer AuthTagMaterials: Kursmaterialien sind freigegeben @@ -773,6 +792,7 @@ CommDuplicateRecipients n@Int: #{tshow n} #{pluralDE n "doppelter" "doppelte"} E CommSuccess n@Int: Nachricht wurde an #{tshow n} Empfänger versandt CommCourseHeading: Kursmitteilung +CommTutorialHeading: Tutorium-Mitteilung RecipientCustom: Weitere Empfänger RecipientToggleAll: Alle/Keine @@ -780,6 +800,8 @@ RecipientToggleAll: Alle/Keine RGCourseParticipants: Kursteilnehmer RGCourseLecturers: Kursverwalter RGCourseCorrectors: Korrektoren +RGCourseTutors: Tutoren +RGTutorialParticipants: Tutorium-Teilnehmer MultiSelectFieldTip: Mehrfach-Auswahl ist möglich (Umschalt bzw. Strg) MultiEmailFieldTip: Es sind mehrere, Komma-separierte, E-Mail-Addressen möglich @@ -794,3 +816,60 @@ CorrectorInvitationAccepted shn@SheetName: Sie wurden als Korrektor für #{shn} CorrectorInvitationDeclined shn@SheetName: Sie haben die Einladung, Korrektor für #{shn} zu werden, abgelehnt SheetCorrInviteHeading shn@SheetName: Einladung zum Korrektor für #{shn} SheetCorrInviteExplanation: Sie wurden eingeladen, Korrektor für ein Übungsblatt zu sein. + +ScheduleKindWeekly: Wöchentlich + +ScheduleRegular: Planmäßiger Termin +ScheduleRegularKind: Plan +WeekDay: Wochentag +Day: Tag +OccurenceStart: Beginn +OccurenceEnd: Ende +ScheduleExists: Dieser Plan existiert bereits + +ScheduleExceptions: Termin-Ausnahmen +ScheduleExceptionsTip: Ausfälle überschreiben planmäßiges Stattfinden. Außerplanmäßiges Stattfinden überschreibt Ausfall +ExceptionKind: Termin ... +ExceptionKindOccur: Findet statt +ExceptionKindNoOccur: Findet nicht statt +ExceptionExists: Diese Ausnahme existiert bereits +ExceptionNoOccurAt: Termin + +TutorialType: Typ +TutorialName: Bezeichnung +TutorialParticipants: Teilnehmer +TutorialCapacity: Kapazität +TutorialRoom: Regulärer Raum +TutorialTime: Zeit +TutorialRegistered: Angemeldet +TutorialRegGroup: Registrierungs-Gruppe +TutorialRegisterFrom: Anmeldungen ab +TutorialRegisterTo: Anmeldungen bis +TutorialDeregisterUntil: Abmeldungen bis +TutorialsHeading: Tutorien +TutorialEdit: Bearbeiten +TutorialDelete: Löschen + +CourseTutorials: Übungen + +ParticipantsN n@Int: Teilnehmer +TutorialDeleteQuestion: Wollen Sie das unten aufgeführte Tutorium wirklich löschen? +TutorialDeleted: Tutorium gelöscht + +TutorialRegisteredSuccess tutn@TutorialName: Erfolgreich zum Tutorium #{tutn} angemeldet +TutorialDeregisteredSuccess tutn@TutorialName: Erfolgreich vom Tutorium #{tutn} abgemeldet + +TutorialNameTip: Muss eindeutig sein +TutorialCapacityNonPositive: Kapazität muss größer oder gleich null sein +TutorialCapacityTip: Beschränkt wieviele Studenten sich zu diesem Tutorium anmelden können +TutorialRegGroupTip: Studenten können sich in jeweils maximal einem Tutorium pro Registrierungs-Gruppe anmelden. Ist bei zwei oder mehr Tutorien keine Registrierungs-Gruppe gesetzt zählen diese als in verschiedenen Registrierungs-Gruppen +TutorialRoomPlaceholder: Raum +TutorialTutors: Tutoren +TutorialTutorAlreadyAdded: Ein Tutor mit dieser E-Mail ist bereits für dieses Tutorium eingetragen + +TutorialNew: Neues Tutorium + +TutorialNameTaken tutn@TutorialName: Es existiert bereits anderes Tutorium mit Namen #{tutn} +TutorialCreated tutn@TutorialName: Tutorium #{tutn} erfolgreich angelegt + +TutorialEditHeading tutn@TutorialName: #{tutn} bearbeiten \ No newline at end of file diff --git a/models/rooms b/models/rooms deleted file mode 100644 index 2ef670fd3..000000000 --- a/models/rooms +++ /dev/null @@ -1,32 +0,0 @@ --- ROOMS ARE TODO; THIS IS JUST AN UNUSED STUB --- Idea is to create a selection of rooms that may be --- associated with exercise classes and exams --- offering links to the LMU Roomfinder --- and allow the creation of neat timetables for users -Booking - term TermId - begin UTCTime - end UTCTime - weekly Bool - exceptions [Day] -- only if weekly, begin in exception - bookedFor RoomForId - room RoomId -BookingEdit - user UserId - time UTCTime - boooking BookingId -Room - name Text - capacity Int Maybe - building Text Maybe -- name of building - roomfinder Text Maybe -- external url for LMU Roomfinder --- BookingRoom --- subject RoomForId --- room RoomId --- booking BookingId --- UniqueRoomCourse subject room booking -+RoomFor - course CourseId - tutorial TutorialId - exam ExamId --- data RoomFor = RoomForCourseSum CourseId | RoomForTutorialSum TutorialId ... diff --git a/models/tutorials b/models/tutorials index 3afed739e..1f47400bf 100644 --- a/models/tutorials +++ b/models/tutorials @@ -1,11 +1,20 @@ --- TUTORIALS ARE TODO; THIS IS JUST AN UNUSED STUB --- Idea: management of exercise classes, offering sub-enrolement to distribute all students among all exercise classs Tutorial json - name Text - tutor UserId - course CourseId - capacity Int Maybe -- limit for enrolement in this tutorial -TutorialUser - user UserId + name TutorialName + course CourseId + type (CI Text) -- "Tutorium", "Zentralübung", ... + capacity Int Maybe -- limit for enrolment in this tutorial + room Text + time Occurences + regGroup (CI Text) Maybe -- each participant may register for one tutorial per regGroup + registerFrom UTCTime Maybe + registerTo UTCTime Maybe + deregisterUntil UTCTime Maybe + UniqueTutorial course name +Tutor tutorial TutorialId - UniqueTutorialUser user tutorial + user UserId + UniqueTutor tutorial user +TutorialParticipant + tutorial TutorialId + user UserId + UniqueTutorialParticipant tutorial user \ No newline at end of file diff --git a/package.yaml b/package.yaml index 470e510db..d1c262645 100644 --- a/package.yaml +++ b/package.yaml @@ -124,6 +124,7 @@ dependencies: - systemd - lifted-async - streaming-commons + - hourglass other-extensions: - GeneralizedNewtypeDeriving diff --git a/routes b/routes index 0e801e22b..dd82ed43b 100644 --- a/routes +++ b/routes @@ -13,8 +13,12 @@ -- !free -- free for all -- !lecturer -- lecturer for this course (or for any school, if route is not connected to a course) -- !corrector -- corrector for this sheet (or the submission, if route is connected to a submission, or the course, if route is not connected to a sheet, or any course, if route is not connected to a course) --- !registered -- participant for this course (no effect outside of courses) +-- !course-registered -- participant for this course (no effect outside of courses) +-- !tutorial-registered -- participant for this tutorial (no effect outside of courses) -- !participant -- connected with a given course (not necessarily registered), i.e. has a submission, is a corrector, etc. (no effect outside of courses) +-- +-- !register-group -- user is member in no other tutorial with same register group +-- -- !owner -- part of the group of owners of this submission -- !self -- route refers to the currently logged in user themselves -- !capacity -- course this route is associated with has at least one unit of participant capacity @@ -84,16 +88,16 @@ /communication CCommR GET POST /notes CNotesR GET POST !corrector /subs CCorrectionsR GET POST - /ex SheetListR GET !registered !materials !corrector + /ex SheetListR GET !course-registered !materials !corrector /ex/new SheetNewR GET POST - /ex/current SheetCurrentR GET !registered !materials !corrector + /ex/current SheetCurrentR GET !course-registered !materials !corrector /ex/unassigned SheetOldUnassigned GET /ex/#SheetName SheetR: - /show SShowR GET !timeANDregistered !timeANDmaterials !corrector + /show SShowR GET !timeANDcourse-registered !timeANDmaterials !corrector /edit SEditR GET POST /delete SDelR GET POST /subs SSubsR GET POST -- for lecturer only - !/subs/new SubmissionNewR GET POST !timeANDregisteredANDuser-submissions + !/subs/new SubmissionNewR GET POST !timeANDcourse-registeredANDuser-submissions !/subs/own SubmissionOwnR GET !free -- just redirect /subs/#CryptoFileNameSubmission SubmissionR: / SubShowR GET POST !ownerANDtime !ownerANDread !correctorANDread @@ -103,9 +107,17 @@ /correction CorrectionR GET POST !corrector !ownerANDreadANDrated !/#SubmissionFileType/*FilePath SubDownloadR GET !owner !corrector /correctors SCorrR GET POST - /pseudonym SPseudonymR GET POST !registeredANDcorrector-submissions + /pseudonym SPseudonymR GET POST !course-registeredANDcorrector-submissions /corrector-invite/#UserEmail SCorrInviteR GET POST - !/#SheetFileType/*FilePath SFileR GET !timeANDregistered !timeANDmaterials !corrector + !/#SheetFileType/*FilePath SFileR GET !timeANDcourse-registered !timeANDmaterials !corrector + /tuts CTutorialListR GET !tutor + /tuts/new CTutorialNewR GET POST + /tuts/#TutorialName TutorialR: + /edit TEditR GET POST + /delete TDeleteR GET POST + /participants TUsersR GET POST !tutor + /register TRegisterR POST !timeANDcapacityANDcourse-registeredANDregister-group !timeANDtutorial-registered + /communication TCommR GET POST !tutor /subs CorrectionsR GET POST !corrector !lecturer diff --git a/src/Application.hs b/src/Application.hs index 3e5ace925..77a19df68 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -91,6 +91,7 @@ import Handler.School import Handler.Course import Handler.Sheet import Handler.Submission +import Handler.Tutorial import Handler.Corrections import Handler.CryptoIDDispatch import Handler.SystemMessage diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 6c89e6c96..990c782ff 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -7,6 +7,7 @@ module Database.Esqueleto.Utils , SqlIn(..) , mkExactFilter, mkExactFilterWith , mkContainsFilter + , mkExistsFilter , anyFilter, allFilter ) where @@ -104,6 +105,15 @@ mkContainsFilter lenslike row criterias | Set.null criterias = true | otherwise = any (hasInfix $ lenslike row) criterias +mkExistsFilter :: PathPiece a + => (t -> a -> E.SqlQuery ()) + -> t + -> Set.Set a + -> E.SqlExpr (E.Value Bool) +mkExistsFilter query row criterias + | Set.null criterias = true + | otherwise = any (E.exists . query row) criterias + -- | Combine several filters, using logical or anyFilter :: (Foldable f) => f (t -> Set.Set Text-> E.SqlExpr (E.Value Bool)) @@ -122,4 +132,4 @@ allFilter :: (Foldable f) -> E.SqlExpr (E.Value Bool) allFilter fltrs needle criterias = F.foldr aux true fltrs where - aux fltr acc = fltr needle criterias E.&&. acc \ No newline at end of file + aux fltr acc = fltr needle criterias E.&&. acc diff --git a/src/Foundation.hs b/src/Foundation.hs index 46e176a19..8b2769cea 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -45,7 +45,7 @@ import Data.Map (Map, (!?)) import qualified Data.Map as Map import qualified Data.HashSet as HashSet -import Data.List (nubBy) +import Data.List (nubBy, (!!)) import Data.Monoid (Any(..)) @@ -161,6 +161,10 @@ pattern CSheetR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetR pattern CSheetR tid ssh csh shn ptn = CourseR tid ssh csh (SheetR shn ptn) +pattern CTutorialR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> TutorialR -> Route UniWorX +pattern CTutorialR tid ssh csh shn ptn + = CourseR tid ssh csh (TutorialR shn ptn) + pattern CSubmissionR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionR -> Route UniWorX pattern CSubmissionR tid ssh csh shn cid ptn = CSheetR tid ssh csh shn (SubmissionR cid ptn) @@ -402,6 +406,14 @@ appLanguagesOpts = do return $ mkOptionList langOptions +instance RenderMessage UniWorX WeekDay where + renderMessage _ ls wDay = pack $ map fst (wDays $ getTimeLocale' ls) !! fromEnum wDay + +newtype ShortWeekDay = ShortWeekDay { longWeekDay :: WeekDay } + +instance RenderMessage UniWorX ShortWeekDay where + renderMessage _ ls (ShortWeekDay wDay) = pack $ map snd (wDays $ getTimeLocale' ls) !! fromEnum wDay + -- Access Control newtype InvalidAuthTag = InvalidAuthTag Text deriving (Eq, Ord, Show, Read, Generic, Typeable) @@ -582,7 +594,49 @@ tagAccessPredicate AuthCorrector = APDB $ \mAuthId route _ -> exceptT return ret _ -> do guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny) return Authorized +tagAccessPredicate AuthTutor = APDB $ \mAuthId route _ -> exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + resList <- lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do + E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId + E.on $ tutorial E.^. TutorialCourse E.==. course E.^. CourseId + E.where_ $ tutor E.^. TutorUser E.==. E.val authId + return (course E.^. CourseId, tutorial E.^. TutorialId) + let + resMap :: Map CourseId (Set TutorialId) + resMap = Map.fromListWith Set.union [ (cid, Set.singleton tutid) | (E.Value cid, E.Value tutid) <- resList ] + case route of + CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialTutor) $ do + Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh + Entity tutid _ <- MaybeT . lift . getBy $ UniqueTutorial cid tutn + guard $ tutid `Set.member` fromMaybe Set.empty (resMap !? cid) + return Authorized + CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnauthorizedCourseTutor) $ do + Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh + guard $ cid `Set.member` Map.keysSet resMap + return Authorized + _ -> do + guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedTutor) + return Authorized tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of + CTutorialR tid ssh csh tutn TRegisterR -> maybeT (unauthorizedI MsgUnauthorizedTutorialTime) $ do + now <- liftIO getCurrentTime + course <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh + Entity tutId Tutorial{..} <- MaybeT . getBy $ UniqueTutorial course tutn + registered <- case mAuthId of + Just uid -> lift . existsBy $ UniqueTutorialParticipant tutId uid + Nothing -> return False + + if + | not registered + , maybe False (now >=) tutorialRegisterFrom + , maybe True (now <=) tutorialRegisterTo + -> return Authorized + | registered + , maybe True (now <=) tutorialDeregisterUntil + -> return Authorized + | otherwise + -> mzero + CSheetR tid ssh csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh Entity _sid Sheet{..} <- MaybeT . getBy $ CourseSheet cid shn @@ -630,7 +684,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of return Authorized r -> $unsupportedAuthPredicate AuthTime r -tagAccessPredicate AuthRegistered = APDB $ \mAuthId route _ -> case route of +tagAccessPredicate AuthCourseRegistered = APDB $ \mAuthId route _ -> case route of CourseR tid ssh csh _ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` courseParticipant) -> do @@ -642,7 +696,34 @@ tagAccessPredicate AuthRegistered = APDB $ \mAuthId route _ -> case route of return (E.countRows :: E.SqlExpr (E.Value Int64)) guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedRegistered) return Authorized - r -> $unsupportedAuthPredicate AuthRegistered r + r -> $unsupportedAuthPredicate AuthCourseRegistered r +tagAccessPredicate AuthTutorialRegistered = APDB $ \mAuthId route _ -> case route of + CourseR tid ssh csh _ -> exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialParticipant) -> do + E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial + E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse + E.where_ $ tutorialParticipant E.^. TutorialParticipantUser 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 + return (E.countRows :: E.SqlExpr (E.Value Int64)) + guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedRegistered) + return Authorized + CTutorialR tid ssh csh tutn _ -> exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialParticipant) -> do + E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial + E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse + E.where_ $ tutorialParticipant E.^. TutorialParticipantUser 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.&&. tutorial E.^. TutorialName E.==. E.val tutn + return (E.countRows :: E.SqlExpr (E.Value Int64)) + guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedRegistered) + return Authorized + r -> $unsupportedAuthPredicate AuthTutorialRegistered r tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of CourseR tid ssh csh (CUserR cID) -> exceptT return return $ do let authorizedIfExists f = do @@ -683,16 +764,17 @@ tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of E.&&. course E.^. CourseShorthand E.==. E.val csh -- participant is a tutorial user authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialUser) -> do - E.on $ tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialUserTutorial + E.on $ tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialParticipantTutorial E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse - E.where_ $ tutorialUser E.^. TutorialUserUser E.==. E.val participant + E.where_ $ tutorialUser E.^. TutorialParticipantUser E.==. E.val participant E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh -- participant is tutor for this course - authorizedIfExists $ \(course `E.InnerJoin` tutorial) -> do + authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do + E.on $ tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse - E.where_ $ tutorial E.^. TutorialTutor E.==. E.val participant + E.where_ $ tutor E.^. TutorUser E.==. E.val participant E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh @@ -706,12 +788,33 @@ tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of unauthorizedI MsgUnauthorizedParticipant r -> $unsupportedAuthPredicate AuthParticipant r tagAccessPredicate AuthCapacity = APDB $ \_ route _ -> case route of + CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgTutorialNoCapacity) $ do + cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh + Entity tutId Tutorial{..} <- MaybeT . getBy $ UniqueTutorial cid tutn + registered <- lift $ fromIntegral <$> count [ TutorialParticipantTutorial ==. tutId ] + guard $ NTop tutorialCapacity > NTop (Just registered) + return Authorized CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ] guard $ NTop courseCapacity > NTop (Just registered) return Authorized r -> $unsupportedAuthPredicate AuthCapacity r +tagAccessPredicate AuthRegisterGroup = APDB $ \mAuthId route _ -> case route of + CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialRegisterGroup) $ do + cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh + Entity _ Tutorial{..} <- MaybeT . getBy $ UniqueTutorial cid tutn + case (tutorialRegGroup, mAuthId) of + (Nothing, _) -> return Authorized + (_, Nothing) -> return AuthenticationRequired + (Just rGroup, Just uid) -> do + [E.Value hasOther] <- lift . E.select . return . E.exists . E.from $ \(tutorial `E.InnerJoin` participant) -> do + E.on $ tutorial E.^. TutorialId E.==. participant E.^. TutorialParticipantTutorial + E.where_ $ participant E.^. TutorialParticipantUser E.==. E.val uid + E.&&. tutorial E.^. TutorialRegGroup E.==. E.just (E.val rGroup) + guard $ not hasOther + return Authorized + r -> $unsupportedAuthPredicate AuthRegisterGroup r tagAccessPredicate AuthEmpty = APDB $ \_ route _ -> case route of CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNotEmpty) $ do -- Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh @@ -1265,10 +1368,17 @@ instance YesodBreadcrumbs UniWorX where breadcrumb (CourseR tid ssh csh SheetListR) = return ("Übungen" , Just $ CourseR tid ssh csh CShowR) breadcrumb (CourseR tid ssh csh SheetNewR ) = return ("Neu", Just $ CourseR tid ssh csh SheetListR) breadcrumb (CourseR tid ssh csh CCommR ) = return ("Kursmitteilung", Just $ CourseR tid ssh csh CShowR) + breadcrumb (CourseR tid ssh csh CTutorialListR) = return ("Tutorien", Just $ CourseR tid ssh csh CShowR) + breadcrumb (CourseR tid ssh csh CTutorialNewR) = return ("Anlegen", Just $ CourseR tid ssh csh CTutorialListR) + + breadcrumb (CTutorialR tid ssh csh tutn TUsersR) = return (CI.original tutn, Just $ CourseR tid ssh csh CTutorialListR) + breadcrumb (CTutorialR tid ssh csh tutn TEditR) = return ("Bearbeiten", Just $ CTutorialR tid ssh csh tutn TUsersR) + breadcrumb (CTutorialR tid ssh csh tutn TDeleteR) = return ("Löschen", Just $ CTutorialR tid ssh csh tutn TUsersR) + breadcrumb (CTutorialR tid ssh csh tutn TCommR) = return ("Mitteilung", Just $ CTutorialR tid ssh csh tutn TUsersR) breadcrumb (CSheetR tid ssh csh shn SShowR) = return (CI.original shn, Just $ CourseR tid ssh csh SheetListR) - breadcrumb (CSheetR tid ssh csh shn SEditR) = return ("Edit", Just $ CSheetR tid ssh csh shn SShowR) - breadcrumb (CSheetR tid ssh csh shn SDelR ) = return ("DELETE", Just $ CSheetR tid ssh csh shn SShowR) + breadcrumb (CSheetR tid ssh csh shn SEditR) = return ("Bearbeiten", Just $ CSheetR tid ssh csh shn SShowR) + breadcrumb (CSheetR tid ssh csh shn SDelR ) = return ("Löschen", Just $ CSheetR tid ssh csh shn SShowR) breadcrumb (CSheetR tid ssh csh shn SSubsR) = return ("Abgaben", Just $ CSheetR tid ssh csh shn SShowR) breadcrumb (CSheetR tid ssh csh shn SubmissionNewR) = return ("Abgabe", Just $ CSheetR tid ssh csh shn SShowR) breadcrumb (CSheetR tid ssh csh shn SubmissionOwnR) = return ("Abgabe", Just $ CSheetR tid ssh csh shn SShowR) @@ -1635,6 +1745,14 @@ pageActions (CourseR tid ssh csh CShowR) = } ] ++ pageActions (CourseR tid ssh csh SheetListR) ++ [ MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuTutorialList + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CourseR tid ssh csh CTutorialListR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + , MenuItem { menuItemType = PageActionSecondary , menuItemLabel = MsgMenuCourseMembers , menuItemIcon = Just "user-graduate" @@ -1736,6 +1854,44 @@ pageActions (CourseR tid ssh csh SheetListR) = , menuItemAccessCallback' = return True } ] +pageActions (CourseR tid ssh csh CTutorialListR) = + [ MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuTutorialNew + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CourseR tid ssh csh CTutorialNewR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + ] +pageActions (CTutorialR tid ssh csh tutn TEditR) = + [ MenuItem + { menuItemType = PageActionSecondary + , menuItemLabel = MsgMenuTutorialDelete + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CTutorialR tid ssh csh tutn TDeleteR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + ] +pageActions (CTutorialR tid ssh csh tutn TUsersR) = + [ MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuTutorialEdit + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CTutorialR tid ssh csh tutn TEditR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + , MenuItem + { menuItemType = PageActionSecondary + , menuItemLabel = MsgMenuTutorialDelete + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CTutorialR tid ssh csh tutn TDeleteR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + ] pageActions (CSheetR tid ssh csh shn SShowR) = [ MenuItem { menuItemType = PageActionPrime diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index aba016f41..2180e28e8 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -165,7 +165,7 @@ postAdminTestR = do -- | Make a form for adding a point/line/plane/hyperplane/... (in this case: cell) -- - -- This /needs/ to replace all occurances of @mreq@ with @mpreq@ (no fields should be /actually/ required) + -- This /needs/ to replace all occurences of @mreq@ with @mpreq@ (no fields should be /actually/ required) mkAddForm :: ListPosition -- ^ Approximate position of the add-widget -> Natural -- ^ Dimension Index, outermost dimension ist 0 i.e. if dimension is 3 hyperplane-adders get passed 0, planes get passed 1, lines get 2, and points get 3 -> (Text -> Text) -- ^ Nudge deterministic field ids so they're unique diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 7de5e6b0d..4ef07e77d 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -128,7 +128,7 @@ colSubmissionLink = sortable Nothing (i18nCell MsgSubmission) return $ CSubmissionR tid ssh csh shn cid SubShowR in anchorCellM mkRoute (mkCid >>= \cid -> [whamlet|#{display cid}|]) -colSelect :: forall act h. (Monoid act, Headedness h) => Colonnade h CorrectionTableData (DBCell _ (FormResult (act, DBFormResult CryptoFileNameSubmission Bool CorrectionTableData), SheetTypeSummary)) +colSelect :: forall act h. (Semigroup act, Monoid act, Headedness h) => Colonnade h CorrectionTableData (DBCell _ (FormResult (act, DBFormResult CryptoFileNameSubmission Bool CorrectionTableData), SheetTypeSummary)) colSelect = dbSelect (_1 . applying _2) id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> encrypt subId colSubmittors :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 4c1d7a153..1163a9e8f 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -9,6 +9,7 @@ import Utils.Form -- import Utils.DB import Handler.Utils import Handler.Utils.Course +import Handler.Utils.Tutorial import Handler.Utils.Communication import Handler.Utils.Form.MassInput import Handler.Utils.Delete @@ -24,8 +25,6 @@ import qualified Data.CaseInsensitive as CI import Data.Function ((&)) -- import Yesod.Form.Bootstrap3 -import Data.Monoid (Last(..)) - import Data.Maybe (fromJust) import qualified Data.Set as Set import Data.Map ((!)) @@ -275,7 +274,7 @@ getTermCourseListR tid = do getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCShowR tid ssh csh = do mbAid <- maybeAuthId - (course,schoolName,participants,registration,defSFid,lecturers,assistants) <- runDB . maybeT notFound $ do + (cid,course,schoolName,participants,registration,defSFid,lecturers,assistants,tutors,correctors) <- runDB . maybeT notFound $ do [(E.Entity cid course, E.Value schoolName, E.Value participants, fmap entityVal -> registration)] <- lift . E.select . E.from $ \((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do @@ -301,7 +300,18 @@ getCShowR tid ssh csh = do partStaff (CourseLecturer ,name,surn,mail) = Right (name,surn,mail) partStaff (_courseAssistant,name,surn,mail) = Left (name,surn,mail) (assistants,lecturers) = partitionWith partStaff $ map $(unValueN 4) staff - return (course,schoolName,participants,registration,entityKey <$> defSFid,lecturers,assistants) + tutors <- fmap (map $(unValueN 3)) . lift . E.select $ E.from $ \(tutorial `E.InnerJoin` tutor `E.InnerJoin` user) -> E.distinctOnOrderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName, E.asc $ user E.^. UserEmail ] $ do + E.on $ tutor E.^. TutorUser E.==. user E.^. UserId + E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId + E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid + return ( user E.^. UserEmail, user E.^. UserDisplayName, user E.^. UserSurname ) + correctors <- fmap (map $(unValueN 3)) . lift . E.select $ E.from $ \(sheet `E.InnerJoin` sheetCorrector `E.InnerJoin` user) -> E.distinctOnOrderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName, E.asc $ user E.^. UserEmail ] $ do + E.on $ sheetCorrector E.^. SheetCorrectorUser E.==. user E.^. UserId + E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId + E.where_ $ sheet E.^. SheetCourse E.==. E.val cid + E.orderBy [ E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName ] + return ( user E.^. UserEmail, user E.^. UserDisplayName, user E.^. UserSurname ) + return (cid,course,schoolName,participants,registration,entityKey <$> defSFid,lecturers,assistants,tutors,correctors) mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course @@ -314,6 +324,58 @@ getCShowR tid ssh csh = do , formSubmit = FormNoSubmit } registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True + + let + tutorialDBTable = DBTable{..} + where + dbtSQLQuery tutorial = do + E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid + return tutorial + dbtRowKey = (E.^. TutorialId) + dbtProj = return + dbtColonnade = dbColonnade $ mconcat + [ sortable (Just "type") (i18nCell MsgTutorialType) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> textCell $ CI.original tutorialType + , sortable (Just "name") (i18nCell MsgTutorialName) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> indicatorCell <> textCell (CI.original tutorialName) + , sortable (Just "room") (i18nCell MsgTutorialRoom) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> textCell tutorialRoom + , sortable Nothing (i18nCell MsgTutorialTime) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> occurencesCell tutorialTime + , sortable (Just "register-from") (i18nCell MsgTutorialRegisterFrom) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> maybeDateTimeCell tutorialRegisterFrom + , sortable (Just "register-to") (i18nCell MsgTutorialRegisterTo) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> maybeDateTimeCell tutorialRegisterTo + , sortable (Just "deregister-until") (i18nCell MsgTutorialDeregisterUntil) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> maybeDateTimeCell tutorialDeregisterUntil + , sortable Nothing mempty $ \DBRow{ dbrOutput = Entity tutId Tutorial{..} } -> sqlCell $ do + mayRegister <- (== Authorized) <$> evalAccessDB (CTutorialR tid ssh csh tutorialName TRegisterR) True + isRegistered <- case mbAid of + Nothing -> return False + Just uid -> existsBy $ UniqueTutorialParticipant tutId uid + if + | mayRegister -> do + (tutRegisterForm, tutRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered + return $ wrapForm tutRegisterForm def + { formAction = Just . SomeRoute $ CTutorialR tid ssh csh tutorialName TRegisterR + , formEncoding = tutRegisterEnctype + , formSubmit = FormNoSubmit + } + | isRegistered -> return [whamlet|_{MsgTutorialRegistered}|] + | otherwise -> return mempty + ] + dbtSorting = Map.fromList + [ ("type", SortColumn $ \tutorial -> tutorial E.^. TutorialType ) + , ("name", SortColumn $ \tutorial -> tutorial E.^. TutorialName ) + , ("room", SortColumn $ \tutorial -> tutorial E.^. TutorialRoom ) + , ("register-from", SortColumn $ \tutorial -> tutorial E.^. TutorialRegisterFrom ) + , ("register-to", SortColumn $ \tutorial -> tutorial E.^. TutorialRegisterTo ) + , ("deregister-until", SortColumn $ \tutorial -> tutorial E.^. TutorialDeregisterUntil ) + ] + dbtFilter = Map.empty + dbtFilterUI = const mempty + dbtStyle = def + dbtParams = def + dbtIdent :: Text + dbtIdent = "tutorials" + + tutorialDBTableValidator = def + & defaultSorting [SortAscBy "type", SortAscBy "name"] + (Any hasTutorials, tutorialTable) <- runDB $ dbTable tutorialDBTableValidator tutorialDBTable + siteLayout (toWgt $ courseName course) $ do setTitleI $ prependCourseTitle tid ssh csh (""::Text) $(widgetFile "course") @@ -870,13 +932,28 @@ instance Finite CourseUserAction nullaryPathPiece ''CourseUserAction $ camelToPathPiece' 2 embedRenderMessage ''UniWorX ''CourseUserAction id -makeCourseUserTable :: CourseId -> _ -> _ -> DB (FormResult (CourseUserAction, Set UserId), Widget) -makeCourseUserTable cid colChoices psValidator = do +data TutorialUserAction = TutorialUserSendMail | TutorialUserDeregister + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) + +instance Universe TutorialUserAction +instance Finite TutorialUserAction +nullaryPathPiece ''TutorialUserAction $ camelToPathPiece' 2 +embedRenderMessage ''UniWorX ''TutorialUserAction id + +makeCourseUserTable :: forall h act. + ( Functor h, ToSortable h + , RenderMessage UniWorX act, Eq act, PathPiece act, Finite act) + => CourseId + -> (UserTableExpr -> E.SqlExpr (E.Value Bool)) + -> Colonnade h UserTableData (DBCell (MForm Handler) (FormResult (First act, DBFormResult UserId Bool UserTableData))) + -> PSValidator (MForm Handler) (FormResult (First act, DBFormResult UserId Bool UserTableData)) + -> DB (FormResult (act, Set UserId), Widget) +makeCourseUserTable cid restrict colChoices psValidator = do Just currentRoute <- liftHandlerT getCurrentRoute -- -- psValidator has default sorting and filtering let dbtIdent = "courseUsers" :: Text dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } - dbtSQLQuery = userTableQuery cid + dbtSQLQuery q = userTableQuery cid q <* E.where_ (restrict q) dbtRowKey = queryUser >>> (E.^. UserId) dbtProj = traverse $ \(user, E.Value registrationTime , E.Value userNoteId, (feature,degree,terms)) -> return (user, registrationTime, userNoteId, (entityVal <$> feature, entityVal <$> degree, entityVal <$> terms)) dbtColonnade = colChoices @@ -917,14 +994,22 @@ makeCourseUserTable cid colChoices psValidator = do , E.mkExactFilterWith readMay $ queryFeaturesDegree >>> (E.?. StudyDegreeKey) ] ) , ("semesternr" , FilterColumn $ E.mkExactFilter $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester)) + , ("tutorial" , FilterColumn $ E.mkExistsFilter $ \row criterion -> + E.from $ \(tutorial `E.InnerJoin` tutorialParticipant) -> do + E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial + E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid + E.&&. E.hasInfix (tutorial E.^. TutorialName) criterion + E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. (queryUser row) E.^. UserId + ) -- , ("course-registration", error "TODO") -- TODO -- , ("course-user-note", error "TODO") -- TODO ] dbtFilterUI mPrev = mconcat [ fltrUserNameEmailUI mPrev , fltrUserMatriclenrUI mPrev - , prismAForm (singletonFilter "degree") mPrev $ aopt (searchField False) (fslI MsgStudyFeatureDegree) - , prismAForm (singletonFilter "field") mPrev $ aopt (searchField False) (fslI MsgCourseStudyFeature) + , prismAForm (singletonFilter "degree") mPrev $ aopt (searchField False) (fslI MsgStudyFeatureDegree) + , prismAForm (singletonFilter "field") mPrev $ aopt (searchField False) (fslI MsgCourseStudyFeature) + , prismAForm (singletonFilter "tutorial") mPrev $ aopt (searchField False) (fslI MsgCourseTutorial) ] dbtParams = DBParamsForm { dbParamsFormMethod = POST @@ -942,7 +1027,7 @@ makeCourseUserTable cid colChoices psValidator = do } over _1 postprocess <$> dbTable psValidator DBTable{..} where - postprocess :: FormResult (First CourseUserAction, DBFormResult UserId Bool UserTableData) -> FormResult (CourseUserAction, Set UserId) + postprocess :: FormResult (First act, DBFormResult UserId Bool UserTableData) -> FormResult (act, Set UserId) postprocess inp = do (First (Just act), usrMap) <- inp let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap @@ -966,7 +1051,7 @@ postCUsersR tid ssh csh = do psValidator = def & defaultSortingByName ent@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh numParticipants <- count [CourseParticipantCourse ==. cid] - table <- makeCourseUserTable cid colChoices psValidator + table <- makeCourseUserTable cid (const $ E.true) colChoices psValidator return (ent, numParticipants, table) formResult participantRes $ \case (CourseUserSendMail, selectedUsers) -> do @@ -986,6 +1071,49 @@ postCUsersR tid ssh csh = do $(widgetFile "course-participants") + +getTUsersR, postTUsersR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html +getTUsersR = postTUsersR +postTUsersR tid ssh csh tutn = do + (Entity tutid Tutorial{..}, (participantRes, participantTable)) <- runDB $ do + tut@(Entity tutid _) <- fetchTutorial tid ssh csh tutn + let colChoices = mconcat + [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) + , colUserName + , colUserEmail + , colUserMatriclenr + , colUserDegreeShort + , colUserField + , colUserSemester + ] + psValidator = def + & defaultSortingByName + & restrictSorting (\name _ -> none (== name) ["note"]) -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information + isInTut q = E.exists . E.from $ \tutorialParticipant -> do + E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. (queryUser q) E.^. UserId + E.&&. tutorialParticipant E.^. TutorialParticipantTutorial E.==. E.val tutid + cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh + table <- makeCourseUserTable cid isInTut colChoices psValidator + return (tut, table) + + formResult participantRes $ \case + (TutorialUserSendMail, selectedUsers) -> do + cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser] + redirect (CTutorialR tid ssh csh tutn TCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cids]) + (TutorialUserDeregister,selectedUsers) -> do + nrDel <- runDB $ deleteWhereCount + [ TutorialParticipantTutorial ==. tutid + , TutorialParticipantUser <-. Set.toList selectedUsers + ] + addMessageI Success $ MsgTutorialUsersDeregistered nrDel + redirect $ CTutorialR tid ssh csh tutn TUsersR + + let heading = prependCourseTitle tid ssh csh $ CI.original tutorialName + siteLayoutMsg heading $ do + setTitleI heading + $(widgetFile "tutorial-participants") + + getCUserR, postCUserR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDUser -> Handler Html getCUserR = postCUserR postCUserR tid ssh csh uCId = do @@ -1125,6 +1253,13 @@ postCCommR tid ssh csh = do E.where_ $ sheet E.^. SheetCourse E.==. E.val cid return user ) + , ( RGCourseTutors + , E.from $ \user -> do + E.where_ $ E.exists $ E.from $ \(tutorial `E.InnerJoin` tutor) -> do + E.on $ tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial + E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid + return user + ) ] , crRecipientAuth = Just $ \uid -> do cID <- encrypt uid diff --git a/src/Handler/Tutorial.hs b/src/Handler/Tutorial.hs new file mode 100644 index 000000000..55f2d0811 --- /dev/null +++ b/src/Handler/Tutorial.hs @@ -0,0 +1,376 @@ +module Handler.Tutorial where + +import Import +import Handler.Utils +import Handler.Utils.Tutorial +import Handler.Utils.Table.Cells +import Handler.Utils.Delete +import Handler.Utils.Communication +import Handler.Utils.Form.MassInput +import Handler.Utils.Form.Occurences + +import qualified Database.Esqueleto as E +import Database.Esqueleto.Utils.TH + +import Data.Map ((!)) +import qualified Data.Map as Map +import qualified Data.Set as Set + +import qualified Data.CaseInsensitive as CI + +import Utils.Lens + + +getCTutorialListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +getCTutorialListR tid ssh csh = do + Entity cid Course{..} <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh + + let + tutorialDBTable = DBTable{..} + where + dbtSQLQuery tutorial = do + E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid + let participants = E.sub_select . E.from $ \tutorialParticipant -> do + E.where_ $ tutorialParticipant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId + return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int)) + return (tutorial, participants) + dbtRowKey = (E.^. TutorialId) + dbtProj = return . over (_dbrOutput . _2) E.unValue + dbtColonnade = dbColonnade $ mconcat + [ sortable (Just "type") (i18nCell MsgTutorialType) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> textCell $ CI.original tutorialType + , sortable (Just "name") (i18nCell MsgTutorialName) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> textCell $ CI.original tutorialName + , sortable Nothing (i18nCell MsgTutorialTutors) $ \DBRow{ dbrOutput = (Entity tutid _, _) } -> sqlCell $ do + tutors <- fmap (map $(unValueN 3)) . E.select . E.from $ \(tutor `E.InnerJoin` user) -> do + E.on $ tutor E.^. TutorUser E.==. user E.^. UserId + E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid + return (user E.^. UserEmail, user E.^. UserDisplayName, user E.^. UserSurname) + return [whamlet| +