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/config/settings.yml b/config/settings.yml index 287baf0b3..974b2e7e2 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -30,6 +30,9 @@ session-timeout: 7200 jwt-expiration: 604800 jwt-encoding: HS256 maximum-content-length: 52428800 +health-check-interval: "_env:HEALTHCHECK_INTERVAL:600" # or WATCHDOG_USEC/2, whichever is smaller +health-check-http: "_env:HEALTHCHECK_HTTP:true" +health-check-delay-notify: "_env:HEALTHCHECK_DELAY_NOTIFY:true" log-settings: detailed: "_env:DETAILED_LOGGING:false" 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 37a5523e6..4586461e8 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -24,6 +24,7 @@ RegisteredSince date@Text: Angemeldet seit #{date} RegisterFrom: Anmeldungen von RegisterTo: Anmeldungen bis DeRegUntil: Abmeldungen bis +RegisterRetry: Sie wurden noch nicht angemeldet. Drücken Sie dazu den Knopf "Anmelden" GenericKey: Schlüssel GenericShort: Kürzel @@ -69,10 +70,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 +123,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 +134,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. @@ -254,6 +260,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. @@ -271,6 +278,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. @@ -432,6 +443,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. @@ -466,6 +479,7 @@ LDAPLoginTitle: Campus-Login PWHashLoginTitle: Uni2work-Login PWHashLoginNote: Dieses Formular ist zu verwenden, wenn Sie vom Uni2work-Team spezielle Logindaten erhalten haben. Normale Nutzer melden sich bitte via Campus-Login an! DummyLoginTitle: Development-Login +LoginNecessary: Bitte melden Sie sich dazu vorher an! CorrectorNormal: Normal CorrectorMissing: Abwesend @@ -713,6 +727,8 @@ MenuInformation: Informationen MenuImpressum: Impressum MenuDataProt: Datenschutz MenuVersion: Versionsgeschichte +MenuInstance: Instanz-Identifikation +MenuHealth: Instanz-Zustand MenuHelp: Hilfe MenuProfile: Anpassen MenuLogin: Login @@ -736,6 +752,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 @@ -752,6 +770,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 @@ -764,9 +784,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 @@ -798,6 +821,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 @@ -805,6 +829,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 @@ -819,3 +845,75 @@ 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 +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. + +HealthReport: Instanz-Zustand +InstanceIdentification: Instanz-Identifikation + +InstanceId: Instanz-Nummer +ClusterId: Cluster-Nummer + +HealthMatchingClusterConfig: Cluster-geteilte Konfiguration ist aktuell +HealthHTTPReachable: Cluster kann an der erwarteten URL über HTTP erreicht werden +HealthLDAPAdmins: Anteil der Administratoren, die im LDAP-Verzeichnis gefunden werden können +HealthSMTPConnect: SMTP-Server kann erreicht werden +HealthWidgetMemcached: Memcached-Server liefert Widgets korrekt aus \ No newline at end of file diff --git a/models/rooms b/models/rooms deleted file mode 100644 index 2ef670fd3..000000000 --- a/models/rooms +++ /dev/null @@ -1,32 +0,0 @@ --- ROOMS ARE TODO; THIS IS JUST AN UNUSED STUB --- Idea is to create a selection of rooms that may be --- associated with exercise classes and exams --- offering links to the LMU Roomfinder --- and allow the creation of neat timetables for users -Booking - term TermId - begin UTCTime - end UTCTime - weekly Bool - exceptions [Day] -- only if weekly, begin in exception - bookedFor RoomForId - room RoomId -BookingEdit - user UserId - time UTCTime - boooking BookingId -Room - name Text - capacity Int Maybe - building Text Maybe -- name of building - roomfinder Text Maybe -- external url for LMU Roomfinder --- BookingRoom --- subject RoomForId --- room RoomId --- booking BookingId --- UniqueRoomCourse subject room booking -+RoomFor - course CourseId - tutorial TutorialId - exam ExamId --- data RoomFor = RoomForCourseSum CourseId | RoomForTutorialSum TutorialId ... diff --git a/models/tutorials b/models/tutorials index 3afed739e..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 470e510db..3994357bf 100644 --- a/package.yaml +++ b/package.yaml @@ -124,6 +124,8 @@ dependencies: - systemd - lifted-async - streaming-commons + - hourglass + - unix other-extensions: - GeneralizedNewtypeDeriving diff --git a/routes b/routes index 70c4b50d0..26fe33c4d 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 -- current user is 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 @@ -46,6 +50,8 @@ /admin/test AdminTestR GET POST /admin/errMsg AdminErrMsgR GET POST +/health HealthR GET !free +/instance InstanceR GET !free /info InfoR GET !free /info/lecturer InfoLecturerR GET !lecturer /info/data DataProtR GET !free @@ -74,7 +80,7 @@ !/course/new CourseNewR GET POST !lecturer /course/#TermId/#SchoolId/#CourseShorthand CourseR !lecturer: / CShowR GET !free - /register CRegisterR POST !timeANDcapacity + /register CRegisterR GET POST !timeANDcapacity /edit CEditR GET POST /lecturer-invite/#UserEmail CLecInviteR GET POST /delete CDeleteR GET POST !lecturerANDempty @@ -84,16 +90,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,16 +109,24 @@ /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 - /file MaterialListR GET !materials !registered !corrector + !/#SheetFileType/*FilePath SFileR GET !timeANDcourse-registered !timeANDmaterials !corrector + /file MaterialListR GET !timeANDcourse-registered !timeANDmaterials !corrector /file/new MaterialNewR GET POST /file/#MaterialName MaterialR: /edit MEditR GET POST /delete MDelR GET POST - /show MShowR GET !timeANDregistered !timeANDmaterials !corrector - /part/*FilePath MFileR GET !timeANDregistered !timeANDmaterials !corrector + /show MShowR GET !timeANDcourse-registered !timeANDmaterials !corrector + /part/*FilePath MFileR 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 eff399e81..2800a652e 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -64,7 +64,7 @@ import qualified Yesod.Core.Types as Yesod (Logger(..)) import qualified Data.HashMap.Strict as HashMap -import Control.Lens +import Utils.Lens import Data.Proxy @@ -76,6 +76,10 @@ import qualified Database.Memcached.Binary.IO as Memcached import qualified System.Systemd.Daemon as Systemd import Control.Concurrent.Async.Lifted.Safe (async, waitAnyCancel) +import System.Environment (lookupEnv) +import System.Posix.Process (getProcessID) + +import Control.Monad.Trans.State (execStateT) -- Import all relevant handler modules here. -- (HPack takes care to add new modules to our cabal file nowadays.) @@ -91,10 +95,12 @@ import Handler.School import Handler.Course import Handler.Sheet import Handler.Submission +import Handler.Tutorial import Handler.Corrections import Handler.Material import Handler.CryptoIDDispatch import Handler.SystemMessage +import Handler.Health -- This line actually creates our YesodDispatch instance. It is the second half @@ -141,13 +147,14 @@ makeFoundation appSettings'@AppSettings{..} = do appJobCtl <- liftIO $ newTVarIO Map.empty appCronThread <- liftIO newEmptyTMVarIO + appHealthReport <- liftIO $ newTVarIO Nothing -- We need a log function to create a connection pool. We need a connection -- pool to create our foundation. And we need our foundation to get a -- logging function. To get out of this loop, we initially create a -- temporary foundation without a real connection pool, get a log function -- from there, and then create the real foundation. - let mkFoundation appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached appJSONWebKeySet = UniWorX {..} + let mkFoundation appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID = UniWorX {..} -- The UniWorX {..} syntax is an example of record wild cards. For more -- information, see: -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html @@ -160,6 +167,7 @@ makeFoundation appSettings'@AppSettings{..} = do (error "secretBoxKey forced in tempFoundation") (error "widgetMemcached forced in tempFoundation") (error "JSONWebKeySet forced in tempFoundation") + (error "ClusterID forced in tempFoundation") runAppLoggingT tempFoundation $ do $logInfoS "InstanceID" $ UUID.toText appInstanceID @@ -191,8 +199,9 @@ makeFoundation appSettings'@AppSettings{..} = do appSessionKey <- clusterSetting (Proxy :: Proxy 'ClusterClientSessionKey) `runSqlPool` sqlPool appSecretBoxKey <- clusterSetting (Proxy :: Proxy 'ClusterSecretBoxKey) `runSqlPool` sqlPool appJSONWebKeySet <- clusterSetting (Proxy :: Proxy 'ClusterJSONWebKeySet) `runSqlPool` sqlPool + appClusterID <- clusterSetting (Proxy :: Proxy 'ClusterId) `runSqlPool` sqlPool - let foundation = mkFoundation sqlPool smtpPool ldapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached appJSONWebKeySet + let foundation = mkFoundation sqlPool smtpPool ldapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID $logDebugS "setup" "Job-Handling" handleJobs foundation @@ -311,8 +320,16 @@ makeLogWare app = do warpSettings :: UniWorX -> Settings warpSettings foundation = defaultSettings & setBeforeMainLoop (runAppLoggingT foundation $ do - $logInfoS "setup" "Ready" - void $ liftIO Systemd.notifyReady + let notifyReady = do + $logInfoS "setup" "Ready" + void $ liftIO Systemd.notifyReady + if + | foundation ^. _appHealthCheckDelayNotify + -> void . fork $ do + atomically $ readTVar (foundation ^. _appHealthReport) >>= guard . maybe False ((== HealthSuccess) . classifyHealthReport . snd) + notifyReady + | otherwise + -> notifyReady ) & setHost (foundation ^. _appHost) & setPort (foundation ^. _appPort) @@ -336,8 +353,20 @@ getApplicationDev = do app <- makeApplication foundation return (wsettings, app) -getAppDevSettings :: MonadIO m => m AppSettings -getAppDevSettings = liftIO $ loadYamlSettings [configSettingsYml] [configSettingsYmlValue] useEnv +getAppDevSettings, getAppSettings :: MonadIO m => m AppSettings +getAppDevSettings = liftIO $ adjustSettings =<< loadYamlSettings [configSettingsYml] [configSettingsYmlValue] useEnv +getAppSettings = liftIO $ adjustSettings =<< loadYamlSettingsArgs [configSettingsYmlValue] useEnv + +adjustSettings :: MonadIO m => AppSettings -> m AppSettings +adjustSettings = execStateT $ do + watchdogMicroSec <- liftIO $ (>>= readMay) <$> lookupEnv "WATCHDOG_USEC" + watchdogProcess <- liftIO $ (>>= fmap fromInteger . readMay) <$> lookupEnv "WATCHDOG_PID" + myProcessID <- liftIO getProcessID + case watchdogMicroSec of + Just wInterval + | maybe True (== myProcessID) watchdogProcess + -> _appHealthCheckInterval %= min (fromRational $ (toRational wInterval / 1e6) / 2) + _other -> return () -- | main function for use by yesod devel develMain :: IO () @@ -347,14 +376,7 @@ develMain = runResourceT $ -- | The @main@ function for an executable running this site. appMain :: MonadResourceBase m => m () appMain = runResourceT $ do - -- Get the settings from all relevant sources - settings <- liftIO $ - loadYamlSettingsArgs - -- fall back to compile-time values, set to [] to require values at runtime - [configSettingsYmlValue] - - -- allow environment variables to override - useEnv + settings <- getAppSettings -- Generate the foundation from the settings foundation <- makeFoundation settings diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 32eed0a58..38105a37a 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 150792300..71eb9835a 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(..)) @@ -118,12 +118,14 @@ data UniWorX = UniWorX , appLogger :: (ReleaseKey, TVar Logger) , appLogSettings :: TVar LogSettings , appCryptoIDKey :: CryptoIDKey + , appClusterID :: ClusterId , appInstanceID :: InstanceId , appJobCtl :: TVar (Map ThreadId (TMChan JobCtl)) , appCronThread :: TMVar (ReleaseKey, ThreadId) , appSessionKey :: ClientSession.Key , appSecretBoxKey :: SecretBox.Key , appJSONWebKeySet :: Jose.JwkSet + , appHealthReport :: TVar (Maybe (UTCTime, HealthReport)) } makeLenses_ ''UniWorX @@ -161,6 +163,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 +408,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 +596,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 @@ -598,6 +654,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of SFileR SheetExercise _ -> guard $ sheetActiveFrom <= cTime SFileR SheetHint _ -> guard $ maybe False (<= cTime) sheetHintFrom SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom + SFileR _ _ -> mzero SubmissionNewR -> guard active SubmissionR _ SAssignR -> guard marking -- Correctors can only be assigned when the Sheet is inactive, since submissions are subject to change SubmissionR _ _ -> guard active @@ -630,7 +687,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 +699,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 + 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 + 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 + 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 +767,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 +791,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 @@ -1056,6 +1162,8 @@ siteLayout' headingOverride widget = do isModal <- hasCustomHeader HeaderIsModal + primaryLanguage <- unsafeHead . Text.splitOn "-" <$> selectLanguage appLanguages + mcurrentRoute <- getCurrentRoute -- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance. @@ -1242,6 +1350,10 @@ instance YesodBreadcrumbs UniWorX where breadcrumb HelpR = return ("Hilfe" , Just HomeR) + breadcrumb HealthR = return ("Status" , Nothing) + breadcrumb InstanceR = return ("Identifikation", Nothing) + + breadcrumb ProfileR = return ("User" , Just HomeR) breadcrumb ProfileDataR = return ("Profile" , Just ProfileR) breadcrumb AuthPredsR = return ("Authentifizierung", Just ProfileR) @@ -1265,10 +1377,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) @@ -1538,6 +1657,26 @@ pageActions (VersionR) = [ , menuItemAccessCallback' = return True } ] +pageActions HealthR = [ + MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuInstance + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute InstanceR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + ] +pageActions InstanceR = [ + MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuHealth + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute HealthR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + ] pageActions (HelpR) = [ -- MenuItem -- { menuItemType = PageActionPrime @@ -1635,6 +1774,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 +1883,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/Common.hs b/src/Handler/Common.hs index 54eddd1c3..f11a76cfb 100644 --- a/src/Handler/Common.hs +++ b/src/Handler/Common.hs @@ -8,10 +8,19 @@ import Import hiding (embedFile) -- runtime dependency, and for efficiency. getFaviconR :: Handler TypedContent -getFaviconR = do cacheSeconds $ 60 * 60 * 24 * 30 -- cache for a month - return $ TypedContent "image/x-icon" - $ toContent $(embedFile "static/favicon.ico") +getFaviconR = do + let content = $(embedFile "static/favicon.ico") + + setEtagHashable content + + return $ TypedContent "image/x-icon" + $ toContent content getRobotsR :: Handler TypedContent -getRobotsR = return $ TypedContent typePlain - $ toContent $(embedFile "static/robots.txt") +getRobotsR = do + let content = $(embedFile "static/robots.txt") + + setEtagHashable content + + return $ TypedContent typePlain + $ toContent content diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 7de5e6b0d..4ef07e77d 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -128,7 +128,7 @@ colSubmissionLink = sortable Nothing (i18nCell MsgSubmission) return $ CSubmissionR tid ssh csh shn cid SubShowR in anchorCellM mkRoute (mkCid >>= \cid -> [whamlet|#{display cid}|]) -colSelect :: forall act h. (Monoid act, Headedness h) => Colonnade h CorrectionTableData (DBCell _ (FormResult (act, DBFormResult CryptoFileNameSubmission Bool CorrectionTableData), SheetTypeSummary)) +colSelect :: forall act h. (Semigroup act, Monoid act, Headedness h) => Colonnade h CorrectionTableData (DBCell _ (FormResult (act, DBFormResult CryptoFileNameSubmission Bool CorrectionTableData), SheetTypeSummary)) colSelect = dbSelect (_1 . applying _2) id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> encrypt subId colSubmittors :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 4c1d7a153..13da90fbf 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -9,6 +9,7 @@ import Utils.Form -- import Utils.DB import Handler.Utils import Handler.Utils.Course +import Handler.Utils.Tutorial import Handler.Utils.Communication import Handler.Utils.Form.MassInput import Handler.Utils.Delete @@ -24,8 +25,6 @@ import qualified Data.CaseInsensitive as CI import Data.Function ((&)) -- import Yesod.Form.Bootstrap3 -import Data.Monoid (Last(..)) - import Data.Maybe (fromJust) import qualified Data.Set as Set import Data.Map ((!)) @@ -275,7 +274,7 @@ getTermCourseListR tid = do getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCShowR tid ssh csh = do mbAid <- maybeAuthId - (course,schoolName,participants,registration,defSFid,lecturers,assistants) <- runDB . maybeT notFound $ do + (cid,course,schoolName,participants,registration,defSFid,lecturers,assistants,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,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 @@ -314,6 +319,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 +