Tutorials

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 -- $@

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

models/rooms

@@ -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 ...

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
+    name            TutorialName
-    tutor       UserId
+    course          CourseId
-    course      CourseId
+    type            (CI Text) -- "Tutorium", "Zentralübung", ...
-    capacity    Int Maybe -- limit for enrolement in this tutorial
+    capacity        Int Maybe -- limit for enrolment in this tutorial
-TutorialUser
+    room            Text
-    user        UserId
+    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

package.yaml

@@ -124,6 +124,7 @@ dependencies:
   - systemd
   - lifted-async
   - streaming-commons
+  - hourglass
 
 other-extensions:
   - GeneralizedNewtypeDeriving

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

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

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
+    aux fltr acc = fltr needle criterias E.&&. acc

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 SEditR) = return ("Bearbeiten",    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 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

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

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)

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)
+data TutorialUserAction = TutorialUserSendMail | TutorialUserDeregister
-makeCourseUserTable cid colChoices psValidator = do
+  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 "degree")   mPrev $ aopt (searchField False) (fslI MsgStudyFeatureDegree)
-          , prismAForm (singletonFilter "field")  mPrev $ aopt (searchField False) (fslI MsgCourseStudyFeature)
+          , 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

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|
+                       <ul .list--iconless .list--inline .list--comma-separated>
+                         $forall tutor <- tutors
+                           <li>
+                             ^{nameEmailWidget' tutor}
+                     |]
+          , sortable (Just "participants") (i18nCell MsgTutorialParticipants) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, n) } -> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) . toWidget $ tshow n
+          , sortable (Just "capacity") (i18nCell MsgTutorialCapacity) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybe mempty (textCell . tshow) tutorialCapacity
+          , sortable (Just "room") (i18nCell MsgTutorialRoom) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> textCell tutorialRoom
+          , sortable Nothing (i18nCell MsgTutorialTime) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> occurencesCell tutorialTime
+          , sortable (Just "reg-group") (i18nCell MsgTutorialRegGroup) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybe mempty (textCell . CI.original) tutorialRegGroup
+          , 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 _ Tutorial{..}, _) } -> cell $ do
+              linkButton [whamlet|_{MsgTutorialEdit}|] [BCIsButton] . SomeRoute $ CTutorialR tid ssh csh tutorialName TEditR
+              linkButton [whamlet|_{MsgTutorialDelete}|] [BCIsButton, BCDanger] . SomeRoute $ CTutorialR tid ssh csh tutorialName TDeleteR
+          ]
+        dbtSorting = Map.fromList
+          [ ("type", SortColumn $ \tutorial -> tutorial E.^. TutorialType )
+          , ("name", SortColumn $ \tutorial -> tutorial E.^. TutorialName )
+          , ("participants", SortColumn $ \tutorial -> 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))
+            )
+          , ("capacity", SortColumn $ \tutorial -> tutorial E.^. TutorialCapacity )
+          , ("room", SortColumn $ \tutorial -> tutorial E.^. TutorialRoom )
+          , ("reg-grep", SortColumn $ \tutorial -> tutorial E.^. TutorialRegGroup )
+          , ("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"]
+  ((), tutorialTable) <- runDB $ dbTable tutorialDBTableValidator tutorialDBTable
+
+  siteLayoutMsg (prependCourseTitle tid ssh csh MsgTutorialsHeading) $ do
+    setTitleI $ prependCourseTitle tid ssh csh MsgTutorialsHeading
+    $(widgetFile "tutorial-list")
+
+postTRegisterR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler ()
+postTRegisterR tid ssh csh tutn = do
+  uid <- requireAuthId
+
+  Entity tutid Tutorial{..} <- runDB $ fetchTutorial tid ssh csh tutn
+
+  ((btnResult, _), _) <- runFormPost buttonForm
+
+  formResult btnResult $ \case
+    BtnRegister -> do
+      runDB . void . insert $ TutorialParticipant tutid uid
+      addMessageI Success $ MsgTutorialRegisteredSuccess tutorialName
+      redirect $ CourseR tid ssh csh CShowR
+    BtnDeregister -> do
+      runDB . deleteBy $ UniqueTutorialParticipant tutid uid
+      addMessageI Success $ MsgTutorialDeregisteredSuccess tutorialName
+      redirect $ CourseR tid ssh csh CShowR
+
+  invalidArgs ["Register/Deregister button required"]
+
+getTDeleteR, postTDeleteR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html
+getTDeleteR = postTDeleteR
+postTDeleteR tid ssh csh tutn = do
+  tutid <- runDB $ fetchTutorialId tid ssh csh tutn
+  deleteR DeleteRoute
+    { drRecords = Set.singleton tutid
+    , drUnjoin = \(_ `E.InnerJoin` tutorial) -> tutorial
+    , drGetInfo = \(course `E.InnerJoin` tutorial) -> do
+        E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
+        let participants = E.sub_select . E.from $ \participant -> do
+              E.where_ $ participant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId
+              return E.countRows
+        return (course, tutorial, participants :: E.SqlExpr (E.Value Int))
+    , drRenderRecord = \(Entity _ Course{..}, Entity _ Tutorial{..}, E.Value ps) ->
+        return [whamlet|_{prependCourseTitle courseTerm courseSchool courseShorthand (CI.original tutorialName)} (#{tshow ps} _{MsgParticipantsN ps})|]
+    , drRecordConfirmString = \(Entity _ Course{..}, Entity _ Tutorial{..}, E.Value ps) ->
+        return [st|#{termToText (unTermKey courseTerm)}/#{unSchoolKey courseSchool}/#{courseShorthand}/#{tutorialName}+#{tshow ps}|]
+    , drCaption = SomeMessage MsgTutorialDeleteQuestion
+    , drSuccessMessage = SomeMessage MsgTutorialDeleted
+    , drAbort = SomeRoute $ CTutorialR tid ssh csh tutn TUsersR
+    , drSuccess = SomeRoute $ CourseR tid ssh csh CTutorialListR
+    }
+
+getTCommR, postTCommR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html
+getTCommR = postTCommR
+postTCommR tid ssh csh tutn = do
+  jSender <- requireAuthId
+  (cid, tutid) <- runDB $ fetchCourseIdTutorialId tid ssh csh tutn
+
+  commR CommunicationRoute
+    { crHeading    = SomeMessage . prependCourseTitle tid ssh csh $ SomeMessage MsgCommTutorialHeading
+    , crUltDest    = SomeRoute $ CTutorialR tid ssh csh tutn TCommR
+    , crJobs       = \Communication{..} -> do
+        let jSubject = cSubject
+            jMailContent = cBody
+            jCourse = cid
+            allRecipients = Set.toList $ Set.insert (Right jSender) cRecipients
+        jMailObjectUUID <- liftIO getRandom
+        jAllRecipientAddresses <- lift . fmap Set.fromList . forM allRecipients $ \case
+          Left email -> return . Address Nothing $ CI.original email
+          Right rid  -> userAddress <$> getJust rid
+        forM_ allRecipients $ \jRecipientEmail ->
+          yield JobSendCourseCommunication{..}
+    , crRecipients = Map.fromList
+      [ ( RGTutorialParticipants
+        , E.from $ \(user `E.InnerJoin` participant) -> do
+            E.on $ user E.^. UserId E.==. participant E.^. TutorialParticipantUser
+            E.where_ $ participant E.^. TutorialParticipantTutorial E.==. E.val tutid
+            return user
+        )
+      , ( RGCourseLecturers
+        , E.from $ \(user `E.InnerJoin` lecturer) -> do
+            E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser
+            E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid
+            return user
+        )
+      , ( RGCourseCorrectors
+        , E.from $ \user -> do
+            E.where_ $ E.exists $ E.from $ \(sheet `E.InnerJoin` corrector) -> do
+              E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
+              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
+        evalAccessDB (CourseR tid ssh csh $ CUserR cID) False
+    }
+
+
+data TutorialForm = TutorialForm
+  { tfName            :: TutorialName
+  , tfType            :: CI Text
+  , tfCapacity        :: Maybe Int
+  , tfRoom            :: Text
+  , tfTime            :: Occurences
+  , tfRegGroup        :: Maybe (CI Text)
+  , tfRegisterFrom    :: Maybe UTCTime
+  , tfRegisterTo      :: Maybe UTCTime
+  , tfDeregisterUntil :: Maybe UTCTime
+  , tfTutors          :: Set UserId -- awaiting feat/generic-invitations
+  }
+
+tutorialForm :: CourseId -> Maybe TutorialForm -> Form TutorialForm
+tutorialForm cid template html = do
+  MsgRenderer mr <- getMsgRenderer
+  Just cRoute <- getCurrentRoute
+  uid <- liftHandlerT requireAuthId
+
+  let 
+    tutorForm = Set.fromList <$> massInputAccumA miAdd' miCell' (\p -> Just . SomeRoute $ cRoute :#: p) miLayout' (fslI MsgTutorialTutors) True (Set.toList . tfTutors <$> template)
+      where
+        miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([UserId] -> FormResult [UserId])
+        miAdd' nudge submitView csrf = do
+          (addRes, addView) <- mpreq (multiUserField False . Just $ tutUserSuggestions uid) ("" & addName (nudge "email")) Nothing
+          let
+            addRes'
+              | unresolved <- toListOf (_FormSuccess . folded . _Left) addRes
+              , (fUnresolved : _) <- unresolved
+              = FormFailure [mr $ MsgEMailUnknown fUnresolved]
+              | otherwise
+              = addRes <&> \newDat oldDat -> if
+                  | (_ : _) <- Set.toList $ setOf (folded . _Right) newDat `Set.intersection` Set.fromList oldDat
+                    -> FormFailure [mr MsgTutorialTutorAlreadyAdded]
+                  | otherwise
+                    -> FormSuccess $ toListOf (folded . _Right) newDat
+          return (addRes', $(widgetFile "tutorial/tutorMassInput/add"))
+
+
+        miCell' :: UserId -> Widget
+        miCell' userId = do
+          User{..} <- liftHandlerT . runDB $ get404 userId
+          $(widgetFile "tutorial/tutorMassInput/cellKnown")
+
+        miLayout' :: MassInputLayout ListLength UserId ()
+        miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "tutorial/tutorMassInput/layout")
+  
+  flip (renderAForm FormStandard) html $ TutorialForm
+    <$> areq ciField (fslpI MsgTutorialName (mr MsgTutorialName) & setTooltip MsgTutorialNameTip) (tfName <$> template)
+    <*> areq (ciField & addDatalist tutTypeDatalist) (fslpI MsgTutorialType $ mr MsgTutorialType) (tfType <$> template)
+    <*> aopt (natFieldI MsgTutorialCapacityNonPositive) (fslpI MsgTutorialCapacity (mr MsgTutorialCapacity) & setTooltip MsgTutorialCapacityTip) (tfCapacity <$> template)
+    <*> areq textField (fslpI MsgTutorialRoom $ mr MsgTutorialRoomPlaceholder) (tfRoom <$> template)
+    <*> occurencesAForm (tfTime <$> template)
+    <*> aopt ciField (fslI MsgTutorialRegGroup & setTooltip MsgTutorialRegGroupTip) ((tfRegGroup <$> template) <|> Just (Just "tutorial"))
+    <*> aopt utcTimeField   (fslpI MsgRegisterFrom (mr MsgDate)
+                               & setTooltip MsgCourseRegisterFromTip
+                            ) (tfRegisterFrom <$> template)
+    <*> aopt utcTimeField   (fslpI MsgRegisterTo   (mr MsgDate)
+                               & setTooltip MsgCourseRegisterToTip
+                            ) (tfRegisterTo <$> template)
+    <*> aopt utcTimeField   (fslpI MsgDeRegUntil   (mr MsgDate)
+                               & setTooltip MsgCourseDeregisterUntilTip
+                            ) (tfDeregisterUntil <$> template)
+    <*> tutorForm
+  where
+    tutTypeDatalist :: WidgetT UniWorX IO (Set (CI Text))
+    tutTypeDatalist = liftHandlerT . runDB $
+      fmap (setOf $ folded . _Value) . E.select . E.from $ \tutorial -> do
+        E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
+        return $ tutorial E.^. TutorialType
+
+    tutUserSuggestions :: UserId -> E.SqlQuery (E.SqlExpr (Entity User))
+    tutUserSuggestions uid = E.from $ \(lecturer `E.InnerJoin` course `E.InnerJoin` tutorial `E.InnerJoin` tutor `E.InnerJoin` tutorUser) -> do
+      E.on $ tutorUser E.^. UserId E.==. tutor E.^. TutorUser
+      E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId
+      E.on $ tutorial E.^. TutorialCourse E.==. course E.^. CourseId
+      E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
+      E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid
+      return tutorUser
+
+
+getCTutorialNewR, postCTutorialNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+getCTutorialNewR = postCTutorialNewR
+postCTutorialNewR tid ssh csh = do
+  Entity cid Course{..} <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
+  
+  ((newTutResult, newTutWidget), newTutEnctype) <- runFormPost $ tutorialForm cid Nothing
+
+  formResult newTutResult $ \TutorialForm{..} -> do
+    insertRes <- runDB $ do
+      insertRes <- insertUnique Tutorial
+        { tutorialName            = tfName
+        , tutorialCourse          = cid
+        , tutorialType            = tfType
+        , tutorialCapacity        = tfCapacity
+        , tutorialRoom            = tfRoom
+        , tutorialTime            = tfTime
+        , tutorialRegGroup        = tfRegGroup
+        , tutorialRegisterFrom    = tfRegisterFrom
+        , tutorialRegisterTo      = tfRegisterTo
+        , tutorialDeregisterUntil = tfDeregisterUntil
+        }
+      forM_ tfTutors $ \tutor -> case insertRes of
+        Just tutid -> void . insert $ Tutor tutid tutor
+        _other     -> return ()
+      return insertRes
+    case insertRes of
+      Nothing -> addMessageI Error $ MsgTutorialNameTaken tfName
+      Just _  -> do
+        addMessageI Success $ MsgTutorialCreated tfName
+        redirect $ CourseR tid ssh csh CTutorialListR
+
+  let heading = prependCourseTitle tid ssh csh MsgTutorialNew
+
+  siteLayoutMsg heading $ do
+    setTitleI heading
+    let
+      newTutForm = wrapForm newTutWidget def
+        { formMethod = POST
+        , formAction = Just . SomeRoute $ CourseR tid ssh csh CTutorialNewR
+        , formEncoding = newTutEnctype
+        }
+    $(widgetFile "tutorial-new")
+
+getTEditR, postTEditR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html
+getTEditR = postTEditR
+postTEditR tid ssh csh tutn = do
+  (cid, tutid, template) <- runDB $ do
+    (cid, Entity tutid Tutorial{..}) <- fetchCourseIdTutorial tid ssh csh tutn
+
+    tutorIds <- fmap (map E.unValue) . E.select . E.from $ \tutor -> do
+      E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid
+      return $ tutor E.^. TutorUser
+
+    let
+      template = TutorialForm
+        { tfName            = tutorialName
+        , tfType            = tutorialType
+        , tfCapacity        = tutorialCapacity
+        , tfRoom            = tutorialRoom
+        , tfTime            = tutorialTime
+        , tfRegGroup        = tutorialRegGroup
+        , tfRegisterFrom    = tutorialRegisterFrom
+        , tfRegisterTo      = tutorialRegisterTo
+        , tfDeregisterUntil = tutorialDeregisterUntil
+        , tfTutors          = Set.fromList tutorIds
+        }
+
+    return (cid, tutid, template)
+
+  ((newTutResult, newTutWidget), newTutEnctype) <- runFormPost . tutorialForm cid $ Just template
+
+  formResult newTutResult $ \TutorialForm{..} -> do
+    insertRes <- runDB $ do
+      insertRes <- myReplaceUnique tutid Tutorial
+        { tutorialName            = tfName
+        , tutorialCourse          = cid
+        , tutorialType            = tfType
+        , tutorialCapacity        = tfCapacity
+        , tutorialRoom            = tfRoom
+        , tutorialTime            = tfTime
+        , tutorialRegGroup        = tfRegGroup
+        , tutorialRegisterFrom    = tfRegisterFrom
+        , tutorialRegisterTo      = tfRegisterTo
+        , tutorialDeregisterUntil = tfDeregisterUntil
+        }
+      deleteWhere [ TutorTutorial ==. tutid ]
+      forM_ tfTutors $ void . insert . Tutor tutid
+      return insertRes
+    case insertRes of
+      Just _  -> addMessageI Error $ MsgTutorialNameTaken tfName
+      Nothing -> do
+        addMessageI Success $ MsgTutorialCreated tfName
+        redirect $ CourseR tid ssh csh CTutorialListR
+
+  let heading = prependCourseTitle tid ssh csh . MsgTutorialEditHeading $ tfName template
+
+  siteLayoutMsg heading $ do
+    setTitleI heading
+    let
+      newTutForm = wrapForm newTutWidget def
+        { formMethod = POST
+        , formAction = Just . SomeRoute $ CTutorialR tid ssh csh tutn TEditR
+        , formEncoding = newTutEnctype
+        }
+    $(widgetFile "tutorial-edit")

src/Handler/Utils/Communication.hs

@@ -25,7 +25,8 @@ import Data.Aeson.TH
 import Data.Aeson.Types (ToJSONKey(..), FromJSONKey(..), toJSONKeyText, FromJSONKeyFunction(..))
 
 
-data RecipientGroup = RGCourseParticipants | RGCourseLecturers | RGCourseCorrectors
+data RecipientGroup = RGCourseParticipants | RGCourseLecturers | RGCourseCorrectors | RGCourseTutors
+                    | RGTutorialParticipants
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
 
 instance Universe RecipientGroup

src/Handler/Utils/DateTime.hs

@@ -25,6 +25,8 @@ import qualified Data.Time.Format as Time
 import Data.Set (Set)
 import qualified Data.Set as Set
 
+import Data.Time.Clock.System (systemEpochDay)
+
 
 utcToLocalTime :: UTCTime -> LocalTime
 utcToLocalTime = TZ.utcToLocalTimeTZ appTZ
@@ -62,6 +64,9 @@ instance HasLocalTime Day where
 instance HasLocalTime UTCTime where
   toLocalTime = utcToLocalTime
 
+instance HasLocalTime TimeOfDay where
+  toLocalTime = LocalTime systemEpochDay
+
 formatTime' :: (HasLocalTime t, MonadHandler m, HandlerSite m ~ UniWorX) => String -> t -> m Text
 formatTime' fmtStr t = fmap fromString $ Time.formatTime <$> getTimeLocale <*> pure fmtStr <*> pure (toLocalTime t)
 

src/Handler/Utils/Delete.hs

@@ -33,8 +33,8 @@ import qualified Database.Esqueleto.Internal.Language as E (From)
 
 data DeleteRoute record = forall tables infoExpr info. (E.SqlSelect infoExpr info, E.From E.SqlQuery E.SqlExpr SqlBackend tables) => DeleteRoute
   { drRecords :: Set (Key record)
-  , drUnjoin :: tables -> E.SqlExpr (Entity record)
   , drGetInfo :: tables -> E.SqlQuery infoExpr
+  , drUnjoin :: tables -> E.SqlExpr (Entity record)
   , drRenderRecord :: info -> ReaderT SqlBackend (HandlerT UniWorX IO) Widget
   , drRecordConfirmString :: info -> ReaderT SqlBackend (HandlerT UniWorX IO) Text
   , drCaption

src/Handler/Utils/Form.hs

@@ -173,6 +173,13 @@ multiActionA :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq
              -> AForm Handler a
 multiActionA acts fSettings defAction = formToAForm $ multiAction acts fSettings defAction mempty
 
+multiActionW :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
+             => Map action (AForm Handler a)
+             -> FieldSettings UniWorX
+             -> Maybe action
+             -> WForm Handler (FormResult a)
+multiActionW acts fSettings defAction = aFormToWForm $ multiActionA acts fSettings defAction
+
 multiActionM :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
              => Map action (AForm (HandlerT UniWorX IO) a)
              -> FieldSettings UniWorX
@@ -509,11 +516,8 @@ dayTimeField fs mutc = do
       | otherwise = (Nothing,Nothing)
 -}
 
-
+localTimeField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m LocalTime
-utcTimeField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m UTCTime
+localTimeField = Field
--- StackOverflow: dayToUTC <$> (areq (jqueryDayField def {...}) settings Nothing)
--- Browser returns LocalTime
-utcTimeField = Field
     { fieldParse = parseHelperGen readTime
     , fieldView = \theId name attrs val isReq -> do
         val' <- either id id <$> traverse (formatTime' fieldTimeFormat) val
@@ -529,13 +533,20 @@ utcTimeField = Field
     fieldTimeFormat = "%Y-%m-%dT%H:%M"
 
     -- `defaultTimeLocale` is okay here, since `fieldTimeFormat` does not contain any
-    readTime :: Text -> Either UniWorXMessage UTCTime
+    readTime :: Text -> Either UniWorXMessage LocalTime
     readTime t =
-      case localTimeToUTC <$> parseTimeM True defaultTimeLocale fieldTimeFormat (T.unpack t) of
+      case parseTimeM True defaultTimeLocale fieldTimeFormat (T.unpack t) of
-        Just LTUUnique{_ltuResult} -> Right _ltuResult
+        Just lTime -> Right lTime
-        Just LTUNone{}             -> Left MsgIllDefinedUTCTime
+        Nothing    -> Left MsgInvalidDateTimeFormat
-        Just LTUAmbiguous{}        -> Left MsgAmbiguousUTCTime
+
-        Nothing                    -> Left MsgInvalidDateTimeFormat
+utcTimeField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m UTCTime
+utcTimeField = checkMMap (return . localTimeToUTC') utcToLocalTime localTimeField
+  where
+    localTimeToUTC' l = case localTimeToUTC l of
+      LTUUnique{_ltuResult} -> Right _ltuResult
+      LTUNone{}             -> Left MsgIllDefinedUTCTime
+      LTUAmbiguous{}        -> Left MsgAmbiguousUTCTime
+      
 
 langField :: Bool -- ^ Only allow values from `appLanguages`
           -> Field (HandlerT UniWorX IO) Lang

src/Handler/Utils/Form/MassInput.hs

@@ -2,12 +2,13 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 
 module Handler.Utils.Form.MassInput
-  ( MassInput(..)
+  ( MassInput(..), MassInputLayout
-  , defaultMiLayout
+  , defaultMiLayout, listMiLayout
   , massInput
   , module Handler.Utils.Form.MassInput.Liveliness
   , massInputA, massInputW
   , massInputList
+  , massInputAccum, massInputAccumA
   , ListLength(..), ListPosition(..), miDeleteList
   , EnumLiveliness(..), EnumPosition(..)
   , MapLiveliness(..)
@@ -254,14 +255,17 @@ data MassInput handler liveliness cellData cellResult = MassInput
                -> liveliness
                -> Set (BoxCoord liveliness) -- ^ Usually addition widgets are only provided for dimension 0 and all _lines_ that have at least one live coordinate. `miAddEmpty` allows specifying when to provide additional widgets
   , miButtonAction :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) -- ^ Override form-tag route for `massInput`-Buttons to keep the user closer to the Widget, the `PathPiece` Argument is to be used for constructiong a `Fragment`
-  , miLayout :: liveliness
+  , miLayout :: MassInputLayout liveliness cellData cellResult
-             -> Map (BoxCoord liveliness) (cellData, FormResult cellResult)
-             -> Map (BoxCoord liveliness) Widget -- Cell Widgets
-             -> Map (BoxCoord liveliness) (FieldView UniWorX) -- Delete buttons
-             -> Map (Natural, BoxCoord liveliness) Widget -- Addition forms
-             -> Widget
   }
 
+type MassInputLayout liveliness cellData cellResult
+  =    liveliness
+    -> Map (BoxCoord liveliness) (cellData, FormResult cellResult)
+    -> Map (BoxCoord liveliness) Widget -- Cell Widgets
+    -> Map (BoxCoord liveliness) (FieldView UniWorX) -- Delete buttons
+    -> Map (Natural, BoxCoord liveliness) Widget -- Addition forms
+    -> Widget
+
 massInput :: forall handler cellData cellResult liveliness.
            ( MonadHandler handler, HandlerSite handler ~ UniWorX
            , ToJSON cellData, FromJSON cellData
@@ -418,12 +422,7 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
 
 defaultMiLayout :: forall liveliness cellData cellResult.
                    Liveliness liveliness
-                => liveliness
+                => MassInputLayout liveliness cellData cellResult
-                -> Map (BoxCoord liveliness) (cellData, FormResult cellResult)
-                -> Map (BoxCoord liveliness) Widget
-                -> Map (BoxCoord liveliness) (FieldView UniWorX)
-                -> Map (Natural, BoxCoord liveliness) Widget
-                -> Widget
 -- | Generic `miLayout` using recursively nested lists
 defaultMiLayout liveliness _ cellResults delResults addResults = miWidget' boxOrigin [] $ zip [0..] boxDimensions
   where
@@ -442,6 +441,9 @@ defaultMiLayout liveliness _ cellResults delResults addResults = miWidget' boxOr
           addWidget = Map.lookup (dimIx, miCoord) addResults
        in $(widgetFile "widgets/massinput/row")
 
+listMiLayout :: MassInputLayout ListLength cellData cellResult
+listMiLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/list/layout")
+
 
 -- | Wrapper around `massInput` for the common case, that we just want an arbitrary list of single fields without any constraints
 massInputList :: forall handler cellResult.
@@ -464,13 +466,67 @@ massInputList field fieldSettings miButtonAction miSettings miRequired miPrevRes
             , miAllowAdd = \_ _ _ -> True
             , miAddEmpty = \_ _ _ -> Set.empty
             , miButtonAction
-            , miLayout = \lLength _ cellWdgts delButtons addWdgts
+            , miLayout = listMiLayout
-              -> $(widgetFile "widgets/massinput/list/layout")
             }
   miSettings
   miRequired
   (Map.fromList . zip [0..] . map ((), ) <$> miPrevResult)
 
+-- | Wrapper around `massInput` for the common case, that we just want a list of data with no option to modify it except deletion and addition
+massInputAccum :: forall handler cellData.
+                  ( MonadHandler handler, HandlerSite handler ~ UniWorX
+                  , MonadLogger handler
+                  , ToJSON cellData, FromJSON cellData
+                  )
+               => ((Text -> Text) -> FieldView UniWorX -> (Markup -> MForm handler (FormResult ([cellData] -> FormResult [cellData]), Widget)))
+               -> (cellData -> Widget)
+               -> (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX))
+               -> MassInputLayout ListLength cellData ()
+               -> FieldSettings UniWorX
+               -> Bool
+               -> Maybe [cellData]
+               -> (Markup -> MForm handler (FormResult [cellData], FieldView UniWorX))
+massInputAccum miAdd' miCell' miButtonAction miLayout fSettings fRequired mPrev csrf
+  = over (_1 . mapped) (map fst . Map.elems) <$> massInput MassInput{..} fSettings fRequired (Map.fromList . zip [0..] . map (, ()) <$> mPrev) csrf
+  where
+    miAdd :: ListPosition -> Natural
+          -> (Text -> Text) -> FieldView UniWorX
+          -> Maybe (Markup -> MForm handler (FormResult (Map ListPosition cellData -> FormResult (Map ListPosition cellData)), Widget))
+    miAdd _pos _dim nudge submitView = Just $ \csrf' -> over (_1 . mapped) doAdd <$> miAdd' nudge submitView csrf'
+
+    doAdd :: ([cellData] -> FormResult [cellData]) -> (Map ListPosition cellData -> FormResult (Map ListPosition cellData))
+    doAdd f prevData = Map.fromList . zip [startKey..] <$> f prevElems
+      where
+        prevElems = Map.elems prevData
+        startKey = maybe 0 succ $ fst <$> Map.lookupMax prevData
+
+    miCell :: ListPosition -> cellData -> Maybe () -> (Text -> Text)
+           -> (Markup -> MForm handler (FormResult (), Widget))
+    miCell _pos dat _mPrev _nudge csrf' = return (FormSuccess (), toWidget csrf' <> miCell' dat)
+
+    miDelete = miDeleteList
+
+    miAllowAdd _ _ _ = True
+
+    miAddEmpty _ _ _ = Set.empty
+
+massInputAccumA :: forall handler cellData.
+                  ( MonadHandler handler, HandlerSite handler ~ UniWorX
+                  , MonadLogger handler
+                  , ToJSON cellData, FromJSON cellData
+                  )
+               => ((Text -> Text) -> FieldView UniWorX -> (Markup -> MForm handler (FormResult ([cellData] -> FormResult [cellData]), Widget)))
+               -> (cellData -> Widget)
+               -> (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX))
+               -> MassInputLayout ListLength cellData ()
+               -> FieldSettings UniWorX
+               -> Bool
+               -> Maybe [cellData]
+               -> AForm handler [cellData]
+massInputAccumA miAdd' miCell' miButtonAction' miLayout' fSettings fRequired mPrev
+  = formToAForm $ over _2 pure <$> massInputAccum miAdd' miCell' miButtonAction' miLayout' fSettings fRequired mPrev mempty
+
+
 massInputA :: forall handler cellData cellResult liveliness.
            ( MonadHandler handler, HandlerSite handler ~ UniWorX
            , ToJSON cellData, FromJSON cellData

src/Handler/Utils/Form/Occurences.hs

@@ -0,0 +1,122 @@
+module Handler.Utils.Form.Occurences
+  ( occurencesAForm
+  ) where
+
+import Import
+import Handler.Utils.Form
+import Handler.Utils.Form.MassInput
+import Handler.Utils.DateTime
+
+import qualified Data.Set as Set
+import Data.Map ((!))
+import qualified Data.Map as Map
+
+import Utils.Lens
+
+  
+data OccurenceScheduleKind = ScheduleKindWeekly
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
+
+instance Universe OccurenceScheduleKind
+instance Finite OccurenceScheduleKind
+
+nullaryPathPiece ''OccurenceScheduleKind $ camelToPathPiece' 2
+embedRenderMessage ''UniWorX ''OccurenceScheduleKind id
+
+data OccurenceExceptionKind = ExceptionKindOccur
+                            | ExceptionKindNoOccur
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
+
+instance Universe OccurenceExceptionKind
+instance Finite OccurenceExceptionKind
+
+nullaryPathPiece ''OccurenceExceptionKind $ camelToPathPiece' 2
+embedRenderMessage ''UniWorX ''OccurenceExceptionKind id
+
+
+occurencesAForm :: Maybe Occurences -> AForm Handler Occurences
+occurencesAForm mPrev = wFormToAForm $ do
+  Just cRoute <- getCurrentRoute
+  
+  let
+    scheduled :: AForm Handler (Set OccurenceSchedule)
+    scheduled = Set.fromList <$> massInputAccumA
+      miAdd'
+      miCell'
+      (\p -> Just . SomeRoute $ cRoute :#: p)
+      miLayout'
+      (fslI MsgScheduleRegular)
+      False
+      (Set.toList . occurencesScheduled <$> mPrev)
+      where
+        miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([OccurenceSchedule] -> FormResult [OccurenceSchedule])
+        miAdd' nudge submitView = over (mapped . mapped . _2) (\addWidget -> $(widgetFile "widgets/occurence/form/scheduled-add")) . renderAForm FormStandard . wFormToAForm $ do
+          newSched <- multiActionW
+            (Map.fromList [ ( ScheduleKindWeekly
+                            , ScheduleWeekly
+                                <$> apreq (selectField optionsFinite) (fslI MsgWeekDay & addName (nudge "occur-week-day")) Nothing
+                                <*> apreq timeFieldTypeTime (fslI MsgOccurenceStart & addName (nudge "occur-start")) Nothing
+                                <*> apreq timeFieldTypeTime (fslI MsgOccurenceEnd & addName (nudge "occur-end")) Nothing
+                            )
+                          ]
+            ) (fslI MsgScheduleRegularKind & addName (nudge "kind")) Nothing
+          MsgRenderer mr <- getMsgRenderer
+          return $ newSched <&> \newSched' oldScheds -> if
+            | newSched' `elem` oldScheds -> FormFailure [mr MsgScheduleExists]
+            | otherwise -> FormSuccess $ pure newSched'
+
+        miCell' :: OccurenceSchedule -> Widget
+        miCell' ScheduleWeekly{..} = do
+          scheduleStart' <- formatTime SelFormatTime scheduleStart
+          scheduleEnd' <- formatTime SelFormatTime scheduleEnd
+          $(widgetFile "widgets/occurence/form/weekly")
+
+        miLayout' :: MassInputLayout ListLength OccurenceSchedule ()
+        miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/occurence/form/scheduled-layout")
+
+    exceptions :: AForm Handler (Set OccurenceException)
+    exceptions = Set.fromList <$> massInputAccumA
+      miAdd'
+      miCell'
+      (\p -> Just . SomeRoute $ cRoute :#: p)
+      miLayout'
+      (fslI MsgScheduleExceptions & setTooltip MsgScheduleExceptionsTip)
+      False
+      (Set.toList . occurencesExceptions <$> mPrev)
+      where
+        miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([OccurenceException] -> FormResult [OccurenceException])
+        miAdd' nudge submitView = over (mapped . mapped . _2) (\addWidget -> $(widgetFile "widgets/occurence/form/except-add")) . renderAForm FormStandard . wFormToAForm $ do
+          newExc <- multiActionW
+            (Map.fromList [ ( ExceptionKindOccur
+                            , ExceptOccur
+                                <$> apreq dayField (fslI MsgDay & addName (nudge "occur-day")) Nothing
+                                <*> apreq timeFieldTypeTime (fslI MsgOccurenceStart & addName (nudge "occur-start")) Nothing
+                                <*> apreq timeFieldTypeTime (fslI MsgOccurenceEnd & addName (nudge "occur-end")) Nothing
+                            )
+                          , ( ExceptionKindNoOccur
+                            , ExceptNoOccur
+                                <$> apreq localTimeField (fslI MsgExceptionNoOccurAt & addName (nudge "no-occur-time")) Nothing
+                            )
+                          ]
+            ) (fslI MsgExceptionKind & addName (nudge "kind")) Nothing
+          MsgRenderer mr <- getMsgRenderer
+          return $ newExc <&> \newExc' oldExcs -> if
+            | newExc' `elem` oldExcs -> FormFailure [mr MsgExceptionExists]
+            | otherwise -> FormSuccess $ pure newExc'
+          
+
+        miCell' :: OccurenceException -> Widget
+        miCell' ExceptOccur{..} = do
+          exceptStart' <- formatTime SelFormatDateTime (LocalTime exceptDay exceptStart)
+          exceptEnd'   <- formatTime SelFormatTime     exceptStart
+          $(widgetFile "widgets/occurence/form/except-occur")
+        miCell' ExceptNoOccur{..} = do
+          exceptTime' <- formatTime SelFormatDateTime exceptTime
+          $(widgetFile "widgets/occurence/form/except-no-occur")
+
+        miLayout' :: MassInputLayout ListLength OccurenceException ()
+        miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/occurence/form/except-layout")
+
+  aFormToWForm $ Occurences
+    <$> scheduled
+    <*> exceptions

src/Handler/Utils/Sheet.hs

@@ -15,7 +15,7 @@ fetchSheetAux ::  ( BaseBackend backend ~ SqlBackend
   =>  (E.SqlExpr (Entity Sheet) -> E.SqlExpr (Entity Course) -> b)
       -> TermId -> SchoolId -> CourseShorthand -> SheetName -> ReaderT backend m a
 fetchSheetAux prj tid ssh csh shn =
-    let cachId = encodeUtf8 $ tshow (tid,ssh,csh,shn)
+    let cachId = encodeUtf8 $ tshow (tid, ssh, csh, shn)
     in  cachedBy cachId $ do
     -- Mit Yesod:
     -- cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh

src/Handler/Utils/Submission.hs

@@ -79,32 +79,33 @@ assignSubmissions sid restriction = do
       loadMap :: Map UserId Bool
       loadMap = Map.fromList [(sheetCorrectorUser,b) | Entity _ SheetCorrector{ sheetCorrectorLoad = (Load {byTutorial = Just b}), .. } <- corrsTutorial]
 
-    currentSubs <- E.select . E.from $ \(submission `E.LeftOuterJoin` tutor) -> do
+    currentSubs <- E.select . E.from $ \(submission `E.LeftOuterJoin` tutor') -> do
-        let tutors = E.subList_select . E.from $ \(submissionUser `E.InnerJoin` tutorialUser `E.InnerJoin` tutorial) -> do
+        let tutors = E.subList_select . E.from $ \(submissionUser `E.InnerJoin` tutorialUser `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do
               -- Uncomment next line for equal chance between tutors, irrespective of the number of students per tutor per submission group
               -- E.distinctOn [E.don $ tutorial E.^. TutorialTutor] $ do
-                E.on (tutorial       E.^. TutorialId         E.==. tutorialUser E.^. TutorialUserTutorial)
+                E.on (tutorial       E.^. TutorialId         E.==. tutor        E.^. TutorTutorial)
-                E.on (submissionUser E.^. SubmissionUserUser E.==. tutorialUser E.^. TutorialUserUser)
+                E.on (tutorial       E.^. TutorialId         E.==. tutorialUser E.^. TutorialParticipantTutorial)
-                E.where_ (tutorial   E.^. TutorialTutor `E.in_` E.valList (map (sheetCorrectorUser . entityVal) corrsTutorial))
+                E.on (submissionUser E.^. SubmissionUserUser E.==. tutorialUser E.^. TutorialParticipantUser)
-                return $ tutorial E.^. TutorialTutor
+                E.where_ (tutor   E.^. TutorUser `E.in_` E.valList (map (sheetCorrectorUser . entityVal) corrsTutorial))
-        E.on $ tutor E.?. UserId `E.in_` E.justList tutors
+                return $ tutor E.^. TutorUser
+        E.on $ tutor' E.?. UserId `E.in_` E.justList tutors
         E.where_ $ submission E.^. SubmissionSheet E.==. E.val sid
              E.&&. maybe (E.val True) (submission E.^. SubmissionId `E.in_`) (E.valList . Set.toList <$> restriction)
-        return (submission E.^. SubmissionId, tutor)
+        return (submission E.^. SubmissionId, tutor' E.?. UserId)
 
     let subTutor' :: Map SubmissionId (Set UserId)
         subTutor' = Map.fromListWith Set.union $ currentSubs
-          & mapped._2 %~ maybe Set.empty Set.singleton
+          & mapped._2 %~ (maybe Set.empty Set.singleton . E.unValue)
-          & mapped._2 %~ Set.mapMonotonic entityKey
           & mapped._1 %~ E.unValue
 
     prevSubs <- E.select . E.from $ \((sheet `E.InnerJoin` sheetCorrector) `E.LeftOuterJoin` submission) -> do
         E.on $ E.joinV (submission E.?. SubmissionRatingBy) E.==. E.just (sheetCorrector E.^. SheetCorrectorUser)
         E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
-        let isByTutorial = E.exists . E.from $ \(submissionUser `E.InnerJoin` tutorialUser `E.InnerJoin` tutorial) -> do
+        let isByTutorial = E.exists . E.from $ \(submissionUser `E.InnerJoin` tutorialUser `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do
-              E.on $ tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialUserTutorial
+              E.on (tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial)
-              E.on $ submissionUser E.^. SubmissionUserUser E.==. tutorialUser E.^. TutorialUserUser
+              E.on $ tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialParticipantTutorial
-              E.where_ $ tutorial E.^. TutorialTutor E.==. sheetCorrector E.^. SheetCorrectorUser
+              E.on $ submissionUser E.^. SubmissionUserUser E.==. tutorialUser E.^. TutorialParticipantUser
+              E.where_ $ tutor E.^. TutorUser E.==. sheetCorrector E.^. SheetCorrectorUser
                    E.&&. submission E.?. SubmissionId E.==. E.just (submissionUser E.^. SubmissionUserSubmission)
         E.where_ $ sheet E.^. SheetCourse E.==. E.val sheetCourse
              E.&&. sheetCorrector E.^. SheetCorrectorUser `E.in_` E.valList (map (sheetCorrectorUser . entityVal) correctors)

src/Handler/Utils/Table/Cells.hs

@@ -14,6 +14,10 @@ import Text.Blaze (ToMarkup(..))
 import Utils.Lens
 import Handler.Utils
 
+import Utils.Occurences
+
+import qualified Data.Set as Set
+
 
 type CourseLink = (TermId, SchoolId, CourseShorthand) -- TODO: Refactor with WithHoles !
 
@@ -189,3 +193,19 @@ correctorLoadCell :: IsDBTable m a => SheetCorrector -> DBCell m a
 correctorLoadCell sc =
   i18nCell $ sheetCorrectorLoad sc
 
+occurencesCell :: IsDBTable m a => Occurences -> DBCell m a
+occurencesCell (normalizeOccurences -> Occurences{..}) = cell $ do
+  let occurencesScheduled' = flip map (Set.toList occurencesScheduled) $ \case
+        ScheduleWeekly{..} -> do
+          scheduleStart' <- formatTime SelFormatTime scheduleStart
+          scheduleEnd' <- formatTime SelFormatTime scheduleEnd
+          $(widgetFile "widgets/occurence/cell/weekly")
+      occurencesExceptions' = flip map (Set.toList occurencesExceptions) $ \case
+        ExceptOccur{..} -> do
+          exceptStart' <- formatTime SelFormatDateTime (LocalTime exceptDay exceptStart)
+          exceptEnd'   <- formatTime SelFormatTime     exceptStart
+          $(widgetFile "widgets/occurence/cell/except-occur")
+        ExceptNoOccur{..} -> do
+          exceptTime' <- formatTime SelFormatDateTime exceptTime
+          $(widgetFile "widgets/occurence/cell/except-no-occur")
+  $(widgetFile "widgets/occurence/cell")

src/Handler/Utils/Table/Pagination.hs

@@ -87,6 +87,15 @@ import Crypto.Hash.Algorithms (SHAKE256)
 import qualified Data.ByteString.Base64.URL as Base64 (encode)
 import qualified Data.ByteString.Lazy as LBS
 
+import Data.Semigroup as Sem (Semigroup(..))
+
+
+#if MIN_VERSION_base(4,11,0)
+type Monoid' = Monoid
+#else
+type Monoid' x = (Sem.Semigroup x, Monoid x)
+#endif
+
 
 data SortColumn t = forall a. PersistField a => SortColumn { getSortColumn :: t -> E.SqlExpr (E.Value a) }
 
@@ -404,7 +413,7 @@ data DBTable m x = forall a r r' h i t k k'.
   , dbtIdent :: i
   }
 
-class (MonadHandler m, HandlerSite m ~ UniWorX, Monoid x, Monoid (DBCell m x), Default (DBParams m x)) => IsDBTable (m :: * -> *) (x :: *) where
+class (MonadHandler m, HandlerSite m ~ UniWorX, Monoid' x, Monoid' (DBCell m x), Default (DBParams m x)) => IsDBTable (m :: * -> *) (x :: *) where
   data DBParams m x :: *
   type DBResult m x :: *
   -- type DBResult' m x :: *
@@ -428,7 +437,7 @@ cellAttrs = dbCell . _1
 cellContents :: IsDBTable m x => Lens' (DBCell m x) (WriterT x m Widget)
 cellContents = dbCell . _2
 
-instance Monoid x => IsDBTable (HandlerT UniWorX IO) x where
+instance Monoid' x => IsDBTable (HandlerT UniWorX IO) x where
   data DBParams (HandlerT UniWorX IO) x = DBParamsWidget
   type DBResult (HandlerT UniWorX IO) x = (x, Widget)
   -- type DBResult' (WidgetT UniWorX IO) () = ()
@@ -447,14 +456,17 @@ instance Monoid x => IsDBTable (HandlerT UniWorX IO) x where
   dbHandler _ _ f = return . over _2 f
   runDBTable _ _ _ = liftHandlerT
 
-instance Monoid x => Monoid (DBCell (HandlerT UniWorX IO) x) where
+instance Monoid' x => Sem.Semigroup (DBCell (HandlerT UniWorX IO) x) where
+  (WidgetCell a c) <> (WidgetCell a' c') = WidgetCell (a <> a') ((<>) <$> c <*> c')
+
+instance Monoid' x => Monoid (DBCell (HandlerT UniWorX IO) x) where
   mempty = WidgetCell mempty $ return mempty
-  (WidgetCell a c) `mappend` (WidgetCell a' c') = WidgetCell (mappend a a') (mappend <$> c <*> c')
+  mappend = (<>)
 
 instance Default (DBParams (HandlerT UniWorX IO) x) where
   def = DBParamsWidget
 
-instance Monoid x => IsDBTable (ReaderT SqlBackend (HandlerT UniWorX IO)) x where
+instance Monoid' x => IsDBTable (ReaderT SqlBackend (HandlerT UniWorX IO)) x where
   data DBParams (ReaderT SqlBackend (HandlerT UniWorX IO)) x = DBParamsDB
   type DBResult (ReaderT SqlBackend (HandlerT UniWorX IO)) x = (x, Widget)
 
@@ -472,9 +484,12 @@ instance Monoid x => IsDBTable (ReaderT SqlBackend (HandlerT UniWorX IO)) x wher
   -- runDBTable :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX) => ReaderT SqlBackend (HandlerT UniWorX IO) ((), Widget) -> m (Widget)
   runDBTable _ _ _ = mapReaderT liftHandlerT
 
-instance Monoid x => Monoid (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x) where
+instance Monoid' x => Sem.Semigroup (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x) where
+  (DBCell a c) <> (DBCell a' c') = DBCell (a <> a') ((<>) <$> c <*> c')
+
+instance Monoid' x => Monoid (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x) where
   mempty = DBCell mempty $ return mempty
-  (DBCell a c) `mappend` (DBCell a' c') = DBCell (mappend a a') (mappend <$> c <*> c')
+  mappend = (<>)
 
 instance Default (DBParams (ReaderT SqlBackend (HandlerT UniWorX IO)) x) where
   def = DBParamsDB
@@ -492,7 +507,7 @@ unDBParamsFormIdent DBTable{dbtIdent}  DBParamsFormTableIdent       = Just $ toP
 unDBParamsFormIdent _                 (DBParamsFormOverrideIdent x) = Just $ toPathPiece x
 unDBParamsFormIdent _                  DBParamsFormNoIdent          = Nothing
 
-instance Monoid x => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x where
+instance Monoid' x => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x where
   data DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x = forall a. DBParamsForm
     { dbParamsFormMethod     :: StdMethod
     , dbParamsFormAction     :: Maybe (SomeRoute UniWorX)
@@ -541,7 +556,7 @@ instance Monoid x => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enc
       adjResult _                  = FormFailure $ pure reasonTxt
     return $ over (_1 . dbParamsFormResult) adjResult result
 
-instance Monoid x => Default (DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x) where
+instance Monoid' x => Default (DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x) where
   def = DBParamsForm
     { dbParamsFormMethod     = POST
     , dbParamsFormAction     = Nothing
@@ -553,7 +568,7 @@ instance Monoid x => Default (DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [La
     , dbParamsFormIdent      = def
     }
 
-dbParamsFormWrap :: Monoid x => DBTable (MForm (HandlerT UniWorX IO)) x -> DBParams (MForm (HandlerT UniWorX IO)) x -> (Html -> MForm (HandlerT UniWorX IO) (x, Widget)) -> (Html -> MForm (HandlerT UniWorX IO) (x, Widget))
+dbParamsFormWrap :: Monoid' x => DBTable (MForm (HandlerT UniWorX IO)) x -> DBParams (MForm (HandlerT UniWorX IO)) x -> (Html -> MForm (HandlerT UniWorX IO) (x, Widget)) -> (Html -> MForm (HandlerT UniWorX IO) (x, Widget))
 dbParamsFormWrap DBTable{ dbtIdent } DBParamsForm{..} tableForm frag = do
   let form = mappend <$> tableForm frag <*> (fmap (over _1 $ (flip $ set dbParamsFormResult) mempty) $ dbParamsFormAdditional mempty)
   ((res, fWidget), enctype) <- listen form
@@ -588,9 +603,12 @@ addPreviousHiddenField DBTable{ dbtIdent } pKeys form fragment = do
     wIdent :: Text -> Text
     wIdent = toPathPiece . WithIdent dbtIdent
 
-instance Monoid x => Monoid (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x) where
+instance Monoid' x => Sem.Semigroup (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x) where
+  (FormCell attrs c l) <> (FormCell attrs' c' l') = FormCell (attrs <> attrs') ((\(a, w) (a', w') -> ((,) <$> a <*> a', w <> w')) <$> c <*> c') (lens (liftA2 (,) <$> view l <*> view l') (\s as -> s & l .~ (fst <$> as) & l' .~ (snd <$> as)))
+
+instance Monoid' x => Monoid (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x) where
   mempty = FormCell mempty (return mempty) $ lens (\_ -> pure ()) (\s _ -> s)
-  (FormCell attrs c l) `mappend` (FormCell attrs' c' l') = FormCell (mappend attrs attrs') ((\(a, w) (a', w') -> ((,) <$> a <*> a', mappend w w')) <$> c <*> c') (lens (liftA2 (,) <$> view l <*> view l') (\s as -> s & l .~ (fst <$> as) & l' .~ (snd <$> as)))
+  mappend = (<>)
 
 instance IsDBTable m a => IsString (DBCell m a) where
   fromString = cell . fromString
@@ -779,24 +797,24 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
     setParam :: Text -> Maybe Text -> QueryText -> QueryText
     setParam key = setParams key . maybeToList
 
-dbTableWidget :: Monoid x => PSValidator (HandlerT UniWorX IO) x -> DBTable (HandlerT UniWorX IO) x
+dbTableWidget :: Monoid' x => PSValidator (HandlerT UniWorX IO) x -> DBTable (HandlerT UniWorX IO) x
     -> DB (DBResult (HandlerT UniWorX IO) x)
 dbTableWidget = dbTable
 
 dbTableWidget' :: PSValidator (HandlerT UniWorX IO) () -> DBTable (HandlerT UniWorX IO) () -> DB Widget
 dbTableWidget' = fmap (fmap snd) . dbTable
 
-widgetColonnade :: (Headedness h, Monoid x)
+widgetColonnade :: (Headedness h, Monoid' x)
                 => Colonnade h r (DBCell (HandlerT UniWorX IO) x)
                 -> Colonnade h r (DBCell (HandlerT UniWorX IO) x)
 widgetColonnade = id
 
-formColonnade :: (Headedness h, Monoid a)
+formColonnade :: (Headedness h, Monoid' a)
               => Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a))
               -> Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a))
 formColonnade = id
 
-dbColonnade :: (Headedness h, Monoid x)
+dbColonnade :: (Headedness h, Monoid' x)
             => Colonnade h r (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x)
             -> Colonnade h r (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x)
 dbColonnade = id
@@ -880,9 +898,12 @@ newtype DBFormResult i a r = DBFormResult (Map i (r, a -> a))
 instance Functor (DBFormResult i a) where
   f `fmap` (DBFormResult resMap) = DBFormResult $ fmap (over _1 f) resMap
 
+instance Ord i => Sem.Semigroup (DBFormResult i a r) where
+  (DBFormResult m1) <> (DBFormResult m2) = DBFormResult $ Map.unionWith (\(r, f1) (_, f2) -> (r, f2 . f1)) m1 m2
+
 instance Ord i => Monoid (DBFormResult i a r) where
   mempty = DBFormResult Map.empty
-  (DBFormResult m1) `mappend` (DBFormResult m2) = DBFormResult $ Map.unionWith (\(r, f1) (_, f2) -> (r, f2 . f1)) m1 m2
+  mappend = (<>)
 
 getDBFormResult :: forall r i a. Ord i => (r -> a) -> DBFormResult i a r -> Map i a
 getDBFormResult initial (DBFormResult m) = Map.map (\(r, f) -> f $ initial r) m
@@ -914,7 +935,7 @@ formCell formCellLens genIndex genForm input@(DBRow{dbrKey}) = FormCell
 dbRow :: forall h r m a. (Headedness h, IsDBTable m a) => Colonnade h (DBRow r) (DBCell m a)
 dbRow = Colonnade.singleton (headednessPure $ i18nCell MsgNrColumn) $ \DBRow{ dbrIndex } -> textCell $ tshow dbrIndex
 
-dbSelect :: forall x h r i a. (Headedness h, Ord i, PathPiece i, Monoid x)
+dbSelect :: forall x h r i a. (Headedness h, Ord i, PathPiece i, Monoid' x)
          => Lens' x (FormResult (DBFormResult i a (DBRow r)))
          -> Setter' a Bool
          -> (DBRow r -> MForm (HandlerT UniWorX IO) i)

src/Handler/Utils/Tutorial.hs

@@ -0,0 +1,47 @@
+module Handler.Utils.Tutorial
+  ( fetchTutorialAux
+  , fetchTutorial, fetchTutorialId, fetchCourseIdTutorialId, fetchCourseIdTutorial
+  ) where
+
+import Import
+
+import Database.Persist.Sql (SqlBackendCanRead)
+import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Internal.Sql as E
+import Database.Esqueleto.Utils.TH
+
+import Utils.Lens
+
+
+fetchTutorialAux :: ( SqlBackendCanRead backend
+                    , E.SqlSelect b a
+                    , MonadHandler m
+                    , Typeable a
+                    )
+                 => (E.SqlExpr (Entity Tutorial) -> E.SqlExpr (Entity Course) -> b)
+                 -> TermId -> SchoolId -> CourseShorthand -> TutorialName -> ReaderT backend m a
+fetchTutorialAux prj tid ssh csh tutn =
+    let cachId = encodeUtf8 $ tshow (tid, ssh, csh, tutn)
+    in  cachedBy cachId $ do
+        tutList <- E.select . E.from $ \(course `E.InnerJoin` tut) -> do
+            E.on     $ course E.^. CourseId E.==. tut E.^. TutorialCourse
+            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.&&.  tut    E.^. TutorialName    E.==. E.val tutn
+            return $ prj tut course
+        case tutList of
+          [tut] -> return tut
+          _other  -> notFound
+
+fetchTutorial :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> DB (Entity Tutorial)
+fetchTutorial = fetchTutorialAux const
+
+fetchTutorialId :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> YesodDB UniWorX (Key Tutorial)
+fetchTutorialId tid ssh cid tutn = E.unValue <$> fetchTutorialAux (\tutorial _ -> tutorial E.^. TutorialId) tid ssh cid tutn
+
+fetchCourseIdTutorialId  :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> YesodDB UniWorX (Key Course, Key Tutorial)
+fetchCourseIdTutorialId tid ssh cid tutn = $(unValueN 2) <$> fetchTutorialAux (\tutorial course -> (course E.^. CourseId, tutorial E.^. TutorialId)) tid ssh cid tutn
+
+fetchCourseIdTutorial  :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> YesodDB UniWorX (Key Course, Entity Tutorial)
+fetchCourseIdTutorial tid ssh cid tutn = over _1 E.unValue <$> fetchTutorialAux (\tutorial course -> (course E.^. CourseId, tutorial)) tid ssh cid tutn

src/Handler/Utils/Zip.hs

@@ -23,7 +23,7 @@ import Data.ByteString (ByteString)
 import qualified Data.ByteString as ByteString
 
 import System.FilePath
-import Data.Time
+import Data.Time.LocalTime (localTimeToUTC, utcToLocalTime)
 
 import Data.List (dropWhileEnd)
 

src/Import/NoFoundation.hs

@@ -53,7 +53,7 @@ import Data.List.NonEmpty.Instances as Import ()
 import Data.NonNull.Instances as Import ()
 import Data.Text.Encoding.Error as Import(UnicodeException(..))
 import Data.Semigroup         as Import (Semigroup)
-import Data.Monoid            as Import (Last(..), First(..))
+import Data.Monoid            as Import (Last(..), First(..), Any(..), All(..))
 import Data.Monoid.Instances  as Import ()
 import Data.Set.Instances     as Import ()
 import Data.HashMap.Strict.Instances as Import ()
@@ -86,6 +86,15 @@ import Text.Blaze.Instances as Import ()
 import Jose.Jwt.Instances as Import ()
 import Web.PathPieces.Instances as Import ()
 
+import Data.Time.Calendar as Import
+import Data.Time.Clock as Import
+import Data.Time.LocalTime as Import hiding (utcToLocalTime, localTimeToUTC)
+import Time.Types as Import (WeekDay(..))
+
+import Time.Types.Instances as Import ()
+
+import Data.CaseInsensitive as Import (CI, FoldCase(..), foldedCase)
+
 
 import Control.Monad.Trans.RWS (RWST)
 

src/Jobs.hs

@@ -47,7 +47,6 @@ import Control.Monad.Trans.Resource (MonadResourceBase, runResourceT, allocate,
 import Control.Monad.Trans.Maybe (MaybeT(..))
 import Control.Monad.Logger
 
-import Data.Time.Clock
 import Data.Time.Zones
 
 import Control.Concurrent.STM (retry)

src/Jobs/Crontab.hs

@@ -11,7 +11,6 @@ import Data.Maybe (fromJust)
 import qualified Data.Map as Map
 import Data.Semigroup (Max(..))
 
-import Data.Time
 import Data.Time.Zones
 
 import Control.Monad.Trans.Writer (execWriterT)

src/Jobs/Queue.hs

@@ -6,7 +6,7 @@ module Jobs.Queue
   , module Jobs.Types
   ) where
 
-import Import
+import Import hiding ((<>))
 
 import Utils.Sql
 import Jobs.Types
@@ -23,6 +23,8 @@ import Control.Monad.Random (evalRand, mkStdGen, uniform)
 
 import qualified Data.Conduit.List as C
 
+import Data.Semigroup ((<>))
+
 
 data JobQueueException = JobQueuePoolEmpty
   deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic)

src/Model.hs

@@ -35,6 +35,7 @@ share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll
 -- (Eq Course) is impossible so we derive it for the Uniqueness Constraint only
 deriving instance Eq (Unique Course)
 deriving instance Eq (Unique Sheet)
+deriving instance Eq (Unique Tutorial)
 
 -- Primary keys mentioned in dbtable row-keys must be Binary
 -- Automatically generated (i.e. numeric) ids are already taken care of

src/Model/Migration.hs

@@ -247,6 +247,11 @@ customMigrations = Map.fromListWith (>>)
                 ( Legacy.UserSubmissions     , Legacy.Upload False ) -> SubmissionMode False (Just $ Upload False)
           [executeQQ| UPDATE "sheet" SET "submission_mode" = #{submissionMode'} WHERE "id" = #{shid}; |]
     )
+  , ( AppliedMigrationKey [migrationVersion|11.0.0|] [version|12.0.0|]
+    , whenM ((&&) <$> tableExists "tutorial" <*> tableExists "tutorial_user") $ do -- Tutorials were an unused stub before
+        tableDropEmpty "tutorial"
+        tableDropEmpty "tutorial_user"
+    )
   ]
 
 
@@ -258,6 +263,18 @@ tableExists table = do
     [Just _] -> return True
     _other   -> return False
 
+tableIsEmpty :: MonadIO m => Text -> ReaderT SqlBackend m Bool
+tableIsEmpty table = do
+  [rows] <- rawSql [st|SELECT COUNT(*) FROM "#{table}"|] []
+  return $ unSingle rows == (0 :: Int64)
+
+tableDropEmpty :: MonadIO m => Text -> ReaderT SqlBackend m ()
+tableDropEmpty table = do
+  isEmpty <- tableIsEmpty table
+  if
+    | isEmpty   -> rawExecute [st|DROP TABLE "#{table}" CASCADE|] []
+    | otherwise -> fail $ "Table " <> unpack table <> " is not empty"
+
 columnExists :: MonadIO m
              => Text -- ^ Table
              -> Text -- ^ Column

src/Model/Types.hs

@@ -83,6 +83,9 @@ import Data.Text.Metrics (damerauLevenshtein)
 
 import Data.Binary (Binary)
 import qualified Data.Binary as Binary
+
+import Time.Types (WeekDay(..))
+import Data.Time.LocalTime (LocalTime, TimeOfDay)
   
 
 instance PathPiece UUID where
@@ -752,10 +755,11 @@ pseudonymFragments = folding
 
 data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prädikate sind sortier nach Relevanz für Benutzer
   = AuthAdmin
-  | AuthToken
   | AuthLecturer
   | AuthCorrector
-  | AuthRegistered
+  | AuthTutor
+  | AuthCourseRegistered
+  | AuthTutorialRegistered
   | AuthParticipant
   | AuthTime
   | AuthMaterials
@@ -764,12 +768,14 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä
   | AuthUserSubmissions
   | AuthCorrectorSubmissions
   | AuthCapacity
+  | AuthRegisterGroup
   | AuthEmpty
   | AuthSelf
   | AuthAuthentication
   | AuthNoEscalation
   | AuthRead
   | AuthWrite
+  | AuthToken
   | AuthDeprecated
   | AuthDevelopment
   | AuthFree
@@ -870,6 +876,51 @@ derivePersistFieldJSON ''LecturerType
 
 instance Hashable LecturerType
 
+  
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece
+  } ''WeekDay
+  
+data OccurenceSchedule = ScheduleWeekly
+                         { scheduleDayOfWeek :: WeekDay
+                         , scheduleStart     :: TimeOfDay
+                         , scheduleEnd       :: TimeOfDay
+                         }
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+deriveJSON defaultOptions
+  { fieldLabelModifier = camelToPathPiece' 1
+  , constructorTagModifier = camelToPathPiece' 1
+  , tagSingleConstructors = True
+  , sumEncoding = TaggedObject "repeat" "schedule"
+  } ''OccurenceSchedule
+
+data OccurenceException = ExceptOccur
+                          { exceptDay   :: Day
+                          , exceptStart :: TimeOfDay
+                          , exceptEnd   :: TimeOfDay
+                          }
+                        | ExceptNoOccur
+                          { exceptTime  :: LocalTime
+                          }
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+deriveJSON defaultOptions
+  { fieldLabelModifier = camelToPathPiece' 1
+  , constructorTagModifier = camelToPathPiece' 1
+  , sumEncoding = TaggedObject "exception" "for"
+  } ''OccurenceException
+
+data Occurences = Occurences
+  { occurencesScheduled  :: Set OccurenceSchedule
+  , occurencesExceptions :: Set OccurenceException
+  } deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+deriveJSON defaultOptions
+  { fieldLabelModifier = camelToPathPiece' 1
+  } ''Occurences
+derivePersistFieldJSON ''Occurences
+
 
 -- Type synonyms
 
@@ -881,6 +932,7 @@ type CourseName      = CI Text
 type CourseShorthand = CI Text
 type SheetName       = CI Text
 type UserEmail       = CI Email
+type TutorialName    = CI Text
 
 type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString
 type InstanceId      = UUID

src/Time/Types/Instances.hs

@@ -0,0 +1,19 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Time.Types.Instances
+  (
+  ) where
+
+-- import ClassyPrelude
+
+import Time.Types
+
+import Data.Universe
+
+import Utils.PathPiece
+
+
+instance Universe WeekDay
+instance Finite WeekDay
+
+nullaryPathPiece ''WeekDay camelToPathPiece

src/Utils/Form.hs

@@ -23,6 +23,7 @@ import qualified Data.Set as Set
 import Control.Monad.Trans.Maybe (MaybeT(..))
 import Control.Monad.Reader.Class (MonadReader(..))
 import Control.Monad.Writer.Class (MonadWriter(..))
+import Control.Monad.Trans.RWS (mapRWST)
 
 import Data.List ((!!))
 
@@ -357,8 +358,11 @@ submitButtonView = do
 
 
 buttonForm :: (Button site a, Finite a) => Html -> MForm (HandlerT site IO) (FormResult a, WidgetT site IO ())
-buttonForm csrf = do
+buttonForm = buttonForm' universeF
-  (res, ($ []) -> fViews) <- aFormToForm . disambiguateButtons $ combinedButtonFieldF ""
+
+buttonForm' :: Button site a => [a] -> Html -> MForm (HandlerT site IO) (FormResult a, WidgetT site IO ())
+buttonForm' btns csrf = do
+  (res, ($ []) -> fViews) <- aFormToForm . disambiguateButtons $ combinedButtonField btns ""
   return (res, [whamlet|
       $newline never
       #{csrf}
@@ -366,7 +370,6 @@ buttonForm csrf = do
         ^{fvInput bView}
     |])
 
-
 -------------------
 -- Custom Fields --
 -------------------
@@ -614,6 +617,18 @@ prismAForm p outer form = review p <$> form inner
   where
     inner = outer >>= preview p
 
+-----------------------
+-- Form Manipulation --
+-----------------------
+
+aFormToWForm :: MonadHandler m => AForm m a -> WForm m (FormResult a)
+aFormToWForm = mapRWST mFormToWForm' . over (mapped . _2) ($ []) . aFormToForm
+  where
+    mFormToWForm' f = do
+      ((a, vs), ints, enctype) <- lift f
+      writer ((a, ints, enctype), vs)
+
+
 ---------------------------------------------
 -- Special variants of @mopt@, @mreq@, ... --
 ---------------------------------------------

src/Utils/Lens.hs

@@ -5,6 +5,7 @@ import Model
 import Control.Lens as Utils.Lens hiding ((<.>), universe, snoc)
 import Control.Lens.Extras as Utils.Lens (is)
 import Utils.Lens.TH as Utils.Lens (makeLenses_, makeClassyFor_)
+import Data.Set.Lens as Utils.Lens
 
 import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
 
@@ -103,6 +104,16 @@ makeLenses_ ''SubmissionMode
 
 makePrisms ''E.Value
 
+makeLenses_ ''OccurenceSchedule
+
+makePrisms ''OccurenceSchedule
+
+makeLenses_ ''OccurenceException
+
+makePrisms ''OccurenceException
+
+makeLenses_ ''Occurences
+
 
 -- makeClassy_ ''Load
 

src/Utils/Occurences.hs

@@ -0,0 +1,84 @@
+{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}
+
+module Utils.Occurences
+  ( normalizeOccurences
+  ) where
+
+import ClassyPrelude
+
+import Model.Types
+import Utils
+import Utils.Lens
+
+import Control.Monad.Trans.Reader (runReader, Reader)
+
+import Control.Monad.Trans.Except (ExceptT, throwE, runExceptT)
+
+import qualified Data.Set as Set
+
+import Data.Time
+import Data.Time.Calendar.WeekDate
+
+
+normalizeOccurences :: Occurences -> Occurences
+-- ^ 
+--
+--   - Removes unnecessary exceptions
+--   - Merges overlapping schedules
+normalizeOccurences initial
+  | Left new <- runReader (runExceptT go) initial
+  = normalizeOccurences new
+  | otherwise
+  = initial
+  where
+    go :: ExceptT Occurences (Reader Occurences) ()
+    -- Find some inconsistency and `throwE` a version without it
+    go = do
+      scheduled <- view _occurencesScheduled
+      forM_ scheduled $ \case
+        a@ScheduleWeekly{} -> do
+          let
+            merge b@ScheduleWeekly{}
+              | scheduleDayOfWeek a == scheduleDayOfWeek b -- b starts during a
+              , scheduleStart a <= scheduleStart b
+              , scheduleEnd a >= scheduleStart b
+              = Just $ ScheduleWeekly (scheduleDayOfWeek a) (scheduleStart a) ((max `on` scheduleEnd) a b)
+              | scheduleDayOfWeek a == scheduleDayOfWeek b -- b ends during a
+              , scheduleStart a <= scheduleEnd b
+              , scheduleEnd a >= scheduleEnd b
+              = Just $ ScheduleWeekly (scheduleDayOfWeek a) ((min `on` scheduleStart) a b) (scheduleEnd a)
+              | otherwise
+              = Nothing
+            merge _ = Nothing
+          merges <- views _occurencesScheduled $ mapMaybe (\b -> (,) <$> pure b <*> merge b) . Set.toList . Set.delete a
+          case merges of
+            [] -> return ()
+            ((b, merged) : _) -> throwE =<< asks (over _occurencesScheduled $ Set.insert merged . Set.delete b . Set.delete a)
+
+      exceptions <- view _occurencesExceptions
+      forM_ exceptions $ \case
+        needle@ExceptNoOccur{..} -> do
+          let LocalTime{..} = exceptTime
+              (_, _, toEnum . (`mod` 7) -> localWeekDay) = toWeekDate localDay
+          needed <- views _occurencesScheduled . any $ \case
+            ScheduleWeekly{..} -> and
+              [ scheduleDayOfWeek == localWeekDay
+              , scheduleStart <= localTimeOfDay
+              , localTimeOfDay <= scheduleEnd
+              ]
+          unless needed $
+            throwE =<< asks (over _occurencesExceptions $ Set.delete needle)
+        needle@ExceptOccur{..} -> do
+          let (_, _, toEnum . (`mod` 7) -> localWeekDay) = toWeekDate exceptDay
+              -- | Does this ExceptNoOccur target within needle?
+              withinNeedle ExceptNoOccur{..} = LocalTime exceptDay exceptStart <= exceptTime
+                                            && exceptTime <= LocalTime exceptDay exceptEnd
+              withinNeedle _ = False
+          needed <- views _occurencesScheduled . none $ \case
+            ScheduleWeekly{..} -> and
+              [ scheduleDayOfWeek == localWeekDay
+              , scheduleStart == exceptStart
+              , scheduleEnd == exceptEnd
+              ]
+          unless needed $
+            throwE =<< asks (over _occurencesExceptions $ Set.filter (not . withinNeedle) . Set.delete needle)

static/css/utils/tooltip.scss

@@ -35,6 +35,14 @@
     font-size: 15px;
   }
 
+  &.tooltip__handle--danger::before {
+    content: '\f12a';
+  }
+
+  &.tooltip__handle--danger {
+      background-color: var(--color-warning);
+  }
+
   &:hover {
     background-color: var(--color-light);
   }

static/js/utils/form.js

@@ -216,6 +216,10 @@
 
       childInputs.forEach(function(el) {
         el.disabled = !active;
+        if (el._flatpickr) {
+          console.log("Flatpickr in childInputs", el, el._flatpickr.altInput);
+          el._flatpickr.altInput.disabled = !active;
+        }
       });
     }
 

templates/course.hamlet

@@ -12,25 +12,43 @@
           #{descr}
 
     $with numlecs <- length lecturers
-      $if numlecs > 1
+      $if numlecs /= 0
-        <dt .deflist__dt>_{MsgLecturersFor}
+        $if numlecs > 1
-      $else
+          <dt .deflist__dt>_{MsgLecturersFor}
-        <dt .deflist__dt>_{MsgLecturerFor}
+        $else
-      <dd .deflist__dd>
+          <dt .deflist__dt>_{MsgLecturerFor}
-        <div>
+        <dd .deflist__dd>
-          <ul .list--inline .list--comma-separated>
+          <div>
-            $forall lect <- lecturers
+            <ul .list--inline .list--comma-separated>
-              <li>^{nameEmailWidget' lect}
+              $forall lect <- lecturers
+                <li>^{nameEmailWidget' lect}
     $with numassi <- length assistants
-      $if numassi > 1
+      $if numassi /= 0
-        <dt .deflist__dt>_{MsgAssistantsFor}
+        $if numassi > 1
-      $else
+          <dt .deflist__dt>_{MsgAssistantsFor}
-        <dt .deflist__dt>_{MsgAssistantFor}
+        $else
-      <dd .deflist__dd>
+          <dt .deflist__dt>_{MsgAssistantFor}
-        <div>
+        <dd .deflist__dd>
-          <ul .list--inline .list--comma-separated>
+          <div>
-            $forall assi <- assistants
+            <ul .list--inline .list--comma-separated>
-              <li>^{nameEmailWidget' assi}
+              $forall assi <- assistants
+                <li>^{nameEmailWidget' assi}
+    $with numtutor <- length tutors
+      $if numtutor /= 0
+        <dt .deflist__dt>_{MsgTutorsFor numtutor}
+        <dd .deflist__dd>
+          <div>
+            <ul .list--inline .list--comma-separated>
+              $forall tutor <- tutors
+                <li>^{nameEmailWidget' tutor}
+    $with numcorrector <- length correctors
+      $if numcorrector /= 0
+        <dt .deflist__dt>_{MsgCorrectorsFor numcorrector}
+        <dd .deflist__dd>
+          <div>
+            <ul .list--inline .list--comma-separated>
+              $forall corrector <- correctors
+                <li>^{nameEmailWidget' corrector}
 
     $maybe link <- courseLinkExternal course
       <dt .deflist__dt>Website
@@ -73,6 +91,11 @@ $#    $if NTop (Just 0) < NTop (courseCapacity course)
         $else
           Eine Anmeldung zum Kurs ist Voraussetzung zum Zugang zu Kursmaterial
           (z.B. Übungsblätter).
+    $if hasTutorials
+      <dt .deflist__dt>_{MsgCourseTutorials}
+      <dd .deflist__dd>
+        ^{tutorialTable}
+      
 
 $# <div .container>
 $#   <div .tab-group>

templates/tutorial-edit.hamlet

@@ -0,0 +1,2 @@
+$newline never
+^{newTutForm}

templates/tutorial-list.hamlet

@@ -0,0 +1,2 @@
+$newline never
+^{tutorialTable}

templates/tutorial-new.hamlet

@@ -0,0 +1,2 @@
+$newline never
+^{newTutForm}

templates/tutorial-participants.hamlet

@@ -0,0 +1,2 @@
+$newline never
+^{participantTable}

templates/tutorial/tutorMassInput/add.hamlet

@@ -0,0 +1,6 @@
+$newline never
+<td>
+  #{csrf}
+  ^{fvInput addView}
+<td>
+  ^{fvInput submitView}

templates/tutorial/tutorMassInput/cellKnown.hamlet

@@ -0,0 +1,3 @@
+$newline never
+<td>
+  ^{nameEmailWidget userEmail userDisplayName userSurname}

templates/tutorial/tutorMassInput/layout.hamlet

@@ -0,0 +1,11 @@
+$newline never
+<table>
+  <tbody>
+    $forall coord <- review liveCoords lLength
+      <tr .massinput--cell>
+        ^{cellWdgts ! coord}
+        <td>
+          ^{fvInput (delButtons ! coord)}
+  <tfoot>
+    <tr .massinput--add>
+      ^{addWdgts ! (0, 0)}

templates/widgets/occurence/cell.hamlet

@@ -0,0 +1,12 @@
+$newline never
+<ul .list--inline .list--iconless .list--comma-separated>
+  $forall sched <- occurencesScheduled'
+    <li>^{sched}
+
+$if not (null occurencesExceptions)
+  $# <div .tooltip>
+  $#   <div .tooltip__handle .tooltip__handle--danger>
+  $#   <div .tooltip__content>
+      <ul>
+        $forall exc <- occurencesExceptions'
+          <li>^{exc}

templates/widgets/occurence/cell/except-no-occur.hamlet

@@ -0,0 +1,2 @@
+$newline never
+_{MsgExceptionKindNoOccur}: #{exceptTime'}

templates/widgets/occurence/cell/except-occur.hamlet

@@ -0,0 +1,2 @@
+$newline never
+_{MsgExceptionKindOccur}: #{exceptStart'}–#{exceptEnd'}

templates/widgets/occurence/cell/weekly.hamlet

@@ -0,0 +1,2 @@
+$newline never
+_{ShortWeekDay scheduleDayOfWeek} #{scheduleStart'}–#{scheduleEnd'}

templates/widgets/occurence/form/except-add.hamlet

@@ -0,0 +1,5 @@
+$newline never
+<td colspan=2>
+  ^{addWidget}
+<td>
+  ^{fvInput submitView}

templates/widgets/occurence/form/except-layout.hamlet

@@ -0,0 +1,11 @@
+$newline never
+<table>
+  <tbody>
+    $forall coord <- review liveCoords lLength
+      <tr .massinput--cell>
+        ^{cellWdgts ! coord}
+        <td>
+          ^{fvInput (delButtons ! coord)}
+  <tfoot>
+    <tr .massinput--add>
+      ^{addWdgts ! (0, 0)}

templates/widgets/occurence/form/except-no-occur.hamlet

@@ -0,0 +1,5 @@
+$newline never
+<td>
+  _{ExceptionKindNoOccur}
+<td>
+  #{exceptTime'}

templates/widgets/occurence/form/except-occur.hamlet

@@ -0,0 +1,5 @@
+$newline never
+<td>
+  _{ExceptionKindOccur}
+<td>
+  #{exceptStart'}–#{exceptEnd'}

templates/widgets/occurence/form/scheduled-add.hamlet

@@ -0,0 +1,5 @@
+$newline never
+<td colspan=2>
+  ^{addWidget}
+<td>
+  ^{fvInput submitView}

templates/widgets/occurence/form/scheduled-layout.hamlet

@@ -0,0 +1,11 @@
+$newline never
+<table>
+  <tbody>
+    $forall coord <- review liveCoords lLength
+      <tr .massinput--cell>
+        ^{cellWdgts ! coord}
+        <td>
+          ^{fvInput (delButtons ! coord)}
+  <tfoot>
+    <tr .massinput--add>
+      ^{addWdgts ! (0, 0)}

templates/widgets/occurence/form/weekly.hamlet

@@ -0,0 +1,5 @@
+$newline never
+<td>
+  _{ScheduleKindWeekly}
+<td>
+  _{scheduleDayOfWeek}, #{scheduleStart'}–#{scheduleEnd'}

test/Database.hs

@@ -22,11 +22,11 @@ import System.FilePath ((</>))
 
 import qualified Data.ByteString as BS
 
-import Data.Time
-
 import Utils.Lens (review, view)
 import Control.Monad.Random.Class (MonadRandom(..))
 
+import qualified Data.Set as Set
+
 
 data DBAction = DBClear
               | DBTruncate
@@ -520,6 +520,39 @@ fillDb = do
   void . insert $ SubmissionUser maxMuster sub1
   sub1fid1 <- insertFile "AbgabeH10-1.hs"
   void . insert $ SubmissionFile sub1 sub1fid1 False False
+  tut1 <- insert Tutorial
+    { tutorialName = "Di08"
+    , tutorialCourse = pmo
+    , tutorialType = "Tutorium"
+    , tutorialCapacity = Just 30
+    , tutorialRoom = "Hilbert-Raum"
+    , tutorialTime = Occurences
+      { occurencesScheduled = Set.singleton $ ScheduleWeekly Tuesday (TimeOfDay 08 15 00) (TimeOfDay 10 00 00)
+      , occurencesExceptions = Set.empty
+      }
+    , tutorialRegGroup = Just "tutorium"
+    , tutorialRegisterFrom = Just now
+    , tutorialRegisterTo = Nothing
+    , tutorialDeregisterUntil = Nothing
+    }
+  void . insert $ Tutor tut1 gkleen
+  void . insert $ TutorialParticipant tut1 fhamann
+  tut2 <- insert Tutorial
+    { tutorialName = "Di10"
+    , tutorialCourse = pmo
+    , tutorialType = "Tutorium"
+    , tutorialCapacity = Just 30
+    , tutorialRoom = "Hilbert-Raum"
+    , tutorialTime = Occurences
+      { occurencesScheduled = Set.singleton $ ScheduleWeekly Tuesday (TimeOfDay 10 15 00) (TimeOfDay 12 00 00)
+      , occurencesExceptions = Set.empty
+      }
+    , tutorialRegGroup = Just "tutorium"
+    , tutorialRegisterFrom = Just now
+    , tutorialRegisterTo = Nothing
+    , tutorialDeregisterUntil = Nothing
+    }
+  void . insert $ Tutor tut2 gkleen
   -- datenbanksysteme
   dbs <- insert' Course
     { courseName = "Datenbanksysteme"