diff --git a/ChangeLog.md b/ChangeLog.md index 1e78cad00..8fe2401e2 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,9 @@ + * Version 29.04.2019 + + Tutorien + + Anzeige von Korrektoren auf den Kursseiten + * Version 20.04.2019 Versand von Benachrichtigungen an Kursteilnehmer diff --git a/build.sh b/build.sh index 962ccc1ee..9b4f5a2e2 100755 --- a/build.sh +++ b/build.sh @@ -1,4 +1,4 @@ #!/usr/bin/env bash -exec -- stack build --fast --flag uniworx:-library-only --flag uniworx:dev +exec -- stack build --fast --flag uniworx:-library-only --flag uniworx:dev $@ echo Build task completed. diff --git a/db.sh b/db.sh index b05463c3a..3d80bf68f 100755 --- a/db.sh +++ b/db.sh @@ -1,4 +1,6 @@ #!/usr/bin/env bash # Options: see /test/Database.hs (Main) +set -e + stack build --fast --flag uniworx:-library-only --flag uniworx:dev stack exec uniworxdb -- $@ diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 509bb2120..8ffd3ec53 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -69,10 +69,12 @@ CourseShort: Kürzel CourseCapacity: Kapazität CourseCapacityTip: Anzahl erlaubter Kursanmeldungen, leer lassen für unbeschränkte Kurskapazität CourseNoCapacity: In diesem Kurs sind keine Plätze mehr frei. +TutorialNoCapacity: In dieser Übung sind keine Plätze mehr frei. CourseNotEmpty: In diesem Kurs sind momentan Teilnehmer angemeldet. CourseRegisterOk: Anmeldung erfolgreich CourseDeregisterOk: Erfolgreich abgemeldet CourseStudyFeature: Assoziiertes Hauptfach +CourseTutorial: Tutorium CourseStudyFeatureTooltip: Korrekte Angabe kann Notenweiterleitungen beschleunigen CourseSecretWrong: Falsches Kennwort CourseSecret: Zugangspasswort @@ -120,6 +122,9 @@ CourseUserNoteDeleted: Teilnehmernotiz gelöscht CourseUserDeregister: Abmelden CourseUsersDeregistered count@Int64: #{show count} Teilnehmer abgemeldet CourseUserSendMail: Mitteilung verschicken +TutorialUserDeregister: Vom Tutorium Abmelden +TutorialUserSendMail: Mitteilung verschicken +TutorialUsersDeregistered count@Int64: #{show count} Tutorium-Teilnehmer abgemeldet CourseLecturers: Kursverwalter CourseLecturer: Dozent @@ -128,7 +133,7 @@ CourseLecturerAlreadyAdded email@UserEmail: Es gibt bereits einen Kursverwalter CourseRegistrationEndMustBeAfterStart: Ende des Anmeldezeitraums muss nach dem Anfang liegen CourseDeregistrationEndMustBeAfterStart: Ende des Abmeldezeitraums muss nach dem Anfang des Anmeldezeitraums liegen CourseUserMustBeLecturer: Aktueller Benutzer muss als Kursverwalter eingetragen sein -CourseLecturerRightsIdentical: Alle Sorten von Kursverwalter haben identische Rechte +CourseLecturerRightsIdentical: Alle Sorten von Kursverwalter haben identische Rechte. NoSuchTerm tid@TermId: Semester #{display tid} gibt es nicht. NoSuchSchool ssh@SchoolId: Institut #{display ssh} gibt es nicht. @@ -212,7 +217,7 @@ CorrectorAssignTitle: Korrektor zuweisen Unauthorized: Sie haben hierfür keine explizite Berechtigung. UnauthorizedAnd l@Text r@Text: (#{l} UND #{r}) UnauthorizedOr l@Text r@Text: (#{l} ODER #{r}) -UnauthorizedNoToken: Ihrer Anfrage war kein Authorisierungs-Token beigefügt. +UnauthorizedNoToken: Ihrer Anfrage war kein Authorisierungs-Token beigefügt. UnauthorizedTokenExpired: Ihr Authorisierungs-Token ist abgelaufen. UnauthorizedTokenNotStarted: Ihr Authorisierungs-Token ist noch nicht gültig. UnauthorizedTokenInvalid: Ihr Authorisierungs-Token konnte nicht verarbeitet werden. @@ -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. @@ -269,7 +279,7 @@ CorByProportionIncludingTutorial proportion@Rational: #{display proportion} Ante CorByProportionExcludingTutorial proportion@Rational: #{display proportion} Anteile + Tutorium RowCount count@Int64: #{display count} #{pluralDE count "Eintrag" "Einträge"} nach Filter -DeleteRow: Zeile entfernen +DeleteRow: Entfernen ProportionNegative: Anteile dürfen nicht negativ sein CorrectorUpdated: Korrektor erfolgreich aktualisiert CorrectorsUpdated: Korrektoren erfolgreich aktualisiert @@ -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 @@ -760,8 +779,8 @@ DeleteConfirmationWrong: Bestätigung muss genau dem angezeigten Text entspreche DBTIRowsMissing n@Int: #{pluralDE n "Eine Zeile ist" "Einige Zeilen sind"} aus der Datenbank verschwunden, seit das Formular für Sie generiert wurde -MassInputAddDimension: Hinzufügen -MassInputDeleteCell: Entfernen +MassInputAddDimension: + +MassInputDeleteCell: - NavigationFavourites: Favoriten @@ -773,12 +792,16 @@ 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 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 @@ -802,4 +825,63 @@ InvitationDeclined: Einladung wurde abgelehnt BtnInviteAccept: Einladung annehmen BtnInviteDecline: Einladung ablehnen -LecturerType: Rolle \ No newline at end of file +LecturerType: Rolle +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 +TutorialFreeCapacity: Freie Plätze +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 + +MassInputTip: Es können mehrere Werte angegeben werden. Werte müssen mit + zur Liste hinzugefügt werden und können mit - wieder entfernt werden. Die Liste wird zunächst nur lokal in Ihrem Browser gespeichert und muss noch zusammen mit dem Rest des Formulars Gesendet werden. diff --git a/models/rooms b/models/rooms deleted file mode 100644 index 2ef670fd3..000000000 --- a/models/rooms +++ /dev/null @@ -1,32 +0,0 @@ --- ROOMS ARE TODO; THIS IS JUST AN UNUSED STUB --- Idea is to create a selection of rooms that may be --- associated with exercise classes and exams --- offering links to the LMU Roomfinder --- and allow the creation of neat timetables for users -Booking - term TermId - begin UTCTime - end UTCTime - weekly Bool - exceptions [Day] -- only if weekly, begin in exception - bookedFor RoomForId - room RoomId -BookingEdit - user UserId - time UTCTime - boooking BookingId -Room - name Text - capacity Int Maybe - building Text Maybe -- name of building - roomfinder Text Maybe -- external url for LMU Roomfinder --- BookingRoom --- subject RoomForId --- room RoomId --- booking BookingId --- UniqueRoomCourse subject room booking -+RoomFor - course CourseId - tutorial TutorialId - exam ExamId --- data RoomFor = RoomForCourseSum CourseId | RoomForTutorialSum TutorialId ... diff --git a/models/tutorials b/models/tutorials index 3afed739e..78571389c 100644 --- a/models/tutorials +++ b/models/tutorials @@ -1,11 +1,21 @@ --- TUTORIALS ARE TODO; THIS IS JUST AN UNUSED STUB --- Idea: management of exercise classes, offering sub-enrolement to distribute all students among all exercise classs Tutorial json - name Text - tutor UserId - course CourseId - capacity Int Maybe -- limit for enrolement in this tutorial -TutorialUser - user UserId + name TutorialName + course CourseId + type (CI Text) -- "Tutorium", "Zentralübung", ... + capacity Int Maybe -- limit for enrolment in this tutorial + room Text + time Occurences + regGroup (CI Text) Maybe -- each participant may register for one tutorial per regGroup + registerFrom UTCTime Maybe + registerTo UTCTime Maybe + deregisterUntil UTCTime Maybe + lastChanged UTCTime default='NOW()' + UniqueTutorial course name +Tutor tutorial TutorialId - UniqueTutorialUser user tutorial + user UserId + UniqueTutor tutorial user +TutorialParticipant + tutorial TutorialId + user UserId + UniqueTutorialParticipant tutorial user \ No newline at end of file diff --git a/package.yaml b/package.yaml index 16178c5ae..66afc05b0 100644 --- a/package.yaml +++ b/package.yaml @@ -121,6 +121,10 @@ dependencies: - jose-jwt - mono-traversable - lens-aeson + - systemd + - lifted-async + - streaming-commons + - hourglass other-extensions: - GeneralizedNewtypeDeriving diff --git a/routes b/routes index c9af2ca13..0c6712fff 100644 --- a/routes +++ b/routes @@ -13,8 +13,12 @@ -- !free -- free for all -- !lecturer -- lecturer for this course (or for any school, if route is not connected to a course) -- !corrector -- corrector for this sheet (or the submission, if route is connected to a submission, or the course, if route is not connected to a sheet, or any course, if route is not connected to a course) --- !registered -- participant for this course (no effect outside of courses) +-- !course-registered -- participant for this course (no effect outside of courses) +-- !tutorial-registered -- participant for this tutorial (no effect outside of courses) -- !participant -- connected with a given course (not necessarily registered), i.e. has a submission, is a corrector, etc. (no effect outside of courses) +-- +-- !register-group -- user is member in no other tutorial with same register group +-- -- !owner -- part of the group of owners of this submission -- !self -- route refers to the currently logged in user themselves -- !capacity -- course this route is associated with has at least one unit of participant capacity @@ -84,16 +88,16 @@ /communication CCommR GET POST /notes CNotesR GET POST !corrector /subs CCorrectionsR GET POST - /ex SheetListR GET !registered !materials !corrector + /ex SheetListR GET !course-registered !materials !corrector /ex/new SheetNewR GET POST - /ex/current SheetCurrentR GET !registered !materials !corrector + /ex/current SheetCurrentR GET !course-registered !materials !corrector /ex/unassigned SheetOldUnassigned GET /ex/#SheetName SheetR: - /show SShowR GET !timeANDregistered !timeANDmaterials !corrector + /show SShowR GET !timeANDcourse-registered !timeANDmaterials !corrector /edit SEditR GET POST /delete SDelR GET POST /subs SSubsR GET POST -- for lecturer only - !/subs/new SubmissionNewR GET POST !timeANDregisteredANDuser-submissions + !/subs/new SubmissionNewR GET POST !timeANDcourse-registeredANDuser-submissions !/subs/own SubmissionOwnR GET !free -- just redirect /subs/#CryptoFileNameSubmission SubmissionR: / SubShowR GET POST !ownerANDtime !ownerANDread !correctorANDread @@ -103,9 +107,17 @@ /correction CorrectionR GET POST !corrector !ownerANDreadANDrated !/#SubmissionFileType/*FilePath SubDownloadR GET !owner !corrector /correctors SCorrR GET POST - /pseudonym SPseudonymR GET POST !registeredANDcorrector-submissions + /pseudonym SPseudonymR GET POST !course-registeredANDcorrector-submissions /corrector-invite/#UserEmail SCorrInviteR GET POST - !/#SheetFileType/*FilePath SFileR GET !timeANDregistered !timeANDmaterials !corrector + !/#SheetFileType/*FilePath SFileR GET !timeANDcourse-registered !timeANDmaterials !corrector + /tuts CTutorialListR GET !tutor + /tuts/new CTutorialNewR GET POST + /tuts/#TutorialName TutorialR: + /edit TEditR GET POST + /delete TDeleteR GET POST + /participants TUsersR GET POST !tutor + /register TRegisterR POST !timeANDcapacityANDcourse-registeredANDregister-group !timeANDtutorial-registered + /communication TCommR GET POST !tutor /subs CorrectionsR GET POST !corrector !lecturer diff --git a/src/Application.hs b/src/Application.hs index 5b130dd50..77a19df68 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -24,8 +24,10 @@ import Language.Haskell.TH.Syntax (qLocation) import Network.Wai (Middleware) import Network.Wai.Handler.Warp (Settings, defaultSettings, defaultShouldDisplayException, - runSettings, setHost, + runSettingsSocket, setHost, + setBeforeMainLoop, setOnException, setPort, getPort) +import Data.Streaming.Network (bindPortTCP) import Network.Wai.Middleware.RequestLogger (Destination (Logger), IPAddrSource (..), OutputFormat (..), destination, @@ -71,6 +73,9 @@ import qualified Data.Aeson as Aeson import System.Exit (exitFailure) import qualified Database.Memcached.Binary.IO as Memcached + +import qualified System.Systemd.Daemon as Systemd +import Control.Concurrent.Async.Lifted.Safe (async, waitAnyCancel) -- Import all relevant handler modules here. -- (HPack takes care to add new modules to our cabal file nowadays.) @@ -86,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 @@ -154,27 +160,33 @@ makeFoundation appSettings'@AppSettings{..} = do (error "secretBoxKey forced in tempFoundation") (error "widgetMemcached forced in tempFoundation") (error "JSONWebKeySet forced in tempFoundation") - logFunc loc src lvl str = do - f <- messageLoggerSource tempFoundation <$> readTVarIO (snd appLogger) - f loc src lvl str - flip runLoggingT logFunc $ do - $logDebugS "InstanceID" $ UUID.toText appInstanceID + runAppLoggingT tempFoundation $ do + $logInfoS "InstanceID" $ UUID.toText appInstanceID -- logDebugS "Configuration" $ tshow appSettings' - smtpPool <- traverse createSmtpPool appSmtpConf + smtpPool <- for appSmtpConf $ \c -> do + $logDebugS "setup" "SMTP-Pool" + createSmtpPool c - appWidgetMemcached <- traverse createWidgetMemcached appWidgetMemcachedConf + appWidgetMemcached <- for appWidgetMemcachedConf $ \c -> do + $logDebugS "setup" "Widget-Memcached" + createWidgetMemcached c -- Create the database connection pool + $logDebugS "setup" "PostgreSQL-Pool" sqlPool <- createPostgresqlPool (pgConnStr appDatabaseConf) (pgPoolSize appDatabaseConf) - ldapPool <- for appLdapConf $ \LdapConf{..} -> createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) ldapTimeout (poolLimit ldapPool) + ldapPool <- for appLdapConf $ \LdapConf{..} -> do + $logDebugS "setup" "LDAP-Pool" + createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) ldapTimeout (poolLimit ldapPool) -- Perform database migration using our application's logging settings. + $logDebugS "setup" "Migration" migrateAll `runSqlPool` sqlPool + $logDebugS "setup" "Cluster-Config" appCryptoIDKey <- clusterSetting (Proxy :: Proxy 'ClusterCryptoIDKey) `runSqlPool` sqlPool appSessionKey <- clusterSetting (Proxy :: Proxy 'ClusterClientSessionKey) `runSqlPool` sqlPool appSecretBoxKey <- clusterSetting (Proxy :: Proxy 'ClusterSecretBoxKey) `runSqlPool` sqlPool @@ -182,11 +194,20 @@ makeFoundation appSettings'@AppSettings{..} = do let foundation = mkFoundation sqlPool smtpPool ldapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached appJSONWebKeySet + $logDebugS "setup" "Job-Handling" handleJobs foundation -- Return the foundation + $logDebugS "setup" "Done" return foundation +runAppLoggingT :: UniWorX -> LoggingT m a -> m a +runAppLoggingT app@(appLogger -> (_, loggerTVar)) = flip runLoggingT logFunc + where + logFunc loc src lvl str = do + f <- messageLoggerSource app <$> readTVarIO loggerTVar + f loc src lvl str + clusterSetting :: forall key m p. ( MonadIO m , ClusterSetting key @@ -289,8 +310,12 @@ makeLogWare app = do -- | Warp settings for the given foundation value. warpSettings :: UniWorX -> Settings warpSettings foundation = defaultSettings - & setPort (foundation ^. _appPort) + & setBeforeMainLoop (runAppLoggingT foundation $ do + $logInfoS "setup" "Ready" + void $ liftIO Systemd.notifyReady + ) & setHost (foundation ^. _appHost) + & setPort (foundation ^. _appPort) & setOnException (\_req e -> when (defaultShouldDisplayException e) $ do logger <- readTVarIO . snd $ appLogger foundation @@ -333,12 +358,29 @@ appMain = runResourceT $ do -- Generate the foundation from the settings foundation <- makeFoundation settings + + runAppLoggingT foundation $ do + -- Generate a WAI Application from the foundation + app <- makeApplication foundation - -- Generate a WAI Application from the foundation - app <- makeApplication foundation + -- Run the application with Warp + activatedSockets <- liftIO Systemd.getActivatedSocketsWithNames + sockets <- case activatedSockets of + Just socks@(_ : _) -> do + $logInfoS "bind" [st|Ignoring configuration and listening on #{tshow (fmap snd socks)}|] + return $ fst <$> socks + _other -> do + let + host = foundation ^. _appHost + port = foundation ^. _appPort + $logInfoS "bind" [st|Listening on #{tshow host} port #{tshow port} as per configuration|] + liftIO $ pure <$> bindPortTCP port host - -- Run the application with Warp - liftIO $ runSettings (warpSettings foundation) app + let runWarp socket = runSettingsSocket (warpSettings foundation) socket app + case sockets of + [] -> $logErrorS "bind" "No sockets to listen on" + [s] -> liftIO $ runWarp s + ss -> liftIO $ void . waitAnyCancel =<< mapM (async . runWarp) ss -------------------------------------------------------------- diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 6c89e6c96..990c782ff 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -7,6 +7,7 @@ module Database.Esqueleto.Utils , SqlIn(..) , mkExactFilter, mkExactFilterWith , mkContainsFilter + , mkExistsFilter , anyFilter, allFilter ) where @@ -104,6 +105,15 @@ mkContainsFilter lenslike row criterias | Set.null criterias = true | otherwise = any (hasInfix $ lenslike row) criterias +mkExistsFilter :: PathPiece a + => (t -> a -> E.SqlQuery ()) + -> t + -> Set.Set a + -> E.SqlExpr (E.Value Bool) +mkExistsFilter query row criterias + | Set.null criterias = true + | otherwise = any (E.exists . query row) criterias + -- | Combine several filters, using logical or anyFilter :: (Foldable f) => f (t -> Set.Set Text-> E.SqlExpr (E.Value Bool)) @@ -122,4 +132,4 @@ allFilter :: (Foldable f) -> E.SqlExpr (E.Value Bool) allFilter fltrs needle criterias = F.foldr aux true fltrs where - aux fltr acc = fltr needle criterias E.&&. acc \ No newline at end of file + aux fltr acc = fltr needle criterias E.&&. acc diff --git a/src/Foundation.hs b/src/Foundation.hs index 46e176a19..8b2769cea 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -45,7 +45,7 @@ import Data.Map (Map, (!?)) import qualified Data.Map as Map import qualified Data.HashSet as HashSet -import Data.List (nubBy) +import Data.List (nubBy, (!!)) import Data.Monoid (Any(..)) @@ -161,6 +161,10 @@ pattern CSheetR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetR pattern CSheetR tid ssh csh shn ptn = CourseR tid ssh csh (SheetR shn ptn) +pattern CTutorialR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> TutorialR -> Route UniWorX +pattern CTutorialR tid ssh csh shn ptn + = CourseR tid ssh csh (TutorialR shn ptn) + pattern CSubmissionR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionR -> Route UniWorX pattern CSubmissionR tid ssh csh shn cid ptn = CSheetR tid ssh csh shn (SubmissionR cid ptn) @@ -402,6 +406,14 @@ appLanguagesOpts = do return $ mkOptionList langOptions +instance RenderMessage UniWorX WeekDay where + renderMessage _ ls wDay = pack $ map fst (wDays $ getTimeLocale' ls) !! fromEnum wDay + +newtype ShortWeekDay = ShortWeekDay { longWeekDay :: WeekDay } + +instance RenderMessage UniWorX ShortWeekDay where + renderMessage _ ls (ShortWeekDay wDay) = pack $ map snd (wDays $ getTimeLocale' ls) !! fromEnum wDay + -- Access Control newtype InvalidAuthTag = InvalidAuthTag Text deriving (Eq, Ord, Show, Read, Generic, Typeable) @@ -582,7 +594,49 @@ tagAccessPredicate AuthCorrector = APDB $ \mAuthId route _ -> exceptT return ret _ -> do guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny) return Authorized +tagAccessPredicate AuthTutor = APDB $ \mAuthId route _ -> exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + resList <- lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do + E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId + E.on $ tutorial E.^. TutorialCourse E.==. course E.^. CourseId + E.where_ $ tutor E.^. TutorUser E.==. E.val authId + return (course E.^. CourseId, tutorial E.^. TutorialId) + let + resMap :: Map CourseId (Set TutorialId) + resMap = Map.fromListWith Set.union [ (cid, Set.singleton tutid) | (E.Value cid, E.Value tutid) <- resList ] + case route of + CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialTutor) $ do + Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh + Entity tutid _ <- MaybeT . lift . getBy $ UniqueTutorial cid tutn + guard $ tutid `Set.member` fromMaybe Set.empty (resMap !? cid) + return Authorized + CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnauthorizedCourseTutor) $ do + Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh + guard $ cid `Set.member` Map.keysSet resMap + return Authorized + _ -> do + guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedTutor) + return Authorized tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of + CTutorialR tid ssh csh tutn TRegisterR -> maybeT (unauthorizedI MsgUnauthorizedTutorialTime) $ do + now <- liftIO getCurrentTime + course <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh + Entity tutId Tutorial{..} <- MaybeT . getBy $ UniqueTutorial course tutn + registered <- case mAuthId of + Just uid -> lift . existsBy $ UniqueTutorialParticipant tutId uid + Nothing -> return False + + if + | not registered + , maybe False (now >=) tutorialRegisterFrom + , maybe True (now <=) tutorialRegisterTo + -> return Authorized + | registered + , maybe True (now <=) tutorialDeregisterUntil + -> return Authorized + | otherwise + -> mzero + CSheetR tid ssh csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh Entity _sid Sheet{..} <- MaybeT . getBy $ CourseSheet cid shn @@ -630,7 +684,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of return Authorized r -> $unsupportedAuthPredicate AuthTime r -tagAccessPredicate AuthRegistered = APDB $ \mAuthId route _ -> case route of +tagAccessPredicate AuthCourseRegistered = APDB $ \mAuthId route _ -> case route of CourseR tid ssh csh _ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` courseParticipant) -> do @@ -642,7 +696,34 @@ tagAccessPredicate AuthRegistered = APDB $ \mAuthId route _ -> case route of return (E.countRows :: E.SqlExpr (E.Value Int64)) guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedRegistered) return Authorized - r -> $unsupportedAuthPredicate AuthRegistered r + r -> $unsupportedAuthPredicate AuthCourseRegistered r +tagAccessPredicate AuthTutorialRegistered = APDB $ \mAuthId route _ -> case route of + CourseR tid ssh csh _ -> exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialParticipant) -> do + E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial + E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse + E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. E.val authId + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + return (E.countRows :: E.SqlExpr (E.Value Int64)) + guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedRegistered) + return Authorized + CTutorialR tid ssh csh tutn _ -> exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialParticipant) -> do + E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial + E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse + E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. E.val authId + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.&&. tutorial E.^. TutorialName E.==. E.val tutn + return (E.countRows :: E.SqlExpr (E.Value Int64)) + guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedRegistered) + return Authorized + r -> $unsupportedAuthPredicate AuthTutorialRegistered r tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of CourseR tid ssh csh (CUserR cID) -> exceptT return return $ do let authorizedIfExists f = do @@ -683,16 +764,17 @@ tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of E.&&. course E.^. CourseShorthand E.==. E.val csh -- participant is a tutorial user authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialUser) -> do - E.on $ tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialUserTutorial + E.on $ tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialParticipantTutorial E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse - E.where_ $ tutorialUser E.^. TutorialUserUser E.==. E.val participant + E.where_ $ tutorialUser E.^. TutorialParticipantUser E.==. E.val participant E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh -- participant is tutor for this course - authorizedIfExists $ \(course `E.InnerJoin` tutorial) -> do + authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do + E.on $ tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse - E.where_ $ tutorial E.^. TutorialTutor E.==. E.val participant + E.where_ $ tutor E.^. TutorUser E.==. E.val participant E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh @@ -706,12 +788,33 @@ tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of unauthorizedI MsgUnauthorizedParticipant r -> $unsupportedAuthPredicate AuthParticipant r tagAccessPredicate AuthCapacity = APDB $ \_ route _ -> case route of + CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgTutorialNoCapacity) $ do + cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh + Entity tutId Tutorial{..} <- MaybeT . getBy $ UniqueTutorial cid tutn + registered <- lift $ fromIntegral <$> count [ TutorialParticipantTutorial ==. tutId ] + guard $ NTop tutorialCapacity > NTop (Just registered) + return Authorized CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ] guard $ NTop courseCapacity > NTop (Just registered) return Authorized r -> $unsupportedAuthPredicate AuthCapacity r +tagAccessPredicate AuthRegisterGroup = APDB $ \mAuthId route _ -> case route of + CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialRegisterGroup) $ do + cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh + Entity _ Tutorial{..} <- MaybeT . getBy $ UniqueTutorial cid tutn + case (tutorialRegGroup, mAuthId) of + (Nothing, _) -> return Authorized + (_, Nothing) -> return AuthenticationRequired + (Just rGroup, Just uid) -> do + [E.Value hasOther] <- lift . E.select . return . E.exists . E.from $ \(tutorial `E.InnerJoin` participant) -> do + E.on $ tutorial E.^. TutorialId E.==. participant E.^. TutorialParticipantTutorial + E.where_ $ participant E.^. TutorialParticipantUser E.==. E.val uid + E.&&. tutorial E.^. TutorialRegGroup E.==. E.just (E.val rGroup) + guard $ not hasOther + return Authorized + r -> $unsupportedAuthPredicate AuthRegisterGroup r tagAccessPredicate AuthEmpty = APDB $ \_ route _ -> case route of CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNotEmpty) $ do -- Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh @@ -1265,10 +1368,17 @@ instance YesodBreadcrumbs UniWorX where breadcrumb (CourseR tid ssh csh SheetListR) = return ("Übungen" , Just $ CourseR tid ssh csh CShowR) breadcrumb (CourseR tid ssh csh SheetNewR ) = return ("Neu", Just $ CourseR tid ssh csh SheetListR) breadcrumb (CourseR tid ssh csh CCommR ) = return ("Kursmitteilung", Just $ CourseR tid ssh csh CShowR) + breadcrumb (CourseR tid ssh csh CTutorialListR) = return ("Tutorien", Just $ CourseR tid ssh csh CShowR) + breadcrumb (CourseR tid ssh csh CTutorialNewR) = return ("Anlegen", Just $ CourseR tid ssh csh CTutorialListR) + + breadcrumb (CTutorialR tid ssh csh tutn TUsersR) = return (CI.original tutn, Just $ CourseR tid ssh csh CTutorialListR) + breadcrumb (CTutorialR tid ssh csh tutn TEditR) = return ("Bearbeiten", Just $ CTutorialR tid ssh csh tutn TUsersR) + breadcrumb (CTutorialR tid ssh csh tutn TDeleteR) = return ("Löschen", Just $ CTutorialR tid ssh csh tutn TUsersR) + breadcrumb (CTutorialR tid ssh csh tutn TCommR) = return ("Mitteilung", Just $ CTutorialR tid ssh csh tutn TUsersR) breadcrumb (CSheetR tid ssh csh shn SShowR) = return (CI.original shn, Just $ CourseR tid ssh csh SheetListR) - breadcrumb (CSheetR tid ssh csh shn SEditR) = return ("Edit", Just $ CSheetR tid ssh csh shn SShowR) - breadcrumb (CSheetR tid ssh csh shn SDelR ) = return ("DELETE", Just $ CSheetR tid ssh csh shn SShowR) + breadcrumb (CSheetR tid ssh csh shn SEditR) = return ("Bearbeiten", Just $ CSheetR tid ssh csh shn SShowR) + breadcrumb (CSheetR tid ssh csh shn SDelR ) = return ("Löschen", Just $ CSheetR tid ssh csh shn SShowR) breadcrumb (CSheetR tid ssh csh shn SSubsR) = return ("Abgaben", Just $ CSheetR tid ssh csh shn SShowR) breadcrumb (CSheetR tid ssh csh shn SubmissionNewR) = return ("Abgabe", Just $ CSheetR tid ssh csh shn SShowR) breadcrumb (CSheetR tid ssh csh shn SubmissionOwnR) = return ("Abgabe", Just $ CSheetR tid ssh csh shn SShowR) @@ -1635,6 +1745,14 @@ pageActions (CourseR tid ssh csh CShowR) = } ] ++ pageActions (CourseR tid ssh csh SheetListR) ++ [ MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuTutorialList + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CourseR tid ssh csh CTutorialListR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + , MenuItem { menuItemType = PageActionSecondary , menuItemLabel = MsgMenuCourseMembers , menuItemIcon = Just "user-graduate" @@ -1736,6 +1854,44 @@ pageActions (CourseR tid ssh csh SheetListR) = , menuItemAccessCallback' = return True } ] +pageActions (CourseR tid ssh csh CTutorialListR) = + [ MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuTutorialNew + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CourseR tid ssh csh CTutorialNewR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + ] +pageActions (CTutorialR tid ssh csh tutn TEditR) = + [ MenuItem + { menuItemType = PageActionSecondary + , menuItemLabel = MsgMenuTutorialDelete + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CTutorialR tid ssh csh tutn TDeleteR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + ] +pageActions (CTutorialR tid ssh csh tutn TUsersR) = + [ MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuTutorialEdit + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CTutorialR tid ssh csh tutn TEditR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + , MenuItem + { menuItemType = PageActionSecondary + , menuItemLabel = MsgMenuTutorialDelete + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CTutorialR tid ssh csh tutn TDeleteR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + ] pageActions (CSheetR tid ssh csh shn SShowR) = [ MenuItem { menuItemType = PageActionPrime diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index aba016f41..2180e28e8 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -165,7 +165,7 @@ postAdminTestR = do -- | Make a form for adding a point/line/plane/hyperplane/... (in this case: cell) -- - -- This /needs/ to replace all occurances of @mreq@ with @mpreq@ (no fields should be /actually/ required) + -- This /needs/ to replace all occurences of @mreq@ with @mpreq@ (no fields should be /actually/ required) mkAddForm :: ListPosition -- ^ Approximate position of the add-widget -> Natural -- ^ Dimension Index, outermost dimension ist 0 i.e. if dimension is 3 hyperplane-adders get passed 0, planes get passed 1, lines get 2, and points get 3 -> (Text -> Text) -- ^ Nudge deterministic field ids so they're unique diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index dba8b49fc..4ef07e77d 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -128,7 +128,7 @@ colSubmissionLink = sortable Nothing (i18nCell MsgSubmission) return $ CSubmissionR tid ssh csh shn cid SubShowR in anchorCellM mkRoute (mkCid >>= \cid -> [whamlet|#{display cid}|]) -colSelect :: forall act h. (Monoid act, Headedness h) => Colonnade h CorrectionTableData (DBCell _ (FormResult (act, DBFormResult CryptoFileNameSubmission Bool CorrectionTableData), SheetTypeSummary)) +colSelect :: forall act h. (Semigroup act, Monoid act, Headedness h) => Colonnade h CorrectionTableData (DBCell _ (FormResult (act, DBFormResult CryptoFileNameSubmission Bool CorrectionTableData), SheetTypeSummary)) colSelect = dbSelect (_1 . applying _2) id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> encrypt subId colSubmittors :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) @@ -721,7 +721,9 @@ postCorrectionsUploadR = do , formEncoding = uploadEncoding } - defaultLayout + + defaultLayout $ do + let uploadInstruction = $(i18nWidgetFile "corrections-upload-instructions") $(widgetFile "corrections-upload") getCorrectionsCreateR, postCorrectionsCreateR :: Handler Html diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 3cc623819..40e49c343 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -9,6 +9,7 @@ import Utils.Form -- import Utils.DB import Handler.Utils import Handler.Utils.Course +import Handler.Utils.Tutorial import Handler.Utils.Communication import Handler.Utils.Form.MassInput import Handler.Utils.Delete @@ -25,8 +26,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 ((!)) @@ -281,7 +280,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,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 @@ -307,7 +306,13 @@ 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) + 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,correctors) mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course @@ -320,6 +325,78 @@ 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 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| + $newline never +