Merge branch 'master' into workflows

CHANGELOG.md

@@ -2,6 +2,39 @@
 
 All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
 
+### [22.1.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v22.1.0...v22.1.1) (2020-11-14)
+
+## [22.1.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v22.0.0...v22.1.0) (2020-11-10)
+
+
+### Features
+
+* partial/conditional downloads & video streaming ([5b28303](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/5b28303539e28024b43addb413aedc4e5ee0e470))
+
+
+### Bug Fixes
+
+* translation ([80960f4](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/80960f42c578c201f78e226653431e9dd965cfce))
+* **personalised-sheet-files:** don't delete files when "keep" ([6008cb0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/6008cb040dea268e0a096f6c2fafa87f321d115f))
+
+## [22.0.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v21.1.1...v22.0.0) (2020-11-06)
+
+
+### ⚠ BREAKING CHANGES
+
+* **html-field:** StoredMarkup
+
+### Bug Fixes
+
+* **html-field:** introduce stored-markup ([e25e8a2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/e25e8a2f4ca65afc29acc8a3884df9acf77d4398))
+
+### [21.1.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v21.1.0...v21.1.1) (2020-11-06)
+
+
+### Bug Fixes
+
+* **course:** better explanation for material access ([78c5bc5](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/78c5bc5258c9305deafac18b010dc6a41e5ea864))
+
 ## [21.1.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v21.0.3...v21.1.0) (2020-11-05)
 
 

config/settings.yml

@@ -35,7 +35,7 @@ notification-expiration: 259200
 session-timeout: 7200
 bearer-expiration: 604800
 bearer-encoding: HS256
-maximum-content-length: "_env:MAX_UPLOAD_SIZE:134217728"
+maximum-content-length: "_env:MAX_UPLOAD_SIZE:805306368"
 session-files-expire: 3600
 prune-unreferenced-files-within: 57600
 prune-unreferenced-files-interval: 3600

config/video-types

@@ -0,0 +1,31 @@
+# Simple list of mime-types corresponding to video-formats
+#
+# Comments are empty lines and any line for which the first non-whitespace symbol is ‘#’
+#
+# Format is a single mime-type per line (may not contain whitespace)
+#
+# Largely copied from https://en.wikipedia.org/wiki/Video_file_format
+
+video/webm
+video/x-matroska
+video/x-flv
+video/x-f4v
+video/ogg
+video/x-mng
+video/x-msvideo
+model/vnd.mts
+video/quicktime
+video/x-ms-wmv
+application/vnd.rn-realmedia 
+application/vnd.rn-realmedia-vbr 
+video/vnd.vivo 
+video/x-ms-asf 
+video/mp4 
+video/mpeg 
+video/x-m4v 
+video/3gpp 
+video/3gpp2 
+application/mxf 
+video/h261 
+video/h263 
+video/h264 

frontend/src/app.sass

@@ -1496,3 +1496,17 @@ pre, tt, code
   .workflow-payload--label
     font-size: 20px
     font-weight: 600
+
+video
+  max-width: 100%
+  max-height: calc(90vh - var(--current-header-height))
+  background: black
+
+.video-container
+  display: flex
+  justify-content: center
+  width: 100%
+
+  & > video
+    object-fit: contain
+    flex-grow: 1

frontend/src/utils/inputs/inputs.sass

@@ -225,11 +225,15 @@ option
   margin: 10px 0
   color: var(--color-fontsec)
 
+.file-input__list-wrapper
+  overflow: auto
+  max-height: 75vh
+  max-width: 30vw
+
 .file-input__list
   margin-left: 40px
   margin-top: 10px
   font-weight: 600
-  max-width: 25vw
 
   tr:last-child td
     padding-bottom: 0
@@ -237,6 +241,7 @@ option
   .file-input__list-item
     font-family: var(--font-monospace)
     font-size: 15px
+    word-break: break-all
 
 // PREVIOUSLY UPLOADED FILES
 
@@ -250,3 +255,13 @@ option
 
   .checkbox
     margin-left: 12px
+
+.form--vertical .form-group__input
+  grid-column: unset
+  grid-row: 2
+
+.form-group.form--vertical
+  grid-template: auto auto / auto
+
+.form--vertical__cell
+  vertical-align: top

messages/uniworx/de-de-formal.msg

@@ -435,7 +435,7 @@ MaterialVisibleFromTip: Ohne Datum nie sichtbar für Teilnehmer; leer lassen ist
 MaterialVisibleFromEditWarning: Das Datum der Veröffentlichung liegt in der Vergangenheit und sollte nicht mehr verändert werden, da dies die Benutzer verwirren könnte.
 MaterialInvisible: Dieses Material ist für Teilnehmer momentan unsichtbar!
 MaterialFiles: Dateien
-MaterialHeading materialName@MaterialName: Material "#{materialName}"
+MaterialHeading materialName@MaterialName: #{materialName}
 MaterialListHeading: Materialien
 MaterialNewHeading: Neues Material veröffentlichen
 MaterialNewTitle: Neues Material
@@ -448,6 +448,9 @@ MaterialDelHasFiles count@Int64: inklusive #{count} #{pluralDE count "Datei" "Da
 MaterialIsVisible: Achtung, dieses Material wurde bereits veröffentlicht.
 MaterialDeleted materialName@MaterialName: Material "#{materialName}" gelöscht
 MaterialArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand materialName@MaterialName: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase materialName}
+MaterialVideo materialName@MaterialName: #{materialName} - Video
+MaterialVideoUnsupported: Ihr Browser scheint keine eingebetten Videos zu unterstützen
+MaterialVideoDownload: Herunterladen
 
 
 Unauthorized: Sie haben hierfür keine explizite Berechtigung.
@@ -1026,10 +1029,10 @@ MailCourseRegisteredIntroOther displayName@Text courseName@Text termDesc@Text: #
 MailSubjectExamResult csh@CourseShorthand examn@ExamName: Ergebnisse für #{examn} in #{csh} wurden herausgegeben
 MailExamResultIntro courseName@Text termDesc@Text examn@ExamName: Sie können nun Ihr Ergebnis für #{examn} im Kurs #{courseName} (#{termDesc}) einsehen.
 
-MailSubjectExamOfficeExamResults csh@CourseShorthand examn@ExamName: Ergebnisse für #{examn} in #{csh} sind fertiggestellt
+MailSubjectExamOfficeExamResults coursen@CourseName examn@ExamName: Ergebnisse für #{examn} in #{coursen} sind fertiggestellt
 MailExamOfficeExamResultsIntro courseName@Text termDesc@Text examn@ExamName: Ein Kursverwalter hat die Prüfungsleistungen für #{examn} im Kurs #{courseName} (#{termDesc}) freigegeben.
 
-MailSubjectExamOfficeExamResultsChanged csh@CourseShorthand examn@ExamName: Ergebnisse für #{examn} in #{csh} wurden verändert
+MailSubjectExamOfficeExamResultsChanged coursen@CourseName examn@ExamName: Ergebnisse für #{examn} in #{coursen} wurden verändert
 MailExamOfficeExamResultsChangedIntro courseName@Text termDesc@Text examn@ExamName: Ein Kursverwalter hat Prüfungsleistungen für #{examn} im Kurs #{courseName} (#{termDesc}) verändert.
 
 MailSubjectExamOfficeExternalExamResults coursen@CourseName examn@ExamName: Ergebnisse für #{examn} in #{coursen}
@@ -1468,6 +1471,7 @@ BreadcrumbAllocationInfo: Ablauf einer Zentralanmeldung
 BreadcrumbCourseParticipantInvitation: Einladung zum Kursteilnehmer
 BreadcrumbMaterialArchive: Archiv
 BreadcrumbMaterialFile: Datei
+BreadcrumbMaterialVideo: Video
 BreadcrumbSheetArchive: Dateien
 BreadcrumbSheetIsCorrector: Korrektor-Überprüfung
 BreadcrumbSheetPseudonym: Pseudonym
@@ -1738,6 +1742,10 @@ TutorialParticipants: Teilnehmer
 TutorialCapacity: Kapazität
 TutorialFreeCapacity: Freie Plätze
 TutorialRoom: Regulärer Raum
+TutorialRoomHidden: Raum nur für Teilnehmer
+TutorialRoomHiddenTip: Soll der Raum nur den Teilnehmern des Tutoriums angezeigt werden?
+TutorialRoomIsUnset: —
+TutorialRoomIsHidden: Raum wird nur Teilnehmern angezeigt
 TutorialTime: Zeit
 TutorialRegistered: Angemeldet
 TutorialRegGroup: Registrierungs-Gruppe
@@ -1839,6 +1847,7 @@ ExamFinished: Ergebnisse sichtbar ab
 ExamFinishedOffice: Noten bekannt gegeben
 ExamFinishedParticipant: Bewertung voraussichtlich abgeschlossen
 ExamFinishedTip: Zeitpunkt zu dem Prüfungergebnisse den Teilnehmern gemeldet werden; ohne Datum werden die Prüfungsergebnisse zunächst nie gemeldet
+ExamFinishedTipCloseOnFinished: Zeitpunkt zu dem Prüfungergebnisse den Teilnehmern und den Prüfungsverwaltungen gemeldet werden; ohne Datum werden die Prüfungsergebnisse zunächst nie gemeldet
 ExamClosed: Noten gemeldet
 ExamClosedTip: Prüfungsbeauftraget, die im System Noten einsehen, werden zu diesem Zeitpunkt benachrichtigt und danach bei Änderungen informiert
 ExamGradingMode: Bewertungsmodus
@@ -1886,6 +1895,8 @@ ExamRoomSurname': Nach Nachname
 ExamRoomMatriculation': Nach Matrikelnummer
 ExamRoomRandom': Zufällig pro Teilnehmer
 ExamRoomFifo': Auswahl durch Teilnehmer bei Anmeldung
+ExamOccurrenceRoomIsUnset: —
+ExamOccurrenceRoomIsHidden: Raum wird nur Teilnehmern angezeigt
 
 ExamOccurrence: Termin/Raum
 ExamNoOccurrence: Kein Termin/Raum
@@ -1894,6 +1905,8 @@ ExamOccurrences: Termine
 ExamRooms: Räume
 ExamTimes: Termine
 ExamRoomRoom: Raum
+ExamRoomRoomHidden: Raum nur für Angemeldete
+ExamRoomRoomHiddenTip: Soll der Raum nur zu diesem Termin/Raum angemeldeten Prüfungsteilnehmern angezeigt werden?
 ExamRoomAlreadyExists: Prüfung ist bereits eingetragen
 ExamRoomName: Interne Bezeichnung
 ExamRoomCapacity: Kapazität
@@ -2501,6 +2514,7 @@ BtnCloseExam: Prüfung abschließen
 ExamCloseTip: Wenn eine Prüfung abgeschlossen wird, werden Prüfungsbeauftragte, die im System Noten einsehen, benachrichtigt und danach bei Änderungen informiert.
 ExamCloseReminder: Bitte schließen Sie die Prüfung frühstmöglich, sobald die Prüfungsleistungen sich voraussichtlich nicht mehr ändern werden. Z.B. direkt nach der Klausureinsicht.
 ExamDidClose: Prüfung erfolgreich abgeschlossen
+ExamCloseTipOnFinished: Die Prüfung wird automatisch abgeschlossen, also Prüfungsbeauftragte, die im System Note einsehen, benachrichtigt und danach bei Änderungen informiert, sobald die Noten für die Prüfungsteilnehmer veröffentlicht werden.
 
 ExamClosedSince time@Text: Prüfung abgeschlossen seit #{time}
 
@@ -2561,7 +2575,12 @@ CourseNewsActionDelete: Löschen
 CourseNewsActionCreate: Neue Nachricht
 CourseMaterial: Material
 CourseMaterialFree: Das Kursmaterial ist ohne Anmeldung frei zugänglich
-CourseMaterialNotFree: Eine Anmeldung zum Kurs ist Voraussetzung zum Zugang zu Kursmaterial
+CourseMaterialNotFree: Das Kursmaterial ist nur für Mitglieder des Kurses einsehbar, also z.B. für Teilnehmer, Tutoren, Korrektoren und Verwalter.
+
+CourseSheetsFoundHere: Die Übungsblatter zum Kurs finden Sie hier
+CourseSheetsNoneVisible: Aktuell gibt es zu diesem Kurs keine Übungsblätter, oder nur Übungsblätter auf die Sie keinen Zugriff haben (z.B. aufgrund von Fristen bzgl. der Sichtbarkeit).
+CourseMaterialsFoundHere: Material zum Kurs finden Sie hier
+CourseMaterialsNoneVisible: Aktuell gibt es zu diesem Kurs kein Material, oder nur Material auf das Sie keinen Zugriff haben (z.B. aufgrund von Fristen bzgl. der Sichtbarkeit).
 
 CourseNewsVisibleFromEditWarning: Das Datum der Veröffentlichung liegt in der Vergangenheit und sollte nicht mehr verändert werden, da dies die Teilnehmer verwirren könnte.
 CourseNewsVisibleFromTip: Ohne Datum nie sichtbar für Teilnehmer; leer lassen ist nur sinnvoll für noch unfertige Nachrichten
@@ -2616,6 +2635,10 @@ CourseEventType: Art
 CourseEventTypePlaceholder: Vorlesung, Zentralübung, ...
 CourseEventTime: Zeit
 CourseEventRoom: Regulärer Raum
+CourseEventRoomHidden: Raum nur für Teilnehmer
+CourseEventRoomHiddenTip: Soll der Raum nur angemeldeten Kursteilnehmern angezeigt werden?
+CourseEventRoomIsUnset: —
+CourseEventRoomIsHidden: Raum wird nur Kurs-assoziierten Personen (Teilnehmer, Tutoren, Korrektoren, etc.) angezeigt
 CourseEventNote: Notiz
 CourseEventActions: Aktionen
 CourseEventsActionEdit: Bearbeiten
@@ -3069,3 +3092,20 @@ InvalidCredentialsADTooManyContextIds: Benutzereintrag trägt zu viele Sicherhei
 InvalidCredentialsADAccountExpired: Benutzereintrag abgelaufen
 InvalidCredentialsADPasswordMustChange: Passwort muss geändert werden
 InvalidCredentialsADAccountLockedOut: Benutzereintrag wurde durch Eindringlingserkennung gesperrt
+
+ExamCloseModeSeparate: Separat
+ExamCloseModeOnFinished: Mit Veröffentlichung
+ExamCloseModeOnFinishedHidden: Mit Veröffentlichung (versteckt)
+ExamCloseMode: Prüfungs-Abschluss
+
+RoomReferenceSimple: Text
+RoomReferenceLink: Link & Anweisungen
+RoomReferenceSimpleText: Raum
+RoomReferenceSimpleTextPlaceholder: Raum
+RoomReferenceLinkLink: Link
+RoomReferenceLinkLinkPlaceholder: URL
+RoomReferenceLinkInstructions: Anweisungen
+RoomReferenceLinkInstructionsPlaceholder: Anweisungen
+RoomReferenceNone: —
+
+UrlFieldCouldNotParseAbsolute: Konnte nicht als absolute URL interpretiert werden

messages/uniworx/en-eu.msg

@@ -433,7 +433,7 @@ MaterialVisibleFromTip: Never visible to participants if left empty; leaving the
 MaterialVisibleFromEditWarning: This course material has already been published and should not be edited. Doing so might confuse the participants.
 MaterialInvisible: This course material is currently invisible to participants!
 MaterialFiles: Files
-MaterialHeading materialName: Course material “#{materialName}”
+MaterialHeading materialName: #{materialName}
 MaterialListHeading: Course materials
 MaterialNewHeading: Publish new course material
 MaterialNewTitle: New course material
@@ -446,6 +446,9 @@ MaterialDelHasFiles count: including #{count} #{pluralEN count "file" "files"}
 MaterialIsVisible: Caution, this course material has already been published.
 MaterialDeleted materialName: Successfully deleted course material “#{materialName}”
 MaterialArchiveName tid ssh csh materialName: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase materialName}
+MaterialVideo materialName: #{materialName} - Video
+MaterialVideoUnsupported: Your browser does not seem to support embedded video
+MaterialVideoDownload: Download
 
 Unauthorized: You do not have explicit authorisation.
 UnauthorizedAnd l r: (#{l} AND #{r})
@@ -1015,10 +1018,10 @@ MailCourseRegisteredIntroOther displayName courseName termDesc: #{displayName} w
 MailSubjectExamResult csh examn: Results for #{examn} in #{csh} are now available
 MailExamResultIntro courseName termDesc examn: You may now view your result for #{examn} of the course #{courseName} (#{termDesc}).
 
-MailSubjectExamOfficeExamResults csh examn: Results for #{examn} of #{csh} are now available
+MailSubjectExamOfficeExamResults coursen examn: Results for #{examn} of #{coursen} are now available
 MailExamOfficeExamResultsIntro courseName termDesc examn: A course administrator has made the results for #{examn} of the course #{courseName} (#{termDesc}) available.
 
-MailSubjectExamOfficeExamResultsChanged csh examn: Results for #{examn} of #{csh} were changed
+MailSubjectExamOfficeExamResultsChanged coursen examn: Results for #{examn} of #{coursen} were changed
 MailExamOfficeExamResultsChangedIntro courseName termDesc examn: A course administrator has changed exam results for #{examn} of the course #{courseName} (#{termDesc}).
 
 MailSubjectExamOfficeExternalExamResults coursen@CourseName examn@ExamName: Results for #{examn} in #{coursen}
@@ -1446,6 +1449,7 @@ BreadcrumbAllocationInfo: On central allocations
 BreadcrumbCourseParticipantInvitation: Invitation to be a course participant
 BreadcrumbMaterialArchive: Archive
 BreadcrumbMaterialFile: File
+BreadcrumbMaterialVideo: Video
 BreadcrumbSheetArchive: Files
 BreadcrumbSheetIsCorrector: Corrector-check
 BreadcrumbSheetPseudonym: Pseudonym
@@ -1697,6 +1701,10 @@ TutorialParticipants: Participants
 TutorialCapacity: Capacity
 TutorialFreeCapacity: Free capacity
 TutorialRoom: Regular room
+TutorialRoomHidden: Room only for participants
+TutorialRoomHiddenTip: Should the room only be displayed to tutorial participants?
+TutorialRoomIsUnset: —
+TutorialRoomIsHidden: Room is only displayed to participants
 TutorialTime: Time
 TutorialRegistered: Registered
 TutorialRegGroup: Registration group
@@ -1798,6 +1806,7 @@ ExamFinished: Results visible from
 ExamFinishedOffice: Exam achievements published
 ExamFinishedParticipant: Marking expected to be finished
 ExamFinishedTip: At this participants are informed of their exam achievements. If left empty participants are never informed of their exam achievements.
+ExamFinishedTipCloseOnFinished: At this time participants and exam offices are informed of the exam achievements. If left empty participants and exam offices are never informed of the exam achievements.
 ExamClosed: Exam achievements registered
 ExamClosedTip: At this time exam offices, which pull exam achievements from Uni2work, are informed. Changes to exam achievements trigger further notifications
 ExamGradingMode: Grading mode
@@ -1845,6 +1854,8 @@ ExamRoomSurname': By surname
 ExamRoomMatriculation': By matriculation
 ExamRoomRandom': Randomly
 ExamRoomFifo': Selected by the participants when registering
+ExamOccurrenceRoomIsUnset: —
+ExamOccurrenceRoomIsHidden: Room is only displayed to participants registered for this occurrence/room
 
 ExamOccurrence: Occurrence/room
 ExamNoOccurrence: No occurrence/room
@@ -1853,6 +1864,8 @@ ExamOccurrences: Exams
 ExamRooms: Rooms
 ExamTimes: Times
 ExamRoomRoom: Room
+ExamRoomRoomHidden: Room only for participants
+ExamRoomRoomHiddenTip: Should the room only be displayed to participants registered for this occurrence/room?
 ExamRoomAlreadyExists: Occurrence already configured
 ExamRoomName: Internal name
 ExamRoomCapacity: Capacity
@@ -2461,6 +2474,7 @@ BtnCloseExam: Close exam
 ExamCloseTip: When an exam is closed all relevant exam offices, which pull exam achievements from Uni2work, are informed and kept up to date with changes.
 ExamCloseReminder: Please close the exam as soon as possible, when exam achievements are no longer expected to change e.g. after inspection of the exam has concluced.
 ExamDidClose: Successfully closed exam
+ExamCloseTipOnFinished: The exam will be closed automatically as soon as exam participants are informed of their exam achievements. That means exam offices will be able notified once and after that each time a grade changes.
 
 ExamClosedSince time: Exam closed since #{time}
 
@@ -2520,8 +2534,13 @@ CourseNewsActionEdit: Edit
 CourseNewsActionDelete: Delete
 CourseNewsActionCreate: Create new item
 CourseMaterial: Material
-CourseMaterialFree: Course material is publicly accessable
+CourseMaterialFree: Course material is publicly accessible
-CourseMaterialNotFree: Only course participants may access course material
+CourseMaterialNotFree: Course material is only accessible to members of the course, e.g. for participants, tutors, correctors or administratiors.
+
+CourseSheetsFoundHere: Exercise sheets for this course are available here
+CourseSheetsNoneVisible: Currently there are no exercise sheets for this course or only exercise sheets to which you don't have access (e.g. because of visibility settings)
+CourseMaterialsFoundHere: Material for this course is available here
+CourseMaterialsNoneVisible: Currently there is no material for this course or only material to which you don't have access (e.g. because of visibility settings)
 
 CourseNewsVisibleFromEditWarning: This item of course news has already been published and should no longer be changed sind this might confuse participants.
 CourseNewsVisibleFromTip: If left empty this item is never visible. Leave empty for unfinished items
@@ -2576,6 +2595,10 @@ CourseEventType: Type
 CourseEventTypePlaceholder: Lecture, Exercise discussion, ...
 CourseEventTime: Time
 CourseEventRoom: Regular room
+CourseEventRoomHidden: Room only for participants
+CourseEventRoomHiddenTip: Should the room only be displayde to course participants?
+CourseEventRoomIsUnset: —
+CourseEventRoomIsHidden: Room is only displayed to course associated persons (participants, tutor, correctors, etc.)
 CourseEventNote: Note
 CourseEventActions: Actions
 CourseEventsActionEdit: Edit
@@ -2959,3 +2982,20 @@ InvalidCredentialsADTooManyContextIds: Account carries to many security identifi
 InvalidCredentialsADAccountExpired: Account expired
 InvalidCredentialsADPasswordMustChange: Password needs to be changed
 InvalidCredentialsADAccountLockedOut: Account disabled by intruder detection
+
+ExamCloseModeSeparate: Seperately
+ExamCloseModeOnFinished: With publication of achievements
+ExamCloseModeOnFinishedHidden: With publication of achievements (hidden)
+ExamCloseMode: Exam closure
+
+RoomReferenceSimple: Text
+RoomReferenceLink: Link & Instructions
+RoomReferenceSimpleText: Room
+RoomReferenceSimpleTextPlaceholder: Room
+RoomReferenceLinkLink: Link
+RoomReferenceLinkLinkPlaceholder: URL
+RoomReferenceLinkInstructions: Instructions
+RoomReferenceLinkInstructionsPlaceholder: Instructions
+RoomReferenceNone: —
+
+UrlFieldCouldNotParseAbsolute: Could not parse as an absolute URL

models/allocations.model

@@ -3,8 +3,8 @@ Allocation -- attributes with prefix staff- affect lecturers only, but are invis
     school              SchoolId        -- school that manages this central allocation, not necessarily school of courses
     shorthand           AllocationShorthand -- practical shorthand
     name                AllocationName
-    description         Html Maybe      -- description for prospective students
+    description         StoredMarkup Maybe      -- description for prospective students
-    staffDescription    Html Maybe      -- description seen by prospective lecturers only
+    staffDescription    StoredMarkup Maybe      -- description seen by prospective lecturers only
     staffRegisterFrom   UTCTime Maybe   -- lectureres may register courses
     staffRegisterTo     UTCTime Maybe   -- course registration stops
     -- staffDeregisterUntil not needed: staff may make arbitrary changes until staffRegisterTo, always frozen afterwards

models/courses.model

@@ -5,8 +5,8 @@ DegreeCourse json   -- for which degree programmes this course is appropriate fo
     UniqueDegreeCourse course degree terms
 Course    -- Information about a single course; contained info is always visible to all users
     name             (CI Text)
-    description      Html Maybe    -- user-defined large Html, ought to contain module description
+    description      StoredMarkup Maybe    -- user-defined large Html, ought to contain module description
-    linkExternal     Text Maybe    -- arbitrary user-defined url for external course page
+    linkExternal     URI Maybe     -- arbitrary user-defined url for external course page
     shorthand        (CI Text)     -- practical shorthand of course name, used for identification
     term             TermId        -- semester this course is taught
     school           SchoolId
@@ -21,7 +21,7 @@ Course    -- Information about a single course; contained info is always visible
     registerSecret   Text Maybe    -- enrolement maybe protected by a simple common passphrase
     materialFree     Bool          -- False: only enrolled users may see course materials not stored in this table
     applicationsRequired       Bool default=false
-    applicationsInstructions   Html Maybe
+    applicationsInstructions   StoredMarkup Maybe
     applicationsText           Bool default=false
     applicationsFiles          UploadMode "default='{\"mode\": \"no-upload\"}'::jsonb"
     applicationsRatingsVisible Bool default=false
@@ -31,9 +31,10 @@ Course    -- Information about a single course; contained info is always visible
 CourseEvent
     type (CI Text)
     course CourseId
-    room Text
+    room RoomReference Maybe
+    roomHidden Bool default=false
     time Occurrences
-    note Html Maybe
+    note StoredMarkup Maybe
     lastChanged UTCTime default=now()
 
 CourseAppInstructionFile
@@ -72,7 +73,7 @@ CourseParticipant                      -- course enrolement
 CourseUserNote                 -- lecturers of a specific course may share a text note on each enrolled student
     course       CourseId
     user         UserId
-    note         Html          -- arbitrary user-defined text; visible only to lecturer of this course
+    note         StoredMarkup  -- arbitrary user-defined text; visible only to lecturer of this course
     UniqueCourseUserNote user course
 CourseUserNoteEdit             -- who edited a participants course note when
     user         UserId

models/courses/materials.model

@@ -2,7 +2,7 @@ Material -- course material for disemination to course participants
   course          CourseId
   name            (CI Text)
   type            (CI Text) Maybe
-  description     Html Maybe
+  description     StoredMarkup Maybe
   visibleFrom     UTCTime Maybe    -- Invisible to enrolled participants before
   lastEdit        UTCTime
   UniqueMaterial course name

models/courses/news.model

@@ -3,8 +3,8 @@ CourseNews
     visibleFrom         UTCTime Maybe
     participantsOnly    Bool
     title               Text Maybe
-    content             Html
+    content             StoredMarkup
-    summary             Html Maybe
+    summary             StoredMarkup Maybe
     lastEdit            UTCTime
 CourseNewsFile
     news     CourseNewsId

models/exams.model

@@ -16,7 +16,7 @@ Exam
   closed UTCTime Maybe -- Prüfungsamt hat Einsicht (notification)
   publicStatistics Bool
   gradingMode ExamGradingMode
-  description Html Maybe
+  description StoredMarkup Maybe
   examMode ExamMode
   staff Text Maybe
   UniqueExam course name
@@ -31,11 +31,12 @@ ExamPart
 ExamOccurrence
   exam ExamId
   name ExamOccurrenceName
-  room Text
+  room RoomReference Maybe
+  roomHidden Bool default=false
   capacity Natural
   start UTCTime
   end UTCTime Maybe
-  description Html Maybe
+  description StoredMarkup Maybe
   UniqueExamOccurrence exam name
 ExamRegistration
   exam ExamId

models/schools.model

@@ -7,6 +7,7 @@ School json
     examMinimumRegisterDuration    NominalDiffTime Maybe
     examRequireModeForRegistration Bool default=false
     examDiscouragedModes ExamModeDNF
+    examCloseMode ExamCloseMode default='separate'
     UniqueSchool name
     UniqueSchoolShorthand shorthand -- required for Normalisation of CI Text
     Primary shorthand        -- newtype Key School = SchoolKey { unSchoolKey :: SchoolShorthand }

models/sheets.model

@@ -1,10 +1,10 @@
 Sheet   -- exercise sheet for a given course
     course          CourseId
     name            (CI Text)
-    description     Html Maybe
+    description     StoredMarkup Maybe
     type            SheetType        -- Does it count towards overall course grade?
     grouping        SheetGroup       -- May participants submit in groups of certain sizes?
-    markingText     Html Maybe       -- Instructons for correctors, included in marking templates
+    markingText     StoredMarkup Maybe -- Instructons for correctors, included in marking templates
     visibleFrom     UTCTime Maybe    -- Invisible to enrolled participants before
     activeFrom      UTCTime Maybe    -- Download of questions and submission is permitted afterwards
     activeTo        UTCTime Maybe    -- Submission is only permitted before

models/system-messages.model

@@ -11,14 +11,14 @@ SystemMessage
     lastChanged         UTCTime default=now()
     lastUnhide          UTCTime default=now()
     defaultLanguage     Lang -- Language of @content@ and @summary@
-    content             Html -- Detailed message shown when clicking on the @summary@-popup or when no @summary@ is specified
+    content             StoredMarkup -- Detailed message shown when clicking on the @summary@-popup or when no @summary@ is specified
-    summary             Html Maybe
+    summary             StoredMarkup Maybe
 
 SystemMessageTranslation -- Translation of a @SystemMessage@ into another language; which language to choose is determined by user-sent HTTP-headers
     message             SystemMessageId
     language            Lang
-    content             Html
+    content             StoredMarkup
-    summary             Html Maybe
+    summary             StoredMarkup Maybe
     UniqueSystemMessageTranslation message language
 
 SystemMessageHidden

models/tutorials.model

@@ -3,7 +3,8 @@ Tutorial json
     course          CourseId
     type            (CI Text) -- "Tutorium", "Zentralübung", ...
     capacity        Int Maybe -- limit for enrolment in this tutorial
-    room            Text Maybe
+    room            RoomReference Maybe
+    roomHidden      Bool default=false
     time            Occurrences
     regGroup        (CI Text) Maybe -- each participant may register for one tutorial per regGroup
     registerFrom    UTCTime Maybe

models/workflows.model

@@ -9,14 +9,14 @@ WorkflowDefinitionDescription
     definition  WorkflowDefinitionId
     language    Lang
     title       Text
-    description Html Maybe
+    description StoredMarkup Maybe
     UniqueWorkflowDefinitionDescription definition language
 
 WorkflowDefinitionInstanceDescription
     definition  WorkflowDefinitionId
     language    Lang
     title       Text
-    description Html Maybe
+    description StoredMarkup Maybe
     UniqueWorkflowDefinitionInstanceDescription definition language
 
 WorkflowInstance
@@ -31,7 +31,7 @@ WorkflowInstanceDescription
     instance    WorkflowInstanceId
     language    Lang
     title       Text
-    description Html Maybe
+    description StoredMarkup Maybe
     UniqueWorkflowInstanceDescription instance language
 
 WorkflowWorkflow

package-lock.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "21.1.0",
+  "version": "22.1.1",
   "lockfileVersion": 1,
   "requires": true,
   "dependencies": {

package.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "21.1.0",
+  "version": "22.1.1",
   "description": "",
   "keywords": [],
   "author": "",

package.yaml

@@ -1,5 +1,5 @@
 name:    uniworx
-version: 21.1.0
+version: 22.1.1
 
 dependencies:
   - base
@@ -8,6 +8,7 @@ dependencies:
   - yesod-auth
   - yesod-static
   - yesod-form
+  - yesod-persistent
   - classy-prelude
   - classy-prelude-yesod
   - bytestring
@@ -157,6 +158,7 @@ dependencies:
   - list-t
   - insert-ordered-containers
   - topograph
+  - network-uri
 
 other-extensions:
   - GeneralizedNewtypeDeriving
@@ -318,6 +320,7 @@ tests:
       - http-types
       - yesod-persistent
       - quickcheck-io
+      - network-arbitrary
     ghc-options:
       - -fno-warn-orphans
       - -threaded -rtsopts "-with-rtsopts=-N -T"

routes

@@ -204,6 +204,7 @@
     /show                       MShowR         GET             !timeANDcourse-registered !timeANDmaterialsANDcourse-time !corrector !tutor
     !/download                  MArchiveR      GET             !timeANDcourse-registered !timeANDmaterialsANDcourse-time !corrector !tutor
     !/download/*FilePath        MFileR         GET             !timeANDcourse-registered !timeANDmaterialsANDcourse-time !corrector !tutor
+    /video/#CryptoUUIDMaterialFile MVideoR        GET             !timeANDcourse-registered !timeANDmaterialsANDcourse-time !corrector !tutor
   /tuts                         CTutorialListR GET             !tutor -- THIS route is used to check for overall course tutor access!
   /tuts/new                     CTutorialNewR  GET POST
   /tuts/#TutorialName TutorialR:

src/CryptoID.hs

@@ -75,6 +75,7 @@ decCryptoIDs [ ''SubmissionId
              , ''ExternalExamId
              , ''WorkflowInstanceId
              , ''WorkflowWorkflowId
+             , ''MaterialFileId
              ]
 
 type instance CryptoIDNamespace a WorkflowStateIndex = "WorkflowStateIndex"

src/Database/Esqueleto/Utils.hs

@@ -20,12 +20,12 @@ module Database.Esqueleto.Utils
   , selectExists, selectNotExists
   , SqlHashable
   , sha256
-  , maybe, maybeEq, unsafeCoalesce
+  , maybe, maybe2, maybeEq, unsafeCoalesce
   , bool
   , max, min
   , abs
   , SqlProject(..)
-  , (->.)
+  , (->.), (#>>.)
   , fromSqlKey
   , selectCountRows
   , selectMaybe
@@ -302,6 +302,20 @@ maybe onNothing onJust val = E.case_
   ]
   (E.else_ onNothing)
 
+maybe2 :: (PersistField a, PersistField b, PersistField c)
+       => E.SqlExpr (E.Value c)
+       -> (E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value b) -> E.SqlExpr (E.Value c))
+       -> E.SqlExpr (E.Value (Maybe a))
+       -> E.SqlExpr (E.Value (Maybe b))
+       -> E.SqlExpr (E.Value c)
+maybe2 onNothing onJust val1 val2 = E.case_
+  [ E.when_
+      (isJust val1 E.&&. isJust val2)
+    E.then_
+      (onJust (E.veryUnsafeCoerceSqlExprValue val1) (E.veryUnsafeCoerceSqlExprValue val2))
+  ]
+  (E.else_ onNothing)
+
 infix 4 `maybeEq`
 
 maybeEq :: PersistField a
@@ -350,23 +364,32 @@ unsafeCoalesce :: E.PersistField a => [E.SqlExpr (E.Value (Maybe a))] -> E.SqlEx
 unsafeCoalesce = E.veryUnsafeCoerceSqlExprValue . E.coalesce
 
 
-class (PersistEntity entity, PersistField value) => SqlProject entity value entity' value' | entity value entity' -> value', entity value value' -> entity' where
+class (PersistEntity entity, PersistField value, PersistField value') => SqlProject entity value entity' value' | entity value entity' -> value', entity value value' -> entity' where
   sqlProject :: E.SqlExpr entity' -> EntityField entity value -> E.SqlExpr (E.Value value')
   unSqlProject :: forall p1 p2. p1 entity -> p2 entity' -> value -> value'
+  unSqlProjectExpr :: forall p1 p2. p1 entity -> p2 entity' -> E.SqlExpr (E.Value value) -> E.SqlExpr (E.Value value')
 
 instance (PersistEntity val, PersistField typ) => SqlProject val typ (E.Entity val) typ where
   sqlProject = (E.^.)
   unSqlProject _ _ = id
+  unSqlProjectExpr _ _ = id
 
 instance (PersistEntity val, PersistField typ) => SqlProject val typ (Maybe (E.Entity val)) (Maybe typ) where
   sqlProject = (E.?.)
   unSqlProject _ _ = Just
+  unSqlProjectExpr _ _ = E.just
 
 infixl 8 ->.
 
 (->.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value b)
 (->.) expr t = E.unsafeSqlBinOp "->" expr $ E.val t
 
+infixl 8 #>>.
+
+(#>>.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value (Maybe Text))
+(#>>.) expr t = E.unsafeSqlBinOp "#>>" expr $ E.val t
+
+
 fromSqlKey :: (ToBackendKey SqlBackend entity, PersistField (Key entity)) => E.SqlExpr (E.Value (Key entity)) -> E.SqlExpr (E.Value Int64)
 fromSqlKey = E.veryUnsafeCoerceSqlExprValue
 

src/Foundation/I18n.hs

@@ -230,11 +230,14 @@ embedRenderMessage ''UniWorX ''ExamSynchronicityPreset id
 embedRenderMessage ''UniWorX ''ExamRequiredEquipmentPreset id
 embedRenderMessage ''UniWorX ''ChangelogItemKind id
 embedRenderMessage ''UniWorX ''WorkflowScope' $ ("WorkflowScopeKind" <>) . concat . drop 1 . splitCamel . fromMaybe (error "Expected WorkflowScope' to have '") . stripSuffix "'"
+embedRenderMessage ''UniWorX ''RoomReference' $ dropSuffix "'"
 
 embedRenderMessage ''UniWorX ''AuthenticationMode id
 
 embedRenderMessage ''UniWorX ''RatingValidityException id
 
+embedRenderMessage ''UniWorX ''UrlFieldMessage id
+
 embedRenderMessageVariant ''UniWorX ''ADInvalidCredentials ("InvalidCredentials" <>)
 
 newtype ShortSex = ShortSex Sex
@@ -326,6 +329,15 @@ instance RenderMessage UniWorX CourseParticipantState where
       mr :: RenderMessage UniWorX msg => msg -> Text
       mr = renderMessage foundation ls
 
+instance RenderMessage UniWorX ExamCloseMode where
+  renderMessage foundation ls = \case
+    ExamCloseSeparate         -> mr MsgExamCloseModeSeparate
+    ExamCloseOnFinished False -> mr MsgExamCloseModeOnFinished
+    ExamCloseOnFinished True  -> mr MsgExamCloseModeOnFinishedHidden
+    where
+      mr :: RenderMessage UniWorX msg => msg -> Text
+      mr = renderMessage foundation ls
+
 -- ToMessage instances for converting raw numbers to Text (no internationalization)
 
 instance ToMessage Int where

src/Foundation/Navigation.hs

@@ -291,6 +291,7 @@ instance BearerAuthSite UniWorX => YesodBreadcrumbs UniWorX where
     MDelR  -> i18nCrumb MsgMenuMaterialDelete . Just $ CMaterialR tid ssh csh mnm MShowR
     MArchiveR -> i18nCrumb MsgBreadcrumbMaterialArchive . Just $ CMaterialR tid ssh csh mnm MShowR
     MFileR _ -> i18nCrumb MsgBreadcrumbMaterialFile . Just $ CMaterialR tid ssh csh mnm MShowR
+    MVideoR _ -> i18nCrumb MsgBreadcrumbMaterialVideo . Just $ CMaterialR tid ssh csh mnm MShowR
 
   breadcrumb (CourseR tid ssh csh CPersonalFilesR) = i18nCrumb MsgBreadcrumbCourseSheetPersonalisedFiles . Just $ CourseR tid ssh csh CShowR
 

src/Foundation/SiteLayout.hs

@@ -454,7 +454,7 @@ applySystemMessages = liftHandler . maybeT_ . catchMPlus (Proxy @CryptoIDError)
       case summary of
         Just s ->
           addMessageWidget systemMessageSeverity $ msgModal (toWidget s) (Left . SomeRoute $ MessageR cID)
-        Nothing -> addMessage systemMessageSeverity content
+        Nothing -> addMessage systemMessageSeverity $ toHtml content
 
       tellRegisteredCookieJson CookieSystemMessageState . MergeHashMap $
         HashMap.singleton cID mempty{ userSystemMessageShown = Just now }

src/Foundation/Yesod/Middleware.hs

@@ -164,6 +164,7 @@ routeNormalizers = map (hoist (hoist liftHandler . withReaderT projectBackend) .
   , verifyCourseApplication
   , verifyCourseNews
   , verifyWorkflowWorkflow
+  , verifyMaterialVideo
   ]
   where
     normalizeRender :: Route UniWorX -> WriterT Any (ReaderT SqlReadBackend (HandlerFor UniWorX)) (Route UniWorX)
@@ -291,3 +292,12 @@ routeNormalizers = map (hoist (hoist liftHandler . withReaderT projectBackend) .
       let newRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID wwR)
       tell . Any $ route /= newRoute
       return newRoute
+    verifyMaterialVideo = maybeOrig $ \route -> do
+      CMaterialR _tid _ssh _csh _mnm (MVideoR cID) <- return route
+      mfId <- decrypt cID
+      MaterialFile{materialFileMaterial} <- lift . lift $ get404 mfId
+      Material{materialName, materialCourse} <- lift . lift $ get404 materialFileMaterial
+      Course{courseTerm, courseSchool, courseShorthand} <- lift . lift $ get404 materialCourse
+      let newRoute = CMaterialR courseTerm courseSchool courseShorthand materialName (MVideoR cID)
+      tell . Any $ route /= newRoute
+      return newRoute

src/Handler/Course/Edit.hs

@@ -34,14 +34,14 @@ data CourseForm = CourseForm
         , cfShort       :: CourseShorthand
         , cfSchool      :: SchoolId
         , cfTerm        :: TermId
-        , cfDesc        :: Maybe Html
+        , cfDesc        :: Maybe StoredMarkup
-        , cfLink        :: Maybe Text
+        , cfLink        :: Maybe URI
         , cfVisFrom     :: Maybe UTCTime
         , cfVisTo       :: Maybe UTCTime
         , cfMatFree     :: Bool
         , cfAllocation  :: Maybe AllocationCourseForm
         , cfAppRequired         :: Bool
-        , cfAppInstructions     :: Maybe Html
+        , cfAppInstructions     :: Maybe StoredMarkup
         , cfAppInstructionFiles :: Maybe FileUploads
         , cfAppText             :: Bool
         , cfAppFiles            :: UploadMode
@@ -292,7 +292,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
       <*> areq termsField                     (fslI MsgCourseSemester)  (cfTerm       <$> template)
       <*> aopt htmlField (fslpI MsgCourseDescription (mr MsgCourseDescriptionPlaceholder))
                                                                         (cfDesc       <$> template)
-      <*> aopt (urlField & cfStrip) (fslpI MsgCourseHomepageExternal (mr MsgCourseHomepageExternalPlaceholder))
+      <*> aopt urlField (fslpI MsgCourseHomepageExternal (mr MsgCourseHomepageExternalPlaceholder))
                                                                         (cfLink       <$> template)
       <*> aopt utcTimeField   (fslpI MsgCourseVisibleFrom  (mr MsgDate)
             & setTooltip MsgCourseVisibleFromTip)                       (deepAlt (cfVisFrom    <$> template) newVisFrom)

src/Handler/Course/Events/Delete.hs

@@ -27,7 +27,8 @@ postCEvDeleteR tid ssh csh cID = do
       [whamlet|
         $newline never
         #{courseEventType}
-        , #{courseEventRoom}
+        $maybe room <- courseEventRoom
+          , #{roomReferenceText room}
         :
         ^{occurrencesWidget courseEventTime}
       |]

src/Handler/Course/Events/Edit.hs

@@ -23,6 +23,7 @@ postCEvEditR tid ssh csh cID = do
         { courseEventCourse
         , courseEventType = cefType
         , courseEventRoom = cefRoom
+        , courseEventRoomHidden = cefRoomHidden
         , courseEventTime = cefTime
         , courseEventNote = cefNote
         , courseEventLastChanged = now

src/Handler/Course/Events/Form.hs

@@ -13,9 +13,10 @@ import qualified Database.Esqueleto as E
 
 data CourseEventForm = CourseEventForm
   { cefType             :: CI Text
-  , cefRoom             :: Text
+  , cefRoom             :: Maybe RoomReference
+  , cefRoomHidden       :: Bool
   , cefTime             :: Occurrences
-  , cefNote             :: Maybe Html
+  , cefNote             :: Maybe StoredMarkup
   }
 
 courseEventForm :: Maybe CourseEventForm -> Form CourseEventForm
@@ -30,16 +31,17 @@ courseEventForm template = identifyForm FIDCourseEvent . renderWForm FormStandar
         return event
     )
   let courseEventTypes = optionsPairs [ (courseEventType, courseEventType) | Entity _ CourseEvent{..} <- existingEvents ]
-      courseEventRooms = optionsPairs [ (courseEventRoom, courseEventRoom) | Entity _ CourseEvent{..} <- existingEvents ]
 
   cefType' <- wreq (textField & cfStrip & cfCI & addDatalist courseEventTypes) (fslI MsgCourseEventType & addPlaceholder (mr MsgCourseEventTypePlaceholder)) (cefType <$> template)
-  cefRoom' <- wreq (textField & cfStrip & addDatalist courseEventRooms) (fslI MsgCourseEventRoom) (cefRoom <$> template)
+  cefRoom' <- aFormToWForm $ roomReferenceFormOpt (fslI MsgCourseEventRoom) (cefRoom <$> template)
+  cefRoomHidden' <- wpopt checkBoxField (fslI MsgCourseEventRoomHidden & setTooltip MsgCourseEventRoomHiddenTip) (cefRoomHidden <$> template)
   cefTime' <- aFormToWForm $ occurrencesAForm ("time" :: Text) (cefTime <$> template)
   cefNote' <- wopt htmlField (fslI MsgCourseEventNote) (cefNote <$> template)
 
   return $ CourseEventForm
     <$> cefType'
     <*> cefRoom'
+    <*> cefRoomHidden'
     <*> cefTime'
     <*> cefNote'
 
@@ -47,6 +49,7 @@ courseEventToForm :: CourseEvent -> CourseEventForm
 courseEventToForm CourseEvent{..} = CourseEventForm
   { cefType = courseEventType
   , cefRoom = courseEventRoom
+  , cefRoomHidden = courseEventRoomHidden
   , cefTime = courseEventTime
   , cefNote = courseEventNote
   }

src/Handler/Course/Events/New.hs

@@ -21,6 +21,7 @@ postCEventsNewR tid ssh csh = do
         { courseEventCourse      = cid
         , courseEventType        = cefType
         , courseEventRoom        = cefRoom
+        , courseEventRoomHidden  = cefRoomHidden
         , courseEventTime        = cefTime
         , courseEventNote        = cefNote
         , courseEventLastChanged = now

src/Handler/Course/List.hs

@@ -81,7 +81,12 @@ makeCourseTable whereClause colChoices psValidator = do
         return (course, participants, registered, school)
       lecturerQuery cid (user `E.InnerJoin` lecturer) = do
         E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser
-        E.where_ $ cid E.==. lecturer E.^. LecturerCourse E.&&. lecturer E.^. LecturerType E.==. E.val CourseLecturer
+        E.where_ $ cid E.==. lecturer E.^. LecturerCourse
+             E.&&. lecturer E.^. LecturerType E.==. E.val CourseLecturer
+        return user
+      isCourseAdminQuery cid (user `E.InnerJoin` lecturer) = do
+        E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser
+        E.where_ $ cid E.==. lecturer E.^. LecturerCourse
         return user
       isEditorQuery course user = E.where_ $ mayEditCourse' muid ata course
         E.&&. E.just (user E.^. UserId) E.==. E.val muid
@@ -135,8 +140,8 @@ makeCourseTable whereClause colChoices psValidator = do
         , ( "lecturer", FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) criterias -> if
                 | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
                 | otherwise          -> E.exists $ E.from $ \t -> do
-                  user <- lecturerQuery (course E.^. CourseId) t
+                  user <- isCourseAdminQuery (course E.^. CourseId) t
-                  E.where_ $ E.any (E.hasInfix (user E.^. UserSurname) . E.val) (criterias :: Set.Set Text)
+                  E.where_ $ E.any (E.hasInfix (user E.^. UserDisplayName) . E.val) (criterias :: Set.Set Text)
           )
         , ( "openregistration", FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) criterion -> case getLast (criterion :: Last Bool) of
               Nothing -> E.val True
@@ -167,7 +172,7 @@ makeCourseTable whereClause colChoices psValidator = do
               Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
               Just needle -> (E.castString (course E.^. CourseName) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
                        E.||. (E.castString (course E.^. CourseShorthand) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
-                       E.||. (E.castString (course E.^. CourseDescription) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
+                       E.||. (E.maybe (E.val mempty) (E.castString . esqueletoMarkupOutput) (course E.^. CourseDescription) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
           )
         ]
     , dbtFilterUI = \mPrev -> mconcat $ catMaybes

src/Handler/Course/News/Form.hs

@@ -12,8 +12,8 @@ import qualified Data.Conduit.List as C
 
 data CourseNewsForm = CourseNewsForm
   { cnfTitle            :: Maybe Text
-  , cnfSummary          :: Maybe Html
+  , cnfSummary          :: Maybe StoredMarkup
-  , cnfContent          :: Html
+  , cnfContent          :: StoredMarkup
   , cnfParticipantsOnly :: Bool
   , cnfVisibleFrom      :: Maybe UTCTime
   , cnfFiles            :: Maybe FileUploads

src/Handler/Course/Show.hs

@@ -8,14 +8,16 @@ import Import
 import Utils.Course
 import Utils.Form
 import Handler.Utils
-import qualified Database.Esqueleto.Utils as E
+import Handler.Utils.Course
-import Database.Esqueleto.Utils.TH
+import Handler.Utils.Tutorial
 
 import qualified Data.CaseInsensitive as CI
 
 import qualified Data.Map as Map
 
 import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Utils as E
+import Database.Esqueleto.Utils.TH
 
 import Handler.Course.Register
 
@@ -28,7 +30,7 @@ getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 getCShowR tid ssh csh = do
   mbAid <- maybeAuthId
   now <- liftIO getCurrentTime
-  (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mayReRegister) <- runDB . maybeT notFound $ do
+  (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mayReRegister,(mayViewSheets, mayViewAnySheet), (mayViewMaterials, mayViewAnyMaterial)) <- runDB . maybeT notFound $ do
     [(E.Entity cid course, E.Value courseVisible, E.Value schoolName, E.Value participants, fmap entityVal -> registration, E.Value hasAllocationRegistrationOpen)]
        <- lift . E.select . E.from $
          \((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do
@@ -90,10 +92,13 @@ getCShowR tid ssh csh = do
       lastEditText <- formatTime SelFormatDateTime $ maybe id max (guardOn visible =<< courseNewsVisibleFrom) courseNewsLastEdit
       mayEditNews <- hasWriteAccessTo $ CNewsR tid ssh csh cID CNEditR
       mayDelete <- hasWriteAccessTo $ CNewsR tid ssh csh cID CNDeleteR
+
       return (cID, n, visible, files, lastEditText, mayEditNews, mayDelete)
 
-    events' <- fmap (sortOn $ courseEventTime . entityVal) . lift $ selectList [ CourseEventCourse ==. cid ] []
+    events' <- fmap (sortOn $ courseEventTime . entityVal . view _1) . lift . E.select . E.from $ \courseEvent -> do
-    events <- mapM (\(Entity evId ev) -> (, ev) <$> encrypt evId) events'
+      E.where_ $ courseEvent E.^. CourseEventCourse E.==. E.val cid
+      return (courseEvent, maybe E.false (flip showCourseEventRoom courseEvent . E.val) mbAid)
+    events <- mapM (\(Entity evId ev, E.Value showRoom) -> (, ev, showRoom) <$> encrypt evId) events'
 
     hasSubmissionGroups <- lift . E.selectExists . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup) -> do
       E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
@@ -108,7 +113,19 @@ getCShowR tid ssh csh = do
 
     mayReRegister <- lift . courseMayReRegister $ Entity cid course
 
-    return (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mayReRegister)
+    mayViewSheets <- hasReadAccessTo $ CourseR tid ssh csh SheetListR
+    sheets <- lift . E.select . E.from $ \sheet -> do
+      E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
+      return $ sheet E.^. SheetName
+    mayViewAnySheet <- anyM sheets $ \(E.Value shn) -> hasReadAccessTo $ CSheetR tid ssh csh shn SShowR
+
+    mayViewMaterials <- hasReadAccessTo $ CourseR tid ssh csh MaterialListR
+    materials <- lift . E.select . E.from $ \material -> do
+      E.where_ $ material E.^. MaterialCourse E.==. E.val cid
+      return $ material E.^. MaterialName
+    mayViewAnyMaterial <- anyM materials $ \(E.Value mnm) -> hasReadAccessTo $ CMaterialR tid ssh csh mnm MShowR
+
+    return (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mayReRegister, (mayViewSheets, mayViewAnySheet), (mayViewMaterials, mayViewAnyMaterial))
 
   let mDereg' = maybe id min (allocationOverrideDeregister =<< mAllocation) <$> courseDeregisterUntil course
   mDereg <- traverse (formatTime SelFormatDateTime) mDereg'
@@ -134,15 +151,19 @@ getCShowR tid ssh csh = do
   let
     tutorialDBTable = DBTable{..}
       where
+        resultTutorial :: Lens' (DBRow (Entity Tutorial, Bool)) (Entity Tutorial)
+        resultTutorial = _dbrOutput . _1
+        resultShowRoom = _dbrOutput . _2
+        
         dbtSQLQuery tutorial = do
           E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
-          return tutorial
+          return (tutorial, maybe E.false (flip showTutorialRoom tutorial . E.val) mbAid)
         dbtRowKey = (E.^. TutorialId)
-        dbtProj = return
+        dbtProj = traverse $ return . over _2 E.unValue
         dbtColonnade = dbColonnade $ mconcat
-          [ sortable (Just "type") (i18nCell MsgTutorialType) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> textCell $ CI.original tutorialType
+          [ sortable (Just "type") (i18nCell MsgTutorialType) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> textCell $ CI.original tutorialType
-          , sortable (Just "name") (i18nCell MsgTutorialName) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> indicatorCell <> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) [whamlet|#{tutorialName}|]
+          , sortable (Just "name") (i18nCell MsgTutorialName) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> indicatorCell <> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) [whamlet|#{tutorialName}|]
-          , sortable (Just "tutors") (i18nCell MsgTutorialTutors) $ \DBRow{ dbrOutput = Entity tutid _ } -> sqlCell $ do
+          , sortable (Just "tutors") (i18nCell MsgTutorialTutors) $ \(view $ resultTutorial . _entityKey -> tutid) -> sqlCell $ do
               tutTutors <- 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
@@ -154,12 +175,14 @@ getCShowR tid ssh csh = do
                            <li>
                              ^{nameEmailWidget' tutor}
                      |]
-          , sortable (Just "room") (i18nCell MsgTutorialRoom) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> maybe mempty textCell tutorialRoom
+          , sortable (Just "room") (i18nCell MsgTutorialRoom) $ \res -> if
-          , sortable Nothing (i18nCell MsgTutorialTime) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> occurrencesCell tutorialTime
+              | res ^. resultShowRoom -> maybe (i18nCell MsgTutorialRoomIsUnset) roomReferenceCell $ views (resultTutorial . _entityVal) tutorialRoom res
-          , sortable (Just "register-from") (i18nCell MsgTutorialRegisterFrom) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> maybeDateTimeCell tutorialRegisterFrom
+              | otherwise -> i18nCell MsgTutorialRoomIsHidden & addCellClass ("explanation" :: Text)
-          , sortable (Just "register-to") (i18nCell MsgTutorialRegisterTo) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> maybeDateTimeCell tutorialRegisterTo
+          , sortable Nothing (i18nCell MsgTutorialTime) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> occurrencesCell tutorialTime
-          , sortable (Just "deregister-until") (i18nCell MsgTutorialDeregisterUntil) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> maybeDateTimeCell tutorialDeregisterUntil
+          , sortable (Just "register-from") (i18nCell MsgTutorialRegisterFrom) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybeDateTimeCell tutorialRegisterFrom
-          , sortable Nothing (i18nCell MsgTutorialFreeCapacity) $ \DBRow{ dbrOutput = Entity tutid Tutorial{..} } -> case tutorialCapacity of
+          , sortable (Just "register-to") (i18nCell MsgTutorialRegisterTo) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybeDateTimeCell tutorialRegisterTo
+          , sortable (Just "deregister-until") (i18nCell MsgTutorialDeregisterUntil) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybeDateTimeCell tutorialDeregisterUntil
+          , sortable Nothing (i18nCell MsgTutorialFreeCapacity) $ \(view resultTutorial -> Entity tutid Tutorial{..}) -> case tutorialCapacity of
               Nothing -> mempty
               Just tutorialCapacity' -> sqlCell $ do
                 freeCapacity <- fmap (maybe 0 (max 0 . E.unValue) . listToMaybe)
@@ -168,7 +191,7 @@ getCShowR tid ssh csh = do
                                      E.where_ $ participant E.^. TutorialParticipantTutorial E.==. E.val tutid
                                 in return $ E.val tutorialCapacity' E.-. numParticipants
                 return . toWidget $ tshow freeCapacity
-          , sortable Nothing (mempty & cellAttrs <>~ pure ("uw-hide-columns--hider-label", mr MsgActionsHead)) $ \DBRow{ dbrOutput = Entity tutId Tutorial{..} } -> sqlCell $ do
+          , sortable Nothing (mempty & cellAttrs <>~ pure ("uw-hide-columns--hider-label", mr MsgActionsHead)) $ \(view resultTutorial -> Entity tutId Tutorial{..}) -> sqlCell $ do
               mayRegister <- (== Authorized) <$> evalAccessDB (CTutorialR tid ssh csh tutorialName TRegisterR) True
               isRegistered <- case mbAid of
                 Nothing  -> return False
@@ -219,7 +242,7 @@ getCShowR tid ssh csh = do
         , length fs <= 3
         , all (notElem pathSeparator . view _2) fs
         ]
-      hiddenEventNotes = all (\(_,CourseEvent{..}) -> is _Nothing courseEventNote) events
+      hiddenEventNotes = all (\(_,CourseEvent{..},_) -> is _Nothing courseEventNote) events
       Course{courseVisibleFrom,courseVisibleTo} = course
   mayCreateNews <- hasWriteAccessTo $ CourseR tid ssh csh CNewsNewR
   mayCreateEvents <- hasWriteAccessTo $ CourseR tid ssh csh CEventsNewR

src/Handler/Course/User.hs

@@ -29,6 +29,7 @@ import qualified Data.Text as Text
 import qualified Data.CaseInsensitive as CI
 
 import qualified Data.Conduit.Combinators as C
+import qualified Data.Text.Lazy as LT
 
 
 data ExamAction = ExamDeregister
@@ -226,7 +227,7 @@ courseUserNoteSection (Entity cid Course{..}) (Entity uid _) = do
         maybeM (return ()) (\nk -> deleteWhere [CourseUserNoteEditNote ==. nk]) (getKeyBy thisUniqueNote)
         deleteBy thisUniqueNote
         addMessageI Info MsgCourseUserNoteDeleted
-      _ | (renderHtml <$> mbNote) == (renderHtml <$> noteText) -> return () -- no changes
+      _ | ((==) `on` fmap (LT.strip . renderHtml . markupOutput)) mbNote noteText -> return () -- no changes
       (Just note) -> do
         dozentId <- requireAuthId
         (Entity noteKey _) <- upsertBy thisUniqueNote (CourseUserNote cid uid note) [CourseUserNoteNote =. note]
@@ -459,7 +460,7 @@ courseUserTutorialsSection (Entity cid Course{..}) (Entity uid _) = do
                     <li>
                       ^{nameEmailWidget userEmail userDisplayName userSurname}
               |]
-          , sortable (Just "room") (i18nCell MsgTutorialRoom) $ maybe mempty textCell . view (_dbrOutput . _1 . _entityVal . _tutorialRoom)
+          , sortable (Just "room") (i18nCell MsgTutorialRoom) $ maybe (i18nCell MsgTutorialRoomIsUnset) roomReferenceCell . view (_dbrOutput . _1 . _entityVal . _tutorialRoom)
           , sortable Nothing (i18nCell MsgTutorialTime) $ occurrencesCell . view (_dbrOutput . _1 . _entityVal . _tutorialTime)
           ]
         dbtSorting = mconcat

src/Handler/Course/Users.hs

@@ -174,7 +174,7 @@ data UserTableCsv = UserTableCsv
   , csvUserStudyFeatures :: UserTableStudyFeatures
   , csvUserSubmissionGroup :: Maybe SubmissionGroupName
   , csvUserRegistration :: UTCTime
-  , csvUserNote :: Maybe Html
+  , csvUserNote :: Maybe StoredMarkup
   , csvUserTutorials :: ([TutorialName], Map (CI Text) (Maybe TutorialName))
   , csvUserExams :: [ExamName]
   , csvUserSheets :: Map SheetName (SheetType, Maybe Points)

src/Handler/Exam/Edit.hs

@@ -20,10 +20,11 @@ getEEditR = postEEditR
 postEEditR tid ssh csh examn = do
   (template, (editExamAct, (editExamWidget, editExamEnctype))) <- runDBJobs $ do
     (cid, exam@(Entity eId oldExam)) <- fetchCourseIdExam tid ssh csh examn
+    course <- getEntity404 cid
 
     template <- examFormTemplate exam
 
-    ((editExamResult, editExamWidget), editExamEnctype) <- runFormPost . validateForm (validateExam cid $ Just exam) . examForm $ Just template
+    ((editExamResult, editExamWidget), editExamEnctype) <- runFormPost . validateForm (validateExam cid $ Just exam) . examForm course $ Just template
 
     editExamAct <- formResultMaybe editExamResult $ \ExamForm{..} -> do
       insertRes <- myReplaceUnique eId Exam
@@ -58,6 +59,7 @@ postEEditR tid ssh csh examn = do
               { examOccurrenceExam = eId
               , examOccurrenceName = eofName
               , examOccurrenceRoom = eofRoom
+              , examOccurrenceRoomHidden = eofRoomHidden
               , examOccurrenceCapacity = eofCapacity
               , examOccurrenceStart = eofStart
               , examOccurrenceEnd = eofEnd
@@ -72,6 +74,7 @@ postEEditR tid ssh csh examn = do
               { examOccurrenceExam = eId
               , examOccurrenceName = eofName
               , examOccurrenceRoom = eofRoom
+              , examOccurrenceRoomHidden = eofRoomHidden
               , examOccurrenceCapacity = eofCapacity
               , examOccurrenceStart = eofStart
               , examOccurrenceEnd = eofEnd

src/Handler/Exam/Form.hs

@@ -22,12 +22,14 @@ import qualified Database.Esqueleto as E
 import qualified Database.Esqueleto.Utils as E
 
 import qualified Control.Monad.State.Class as State
-import Text.Blaze.Html.Renderer.String (renderHtml)
+import Text.Blaze.Html.Renderer.Text (renderHtml)
+
+import qualified Data.Text.Lazy as LT
 
 
 data ExamForm = ExamForm
   { efName :: ExamName
-  , efDescription :: Maybe Html
+  , efDescription :: Maybe StoredMarkup
   , efStart :: Maybe UTCTime
   , efEnd :: Maybe UTCTime
   , efVisibleFrom :: Maybe UTCTime
@@ -52,12 +54,13 @@ data ExamForm = ExamForm
 data ExamOccurrenceForm = ExamOccurrenceForm
   { eofId :: Maybe CryptoUUIDExamOccurrence
   , eofName :: ExamOccurrenceName
-  , eofRoom :: Text
+  , eofRoom :: Maybe RoomReference
+  , eofRoomHidden :: Bool
   , eofCapacity :: Natural
   , eofStart :: UTCTime
   , eofEnd :: Maybe UTCTime
-  , eofDescription :: Maybe Html
+  , eofDescription :: Maybe StoredMarkup
-  } deriving (Read, Show, Eq, Generic, Typeable)
+  } deriving (Show, Eq, Generic, Typeable)
 
 instance Ord ExamOccurrenceForm where
   compare = mconcat
@@ -67,6 +70,7 @@ instance Ord ExamOccurrenceForm where
     , comparing eofEnd
     , comparing eofCapacity
     , comparing eofDescription
+    , comparing eofRoomHidden
     , comparing eofId
     ]
 
@@ -101,9 +105,10 @@ deriveJSON defaultOptions
 examForm :: ( MonadHandler m
             , HandlerSite m ~ UniWorX
             )
-         => Maybe ExamForm -> (Html -> MForm m (FormResult ExamForm, Widget))
+         => Entity Course -> Maybe ExamForm -> (Html -> MForm m (FormResult ExamForm, Widget))
-examForm template csrf = hoist liftHandler $ do
+examForm (Entity _ Course{..}) template csrf = hoist liftHandler $ do
   MsgRenderer mr <- getMsgRenderer
+  School{..} <- liftHandler . runDBRead $ getJust courseSchool
 
   flip (renderAForm FormStandard) csrf $ ExamForm
     <$> areq ciField (fslpI MsgExamName (mr MsgExamName) & setTooltip MsgExamNameTip) (efName <$> template)
@@ -116,7 +121,7 @@ examForm template csrf = hoist liftHandler $ do
     <*> aopt utcTimeField (fslpI MsgExamRegisterTo (mr MsgDate)) (efRegisterTo <$> template)
     <*> aopt utcTimeField (fslpI MsgExamDeregisterUntil (mr MsgDate)) (efDeregisterUntil <$> template)
     <*> aopt utcTimeField (fslpI MsgExamPublishOccurrenceAssignments (mr MsgDate) & setTooltip MsgExamPublishOccurrenceAssignmentsTip) (efPublishOccurrenceAssignments <$> template)
-    <*> aopt utcTimeField (fslpI MsgExamFinished (mr MsgDate) & setTooltip MsgExamFinishedTip) (efFinished <$> template)
+    <*> aopt utcTimeField (fslpI MsgExamFinished (mr MsgDate) & setTooltip (bool MsgExamFinishedTip MsgExamFinishedTipCloseOnFinished $ is _ExamCloseOnFinished' schoolExamCloseMode)) (efFinished <$> template)
     <*  aformSection MsgExamFormOccurrences
     <*> examOccurrenceForm (efOccurrences <$> template)
     <*  aformSection MsgExamFormAutomaticFunctions
@@ -218,20 +223,25 @@ examOccurrenceForm prev = wFormToAForm $ do
     examOccurrenceForm' nudge mPrev csrf = do
       (eofIdRes, eofIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ eofId =<< mPrev)
       (eofNameRes, eofNameView) <- mpreq (textField & cfStrip & cfCI) (fslI MsgExamRoomName & addName (nudge "name")) (eofName <$> mPrev)
-      (eofRoomRes, eofRoomView) <- mpreq (textField & cfStrip) (fslI MsgExamRoomRoom & addName (nudge "room")) (eofRoom <$> mPrev)
+      (eofRoomRes', eofRoomView) <- ($ mempty) . renderAForm FormVertical $ (,)
+        <$> roomReferenceFormOpt (fslI MsgExamRoomRoom & addName (nudge "room")) (eofRoom <$> mPrev)
+        <*> apopt checkBoxField (fslI MsgExamRoomRoomHidden & setTooltip MsgExamRoomRoomHiddenTip & addName (nudge "room-hidden")) (eofRoomHidden <$> mPrev)
+      let eofRoomRes = view _1 <$> eofRoomRes'
+          eofRoomHiddenRes = view _2 <$> eofRoomRes'
       (eofCapacityRes, eofCapacityView) <- mpreq (natFieldI MsgExamRoomCapacityNegative) (fslI MsgExamRoomCapacity & addName (nudge "capacity")) (eofCapacity <$> mPrev)
       (eofStartRes, eofStartView) <- mpreq utcTimeField (fslI MsgExamRoomStart & addName (nudge "start")) (eofStart <$> mPrev)
       (eofEndRes, eofEndView) <- mopt utcTimeField (fslI MsgExamRoomEnd & addName (nudge "end")) (eofEnd <$> mPrev)
-      (eofDescRes, eofDescView) <- mopt htmlFieldSmall (fslI MsgExamRoomDescription & addName (nudge "description")) (eofDescription <$> mPrev)
+      (eofDescRes, eofDescView) <- mopt htmlField (fslI MsgExamRoomDescription & addName (nudge "description")) (eofDescription <$> mPrev)
 
       return ( ExamOccurrenceForm
                  <$> eofIdRes
                  <*> eofNameRes
                  <*> eofRoomRes
+                 <*> eofRoomHiddenRes
                  <*> eofCapacityRes
                  <*> eofStartRes
                  <*> eofEndRes
-                 <*> (assertM (not . null . renderHtml) <$> eofDescRes)
+                 <*> eofDescRes
              , $(widgetFile "widgets/massinput/examRooms/form")
              )
 
@@ -324,6 +334,7 @@ examFormTemplate (Entity eId Exam{..}) = do
           { eofId
           , eofName        = examOccurrenceName
           , eofRoom        = examOccurrenceRoom
+          , eofRoomHidden  = examOccurrenceRoomHidden
           , eofCapacity    = examOccurrenceCapacity
           , eofStart       = examOccurrenceStart
           , eofEnd         = examOccurrenceEnd
@@ -426,11 +437,12 @@ validateExam cId oldExam = do
   forM_ [ (a, b) | a <- Set.toAscList efOccurrences, b <- Set.toAscList efOccurrences, b > a ] $ \(a, b) -> do
     eofRange' <- formatTimeRange SelFormatDateTime (eofStart a) (eofEnd a)
 
-    guardValidation (MsgExamOccurrenceDuplicate (eofRoom a) eofRange') $ any (\f -> f a b)
+    MsgRenderer mr <- getMsgRenderer
+    guardValidation (MsgExamOccurrenceDuplicate (maybe (mr MsgExamOccurrenceRoomIsUnset) roomReferenceText $ eofRoom a) eofRange') $ any (\f -> f a b)
       [ (/=) `on` eofRoom
       , (/=) `on` eofStart
       , (/=) `on` eofEnd
-      , (/=) `on` fmap renderHtml . eofDescription
+      , (/=) `on` fmap (LT.strip . renderHtml . markupOutput) . eofDescription
       ]
 
     guardValidation (MsgExamOccurrenceDuplicateName $ eofName a) $ ((/=) `on` eofName) a b

src/Handler/Exam/New.hs

@@ -21,9 +21,10 @@ getCExamNewR = postCExamNewR
 postCExamNewR tid ssh csh = do
   (newExamAct, (newExamWidget, newExamEnctype)) <- runDBJobs $ do
     cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
+    course <- getEntity404 cid
     template <- examTemplate cid
 
-    ((newExamResult, newExamWidget), newExamEnctype) <- runFormPost . validateForm (validateExam cid Nothing) $ examForm template
+    ((newExamResult, newExamWidget), newExamEnctype) <- runFormPost . validateForm (validateExam cid Nothing) $ examForm course template
 
     newExamAct <- formResultMaybe newExamResult $ \ExamForm{..} -> do
       now <- liftIO getCurrentTime
@@ -67,6 +68,7 @@ postCExamNewR tid ssh csh = do
           , let examOccurrenceExam        = examid
                 examOccurrenceName        = eofName
                 examOccurrenceRoom        = eofRoom
+                examOccurrenceRoomHidden  = eofRoomHidden
                 examOccurrenceCapacity    = eofCapacity
                 examOccurrenceStart       = eofStart
                 examOccurrenceEnd         = eofEnd

src/Handler/Exam/Show.hs

@@ -66,20 +66,20 @@ getEShowR tid ssh csh examn = do
               E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eId
                    E.&&. examRegistration E.^. ExamRegistrationOccurrence E.==. E.just (examOccurrence E.^. ExamOccurrenceId)
       E.orderBy [E.desc registered, E.asc $ examOccurrence E.^. ExamOccurrenceStart, E.asc $ examOccurrence E.^. ExamOccurrenceRoom]
-      return (examOccurrence, registered, registeredCount)
+      return (examOccurrence, registered, registeredCount, maybe E.false (flip showExamOccurrenceRoom examOccurrence . E.val) mUid)
 
     registeredCount <- fromIntegral <$> count [ ExamRegistrationExam ==. eId ]
 
     registered <- for mUid $ getBy . UniqueExamRegistration eId
     mayRegister <- if
-      | examOccurrenceRule == ExamRoomFifo -> anyM occurrencesRaw $ \(Entity _ ExamOccurrence{..}, _, _) ->
+      | examOccurrenceRule == ExamRoomFifo -> anyM occurrencesRaw $ \(Entity _ ExamOccurrence{..}, _, _, _) ->
           hasWriteAccessTo . CExamR tid ssh csh examName $ ERegisterOccR examOccurrenceName
       | otherwise -> hasWriteAccessTo $ CExamR tid ssh csh examName ERegisterR
 
-    let occurrences = sortOn sortPred $ map (over _3 E.unValue . over _2 E.unValue) occurrencesRaw
+    let occurrences = sortOn sortPred $ map (over _4 E.unValue . over _3 E.unValue . over _2 E.unValue) occurrencesRaw
           where
-            sortPred (Entity _ ExamOccurrence{..}, registered', _)
+            sortPred (Entity _ ExamOccurrence{..}, registered', _, showRoom)
-              = (Down $ registered' && not mayRegister, examOccurrenceStart, examOccurrenceRoom)
+              = (Down $ registered' && not mayRegister, examOccurrenceStart, guardOn @Maybe showRoom examOccurrenceRoom)
 
     lecturerInfoShown <- hasReadAccessTo $ CExamR tid ssh csh examn EEditR
 
@@ -94,7 +94,7 @@ getEShowR tid ssh csh examn = do
 
   let occurrenceNamesShown = lecturerInfoShown
       partNumbersShown = lecturerInfoShown
-      examClosedShown = lecturerInfoShown
+      examClosedShown = lecturerInfoShown && isn't _ExamCloseOnFinished' schoolExamCloseMode
       showCloseWidget = lecturerInfoShown
       showAutoOccurrenceCalculateWidget = lecturerInfoShown
       showRegisteredCount = lecturerInfoShown
@@ -118,14 +118,15 @@ getEShowR tid ssh csh examn = do
   mayRegister' <- fmap ((Map.!) . Map.fromList) . for (Nothing : map Just occurrences) $ \case
     Nothing ->
       fmap (Nothing, ) . hasWriteAccessTo $ CExamR tid ssh csh examName ERegisterR
-    Just (Entity occId ExamOccurrence{..}, _, _) ->
+    Just (Entity occId ExamOccurrence{..}, _, _, _) ->
       fmap (Just occId, ) . hasWriteAccessTo . CExamR tid ssh csh examName $ ERegisterOccR examOccurrenceName
 
-  let examTimes = all (\(Entity _ ExamOccurrence{..}, _, _) -> Just examOccurrenceStart == examStart && examOccurrenceEnd == examEnd) occurrences
+  let examTimes = all (\(Entity _ ExamOccurrence{..}, _, _, _) -> Just examOccurrenceStart == examStart && examOccurrenceEnd == examEnd) occurrences
       examRoom = do
-        Entity _ primeOcc <- occurrences ^? _head . _1
+        (Entity _ primeOcc, _, _, _) <- occurrences ^? _head
-        guard $ all (\(Entity _ occ, _, _) -> examOccurrenceRoom occ == examOccurrenceRoom primeOcc) occurrences
+        guard $ all (\(Entity _ occ, _, _, _) -> examOccurrenceRoom occ == examOccurrenceRoom primeOcc) occurrences
-        return $ examOccurrenceRoom primeOcc
+        guard $ andOf (folded . _4) occurrences
+        examOccurrenceRoom primeOcc
       registerWidget mOcc
         | isRegistered <- is _Just $ join registered
         , examOccurrenceRule /= ExamRoomFifo || (isRegistered && not (orOf (folded . _2) occurrences))

src/Handler/Exam/Users.hs

@@ -181,7 +181,7 @@ data ExamUserTableCsv = ExamUserTableCsv
   , csvEUserBonus :: Maybe (Maybe Points)
   , csvEUserExamPartResults :: Map ExamPartNumber (Maybe ExamResultPoints)
   , csvEUserExamResult :: Maybe ExamResultPassedGrade
-  , csvEUserCourseNote :: Maybe Html
+  , csvEUserCourseNote :: Maybe StoredMarkup
   }
   deriving (Generic)
 makeLenses_ ''ExamUserTableCsv
@@ -345,7 +345,7 @@ data ExamUserCsvAction
     }
   | ExamUserCsvSetCourseNoteData
     { examUserCsvActUser :: UserId
-    , examUserCsvActCourseNote :: Maybe Html
+    , examUserCsvActCourseNote :: Maybe StoredMarkup
     }
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
 deriveJSON defaultOptions

src/Handler/ExamOffice/Exam.hs

@@ -39,30 +39,44 @@ instance Button UniWorX ButtonCloseExam where
 
 examCloseWidget :: SomeRoute UniWorX -> ExamId -> Handler Widget
 examCloseWidget dest eId = do
-  Exam{..} <- runDB $ get404 eId
+  (Exam{..}, School{..})  <- runDB $ do
+    exam@Exam{..} <- get404 eId
+    Course{..} <- get404 examCourse
+    school <- get404 courseSchool
+    return (exam, school)
 
-  ((closeRes, closeView), closeEnc) <- runFormPost $ identifyForm BtnCloseExam buttonForm
+  let closeTime = case (examClosed, examFinished) of
+        (mClose, Just finish)
+          | isn't _ExamCloseSeparate schoolExamCloseMode -> Just $ maybe id min mClose finish
+        (Just close, _)
+          | is _ExamCloseSeparate schoolExamCloseMode -> Just close
+        _other -> Nothing
 
-  formResult closeRes $ \case
+  examClosedStr <- for closeTime $ formatTime SelFormatDateTime
-    BtnCloseExam -> do
-      now <- liftIO getCurrentTime
 
-      unless (is _Nothing examClosed) $
+  if | is _ExamCloseOnFinished' schoolExamCloseMode
-        invalidArgs ["Exam is already closed"]
+       -> return $(widgetFile "widgets/exam-close-on-finished")
+     | otherwise -> do
+         ((closeRes, closeView'), closeEnc) <- runFormPost $ identifyForm BtnCloseExam buttonForm
 
-      runDB $ update eId [ ExamClosed =. Just now ]
+         formResult closeRes $ \case
-      addMessageI Success MsgExamDidClose
+           BtnCloseExam -> do
-      redirect dest
+             now <- liftIO getCurrentTime
 
-  let closeView' = wrapForm closeView def
+             unless (is _Nothing examClosed) $
-        { formSubmit   = FormNoSubmit
+               invalidArgs ["Exam is already closed"]
-        , formAction   = Just dest
-        , formEncoding = closeEnc
-        }
 
-  examClosed' <- for examClosed $ formatTime SelFormatDateTime
+             runDB $ update eId [ ExamClosed =. Just now ]
+             addMessageI Success MsgExamDidClose
+             redirect dest
 
-  return $(widgetFile "widgets/exam-close")
+         let closeView = wrapForm closeView' def
+               { formSubmit   = FormNoSubmit
+               , formAction   = Just dest
+               , formEncoding = closeEnc
+               }
+
+         return $(widgetFile "widgets/exam-close")
 
 
 type ExamUserTableExpr = (              E.SqlExpr (Entity ExamResult)

src/Handler/ExamOffice/Exams.hs

@@ -18,18 +18,22 @@ import qualified Colonnade
 
 type ExamsTableExpr = (               E.SqlExpr (Maybe (Entity Exam))
                         `E.InnerJoin` E.SqlExpr (Maybe (Entity Course))
+                        `E.InnerJoin` E.SqlExpr (Maybe (Entity School))
                       )
     `E.FullOuterJoin` E.SqlExpr (Maybe (Entity ExternalExam))
 
-type ExamsTableData = DBRow ( Either (Entity ExternalExam) (Entity Exam, Entity Course)
+type ExamsTableData = DBRow ( Either (Entity ExternalExam) (Entity Exam, Entity Course, Entity School)
                             , Natural, Natural
                             )
 
 queryExam :: Getter ExamsTableExpr (E.SqlExpr (Maybe (Entity Exam)))
-queryExam = to $ $(E.sqlIJproj 2 1) . $(E.sqlFOJproj 2 1)
+queryExam = to $ $(E.sqlIJproj 3 1) . $(E.sqlFOJproj 2 1)
 
 queryCourse :: Getter ExamsTableExpr (E.SqlExpr (Maybe (Entity Course)))
-queryCourse = to $ $(E.sqlIJproj 2 2) . $(E.sqlFOJproj 2 1)
+queryCourse = to $ $(E.sqlIJproj 3 2) . $(E.sqlFOJproj 2 1)
+  
+querySchool :: Getter ExamsTableExpr (E.SqlExpr (Maybe (Entity School)))
+querySchool = to $ $(E.sqlIJproj 3 3) . $(E.sqlFOJproj 2 1)
 
 queryExternalExam :: Getter ExamsTableExpr (E.SqlExpr (Maybe (Entity ExternalExam)))
 queryExternalExam = to $(E.sqlFOJproj 2 2)
@@ -66,6 +70,7 @@ queryIsSynced :: UTCTime -> E.SqlExpr (E.Value UserId) -> Getter ExamsTableExpr
 queryIsSynced now office = to . runReader $ do
   exam' <- view queryExam
   externalExam' <- view queryExternalExam
+  school' <- view querySchool
   let
     examSynchronised examId = E.not_ . E.exists . E.from $ \examResult -> do
       E.where_ $ examResult E.^. ExamResultExam E.==. examId
@@ -75,8 +80,11 @@ queryIsSynced now office = to . runReader $ do
       E.where_ $ externalExamResult E.^. ExternalExamResultExam E.==. externalExamId
       E.where_ $ ExternalExam.examOfficeExternalExamResultAuth office externalExamResult
       E.where_ . E.not_ $ ExternalExam.resultIsSynced office externalExamResult
-    open examClosed' = E.maybe E.true (E.>. E.val now) examClosed'
+    open examClosed' examFinished'
-  return $ E.maybe E.false examSynchronised (exam' E.?. ExamId) E.||. E.maybe E.false open (exam' E.?. ExamClosed) E.||. E.maybe E.false externalExamSynchronised (externalExam' E.?. ExternalExamId)
+      = E.bool (E.maybe E.true (E.>. E.val now) $ E.min examClosed' examFinished')
+               (E.maybe E.true (E.>. E.val now) examClosed')
+               (E.maybe E.false (E.==. E.val ExamCloseSeparate) (school' E.?. SchoolExamCloseMode))
+  return $ E.maybe E.false examSynchronised (exam' E.?. ExamId) E.||. E.maybe2 E.false open (exam' E.?. ExamClosed) (exam' E.?. ExamFinished) E.||. E.maybe E.false externalExamSynchronised (externalExam' E.?. ExternalExamId)
 
 
 resultExam :: Traversal' ExamsTableData (Entity Exam)
@@ -85,6 +93,9 @@ resultExam = _dbrOutput . _1 . _Right . _1
 resultCourse :: Traversal' ExamsTableData (Entity Course)
 resultCourse = _dbrOutput . _1 . _Right . _2
 
+resultSchool :: Traversal' ExamsTableData (Entity School)
+resultSchool = _dbrOutput . _1 . _Right . _3
+
 resultExternalExam :: Traversal' ExamsTableData (Entity ExternalExam)
 resultExternalExam = _dbrOutput . _1 . _Left
 
@@ -126,6 +137,7 @@ getEOExamsR = do
           dbtSQLQuery = runReaderT $ do
             exam <- view queryExam
             course <- view queryCourse
+            school <- view querySchool
             externalExam <- view queryExternalExam
 
             synchronised <- view querySynchronised'
@@ -133,35 +145,41 @@ getEOExamsR = do
 
             lift $ do
               E.on   E.false
+              E.on $ school E.?. SchoolId E.==. course E.?. CourseSchool
               E.on $ exam E.?. ExamCourse E.==. course E.?. CourseId
 
               E.where_ $ results E.>. E.val 0
               E.where_ $ (E.not_ (E.isNothing $ exam E.?. ExamId) E.&&. E.not_ (E.isNothing $ course E.?. CourseId) E.&&.         E.isNothing  (externalExam E.?. ExternalExamId))
                    E.||. (        E.isNothing  (exam E.?. ExamId) E.&&.         E.isNothing  (course E.?. CourseId) E.&&. E.not_ (E.isNothing $ externalExam E.?. ExternalExamId))
 
-            return (exam, course, externalExam, synchronised, results)
+            return (exam, course, school, externalExam, synchronised, results)
           dbtRowKey = views ($(multifocusG 2) queryExam queryExternalExam) (bimap (E.?. ExamId) (E.?. ExternalExamId))
 
           dbtProj :: DBRow _ -> DB ExamsTableData
           dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $ do
             exam <- view _1
             course <- view _2
-            externalExam <- view _3
+            school <- view _3
+            externalExam <- view _4
 
-            case (exam, course, externalExam) of
+            case (exam, course, school, externalExam) of
-              (Just exam', Just course', Nothing) ->
+              (Just exam', Just course', Just school', Nothing) ->
-                (Right (exam', course'),,) <$> view (_4 . _Value) <*> view (_5 . _Value)
+                (Right (exam', course', school'),,) <$> view (_5 . _Value) <*> view (_6 . _Value)
-              (Nothing, Nothing, Just externalExam') ->
+              (Nothing, Nothing, Nothing, Just externalExam') ->
-                (Left externalExam',,) <$> view (_4 . _Value) <*> view (_5 . _Value)
+                (Left externalExam',,) <$> view (_5 . _Value) <*> view (_6 . _Value)
               _other -> return $ error "Got exam & externalExam in same result"
 
 
           colSynced = Colonnade.singleton (fromSortable . Sortable (Just "synced") $ i18nCell MsgExamSynchronised) $ \x -> flip runReader x $ do
             mExam <- preview resultExam
+            mSchool <- preview resultSchool
 
             if
-              | Just (Entity _ Exam{examClosed}) <- mExam
+              | Just (Entity _ Exam{examClosed, examFinished}) <- mExam
-              , NTop examClosed > NTop (Just now)
+              , Just (Entity _ School{schoolExamCloseMode}) <- mSchool
+              , bool ((min `on` NTop) examClosed examFinished > NTop (Just now))
+                     (NTop examClosed > NTop (Just now))
+                   $ is _ExamCloseSeparate schoolExamCloseMode
                 -> return . cell $ toWidget iconNew
               | otherwise
                 -> do

src/Handler/ExternalExam/Form.hs

@@ -13,6 +13,8 @@ import Data.Map ((!))
 
 import qualified Control.Monad.State.Class as State
 
+import qualified Database.Esqueleto as E
+
 
 data ExternalExamForm = ExternalExamForm
   { eefTerm :: TermId
@@ -32,6 +34,7 @@ externalExamForm template = validateForm validateExternalExam $ \html -> do
   uid <- requireAuthId
   cRoute <- fromMaybe (error "tutorialForm called from 404-Handler") <$> getCurrentRoute
   MsgRenderer mr <- getMsgRenderer
+  allSchoolIds <- fmap (map E.unValue) . liftHandler . runDBRead . E.select . E.from $ return . (E.^. SchoolId)
 
   let termsField = case template of
         Just template' -> termsSetField [eefTerm template']
@@ -44,6 +47,9 @@ externalExamForm template = validateForm validateExternalExam $ \html -> do
       let oldSchool = eefSchool <$> template
       return (lecturerSchools, adminSchools, oldSchool)
   let userSchools = nub . maybe id (:) oldSchool $ lecturerSchools ++ adminSchools
+      templateSchool = eefSchool <$> template <|> case userSchools of
+        [ssh] -> pure ssh
+        _     -> mzero
 
   flip (renderAForm FormStandard) html $ ExternalExamForm
     <$> areq termsField (fslI MsgExternalExamSemester) (eefTerm <$> template)
@@ -52,7 +58,7 @@ externalExamForm template = validateForm validateExternalExam $ \html -> do
     <*> areq (textField & cfStrip & cfCI) (fslI MsgExternalExamExamName & setTooltip MsgExternalExamExamNameTip & addPlaceholder (mr MsgExternalExamExamNamePlaceholder)) (eefExamName <$> template)
     <*> aopt utcTimeField (fslI MsgExternalExamDefaultTime & setTooltip MsgExternalExamDefaultTimeTip & addPlaceholder (mr MsgExternalExamDefaultTimePlaceholder)) (eefDefaultTime <$> template)
     <*> apopt (selectField optionsFinite) (fslI MsgExamGradingMode & setTooltip MsgExamGradingModeTip) (eefGradingMode <$> template <|> Just ExamGradingMixed)
-    <*> (Set.fromList <$> officeSchoolForm cRoute (Set.toList . eefOfficeSchools <$> template))
+    <*> (Set.fromList <$> officeSchoolForm cRoute (Set.toList . eefOfficeSchools <$> template <|> Just (filter ((/= templateSchool) . Just) allSchoolIds)))
     <*> (Set.fromList <$> staffForm cRoute ((Set.toList . eefStaff <$> template) <|> pure (pure $ Right uid)))
   where
     officeSchoolForm cRoute = massInputAccumA miAdd miCell miButtonAction miLayout miIdent fSettings fRequired

src/Handler/Help.hs

@@ -67,7 +67,7 @@ helpForm mReferer mUid = renderWForm FormStandard $ do
     <$> hfReferer'
     <*> hfUserId'
     <*> hfSubject'
-    <*> hfRequest'
+    <*> (fmap markupOutput <$> hfRequest')
     <*> hfError'
 
 validateHelpForm :: FormValidator HelpForm Handler ()

src/Handler/Material.hs

@@ -19,7 +19,7 @@ import Handler.Utils.Delete
 data MaterialForm = MaterialForm
       { mfName         :: MaterialName
       , mfType         :: Maybe (CI Text)
-      , mfDescription  :: Maybe Html
+      , mfDescription  :: Maybe StoredMarkup
       , mfVisibleFrom  :: Maybe UTCTime
       , mfFiles        :: Maybe FileUploads
       }
@@ -170,12 +170,33 @@ getMFileR tid ssh csh mnm title = serveOneFile $ fileQuery .| C.map entityVal
         -- return file entity
         return matFile
 
+getMVideoR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> CryptoUUIDMaterialFile -> Handler Html
+getMVideoR tid ssh csh mnm cID = do
+  mfId <- decrypt cID
+  MaterialFile{..} <- runDB $ get404 mfId
+  let mimeType = mimeLookup $ pack materialFileTitle
+      mfile = CMaterialR tid ssh csh mnm $ MFileR materialFileTitle
+  unless (mimeType `Set.member` videoTypes) $
+    redirectWith movedPermanently301 mfile
+  siteLayout' Nothing $ do
+    setTitleI . prependCourseTitle tid ssh csh $ MsgMaterialVideo mnm
+    [whamlet|
+      $newline never
+      <section>
+        <div .video-container>
+          <video controls autoplay preload=auto>
+            <source src=@{mfile} type=#{decodeUtf8 mimeType}>
+            _{MsgMaterialVideoUnsupported}
+      <section>
+        <a .btn href=@{mfile} download target=_blank>
+          ^{iconFileDownload} #
+          _{MsgMaterialVideoDownload}
+    |]
+    
+
 getMShowR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Html
 getMShowR tid ssh csh mnm = do
-  let matLink :: FilePath -> Route UniWorX
+  let zipLink :: Route UniWorX
-      matLink = CourseR tid ssh csh . MaterialR mnm . MFileR
-
-      zipLink :: Route UniWorX
       zipLink = CMaterialR tid ssh csh mnm MArchiveR
 
   seeAllModificationTimestamps <- hasReadAccessTo $ CourseR tid ssh csh CNotesR -- ordinary users should not see modification dates older than visibility
@@ -192,11 +213,25 @@ getMShowR tid ssh csh mnm = do
       { dbtSQLQuery = \matFile -> do
             E.where_ $ matFile E.^. MaterialFileMaterial E.==. E.val (entityKey matEnt)
                 E.&&.  E.not_ (E.isNothing $ matFile E.^. MaterialFileContent) -- don't show directories
-            return (matFile E.^. MaterialFileTitle, matFile E.^. MaterialFileModified)
+            return (matFile E.^. MaterialFileId, matFile E.^. MaterialFileTitle, matFile E.^. MaterialFileModified)
       , dbtRowKey = (E.^. MaterialFileId)
       , dbtColonnade = widgetColonnade $ mconcat
-            [ (<> indicatorCell) <$> colFilePathSimple   (view $ _dbrOutput . _1) matLink
+            [ fmap (<> indicatorCell) . sortable (Just "path") (i18nCell MsgFileTitle) $ \DBRow{..}
-            , materialModDateCol  (view $ _dbrOutput . _2)
+                -> let matLink = CourseR tid ssh csh . MaterialR mnm <$> if
+                         | isVideo
+                           -> MVideoR <$> encrypt (dbrOutput ^. _1 . _Value)
+                         | otherwise -> return $ MFileR fileTitle
+                       wgt = [whamlet|
+                               $newline never
+                               <span .file-path>
+                                 #{fileTitle}
+                                 $if isVideo
+                                   \ ^{iconVideo}
+                             |]
+                       isVideo = mimeLookup (pack fileTitle) `Set.member` videoTypes
+                       fileTitle = unpack $ dbrOutput ^. _2 . _Value
+                    in anchorCellM matLink wgt
+            , materialModDateCol  (view $ _dbrOutput . _3)
             ]
       , dbtProj     = return
       , dbtStyle    = def

src/Handler/News.hs

@@ -18,6 +18,8 @@ import qualified Data.Conduit.Lift as C
 
 import qualified Data.HashMap.Strict as HashMap
 
+import Handler.Utils.Exam (showExamOccurrenceRoom)
+
 
 getNewsR :: Handler Html
 getNewsR = do
@@ -217,6 +219,7 @@ newsUpcomingExams uid = do
           lensExam       = _2
           lensRegister   = _3 . _Just
           lensOccurrence = _4 . _Just
+          lensShowRoom   = _5 . _Value
 
           dbtSQLQuery ((course `E.InnerJoin` exam) `E.LeftOuterJoin` register `E.LeftOuterJoin` occurrence) = do
             E.on $ register E.?. ExamRegistrationOccurrence E.==. E.just (occurrence E.?. ExamOccurrenceId)
@@ -244,7 +247,7 @@ newsUpcomingExams uid = do
                           E.&&. earliestOccurrence E.<=. E.just (E.val fortnight)
                           -- E.&&. earliestOccurrence E.>=. E.just (E.val now)
             E.where_ $ regToWithinFortnight E.||. startExamFortnight E.||. startOccurFortnight E.||. startEarliest
-            return (course, exam, register, occurrence)
+            return (course, exam, register, occurrence, showExamOccurrenceRoom (E.val uid) occurrence)
           dbtRowKey = queryExam >>> (E.^. ExamId)
           dbtProj = return
           dbtColonnade = dbColonnade $ mconcat
@@ -296,7 +299,8 @@ newsUpcomingExams uid = do
                     | otherwise   -> return [whamlet|_{label}|]
             , sortable (toNothingS "occurrence") (i18nCell MsgExamOccurrence) $ \DBRow{ dbrOutput } ->
                 if  | Just (Entity _ ExamOccurrence{..}) <- preview lensOccurrence dbrOutput
-                      -> textCell examOccurrenceRoom
+                      -> if | view lensShowRoom dbrOutput -> maybe (i18nCell MsgExamOccurrenceRoomIsUnset) roomReferenceCell examOccurrenceRoom
+                            | otherwise -> i18nCell MsgExamOccurrenceRoomIsHidden & addCellClass ("explanation" :: Text)
                     | otherwise -> mempty
             ]
           dbtSorting = Map.fromList

src/Handler/School.hs

@@ -66,6 +66,7 @@ data SchoolForm = SchoolForm
   , sfExamMinimumRegisterDuration :: Maybe NominalDiffTime
   , sfExamRequireModeForRegistration :: Bool
   , sfExamDiscouragedModes :: ExamModeDNF
+  , sfExamCloseMode :: ExamCloseMode
   }
 
 mkSchoolForm :: Maybe SchoolId -> Maybe SchoolForm -> Form SchoolForm
@@ -77,6 +78,7 @@ mkSchoolForm mSsh template = renderAForm FormStandard $ SchoolForm
   <*> aopt daysField (fslI MsgSchoolExamMinimumRegisterDuration & setTooltip MsgSchoolExamMinimumRegisterDurationTip) (sfExamMinimumRegisterDuration <$> template)
   <*> apopt checkBoxField (fslI MsgSchoolExamRequireModeForRegistration & setTooltip MsgSchoolExamRequireModeForRegistration) (sfExamRequireModeForRegistration <$> template)
   <*> areq pathPieceField (fslI MsgSchoolExamDiscouragedModes) (sfExamDiscouragedModes <$> template <|> pure (ExamModeDNF predDNFFalse))
+  <*> apopt (selectField optionsFinite) (fslI MsgExamCloseMode) (sfExamCloseMode <$> template <|> pure ExamCloseSeparate)
   where
     ldapOrgs :: HandlerFor UniWorX (OptionList (CI Text))
     ldapOrgs = fmap (mkOptionList . map (\t -> Option (CI.original t) t (CI.original t)) . Set.toAscList) . runDB $
@@ -94,6 +96,7 @@ schoolToForm ssh = do
     , sfExamMinimumRegisterDuration = schoolExamMinimumRegisterDuration
     , sfExamRequireModeForRegistration = schoolExamRequireModeForRegistration
     , sfExamDiscouragedModes = schoolExamDiscouragedModes
+    , sfExamCloseMode = schoolExamCloseMode
     }
 
 
@@ -112,6 +115,7 @@ postSchoolEditR ssh = do
         , SchoolExamMinimumRegisterDuration =. sfExamMinimumRegisterDuration
         , SchoolExamRequireModeForRegistration =. sfExamRequireModeForRegistration
         , SchoolExamDiscouragedModes =. sfExamDiscouragedModes
+        , SchoolExamCloseMode =. sfExamCloseMode
         ]
       forM_ sfOrgUnits $ \schoolLdapOrgUnit ->
         void $ upsert SchoolLdap
@@ -153,6 +157,7 @@ postSchoolNewR = do
         , schoolExamMinimumRegisterDuration = sfExamMinimumRegisterDuration
         , schoolExamRequireModeForRegistration = sfExamRequireModeForRegistration
         , schoolExamDiscouragedModes = sfExamDiscouragedModes
+        , schoolExamCloseMode = sfExamCloseMode
         }
       when didInsert $ do
         insert_ UserFunction

src/Handler/Sheet/Form.hs

@@ -26,7 +26,7 @@ type Loads = Map (Either UserEmail UserId) (InvitationData SheetCorrector)
 
 data SheetForm = SheetForm
       { sfName         :: SheetName
-      , sfDescription  :: Maybe Html
+      , sfDescription  :: Maybe StoredMarkup
       , sfRequireExamRegistration :: Maybe ExamId
       , sfSheetF, sfHintF, sfSolutionF, sfMarkingF :: Maybe FileUploads
       , sfPersonalF :: Maybe SheetPersonalisedFilesForm
@@ -39,7 +39,7 @@ data SheetForm = SheetForm
       , sfGrouping     :: SheetGroup
       , sfType         :: SheetType
       , sfAutoDistribute :: Bool
-      , sfMarkingText  :: Maybe Html
+      , sfMarkingText  :: Maybe StoredMarkup
       , sfAnonymousCorrection :: Bool
       , sfCorrectors   :: Loads
       -- Keine SheetId im Formular!

src/Handler/Sheet/PersonalisedFiles.hs

@@ -153,9 +153,10 @@ sinkPersonalisedSheetFiles cid sid keep
      openSinks <- State.get
      lift . lift . mapM_ closeResumableSink $ openSinks ^.. folded . folded
      let (nub -> sinkSheets, nub -> sinkUsers) = unzip $ Map.keys openSinks
-     lift . lift $ deleteWhere [ PersonalisedSheetFileSheet  <-. sinkSheets
+     unless keep $
-                               , PersonalisedSheetFileUser  /<-. sinkUsers
+       lift . lift $ deleteWhere [ PersonalisedSheetFileSheet  <-. sinkSheets
-                               ]
+                                 , PersonalisedSheetFileUser  /<-. sinkUsers
+                                 ]
 
    msgUnreferenced ((), unreferenced) = unless (null collated && null uncollated) $
      addMessageModal msgStatus msgTrigger $ Right msgWidget

src/Handler/Submission/List.hs

@@ -472,7 +472,8 @@ correctionsR' whereClause displayColumns dbtFilterUI psValidator actions = do
   formResult actionRes $ \case
     (CorrDownloadData nonAnonymous, subs) -> do
       ids <- Set.fromList <$> forM (Set.toList subs) decrypt -- Set is not traversable
-      addHeader "Content-Disposition" [st|attachment; filename="corrections.zip"|]
+      MsgRenderer mr <- getMsgRenderer
+      setContentDisposition' $ Just ((addExtension `on` unpack) (mr MsgSubmissionArchiveName) extensionZip)
       sendResponse =<< submissionMultiArchive nonAnonymous ids
     (CorrSetCorrectorData (Just uid), subs') -> do
       subs <- mapM decrypt $ Set.toList subs'

src/Handler/Tutorial/Edit.hs

@@ -35,6 +35,7 @@ postTEditR tid ssh csh tutn = do
         , tfType            = tutorialType
         , tfCapacity        = tutorialCapacity
         , tfRoom            = tutorialRoom
+        , tfRoomHidden      = tutorialRoomHidden
         , tfTime            = tutorialTime
         , tfRegGroup        = tutorialRegGroup
         , tfRegisterFrom    = tutorialRegisterFrom
@@ -58,6 +59,7 @@ postTEditR tid ssh csh tutn = do
         , tutorialType            = tfType
         , tutorialCapacity        = tfCapacity
         , tutorialRoom            = tfRoom
+        , tutorialRoomHidden      = tfRoomHidden
         , tutorialTime            = tfTime
         , tutorialRegGroup        = tfRegGroup
         , tutorialRegisterFrom    = tfRegisterFrom

src/Handler/Tutorial/Form.hs

@@ -21,7 +21,8 @@ data TutorialForm = TutorialForm
   , tfRegGroup        :: Maybe (CI Text)
   , tfTutorControlled :: Bool
   , tfCapacity        :: Maybe Int
-  , tfRoom            :: Maybe Text
+  , tfRoom            :: Maybe RoomReference
+  , tfRoomHidden      :: Bool
   , tfTime            :: Occurrences
   , tfRegisterFrom    :: Maybe UTCTime
   , tfRegisterTo      :: Maybe UTCTime
@@ -70,7 +71,8 @@ tutorialForm cid template html = do
     <*> aopt (textField & cfStrip & cfCI) (fslI MsgTutorialRegGroup & setTooltip MsgTutorialRegGroupTip) ((tfRegGroup <$> template) <|> Just (Just "tutorial"))
     <*> apopt checkBoxField (fslI MsgTutorialTutorControlled & setTooltip MsgTutorialTutorControlledTip) (tfTutorControlled <$> template)
     <*> aopt (natFieldI MsgTutorialCapacityNonPositive) (fslpI MsgTutorialCapacity (mr MsgTutorialCapacity) & setTooltip MsgTutorialCapacityTip) (tfCapacity <$> template)
-    <*> (assertM (not . null) <$> aopt (textField & cfStrip) (fslpI MsgTutorialRoom $ mr MsgTutorialRoomPlaceholder) (tfRoom <$> template))
+    <*> roomReferenceFormOpt (fslI MsgTutorialRoom) (tfRoom <$> template)
+    <*> apopt checkBoxField (fslI MsgTutorialRoomHidden & setTooltip MsgTutorialRoomHiddenTip) (tfRoomHidden <$> template <|> Just False)
     <*> occurrencesAForm ("occurrences" :: Text) (tfTime <$> template)
     <*> aopt utcTimeField   (fslpI MsgRegisterFrom (mr MsgDate)
                                & setTooltip MsgCourseRegisterFromTip

src/Handler/Tutorial/List.hs

@@ -4,8 +4,10 @@ module Handler.Tutorial.List
 
 import Import
 import Handler.Utils
+import Handler.Utils.Tutorial
 
 import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Utils as E
 import Database.Esqueleto.Utils.TH
 
 import qualified Data.Map as Map
@@ -15,24 +17,30 @@ import qualified Data.CaseInsensitive as CI
 
 getCTutorialListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 getCTutorialListR tid ssh csh = do
+  muid <- maybeAuthId
   cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
   MsgRenderer mr <- getMsgRenderer
 
   let
     tutorialDBTable = DBTable{..}
       where
+        resultTutorial :: Lens' (DBRow (Entity Tutorial, Int, Bool)) (Entity Tutorial)
+        resultTutorial = _dbrOutput . _1
+        resultParticipants = _dbrOutput . _2
+        resultShowRoom = _dbrOutput . _3
+        
         dbtSQLQuery tutorial = do
           E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
           let participants :: E.SqlExpr (E.Value Int)
               participants = E.subSelectCount . E.from $ \tutorialParticipant ->
                 E.where_ $ tutorialParticipant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId
-          return (tutorial, participants)
+          return (tutorial, participants, maybe E.false (flip showTutorialRoom tutorial . E.val) muid)
         dbtRowKey = (E.^. TutorialId)
-        dbtProj = return . over (_dbrOutput . _2) E.unValue
+        dbtProj = return . over (_dbrOutput . _2) E.unValue . over (_dbrOutput . _3) E.unValue
         dbtColonnade = dbColonnade $ mconcat
-          [ sortable (Just "type") (i18nCell MsgTutorialType) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> textCell $ CI.original tutorialType
+          [ sortable (Just "type") (i18nCell MsgTutorialType) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> textCell $ CI.original tutorialType
-          , sortable (Just "name") (i18nCell MsgTutorialName) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) [whamlet|#{tutorialName}|]
+          , sortable (Just "name") (i18nCell MsgTutorialName) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) [whamlet|#{tutorialName}|]
-          , sortable Nothing (i18nCell MsgTutorialTutors) $ \DBRow{ dbrOutput = (Entity tutid _, _) } -> sqlCell $ do
+          , sortable Nothing (i18nCell MsgTutorialTutors) $ \(view $ resultTutorial . _entityKey -> 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
@@ -44,15 +52,17 @@ getCTutorialListR tid ssh csh = do
                            <li>
                              ^{nameEmailWidget' tutor}
                      |]
-          , sortable (Just "participants") (i18nCell MsgTutorialParticipants) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, n) } -> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) $ tshow n
+          , sortable (Just "participants") (i18nCell MsgTutorialParticipants) $ \(view $ $(multifocusL 2) (resultTutorial . _entityVal) resultParticipants -> (Tutorial{..}, n)) -> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) $ tshow n
-          , sortable (Just "capacity") (i18nCell MsgTutorialCapacity) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybe mempty (textCell . tshow) tutorialCapacity
+          , sortable (Just "capacity") (i18nCell MsgTutorialCapacity) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybe mempty (textCell . tshow) tutorialCapacity
-          , sortable (Just "room") (i18nCell MsgTutorialRoom) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybe mempty textCell tutorialRoom
+          , sortable (Just "room") (i18nCell MsgTutorialRoom) $ \res -> if
-          , sortable Nothing (i18nCell MsgTutorialTime) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> occurrencesCell tutorialTime
+              | res ^. resultShowRoom -> maybe (i18nCell MsgTutorialRoomIsUnset) roomReferenceCell $ views (resultTutorial . _entityVal) tutorialRoom res
-          , sortable (Just "register-group") (i18nCell MsgTutorialRegGroup) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybe mempty (textCell . CI.original) tutorialRegGroup
+              | otherwise -> i18nCell MsgTutorialRoomIsHidden & addCellClass ("explanation" :: Text)
-          , sortable (Just "register-from") (i18nCell MsgTutorialRegisterFrom) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybeDateTimeCell tutorialRegisterFrom
+          , sortable Nothing (i18nCell MsgTutorialTime) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> occurrencesCell tutorialTime
-          , sortable (Just "register-to") (i18nCell MsgTutorialRegisterTo) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybeDateTimeCell tutorialRegisterTo
+          , sortable (Just "register-group") (i18nCell MsgTutorialRegGroup) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybe mempty (textCell . CI.original) tutorialRegGroup
-          , sortable (Just "deregister-until") (i18nCell MsgTutorialDeregisterUntil) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybeDateTimeCell tutorialDeregisterUntil
+          , sortable (Just "register-from") (i18nCell MsgTutorialRegisterFrom) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybeDateTimeCell tutorialRegisterFrom
-          , sortable Nothing (mempty & cellAttrs <>~ pure ("uw-hide-columns--hider-label", mr MsgActionsHead)) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> cell $ do
+          , sortable (Just "register-to") (i18nCell MsgTutorialRegisterTo) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybeDateTimeCell tutorialRegisterTo
+          , sortable (Just "deregister-until") (i18nCell MsgTutorialDeregisterUntil) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybeDateTimeCell tutorialDeregisterUntil
+          , sortable Nothing (mempty & cellAttrs <>~ pure ("uw-hide-columns--hider-label", mr MsgActionsHead)) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> cell $ do
               linkButton mempty [whamlet|_{MsgTutorialEdit}|] [BCIsButton] . SomeRoute $ CTutorialR tid ssh csh tutorialName TEditR
               linkButton mempty [whamlet|_{MsgTutorialDelete}|] [BCIsButton, BCDanger] . SomeRoute $ CTutorialR tid ssh csh tutorialName TDeleteR
           ]

src/Handler/Tutorial/New.hs

@@ -29,6 +29,7 @@ postCTutorialNewR tid ssh csh = do
         , tutorialType            = tfType
         , tutorialCapacity        = tfCapacity
         , tutorialRoom            = tfRoom
+        , tutorialRoomHidden      = tfRoomHidden
         , tutorialTime            = tfTime
         , tutorialRegGroup        = tfRegGroup
         , tutorialRegisterFrom    = tfRegisterFrom

src/Handler/Utils.hs

@@ -43,12 +43,19 @@ sendThisFile File{..}
         fileContent' .| Conduit.map toFlushBuilder
   | otherwise = sendResponseStatus noContent204 ()
 
+sendFileReference :: forall file a. HasFileReference file => file -> Handler a
+sendFileReference (view (_FileReference . _1) -> fRef@FileReference{..}) = do
+  when (is _Just fileReferenceContent) $
+    setContentDisposition' . Just $ takeFileName fileReferenceTitle
+  let cType = simpleContentType (mimeLookup $ pack fileReferenceTitle) <> "; charset=utf-8"
+  join . runDB $ respondFileConditional Nothing cType fRef
+
 -- | Serve a single file, identified through a given DB query
 serveOneFile :: forall file. HasFileReference file => ConduitT () file (YesodDB UniWorX) () -> Handler TypedContent
 serveOneFile source = do
   results <- runDB . runConduit $ source .| Conduit.take 2 -- We don't need more than two files to make a decision below
   case results of
-    [file] -> sendThisFile $ sourceFile' file
+    [file] -> sendFileReference file
     []     -> notFound
     _other -> do
       $logErrorS "SFileR" "Multiple matching files found."
@@ -68,7 +75,7 @@ serveSomeFiles' archiveName source = do
 
   case results of
     []         -> notFound
-    [file]     -> sendThisFile $ either sourceFile' id file
+    [file]     -> either sendFileReference sendThisFile file
     _moreFiles -> do
       setContentDisposition' $ Just archiveName
       respondSourceDB typeZip $ do

src/Handler/Utils/Communication.hs

@@ -210,7 +210,7 @@ commR CommunicationRoute{..} =  do
     <$> recipientAForm
     <*  aformMessage recipientsListMsg
     <*> aopt textField (fslI MsgCommSubject) Nothing
-    <*> areq htmlField (fslI MsgCommBody) Nothing
+    <*> (markupOutput <$> areq htmlField (fslI MsgCommBody) Nothing)
   formResult commRes $ \case
     (comm, BtnCommunicationSend) -> do
       runDBJobs . runConduit $ transPipe (mapReaderT lift) (crJobs comm) .| sinkDBJobs

src/Handler/Utils/Course.hs

@@ -4,6 +4,7 @@ import Import
 import Handler.Utils.Delete
 
 import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Utils as E
 
 import qualified Data.Set as Set
 
@@ -70,3 +71,28 @@ setUsersSubmissionGroup cid uids (Just grp) = do
     when didSet $
       audit $ TransactionSubmissionGroupSet cid uid grp
     return $ bool mempty (Sum 1) didSet
+
+showCourseEventRoom :: forall courseEvent courseId.
+                       E.SqlProject CourseEvent CourseId courseEvent courseId
+                    => E.SqlExpr (E.Value UserId) -> E.SqlExpr courseEvent -> E.SqlExpr (E.Value Bool)
+showCourseEventRoom uid courseEvent = E.or
+  [ E.exists . E.from $ \(tutor `E.InnerJoin` tutorial) -> do
+      E.on $ tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial
+      E.where_ $ tutor E.^. TutorUser E.==. uid
+           E.&&. E.unSqlProjectExpr (Proxy @CourseEvent) (Proxy @courseEvent) (tutorial E.^. TutorialCourse) E.==. courseEvent `E.sqlProject` CourseEventCourse
+  , E.exists . E.from $ \(sheetCorrector `E.InnerJoin` sheet) -> do
+      E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
+      E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. uid
+           E.&&. E.unSqlProjectExpr (Proxy @CourseEvent) (Proxy @courseEvent) (sheet E.^. SheetCourse) E.==. courseEvent `E.sqlProject` CourseEventCourse
+  , E.exists . E.from $ \(examCorrector `E.InnerJoin` exam) -> do
+      E.on $ exam E.^. ExamId E.==. examCorrector E.^. ExamCorrectorExam
+      E.where_ $ examCorrector E.^. ExamCorrectorUser E.==. uid
+           E.&&. E.unSqlProjectExpr (Proxy @CourseEvent) (Proxy @courseEvent) (exam E.^. ExamCourse) E.==. courseEvent `E.sqlProject` CourseEventCourse
+  , E.exists . E.from $ \courseParticipant ->
+      E.where_ $ courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
+           E.&&. courseParticipant E.^. CourseParticipantUser E.==. uid
+           E.&&. E.unSqlProjectExpr (Proxy @CourseEvent) (Proxy @courseEvent) (courseParticipant E.^. CourseParticipantCourse) E.==. courseEvent `E.sqlProject` CourseEventCourse
+  , E.exists . E.from $ \lecturer ->
+      E.where_ $ lecturer E.^. LecturerUser E.==. uid
+           E.&&. E.unSqlProjectExpr (Proxy @CourseEvent) (Proxy @courseEvent) (lecturer E.^. LecturerCourse) E.==. courseEvent `E.sqlProject` CourseEventCourse
+  ]

src/Handler/Utils/Exam.hs

@@ -13,6 +13,7 @@ module Handler.Utils.Exam
   , deregisterExamUsersCount, deregisterExamUsers
   , examAidsPresetWidget, examOnlinePresetWidget, examSynchronicityPresetWidget, examRequiredEquipmentPresetWidget
   , evalExamModeDNF
+  , showExamOccurrenceRoom
   ) where
 
 import Import
@@ -680,3 +681,22 @@ evalExamModeDNF (ExamModeDNF PredDNF{..}) ExamMode{..}
         -> examSynchronicity     == Just (ExamSynchronicityPreset p)
       ExamModePredRequiredEquipment p
         -> examRequiredEquipment == Just (ExamRequiredEquipmentPreset p)
+
+showExamOccurrenceRoom :: forall examOccurrence examOccurrenceId examId.
+                          ( E.SqlProject ExamOccurrence ExamOccurrenceId examOccurrence examOccurrenceId
+                          , E.SqlProject ExamOccurrence ExamId examOccurrence examId
+                          )
+                       => E.SqlExpr (E.Value UserId) -> E.SqlExpr examOccurrence -> E.SqlExpr (E.Value Bool)
+showExamOccurrenceRoom uid occurrence = E.or
+  [ E.exists . E.from $ \register ->
+      E.where_ $ register E.^. ExamRegistrationUser E.==. uid
+           E.&&. E.maybe E.false (\occId -> E.unSqlProjectExpr (Proxy @ExamOccurrence) (Proxy @examOccurrence) occId E.==. occurrence `E.sqlProject` ExamOccurrenceId) (register E.^. ExamRegistrationOccurrence)
+  , E.exists . E.from $ \(lecturer `E.InnerJoin` course `E.InnerJoin` exam) -> do
+      E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
+      E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
+      E.where_ $ lecturer E.^. LecturerUser E.==. uid
+           E.&&. E.unSqlProjectExpr (Proxy @ExamOccurrence) (Proxy @examOccurrence) (exam E.^. ExamId) E.==. occurrence `E.sqlProject` ExamOccurrenceExam
+  , E.exists . E.from $ \examCorrector ->
+      E.where_ $ examCorrector E.^. ExamCorrectorUser E.==. uid
+           E.&&. E.unSqlProjectExpr (Proxy @ExamOccurrence) (Proxy @examOccurrence) (examCorrector E.^. ExamCorrectorExam) E.==. occurrence `E.sqlProject` ExamOccurrenceExam
+  ]

src/Handler/Utils/Files.hs

@@ -4,6 +4,7 @@ module Handler.Utils.Files
   , SourceFilesException(..)
   , sourceFileDB, sourceFileMinio
   , acceptFile
+  , respondFileConditional
   ) where
 
 import Import
@@ -99,6 +100,117 @@ sourceFiles' = C.map sourceFile'
 sourceFile' :: forall file. HasFileReference file => file -> DBFile
 sourceFile' = sourceFile . view (_FileReference . _1)
 
+respondFileConditional :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX)
+                       => Maybe UTCTime -> MimeType
+                       -> FileReference
+                       -> SqlPersistT m (Handler a)
+respondFileConditional representationLastModified cType FileReference{..} = do
+  if
+    | Just fileContent <- fileReferenceContent
+    , fileContent == $$(liftTyped $ FileContentReference $$(emptyHash))
+      -> return . respondSourceConditional @ByteRangesSpecifier condInfo cType . Left $ (return () :: ConduitT () ByteString _ ())
+    | Just fileContent <- fileReferenceContent -> do
+        dbManifest <- fmap fromNullable . E.select . E.from $ \(fileContentEntry `E.LeftOuterJoin` fileContentChunk) -> do
+          E.on $ E.just (fileContentEntry E.^. FileContentEntryChunkHash) E.==. fileContentChunk E.?. FileContentChunkId
+          E.where_ $ fileContentEntry E.^. FileContentEntryHash E.==. E.val fileContent
+          E.orderBy [E.asc $ fileContentEntry E.^. FileContentEntryIx ]
+          return ( fileContentChunk E.?. FileContentChunkHash
+                 , E.maybe E.nothing (E.just . E.length_) $ fileContentChunk E.?. FileContentChunkContent
+                 )
+        case dbManifest of
+          Nothing -> do
+            uploadBucket <- getsYesod $ views appSettings appUploadCacheBucket
+            let uploadName = minioFileReference # fileContent
+            statRes <- maybeT (throwM SourceFilesContentUnavailable) . (hoistMaybe <=< runAppMinio) . runMaybeT $ do
+              catchIfMaybeT minioIsDoesNotExist $ Minio.statObject uploadBucket uploadName Minio.defaultGetObjectOptions
+            let iLength = fromIntegral $ Minio.oiSize statRes
+            respondSourceConditional condInfo cType . Right $ \byteRange ->
+              let byteRange' = case byteRange of
+                    ByteRangeSpecification f Nothing -> ByteRangeFrom (fromIntegral $ min (pred iLength) f)
+                    ByteRangeSpecification f (Just t) -> ByteRangeFromTo (fromIntegral $ min iLength f) (fromIntegral $ min (pred iLength) t)
+                    ByteRangeSuffixSpecification s -> ByteRangeSuffix (fromIntegral $ min iLength s)
+                  respRange = case byteRange of
+                    ByteRangeSpecification f Nothing -> ByteRangeResponseSpecification (min (pred iLength) f) (pred iLength)
+                    ByteRangeSpecification f (Just t) -> ByteRangeResponseSpecification (min (pred iLength) f) (min (pred iLength) t)
+                    ByteRangeSuffixSpecification s -> ByteRangeResponseSpecification (iLength - min (pred iLength) s) (pred iLength)
+               in ( do
+                      chunkVar <- newEmptyTMVarIO
+                      minioAsync <- lift . allocateLinkedAsync $
+                        maybeT (throwM SourceFilesContentUnavailable) . (hoistMaybe <=< runAppMinio) . runMaybeT $ do
+                          objRes <- catchIfMaybeT minioIsDoesNotExist $ Minio.getObject uploadBucket uploadName Minio.defaultGetObjectOptions{ Minio.gooRange = Just byteRange' }
+                          lift . runConduit $ Minio.gorObjectStream objRes .| C.mapM_ (atomically . putTMVar chunkVar)
+                      let go = do
+                            mChunk <- atomically $ Right <$> takeTMVar chunkVar
+                                               <|> Left  <$> waitCatchSTM minioAsync
+                            case mChunk of
+                              Right chunk -> do
+                                observeSourcedChunk StorageMinio $ olength chunk
+                                yield chunk
+                                go
+                              Left (Right ()) -> return ()
+                              Left (Left exc) -> throwM exc
+                       in go
+                  , ByteContentRangeSpecification (Just respRange) (Just iLength)
+                  )
+          Just (toNullable -> dbManifest')
+            | Just dbManifest'' <- forM dbManifest' $ \(E.Value chunkHash, E.Value chunkLength) -> (,) <$> chunkHash <*> chunkLength
+              -> do
+                let iLength = sumOf (folded . _2) dbManifest''
+                respondSourceDBConditional condInfo cType . Right $ \byteRange ->
+                  let (byteFrom, byteTo) = case byteRange of
+                        ByteRangeSpecification f Nothing -> (min (pred iLength) f, pred iLength)
+                        ByteRangeSpecification f (Just t) -> (min (pred iLength) f, min (pred iLength) t)
+                        ByteRangeSuffixSpecification s -> (iLength - min (pred iLength) s, pred iLength)
+                      relevantChunks = view _2 $ foldl' go (0, []) dbManifest''
+                        where go :: (Natural, [(FileContentChunkReference, Natural, Natural)])
+                                 -> (FileContentChunkReference, Natural)
+                                 -> (Natural, [(FileContentChunkReference, Natural, Natural)])
+                              go (lengthBefore, acc) (cChunk, cLength)
+                                = ( lengthBefore + cLength
+                                  , if
+                                      | byteFrom < lengthBefore + cLength, byteTo >= lengthBefore
+                                        -> let cChunk' = ( cChunk
+                                                         , bool 0 (byteFrom - lengthBefore) $ byteFrom >= lengthBefore
+                                                         , bool cLength (cLength - pred (lengthBefore + cLength - byteTo)) $ byteTo < lengthBefore + cLength
+                                                         )
+                                            in acc ++ pure cChunk'
+                                      | otherwise
+                                        -> acc
+                                  )
+                   in ( do
+                          dbChunksize <- getsYesod $ views _appFileUploadDBChunksize fromIntegral
+                          forM_ relevantChunks $ \(chunkHash, offset, cLength)
+                            -> let retrieveChunk = \case
+                                     Just (start, cLength') | cLength' > 0 -> do
+                                       chunk <- E.selectMaybe . E.from $ \fileContentChunk -> do
+                                         E.where_ $ fileContentChunk E.^. FileContentChunkHash E.==. E.val chunkHash
+                                         return $ E.substring (fileContentChunk E.^. FileContentChunkContent) (E.val start) (E.val $ min cLength' dbChunksize)
+                                       case chunk of
+                                         Nothing -> throwM SourceFilesContentUnavailable
+                                         Just (E.Value c) -> do
+                                           observeSourcedChunk StorageDB $ olength c
+                                           return . Just . (c, ) $ if
+                                             | fromIntegral (olength c) >= min cLength' dbChunksize
+                                               -> Just (start + dbChunksize, cLength' - fromIntegral (olength c))
+                                             | otherwise
+                                               -> Nothing
+                                     _other -> return Nothing
+                                in C.unfoldM retrieveChunk . Just $ (succ offset, cLength)
+                      , ByteContentRangeSpecification (Just $ ByteRangeResponseSpecification byteFrom byteTo) (Just iLength)
+                      )
+            | otherwise -> throwM SourceFilesContentUnavailable
+            
+    | otherwise
+      -> return $ sendResponseStatus noContent204 ()
+  where
+    condInfo = RepresentationConditionalInformation
+      { representationETag = review etagFileReference <$> fileReferenceContent
+      , representationLastModified
+      , representationExists = True
+      , requestedActionAlreadySucceeded = Nothing
+      }
+
+
   
 acceptFile :: (MonadResource m, MonadResource m') => FileInfo -> m (File m')
 acceptFile fInfo = do

src/Handler/Utils/Form.hs

@@ -2158,25 +2158,25 @@ examModeForm mPrev = examMode
   where
     examMode examSynchronicity examOnline examAids examRequiredEquipment = ExamMode{..}
     
-    examAidsEither :: Iso' ExamAids (Either Html ExamAidsPreset)
+    examAidsEither :: Iso' ExamAids (Either StoredMarkup ExamAidsPreset)
     examAidsEither = iso examAidsToEither examAidsFromEither
       where examAidsToEither (ExamAidsPreset p) = Right p
             examAidsToEither (ExamAidsCustom c) = Left  c
             examAidsFromEither (Right p) = ExamAidsPreset p
             examAidsFromEither (Left  c) = ExamAidsCustom c
-    examOnlineEither :: Iso' ExamOnline (Either Html ExamOnlinePreset)
+    examOnlineEither :: Iso' ExamOnline (Either StoredMarkup ExamOnlinePreset)
     examOnlineEither = iso examOnlineToEither examOnlineFromEither
       where examOnlineToEither (ExamOnlinePreset p) = Right p
             examOnlineToEither (ExamOnlineCustom c) = Left  c
             examOnlineFromEither (Right p) = ExamOnlinePreset p
             examOnlineFromEither (Left  c) = ExamOnlineCustom c
-    examSynchronicityEither :: Iso' ExamSynchronicity (Either Html ExamSynchronicityPreset)
+    examSynchronicityEither :: Iso' ExamSynchronicity (Either StoredMarkup ExamSynchronicityPreset)
     examSynchronicityEither = iso examSynchronicityToEither examSynchronicityFromEither
       where examSynchronicityToEither (ExamSynchronicityPreset p) = Right p
             examSynchronicityToEither (ExamSynchronicityCustom c) = Left  c
             examSynchronicityFromEither (Right p) = ExamSynchronicityPreset p
             examSynchronicityFromEither (Left  c) = ExamSynchronicityCustom c
-    examRequiredEquipmentEither :: Iso' ExamRequiredEquipment (Either Html ExamRequiredEquipmentPreset)
+    examRequiredEquipmentEither :: Iso' ExamRequiredEquipment (Either StoredMarkup ExamRequiredEquipmentPreset)
     examRequiredEquipmentEither = iso examRequiredEquipmentToEither examRequiredEquipmentFromEither
       where examRequiredEquipmentToEither (ExamRequiredEquipmentPreset p) = Right p
             examRequiredEquipmentToEither (ExamRequiredEquipmentCustom c) = Left  c
@@ -2209,3 +2209,50 @@ allocationPriorityForm fs mPrev = multiActionA opts fs $ classifyAllocationPrior
       whenExceptT (null ts) MsgAllocationPriorityNumericNoValues
       forM ts $ \t' -> maybeExceptT (MsgAllocationPriorityNumericNoParse t') . return $ readMay t'
     fromInts = Text.intercalate ", " . map tshow . Vector.toList
+
+
+roomReferenceFormOpt :: FieldSettings UniWorX
+                     -> Maybe (Maybe RoomReference)
+                     -> AForm Handler (Maybe RoomReference)
+roomReferenceFormOpt = roomReferenceForm' . Just $ SomeMessage MsgRoomReferenceNone
+
+roomReferenceForm :: FieldSettings UniWorX
+                  -> Maybe RoomReference
+                  -> AForm Handler RoomReference
+roomReferenceForm fs mPrev = fmapAForm (maybe FormMissing return =<<) . roomReferenceForm' Nothing fs $ Just <$> mPrev
+
+roomReferenceForm' :: Maybe (SomeMessage UniWorX)
+                   -> FieldSettings UniWorX
+                   -> Maybe (Maybe RoomReference)
+                   -> AForm Handler (Maybe RoomReference)
+roomReferenceForm' noneOpt fs mPrev = multiActionAOpts opts opts' fs $ fmap classifyRoomReference <$> mPrev
+  where
+    opts' = do
+      MsgRenderer mr <- getMsgRenderer
+      let olOptions = map mkOption . maybe id ((:) . Left) noneOpt $ map Right universeF
+            where mkOption (Left noneLbl) = Option
+                    { optionDisplay = mr noneLbl
+                    , optionInternalValue = Nothing
+                    , optionExternalValue = "room-none"
+                    }
+                  mkOption (Right v) = Option
+                    { optionDisplay = mr v
+                    , optionInternalValue = Just v
+                    , optionExternalValue = toPathPiece v
+                    }
+          olReadExternal t | t == "room-none" = Just Nothing
+                           | otherwise = Just <$> fromPathPiece t
+      return OptionList{..}
+    opts = mapF $ \case
+      Nothing -> pure Nothing
+      Just RoomReferenceSimple' -> wFormToAForm $ do
+        MsgRenderer mr <- getMsgRenderer
+        fmap (Just . RoomReferenceSimple) <$> wpreq (textField & cfStrip) (fslI MsgRoomReferenceSimpleText & addPlaceholder (mr MsgRoomReferenceSimpleTextPlaceholder) & maybe id (\n -> addName $ n <> "__text") (fsName fs)) (mPrev ^? _Just . _Just . _roomRefText)
+      Just RoomReferenceLink' -> wFormToAForm $ do
+        MsgRenderer mr <- getMsgRenderer
+        roomRefLink' <- wpreq urlField (fslI MsgRoomReferenceLinkLink & addPlaceholder (mr MsgRoomReferenceLinkLinkPlaceholder) & maybe id (\n -> addName $ n <> "__link") (fsName fs)) (mPrev ^? _Just . _Just . _roomRefLink)
+        roomRefInstructions' <- wopt htmlField (fslI MsgRoomReferenceLinkInstructions & addPlaceholder (mr MsgRoomReferenceLinkInstructionsPlaceholder) & maybe id (\n -> addName $ n <> "__instructions") (fsName fs)) (mPrev ^? _Just . _Just . _roomRefInstructions)
+        let res = RoomReferenceLink
+              <$> roomRefLink'
+              <*> roomRefInstructions'
+        return $ Just <$> res

src/Handler/Utils/Pandoc.hs

@@ -9,6 +9,9 @@ import Import.NoFoundation
 import Handler.Utils.I18n
 
 import qualified Data.Text as Text
+import qualified Data.Text.Lazy as LT
+
+import Control.Monad.Error.Class (liftEither)
 
 import qualified Text.Pandoc as P
 
@@ -24,27 +27,39 @@ data HtmlFieldKind
 instance Universe HtmlFieldKind
 instance Finite HtmlFieldKind
 
-htmlField, htmlFieldSmall :: MonadLogger m => Field m Html
+htmlField, htmlFieldSmall :: MonadLogger m => Field m StoredMarkup
 htmlField = htmlField' HtmlFieldNormal
 htmlFieldSmall = htmlField' HtmlFieldSmall
 
 
-htmlField' :: MonadLogger m => HtmlFieldKind -> Field m Html
+htmlField' :: MonadLogger m => HtmlFieldKind -> Field m StoredMarkup
 htmlField' fieldKind = Field{..}
   where
     fieldEnctype = UrlEncoded
 
-    fieldParse (t : _) _
+    fieldParse ((Text.strip -> t) : _) _ = runExceptT . runMaybeT $ do
-      = return . fmap (assertM' $ not . null . renderHtml) . parseMarkdown $ Text.strip t
+      html <- assertM' (not . null . LT.strip . renderHtml) =<< liftEither (parseMarkdown t)
+      return StoredMarkup
+        { markupInputFormat = MarkupMarkdown
+        , markupInput = fromStrict t
+        , markupOutput = html
+        }
     fieldParse []     _ = return $ Right Nothing
 
     fieldView theId name attrs val isReq = do
-      val' <- either return (maybeT (return mempty) . renderMarkdown) val
+      val'
+        <- let toMarkdown StoredMarkup{..} = case markupInputFormat of
+                 MarkupMarkdown -> return $ toStrict markupInput
+                 MarkupHtml -> renderMarkdown markupOutput
+                 MarkupPlaintext -> plaintextToMarkdown $ toStrict markupInput
+            in either return (maybeT (return mempty) . toMarkdown) val
+                    
       let markdownExplanation = $(i18nWidgetFile "markdown-explanation")
       $(widgetFile "widgets/html-field")
 
     parseMarkdown  = parseMarkdownWith  markdownReaderOptions htmlWriterOptions
     renderMarkdown = renderMarkdownWith htmlReaderOptions     markdownWriterOptions
+    plaintextToMarkdown = plaintextToMarkdownWith markdownWriterOptions
 
 parseMarkdownWith :: P.ReaderOptions -> P.WriterOptions -> Text -> Either (SomeMessage site) Html
 parseMarkdownWith readerOptions writerOptions text =
@@ -60,6 +75,14 @@ renderMarkdownWith readerOptions writerOptions html =
   where
     logPandocError = $logErrorS "renderMarkdown" . tshow
 
+plaintextToMarkdownWith :: (MonadLogger m, MonadPlus m) => P.WriterOptions -> Text -> m Text
+plaintextToMarkdownWith writerOptions text =
+  either (\e -> logPandocError e >> mzero) return . P.runPure $
+    P.writeMarkdown writerOptions pandoc
+  where
+    logPandocError = $logErrorS "renderMarkdown" . tshow
+    pandoc = P.Pandoc mempty [P.Plain [P.Str text]]
+
 
 htmlReaderOptions, markdownReaderOptions :: P.ReaderOptions
 htmlReaderOptions = markdownReaderOptions

src/Handler/Utils/Table/Cells.hs

@@ -262,3 +262,6 @@ correctorLoadCell sc =
 
 occurrencesCell :: IsDBTable m a => Occurrences -> DBCell m a
 occurrencesCell = cell . occurrencesWidget
+
+roomReferenceCell :: IsDBTable m a => RoomReference -> DBCell m a
+roomReferenceCell = cell . roomReferenceWidget

src/Handler/Utils/Tutorial.hs

@@ -1,12 +1,14 @@
 module Handler.Utils.Tutorial
   ( fetchTutorialAux
   , fetchTutorial, fetchTutorialId, fetchCourseIdTutorialId, fetchCourseIdTutorial
+  , showTutorialRoom
   ) where
 
 import Import
 
 import Database.Persist.Sql (SqlBackendCanRead)
 import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Utils as E
 import qualified Database.Esqueleto.Internal.Sql as E
 import Database.Esqueleto.Utils.TH
 
@@ -43,3 +45,21 @@ fetchCourseIdTutorialId tid ssh cid tutn = $(unValueN 2) <$> fetchTutorialAux (\
 
 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
+
+showTutorialRoom :: forall tutorial tutorialId courseId.
+                    ( E.SqlProject Tutorial TutorialId tutorial tutorialId
+                    , E.SqlProject Tutorial CourseId tutorial courseId
+                    )
+                 => E.SqlExpr (E.Value UserId) -> E.SqlExpr tutorial -> E.SqlExpr (E.Value Bool)
+showTutorialRoom uid tutorial = E.or
+  [ E.exists . E.from $ \tutor ->
+      E.where_ $ tutor E.^. TutorUser E.==. uid
+           E.&&. E.unSqlProjectExpr (Proxy @Tutorial) (Proxy @tutorial) (tutor E.^. TutorTutorial) E.==. tutorial `E.sqlProject` TutorialId
+  , E.exists . E.from $ \(lecturer `E.InnerJoin` course) -> do
+      E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
+      E.where_ $ lecturer E.^. LecturerUser E.==. uid
+           E.&&. E.unSqlProjectExpr (Proxy @Tutorial) (Proxy @tutorial) (course E.^. CourseId) E.==. tutorial `E.sqlProject` TutorialCourse
+  , E.exists . E.from $ \tutorialParticipant ->
+      E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. uid
+           E.&&. E.unSqlProjectExpr (Proxy @Tutorial) (Proxy @tutorial) (tutorialParticipant E.^. TutorialParticipantTutorial) E.==. tutorial `E.sqlProject` TutorialId
+  ]

src/Handler/Utils/Widgets.hs

@@ -159,3 +159,11 @@ examOccurrenceMappingDescriptionWidget rule descriptions = $(widgetFile "widgets
       = False
       | otherwise
       = True
+
+
+roomReferenceWidget :: RoomReference -> Widget
+roomReferenceWidget RoomReferenceSimple{..} = toWidget roomRefText
+roomReferenceWidget RoomReferenceLink{..} = $(widgetFile "widgets/room-reference/link")
+  where
+    linkText = uriToString id roomRefLink mempty
+    instrModal = modal (i18n MsgRoomReferenceLinkInstructions) $ Right $(widgetFile "widgets/room-reference/link-instructions-modal")

src/Handler/Utils/Workflow/Form.hs

@@ -178,7 +178,7 @@ data WorkflowDescriptionsFormScope
   deriving (Eq, Ord, Bounded, Enum, Read, Show, Generic, Typeable)
   deriving (Universe, Finite)
   
-workflowDescriptionsForm :: WorkflowDescriptionsFormScope -> Maybe (Map Lang (Text, Maybe Html)) -> AForm Handler (Map Lang (Text, Maybe Html))
+workflowDescriptionsForm :: WorkflowDescriptionsFormScope -> Maybe (Map Lang (Text, Maybe StoredMarkup)) -> AForm Handler (Map Lang (Text, Maybe StoredMarkup))
 workflowDescriptionsForm scope template = Map.fromList <$> massInputAccumEditA descrAdd descrEdit (const Nothing) descrLayout ("workflow-descriptions" :: Text) (fslI msgWorkflowDescriptions) False (Map.toList <$> template)
   where
     descrAdd nudge submitView csrf = do
@@ -191,13 +191,13 @@ workflowDescriptionsForm scope template = Map.fromList <$> massInputAccumEditA d
               -> FormSuccess $ pure newDescr
       return (res', $(widgetFile "widgets/massinput/workflowDescriptions/add"))
     descrEdit nudge = descrForm nudge . Just
-    descrForm :: (Text -> Text) -> Maybe (Lang, (Text, Maybe Html)) -> Form (Lang, (Text, Maybe Html))
+    descrForm :: (Text -> Text) -> Maybe (Lang, (Text, Maybe StoredMarkup)) -> Form (Lang, (Text, Maybe StoredMarkup))
     descrForm nudge descrTemplate csrf = do
       (langRes, langView) <- mpreq (langField False) (fslI MsgWorkflowDescriptionLanguage & addName (nudge "lang")) (fmap (view _1) descrTemplate <|> Just (NonEmpty.head appLanguages))
       (titleRes, titleView) <- mpreq textField (fslI MsgWorkflowDescriptionTitle & addName (nudge "title")) (view (_2 . _1) <$> descrTemplate)
       (descrRes, descrView) <- mopt htmlField (fslI MsgWorkflowDescription & addName (nudge "descr")) (view (_2 . _2) <$> descrTemplate)
       return ((,) <$> langRes <*> ((,) <$> titleRes <*> descrRes), $(widgetFile "widgets/massinput/workflowDescriptions/form"))
-    descrLayout :: MassInputLayout ListLength (Lang, (Text, Maybe Html)) (Lang, (Text, Maybe Html))
+    descrLayout :: MassInputLayout ListLength (Lang, (Text, Maybe StoredMarkup)) (Lang, (Text, Maybe StoredMarkup))
     descrLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/workflowDescriptions/layout")
 
     msgWorkflowDescriptions = case scope of

src/Handler/Workflow/Definition/Form.hs

@@ -16,8 +16,8 @@ data WorkflowDefinitionForm = WorkflowDefinitionForm
   { wdfScope :: WorkflowScope'
   , wdfName  :: WorkflowDefinitionName
   , wdfInstanceCategory :: Maybe WorkflowInstanceCategory
-  , wdfDescriptions :: Map Lang (Text, Maybe Html)
+  , wdfDescriptions :: Map Lang (Text, Maybe StoredMarkup)
-  , wdfInstanceDescriptions :: Map Lang (Text, Maybe Html)
+  , wdfInstanceDescriptions :: Map Lang (Text, Maybe StoredMarkup)
   , wdfGraph :: WorkflowGraphForm
   } deriving (Generic, Typeable)
 

src/Handler/Workflow/Instance/Form.hs

@@ -45,7 +45,7 @@ data WorkflowInstanceForm = WorkflowInstanceForm
   { wifScope :: WorkflowScope TermId SchoolId CourseId
   , wifName :: WorkflowInstanceName
   , wifCategory :: Maybe WorkflowInstanceCategory
-  , wifDescriptions :: Map Lang (Text, Maybe Html)
+  , wifDescriptions :: Map Lang (Text, Maybe StoredMarkup)
   , wifGraph :: WorkflowGraphForm
   } deriving (Generic, Typeable)
 

src/Import/NoFoundation.hs

@@ -12,6 +12,7 @@ import Utils.Frontend.Modal   as Import
 import Utils.Frontend.Notification as Import
 import Utils.Lens             as Import
 import Utils.Failover         as Import
+import Utils.Room             as Import
 
 import Settings                as Import
 import Settings.StaticFiles    as Import

src/Import/NoModel.hs

@@ -18,7 +18,7 @@ import ClassyPrelude.Yesod    as Import
          , HasHttpManager(..)
          , embed
          , try, embed, catches, handle, catch, bracket, bracketOnError, bracket_, catchJust, finally, handleJust, mask, mask_, onException, tryJust, uninterruptibleMask, uninterruptibleMask_
-         , htmlField, fileField
+         , htmlField, fileField, urlField
          , mreq, areq, wreq -- Use `mreqMsg`, `areqMsg`, `wreqMsg`
          , sinkFile, sourceFile
          )
@@ -134,6 +134,8 @@ import Data.List.PointedList as Import (PointedList)
 
 import Language.Haskell.TH.Syntax as Import (Lift(liftTyped))
 
+import Network.URI as Import (URI, parseURI, uriToString)
+
 import Language.Haskell.TH.Instances as Import ()
 import Data.NonNull.Instances as Import ()
 import Data.Monoid.Instances  as Import ()
@@ -181,6 +183,7 @@ import Database.Persist.Sql.Types.Instances as Import ()
 import Control.Monad.Catch.Instances as Import ()
 import Text.Shakespeare.Text.Instances as Import ()
 import Ldap.Client.Instances as Import ()
+import Network.URI.Instances as Import ()
 
 import Crypto.Hash as Import (Digest, SHA3_256, SHA3_512)
 import Crypto.Random as Import (ChaChaDRG, Seed)

src/Jobs/Crontab.hs

@@ -306,7 +306,11 @@ determineCrontab = execWriterT $ do
 
 
   let
-    examJobs (Entity nExam Exam{..}) = do
+    examSelect = E.selectSource . E.from $ \(exam `E.InnerJoin` course `E.InnerJoin` school) -> do
+      E.on $ school E.^. SchoolId E.==. course E.^. CourseSchool
+      E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
+      return (exam, course, school)
+    examJobs (Entity nExam Exam{..}, _, Entity _ School{..}) = do
       newestResult <- lift . E.select . E.from $ \examResult -> do
         E.where_ $ examResult E.^. ExamResultExam E.==. E.val nExam
         return . E.max_ $ examResult E.^. ExamResultLastChanged
@@ -352,8 +356,19 @@ determineCrontab = execWriterT $ do
               , cronNotAfter  = Right . CronTimestamp $ utcToLocalTimeTZ appTZ deregisterUntil
               }
 
-      case examClosed of
+      let closeTime = case (examClosed, examFinished) of
+            (mClose, Just finish)
+              | isn't _ExamCloseSeparate schoolExamCloseMode -> Just $ maybe id min mClose finish
+            (Just close, _)
+              | is _ExamCloseSeparate schoolExamCloseMode -> Just close
+            _other -> Nothing
+
+      case closeTime of
         Just close -> do
+          -- If an exam that was previously under `ExamCloseSeparate` rules transitions to `ExamCloseOnFinish`, it might suddenly have been closed an arbitrary time ago
+          -- If `cronNotAfter` was only `appNotificationExpiration` in that case, no notification might ever be sent
+          -- That's probably fine.
+
           changedResults <- lift . E.select . E.from $ \examResult -> do
             E.where_ $ examResult E.^. ExamResultExam E.==. E.val nExam
                  E.&&. examResult E.^. ExamResultLastChanged E.>. E.val close
@@ -381,8 +396,7 @@ determineCrontab = execWriterT $ do
               , cronNotAfter = Left appNotificationExpiration
               }
         Nothing -> return ()
-
+   in runConduit $ transPipe lift examSelect .| C.mapM_ examJobs
-  runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ examJobs
 
 
   let

src/Jobs/Handler/SendNotification/ExamOffice.hs

@@ -24,7 +24,7 @@ dispatchNotificationExamOfficeExamResults nExam jRecipient = userMailT jRecipien
     course <- belongsToJust examCourse exam
     return (course, exam)
   replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
-  setSubjectI $ MsgMailSubjectExamOfficeExamResults courseShorthand examName
+  setSubjectI $ MsgMailSubjectExamOfficeExamResults courseName examName
 
   MsgRenderer mr <- getMailMsgRenderer
   let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm
@@ -48,7 +48,7 @@ dispatchNotificationExamOfficeExamResultsChanged nExamResults jRecipient = do
       course <- belongsToJust examCourse exam
       return (course, exam)
     replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
-    setSubjectI $ MsgMailSubjectExamOfficeExamResultsChanged courseShorthand examName
+    setSubjectI $ MsgMailSubjectExamOfficeExamResultsChanged courseName examName
 
     MsgRenderer mr <- getMailMsgRenderer
     let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm

src/Model/Migration.hs

@@ -990,11 +990,74 @@ customMigrations = Map.fromListWith (>>)
   , ( AppliedMigrationKey [migrationVersion|42.0.0|] [version|43.0.0|]
     , return () -- Unused; used to create and fill `ChangelogItemFirstSeen`
     )
-  , ( AppliedMigrationKey [migrationVersion|43.0.0|] [version|44.0.0|]
+  , ( AppliedMigrationKey [migrationVersion|43.0.0|] [version|43.1.0|]
     , whenM (tableExists "school") $ do
         schools <- [sqlQQ| SELECT "shorthand", "exam_discouraged_modes" FROM "school"; |]
         forM_ schools $ \(sid, Single edModes) -> update sid [SchoolExamDiscouragedModes =. Legacy.examModeDNF edModes]
     )
+  , ( AppliedMigrationKey [migrationVersion|43.0.0|] [version|44.0.0|]
+    , [executeQQ|
+        SET client_min_messages TO WARNING;
+        ALTER TABLE IF EXISTS ^{Allocation} ALTER COLUMN @{AllocationDescription} TYPE jsonb USING (CASE WHEN @{AllocationDescription} IS NOT NULL THEN to_json(@{AllocationDescription}) ELSE NULL END);
+        ALTER TABLE IF EXISTS ^{Allocation} ALTER COLUMN @{AllocationStaffDescription} TYPE jsonb USING (CASE WHEN @{AllocationStaffDescription} IS NOT NULL THEN to_json(@{AllocationStaffDescription}) ELSE NULL END);
+        ALTER TABLE IF EXISTS ^{Course} ALTER COLUMN @{CourseDescription} TYPE jsonb USING (CASE WHEN @{CourseDescription} IS NOT NULL THEN to_json(@{CourseDescription}) ELSE NULL END);
+        ALTER TABLE IF EXISTS ^{Course} ALTER COLUMN @{CourseApplicationsInstructions} TYPE jsonb USING (CASE WHEN @{CourseApplicationsInstructions} IS NOT NULL THEN to_json(@{CourseApplicationsInstructions}) ELSE NULL END);
+        ALTER TABLE IF EXISTS ^{CourseEvent} ALTER COLUMN @{CourseEventNote} TYPE jsonb USING (CASE WHEN @{CourseEventNote} IS NOT NULL THEN to_json(@{CourseEventNote}) ELSE NULL END);
+        ALTER TABLE IF EXISTS ^{CourseUserNote} ALTER COLUMN @{CourseUserNoteNote} TYPE jsonb USING (CASE WHEN @{CourseUserNoteNote} IS NOT NULL THEN to_json(@{CourseUserNoteNote}) ELSE NULL END);
+        ALTER TABLE IF EXISTS ^{Material} ALTER COLUMN @{MaterialDescription} TYPE jsonb USING (CASE WHEN @{MaterialDescription} IS NOT NULL THEN to_json(@{MaterialDescription}) ELSE NULL END);
+        ALTER TABLE IF EXISTS ^{CourseNews} ALTER COLUMN @{CourseNewsContent} TYPE jsonb USING (CASE WHEN @{CourseNewsContent} IS NOT NULL THEN to_json(@{CourseNewsContent}) ELSE NULL END);
+        ALTER TABLE IF EXISTS ^{CourseNews} ALTER COLUMN @{CourseNewsSummary} TYPE jsonb USING (CASE WHEN @{CourseNewsSummary} IS NOT NULL THEN to_json(@{CourseNewsSummary}) ELSE NULL END);
+        ALTER TABLE IF EXISTS ^{Exam} ALTER COLUMN @{ExamDescription} TYPE jsonb USING (CASE WHEN @{ExamDescription} IS NOT NULL THEN to_json(@{ExamDescription}) ELSE NULL END);
+        ALTER TABLE IF EXISTS ^{ExamOccurrence} ALTER COLUMN @{ExamOccurrenceDescription} TYPE jsonb USING (CASE WHEN @{ExamOccurrenceDescription} IS NOT NULL THEN to_json(@{ExamOccurrenceDescription}) ELSE NULL END);
+        ALTER TABLE IF EXISTS ^{Sheet} ALTER COLUMN @{SheetDescription} TYPE jsonb USING (CASE WHEN @{SheetDescription} IS NOT NULL THEN to_json(@{SheetDescription}) ELSE NULL END);
+        ALTER TABLE IF EXISTS ^{Sheet} ALTER COLUMN @{SheetMarkingText} TYPE jsonb USING (CASE WHEN @{SheetMarkingText} IS NOT NULL THEN to_json(@{SheetMarkingText}) ELSE NULL END);
+        ALTER TABLE IF EXISTS ^{SystemMessage} ALTER COLUMN @{SystemMessageContent} TYPE jsonb USING (CASE WHEN @{SystemMessageContent} IS NOT NULL THEN to_json(@{SystemMessageContent}) ELSE NULL END);
+        ALTER TABLE IF EXISTS ^{SystemMessage} ALTER COLUMN @{SystemMessageSummary} TYPE jsonb USING (CASE WHEN @{SystemMessageSummary} IS NOT NULL THEN to_json(@{SystemMessageSummary}) ELSE NULL END);
+        ALTER TABLE IF EXISTS ^{SystemMessageTranslation} ALTER COLUMN @{SystemMessageTranslationContent} TYPE jsonb USING (CASE WHEN @{SystemMessageTranslationContent} IS NOT NULL THEN to_json(@{SystemMessageTranslationContent}) ELSE NULL END);
+        ALTER TABLE IF EXISTS ^{SystemMessageTranslation} ALTER COLUMN @{SystemMessageTranslationSummary} TYPE jsonb USING (CASE WHEN @{SystemMessageTranslationSummary} IS NOT NULL THEN to_json(@{SystemMessageTranslationSummary}) ELSE NULL END);
+        SET client_min_messages TO NOTICE;
+      |]
+    )
+  , ( AppliedMigrationKey [migrationVersion|44.0.0|] [version|45.0.0|]
+    , do
+        whenM (tableExists "exam_occurrence") $ do
+          [executeQQ|ALTER TABLE "exam_occurrence" ADD COLUMN "room_json" jsonb|]
+          let getExamOccurrences = [queryQQ|SELECT "id", "room" FROM "exam_occurrence"|]
+              migrateExamOccurrence [ fromPersistValue -> Right (eoId :: ExamOccurrenceId), fromPersistValue -> Right roomText ] = [executeQQ|UPDATE "exam_occurrence" SET "room_json" = #{RoomReferenceSimple roomText} WHERE "id" = #{eoId}|]
+              migrateExamOccurrence _ = return ()
+           in runConduit $ getExamOccurrences .| C.mapM_ migrateExamOccurrence
+          [executeQQ|
+            ALTER TABLE "exam_occurrence" DROP COLUMN "room";
+            ALTER TABLE "exam_occurrence" RENAME COLUMN "room_json" TO "room";
+          |]
+        whenM (tableExists "tutorial") $ do
+          [executeQQ|ALTER TABLE "tutorial" ADD COLUMN "room_json" jsonb|]
+          let getTutorials = [queryQQ|SELECT "id", "room" FROM "tutorial"|]
+              migrateTutorial [ fromPersistValue -> Right (tutId :: TutorialId), fromPersistValue -> Right roomText ] = [executeQQ|UPDATE "tutorial" SET "room_json" = #{RoomReferenceSimple roomText} WHERE "id" = #{tutId}|]
+              migrateTutorial _ = return ()
+           in runConduit $ getTutorials .| C.mapM_ migrateTutorial
+          [executeQQ|
+            ALTER TABLE "tutorial" DROP COLUMN "room";
+            ALTER TABLE "tutorial" RENAME COLUMN "room_json" TO "room";
+          |]
+        whenM (tableExists "course_event") $ do
+          [executeQQ|ALTER TABLE "course_event" ADD COLUMN "room_json" jsonb|]
+          let getCourseEvents = [queryQQ|SELECT "id", "room" FROM "course_event"|]
+              migrateCourseEvent [ fromPersistValue -> Right (ceId :: CourseEventId), fromPersistValue -> Right roomText ] = [executeQQ|UPDATE "course_event" SET "room_json" = #{RoomReferenceSimple roomText} WHERE "id" = #{ceId}|]
+              migrateCourseEvent _ = return ()
+           in runConduit $ getCourseEvents .| C.mapM_ migrateCourseEvent
+          [executeQQ|
+            ALTER TABLE "course_event" DROP COLUMN "room";
+            ALTER TABLE "course_event" RENAME COLUMN "room_json" TO "room";
+          |]
+        whenM (tableExists "course") $ do
+          let getCourses = [queryQQ|SELECT "id", "link_external" FROM "course"|]
+              migrateCourse [ fromPersistValue -> Right (cId :: CourseId), fromPersistValue -> Right (uriText :: Maybe Text) ]
+                | Just uri <- parseURI . unpack =<< uriText = [executeQQ|UPDATE "course" SET "link_external" = #{uri} WHERE "id" = #{cId}|]
+                | otherwise = [executeQQ|UPDATE "course" SET "link_external" = NULL WHERE "id" = #{cId}|]
+              migrateCourse _ = return ()
+           in runConduit $ getCourses .| C.mapM_ migrateCourse
+    )
   ]
 
 

src/Model/Types.hs

@@ -19,3 +19,5 @@ import Model.Types.File as Types
 import Model.Types.User as Types
 import Model.Types.Workflow as Types
 import Model.Types.Changelog as Types
+import Model.Types.Markup as Types
+import Model.Types.Room as Types

src/Model/Types/Changelog.hs

@@ -38,6 +38,8 @@ classifyChangelogItem = \case
   ChangelogExamAchievementParticipantDuplication  -> ChangelogItemBugfix
   ChangelogFormsTimesReset                        -> ChangelogItemBugfix
   ChangelogAllocationCourseAcceptSubstitutesFixed -> ChangelogItemBugfix
+  ChangelogStoredMarkup                           -> ChangelogItemBugfix
+  ChangelogFixPersonalisedSheetFilesKeep          -> ChangelogItemBugfix
   _other                                          -> ChangelogItemFeature
 
 changelogItemDays :: Map ChangelogItem Day
@@ -145,4 +147,6 @@ changelogItemDays = Map.fromListWithKey (\k d1 d2 -> bool (error $ "Duplicate ch
   , (ChangelogAbolishCourseAssociatedStudyFeatures,            [day|2020-08-28|])
   , (ChangelogExamStaff,                                       [day|2020-10-12|])
   , (ChangelogExamAdditionalSchools,                           [day|2020-10-12|])
+  , (ChangelogMaterialsVideoStreaming,                         [day|2020-11-10|])
+  , (ChangelogFixPersonalisedSheetFilesKeep,                   [day|2020-11-10|])
   ]

src/Model/Types/Exam.hs

@@ -38,11 +38,13 @@ module Model.Types.Exam
   , ExamRequiredEquipment(..), ExamRequiredEquipmentPreset(..)
   , ExamMode(..)
   , ExamModePredicate(..), ExamModeDNF(..)
+  , ExamCloseMode(..), _ExamCloseSeparate, _ExamCloseOnFinished, _ExamCloseOnFinished', _ExamCloseOnFinishedHidden, _examCloseOnFinishedHidden
   ) where
 
 import Import.NoModel
 import Model.Types.Common
 import Model.Types.TH.PathPiece
+import Model.Types.Markup
 
 import qualified Data.Text as Text
 import qualified Data.Map as Map
@@ -439,7 +441,7 @@ instance Enum ExamPartNumber where
 
 data ExamAids
   = ExamAidsPreset { examAidsPreset :: ExamAidsPreset }
-  | ExamAidsCustom { examAidsCustom :: Html }
+  | ExamAidsCustom { examAidsCustom :: StoredMarkup }
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
 data ExamAidsPreset
@@ -460,7 +462,7 @@ pathPieceJSON ''ExamAidsPreset
 
 data ExamOnline
   = ExamOnlinePreset { examOnlinePreset :: ExamOnlinePreset }
-  | ExamOnlineCustom { examOnlineCustom :: Html }
+  | ExamOnlineCustom { examOnlineCustom :: StoredMarkup }
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
 data ExamOnlinePreset
@@ -481,7 +483,7 @@ pathPieceJSON ''ExamOnlinePreset
 
 data ExamSynchronicity
   = ExamSynchronicityPreset { examSynchronicityPreset :: ExamSynchronicityPreset }
-  | ExamSynchronicityCustom { examSynchronicityCustom :: Html }
+  | ExamSynchronicityCustom { examSynchronicityCustom :: StoredMarkup }
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
 data ExamSynchronicityPreset
@@ -502,7 +504,7 @@ pathPieceJSON ''ExamSynchronicityPreset
 
 data ExamRequiredEquipment
   = ExamRequiredEquipmentPreset { examRequiredEquipmentPreset :: ExamRequiredEquipmentPreset }
-  | ExamRequiredEquipmentCustom { examRequiredEquipmentCustom :: Html }
+  | ExamRequiredEquipmentCustom { examRequiredEquipmentCustom :: StoredMarkup }
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
 data ExamRequiredEquipmentPreset
@@ -557,3 +559,23 @@ newtype ExamModeDNF = ExamModeDNF { examModeDNF :: PredDNF ExamModePredicate }
   deriving newtype (Semigroup, Monoid, ToJSON, FromJSON, PathPiece)
 
 derivePersistFieldJSON ''ExamModeDNF
+
+
+data ExamCloseMode
+  = ExamCloseSeparate
+  | ExamCloseOnFinished { examCloseOnFinishedHidden :: Bool }
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  deriving anyclass (Binary)
+deriveFinite ''ExamCloseMode
+finitePathPiece ''ExamCloseMode ["separate", "on-finished", "on-finished-hidden"]
+derivePersistFieldPathPiece ''ExamCloseMode
+pathPieceJSON ''ExamCloseMode
+pathPieceJSONKey ''ExamCloseMode
+pathPieceHttpApiData ''ExamCloseMode
+
+makeLenses_ ''ExamCloseMode
+makePrisms ''ExamCloseMode
+
+_ExamCloseOnFinished', _ExamCloseOnFinishedHidden :: Prism' ExamCloseMode ()
+_ExamCloseOnFinished' = _ExamCloseOnFinished . only False
+_ExamCloseOnFinishedHidden = _ExamCloseOnFinished . only True

src/Model/Types/File.hs

@@ -5,7 +5,7 @@ module Model.Types.File
   , File(..), _fileTitle, _fileContent, _fileModified
   , PureFile, toPureFile, fromPureFile, pureFileToFileReference, _pureFileContent
   , transFile
-  , minioFileReference
+  , minioFileReference, etagFileReference
   , FileReference(..), _fileReferenceTitle, _fileReferenceContent, _fileReferenceModified
   , HasFileReference(..), IsFileReference(..), FileReferenceResidual(FileReferenceResidual, FileReferenceResidualEither, unFileReferenceResidualEither, FileReferenceResidualEntity, fileReferenceResidualEntityKey, fileReferenceResidualEntityResidual, unPureFileResidual)
   , FileReferenceTitleMap(..)
@@ -68,6 +68,13 @@ minioFileReference = prism' toObjectName fromObjectName
   where toObjectName = decodeUtf8 . Base64.encodeUnpadded . ByteArray.convert
         fromObjectName = fmap (review _Wrapped) . Crypto.digestFromByteString <=< preview _Right . Base64.decodeUnpadded . encodeUtf8
 
+etagFileReference :: Prism' ETag FileContentReference
+etagFileReference = prism' toETag fromETag
+  where toETag = StrongETag . decodeUtf8 . Base64.encodeUnpadded . ByteArray.convert
+        fromETag = \case
+          StrongETag t -> fmap (review _Wrapped) . Crypto.digestFromByteString <=< preview _Right . Base64.decodeUnpadded $ encodeUtf8 t
+          _other -> Nothing
+  
 
 data File m = File
   { fileTitle    :: FilePath

src/Model/Types/Markup.hs

@@ -0,0 +1,133 @@
+module Model.Types.Markup
+  ( MarkupFormat(..)
+  , StoredMarkup(..)
+  , htmlToStoredMarkup, plaintextToStoredMarkup, preEscapedToStoredMarkup
+  , esqueletoMarkupOutput
+  ) where
+
+import Import.NoModel
+
+import Text.Blaze (ToMarkup(..))
+import Text.Blaze.Html.Renderer.Text (renderHtml)
+
+import qualified Data.Text.Lazy as LT
+import qualified Data.ByteString.Lazy as LBS
+import Data.Text.Encoding (decodeUtf8')
+
+import qualified Data.Aeson as Aeson
+import qualified Data.Aeson.Types as Aeson
+
+import qualified Data.Csv as Csv
+
+import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Utils as E
+import qualified Database.Esqueleto.Internal.Internal as E
+import Database.Persist.Sql
+
+
+data MarkupFormat
+  = MarkupMarkdown
+  | MarkupHtml
+  | MarkupPlaintext
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
+  deriving anyclass (Universe, Finite)
+nullaryPathPiece ''MarkupFormat $ camelToPathPiece' 1
+pathPieceJSON ''MarkupFormat
+
+data StoredMarkup = StoredMarkup
+  { markupInputFormat :: MarkupFormat
+  , markupInput       :: LT.Text
+  , markupOutput      :: Html
+  } deriving (Read, Show, Generic, Typeable)
+
+htmlToStoredMarkup :: Html -> StoredMarkup
+htmlToStoredMarkup html = StoredMarkup
+  { markupInputFormat = MarkupHtml
+  , markupInput = renderHtml html
+  , markupOutput = html
+  }
+plaintextToStoredMarkup :: Textual t => t -> StoredMarkup
+plaintextToStoredMarkup (repack -> t) = StoredMarkup
+  { markupInputFormat = MarkupPlaintext
+  , markupInput = t
+  , markupOutput = toMarkup t
+  }
+preEscapedToStoredMarkup :: Textual t => t -> StoredMarkup
+preEscapedToStoredMarkup (repack -> t) = StoredMarkup
+  { markupInputFormat = MarkupHtml
+  , markupInput = fromStrict t
+  , markupOutput = preEscapedToMarkup t
+  }
+
+esqueletoMarkupOutput :: E.SqlExpr (E.Value StoredMarkup) -> E.SqlExpr (E.Value Html)
+esqueletoMarkupOutput sMarkup = E.maybe (E.val mempty) E.veryUnsafeCoerceSqlExprValue $ E.maybe (sMarkup E.#>>. "{}") E.just (sMarkup E.#>>. "{\"markup-output\"}")
+
+instance Eq StoredMarkup where
+  (==) = (==) `on` LT.strip . renderHtml . markupOutput
+instance Ord StoredMarkup where
+  compare = comparing $ LT.strip . renderHtml . markupOutput
+
+instance ToJSON StoredMarkup where
+  toJSON StoredMarkup{..}
+    | markupInputFormat == MarkupHtml
+    , renderHtml markupOutput == markupInput
+    = Aeson.String $ toStrict markupInput
+    | otherwise
+    = Aeson.object
+        [ "input-format"  Aeson..= markupInputFormat
+        , "markup-input"  Aeson..= markupInput
+        , "markup-output" Aeson..= markupOutput
+        ]
+instance FromJSON StoredMarkup where
+  parseJSON v = case v of
+    Aeson.String t -> return $ preEscapedToStoredMarkup t
+    Aeson.Object o -> do
+      markupInputFormat <- o Aeson..: "input-format"
+      markupInput       <- o Aeson..: "markup-input"
+      markupOutput      <- o Aeson..: "markup-output"
+      return StoredMarkup{..}
+    other -> Aeson.typeMismatch "StoredMarkup" other
+
+instance IsString StoredMarkup where
+  fromString = preEscapedToStoredMarkup
+instance ToMarkup StoredMarkup where
+  toMarkup = markupOutput
+instance ToWidget site StoredMarkup where
+  toWidget = toWidget . toMarkup
+
+instance Semigroup StoredMarkup where
+  a <> b
+    | markupInputFormat a == markupInputFormat b
+    = StoredMarkup
+      { markupInputFormat = markupInputFormat a
+      , markupInput = ((<>) `on` markupInput) a b -- this seems optimistic...
+      , markupOutput = ((<>) `on` markupOutput) a b
+      }
+    | null $ markupInput a
+    = b
+    | null $ markupInput b
+    = a
+    | otherwise
+    = StoredMarkup
+      { markupInputFormat = MarkupHtml
+      , markupInput = renderHtml $ ((<>) `on` markupOutput) a b
+      , markupOutput = ((<>) `on` markupOutput) a b
+      }
+instance Monoid StoredMarkup where
+  mempty = fromString mempty
+
+instance Csv.ToField StoredMarkup where
+  toField = Csv.toField . markupOutput
+instance Csv.FromField StoredMarkup where
+  parseField = fmap htmlToStoredMarkup . Csv.parseField
+
+instance PersistField StoredMarkup where
+  fromPersistValue (PersistDbSpecific bs) = first pack $ Aeson.eitherDecodeStrict' bs
+  fromPersistValue (PersistByteString bs) = first pack $ Aeson.eitherDecodeStrict' bs
+                                                     <|> bimap show preEscapedToStoredMarkup (decodeUtf8' bs)
+  fromPersistValue (PersistText t) = first pack $ Aeson.eitherDecodeStrict' (encodeUtf8 t)
+                                              <|> return (preEscapedToStoredMarkup t)
+  fromPersistValue _ = Left "StoredMarkup values must be converted from PersistDbSpecific, PersistText, or PersistByteString"
+  toPersistValue = PersistDbSpecific . LBS.toStrict . Aeson.encode
+instance PersistFieldSql StoredMarkup where
+  sqlType _ = SqlOther "jsonb"

src/Model/Types/Room.hs

@@ -0,0 +1,40 @@
+module Model.Types.Room
+  ( RoomReference(..)
+  , RoomReference'(..), classifyRoomReference
+  ) where
+
+import Import.NoModel
+import Model.Types.Markup
+
+import Data.Text.Lens (unpacked)
+
+
+data RoomReference
+  = RoomReferenceSimple { roomRefText :: Text }
+  | RoomReferenceLink
+    { roomRefLink :: URI
+    , roomRefInstructions :: Maybe StoredMarkup
+    }
+  deriving (Eq, Ord, Show, Generic, Typeable)
+
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece' 2
+  , fieldLabelModifier = camelToPathPiece' 2
+  , omitNothingFields = True
+  } ''RoomReference
+derivePersistFieldJSON ''RoomReference
+
+instance IsString RoomReference where
+  fromString = RoomReferenceSimple . pack
+
+
+data RoomReference' = RoomReferenceSimple' | RoomReferenceLink'
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+  deriving anyclass (Universe, Finite)
+
+nullaryPathPiece ''RoomReference' $ camelToPathPiece' 2 . over unpacked (dropSuffix "'")
+
+classifyRoomReference :: RoomReference -> RoomReference'
+classifyRoomReference = \case
+  RoomReferenceSimple{} -> RoomReferenceSimple'
+  RoomReferenceLink{}   -> RoomReferenceLink'

src/Network/URI/Instances.hs

@@ -0,0 +1,27 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Network.URI.Instances
+  (
+  ) where
+
+import ClassyPrelude
+import Network.URI
+import qualified Data.Aeson as Aeson
+
+import Control.Monad.Fail (MonadFail(..))
+
+import Database.Persist
+import Database.Persist.Sql
+
+
+instance Aeson.ToJSON URI where
+  toJSON = Aeson.String . pack . ($ mempty) . uriToString id
+instance Aeson.FromJSON URI where
+  parseJSON = Aeson.withText "URI" $ maybe (fail "Could not parse URI") return . parseURIReference . unpack
+
+instance PersistField URI where
+  toPersistValue = PersistText . pack . ($ mempty) . uriToString id 
+  fromPersistValue (PersistText t) = maybe (Left "Could not parse URI") return . parseURIReference $ unpack t
+  fromPersistValue v = Left $ "Failed to parse Haskell type `URI`; expected text from database but received: " <> tshow v <> "."
+instance PersistFieldSql URI where
+  sqlType _ = SqlString

src/Settings/Mime.hs

@@ -2,7 +2,7 @@ module Settings.Mime
   ( mimeMap
   , mimeLookup
   , mimeExtensions
-  , archiveTypes
+  , archiveTypes, videoTypes
   , module Network.Mime
   ) where
 
@@ -27,5 +27,6 @@ mimeLookup = mimeByExt mimeMap defaultMimeType
 mimeExtensions :: MimeType -> Set Extension
 mimeExtensions needle = Set.fromList [ ext | (ext, typ) <- Map.toList mimeMap, typ == needle ]
 
-archiveTypes :: Set MimeType
+archiveTypes, videoTypes :: Set MimeType
 archiveTypes = $(mimeSetFile "config/archive-types")
+videoTypes = $(mimeSetFile "config/video-types")

src/Utils.hs

@@ -33,6 +33,7 @@ import Utils.Session as Utils
 import Utils.Csv as Utils
 import Utils.I18n as Utils
 import Utils.NTop as Utils
+import Utils.HttpConditional as Utils
 
 import Text.Blaze (Markup, ToMarkup)
 
@@ -99,6 +100,7 @@ import Data.Binary (Binary)
 import qualified Data.Binary as Binary
 
 import Network.Wai (requestMethod)
+import Network.HTTP.Types.Header
 
 import Data.Time.Clock
 
@@ -1014,7 +1016,7 @@ setContentDisposition :: MonadHandler m => ContentDisposition -> Maybe FilePath
 -- ^ Set a @Content-Disposition@-header using `replaceOrAddHeader`
 --
 -- Takes care of correct formatting and encoding of non-ascii filenames
-setContentDisposition cd (fmap pack -> mFName) = replaceOrAddHeader "Content-Disposition" headerVal
+setContentDisposition cd (fmap pack -> mFName) = replaceOrAddHeader (decodeUtf8 $ CI.original hContentDisposition) headerVal
   where
     headerVal
       | Just fName <- mFName
@@ -1153,6 +1155,8 @@ cachedHereBinary = do
   loc <- location
   [e| \k -> cachedByBinary (loc, k) |]
 
+-- TODO: replace with Utils.HttpConditional
+
 hashToText :: Hashable a => a -> Text
 hashToText = Text.dropWhileEnd (== '=') . decodeUtf8 . Base64.encode . toStrict . Binary.encode . hash
 
@@ -1165,12 +1169,12 @@ setLastModified lastModified = do
   rMethod <- requestMethod <$> waiRequest
 
   when (rMethod `elem` safeMethods) $ do
-    ifModifiedSince <- (=<<) (parseTimeM True defaultTimeLocale "%a, %d %b %Y %X %Z" . unpack <=< either (const Nothing) Just . Text.decodeUtf8') <$> lookupHeader "If-Modified-Since"
+    ifModifiedSince <- (=<<) (parseTimeM True defaultTimeLocale "%a, %d %b %Y %X %Z" . unpack <=< either (const Nothing) Just . Text.decodeUtf8') <$> lookupHeader hIfModifiedSince
     $logDebugS "LastModified" $ tshow (lastModified, ifModifiedSince)
     when (maybe False ((lastModified <=) . addUTCTime precision) ifModifiedSince)
       notModified
 
-  addHeader "Last-Modified" $ formatRFC1123 lastModified
+  addHeader (decodeUtf8 $ CI.original hLastModified) $ formatRFC1123 lastModified
   where
     precision :: NominalDiffTime
     precision = 1

src/Utils/Form.hs

@@ -4,9 +4,9 @@
 
 module Utils.Form where
 
-import ClassyPrelude.Yesod hiding (addMessage, addMessageI, cons, Proxy(..), identifyForm, addClass, mreq, areq, wreq)
+import ClassyPrelude.Yesod hiding (addMessage, addMessageI, cons, Proxy(..), identifyForm, addClass, mreq, areq, wreq, urlField)
 import Data.Kind (Type)
-import qualified Yesod.Form.Functions as Yesod
+import qualified Yesod.Form as Yesod
 import Yesod.Core.Instances ()
 import Settings
 
@@ -56,7 +56,7 @@ import Data.Proxy
 
 import Data.Monoid (Endo(..))
 
-
+import Network.URI (URI, parseURI, uriToString)
 
 
 --------------------
@@ -833,6 +833,16 @@ radioGroupField optMsg mkOpts = Field{..}
                 #{optionDisplay opt}
       |]
 
+data UrlFieldMessage = UrlFieldCouldNotParseAbsolute
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+  deriving anyclass (Universe, Finite)
+
+urlField :: ( Monad m
+            , RenderMessage (HandlerSite m) UrlFieldMessage
+            , RenderMessage (HandlerSite m) FormMessage
+            )
+         => Field m URI
+urlField = checkMap (maybe (Left UrlFieldCouldNotParseAbsolute) Right . parseURI . unpack) (pack . ($ mempty) . uriToString id) Yesod.urlField
 
 -----------
 -- Forms --
@@ -878,9 +888,14 @@ wrapForm' btn formWidget FormSettings{..} = do
 -------------------
 
 -- | Use this type to pass information to the form template
-data FormLayout = FormStandard | FormDBTableFilter | FormDBTablePagesize | FormDBTableCsvImport | FormDBTableCsvExport
+data FormLayout = FormStandard
+                | FormDBTableFilter | FormDBTablePagesize | FormDBTableCsvImport | FormDBTableCsvExport
+                | FormVertical
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+  deriving anyclass (Universe, Finite)
 
 data AFormMessage = MsgAFormFieldRequiredTip
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
 renderAForm :: (RenderMessage (HandlerSite m) AFormMessage, Monad m) => FormLayout -> FormRender m a
 renderAForm formLayout aform fragment = do
@@ -888,6 +903,7 @@ renderAForm formLayout aform fragment = do
   let formHasRequiredFields = any fvRequired fieldViews
       widget = $(widgetFile "widgets/aform/aform")
   return (res, widget)
+  where isFormVertical = formLayout == FormVertical
 
 renderWForm :: (RenderMessage (HandlerSite m) AFormMessage, MonadHandler m) => FormLayout -> WForm m (FormResult a) -> -- Form a   -- (Synonym unavailable here)
   (Markup -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()))

src/Utils/HttpConditional.hs

@@ -0,0 +1,375 @@
+{-# LANGUAGE UndecidableInstances #-}
+
+{-|
+Description: Support for partial and conditional http requests (Range, ETag, If-Match, ...)
+-}
+
+module Utils.HttpConditional
+  ( ByteRangesSpecifier(..), ByteRangeSpecification(..)
+  , ByteContentRangeSpecification(..), ByteRangeResponseSpecification(..)
+  , IsRangeUnit(..)
+  , ETag(..)
+  , RepresentationConditionalInformation(..)
+  , mkResponseConditional
+  , respondSourceConditional, respondSourceDBConditional
+  ) where
+
+import ClassyPrelude hiding (Builder)
+import Yesod.Core
+import Yesod.Persist.Core
+import Data.Conduit
+import qualified Data.Conduit.Combinators as C
+import Data.Binary.Builder (Builder)
+
+import Web.HttpApiData
+
+import qualified Data.Attoparsec.Text as A
+
+import Data.Char (chr, ord)
+import Numeric.Natural
+
+import qualified Data.Set as Set
+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
+
+import Data.Time
+
+import Network.HTTP.Types
+import Network.HTTP.Types.Header
+
+import Control.Lens
+import Control.Lens.Extras
+
+import Data.Kind (Type)
+import Data.Coerce
+import Data.Proxy
+
+import Control.Monad.Trans.Maybe (MaybeT(..))
+import Control.Monad.Fail (MonadFail(..))
+import Control.Monad.Trans.Resource (ResourceT)
+
+import Network.Wai
+
+import Control.Monad.Random.Class
+
+import qualified Data.ByteString.Base64.URL as Base64
+import qualified Data.ByteString as BS
+
+import Data.List.NonEmpty (NonEmpty(..))
+
+
+ows :: A.Parser ()
+ows = A.skipMany $ A.satisfy (`elem` [chr 0x20, chr 0x09])
+
+httpList :: A.Parser a -> A.Parser [a]
+httpList itemParser = do
+  let sep = A.many1 $ ows *> A.char ',' <* ows
+  A.skipMany sep
+  xs <- itemParser `A.sepBy1` sep
+  A.skipMany sep
+  return xs
+
+parseUrlPiece' :: A.Parser a -> (Text -> Either Text a)
+parseUrlPiece' p = first pack . A.parseOnly (p <* A.endOfInput)
+
+
+newtype ByteRangesSpecifier = ByteRangesSpecifier (NonNull (Set ByteRangeSpecification))
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+data ByteRangeSpecification
+  = ByteRangeSpecification
+      { byteRangeSpecFirstPosition :: Natural
+      , byteRangeSpecLastPosition :: Maybe Natural
+      }
+  | ByteRangeSuffixSpecification
+      { byteRangeSpecSuffixLength :: Natural
+      }
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+instance FromHttpApiData ByteRangesSpecifier where
+  parseUrlPiece = parseUrlPiece' parser
+    where parser :: A.Parser ByteRangesSpecifier
+          parser = do
+            ranges <- httpList brSpecParser
+            ByteRangesSpecifier <$> maybe (fail "Parser definition error: empty list of ByteRangeSpecifications") return (fromNullable $ Set.fromList ranges)
+          brSpecParser :: A.Parser ByteRangeSpecification
+          brSpecParser = brSpecParser' <|> brSuffixParser
+            where brSpecParser' = do
+                    byteRangeSpecFirstPosition <- A.decimal
+                    void $ A.char '-'
+                    byteRangeSpecLastPosition <- optional A.decimal
+                    return ByteRangeSpecification{..}
+                  brSuffixParser = do
+                    void $ A.char '-'
+                    byteRangeSpecSuffixLength <- A.decimal
+                    return ByteRangeSuffixSpecification{..}
+
+data ByteContentRangeSpecification
+  = ByteContentRangeSpecification
+      { byteRangeResponse :: Maybe ByteRangeResponseSpecification
+      , byteRangeInstanceLength :: Maybe Natural
+      } deriving (Eq, Ord, Read, Show, Generic, Typeable)
+data ByteRangeResponseSpecification
+  = ByteRangeResponseSpecification
+      { byteRangeResponseSpecFirstPosition
+      , byteRangeResponseSpecLastPosition :: Natural
+      } deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+instance ToHttpApiData ByteContentRangeSpecification where
+  toUrlPiece ByteContentRangeSpecification{..} = maybe "*" encByteRangeResponse byteRangeResponse <> "/" <> maybe "*" encByteRangeInstanceLength byteRangeInstanceLength
+    where
+      encByteRangeInstanceLength = toUrlPiece
+      encByteRangeResponse ByteRangeResponseSpecification{..} = toUrlPiece byteRangeResponseSpecFirstPosition <> "-" <> toUrlPiece byteRangeResponseSpecLastPosition
+
+
+class (FromHttpApiData req, ToHttpApiData resp, Ord (SingularRangeSpecification req), Show resp) => IsRangeUnit req resp | req -> resp, resp -> req where
+  type SingularRangeSpecification req :: Type
+  rangeUnit :: forall p1 p2. p1 req -> p2 resp -> Text
+  rangeRequestAll :: forall p. p req -> SingularRangeSpecification req
+  _RangeSpecifications :: Iso' req (NonNull (Set (SingularRangeSpecification req)))
+  default _RangeSpecifications :: Coercible req (NonNull (Set (SingularRangeSpecification req)))
+                               => Iso' req (NonNull (Set (SingularRangeSpecification req)))
+  _RangeSpecifications = coerced
+  rangeInstanceLength :: resp -> Maybe Natural
+  rangeInstanceLength _ = Nothing
+
+instance IsRangeUnit ByteRangesSpecifier ByteContentRangeSpecification where
+  type SingularRangeSpecification ByteRangesSpecifier = ByteRangeSpecification
+  rangeUnit _ _ = "bytes"
+  rangeRequestAll _ = ByteRangeSpecification 0 Nothing
+  rangeInstanceLength = byteRangeInstanceLength
+
+
+data ETag = WeakETag { unETag :: Text } | StrongETag { unETag :: Text }
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+parseETag :: A.Parser ETag
+parseETag = do
+  isWeak <- is _Just <$> optional (A.string "W/")
+  void $ A.char '"'
+  tag <- pack <$> many (A.satisfy isETagChar)
+  void $ A.char '"'
+  return $ bool StrongETag WeakETag isWeak tag
+  where
+    isETagChar c = c == '!'
+                || (0x23 <= ord c && ord c <= 0x7e)
+                || (0x80 <= ord c && ord c <= 0xff)
+
+instance FromHttpApiData ETag where
+  parseUrlPiece = parseUrlPiece' parseETag
+instance ToHttpApiData ETag where
+  toUrlPiece (WeakETag t) = "W/\"" <> t <> "\"" 
+  toUrlPiece (StrongETag t) = "\"" <> t <> "\"" 
+
+strongETagEq, weakETagEq :: ETag -> ETag -> Bool
+strongETagEq (StrongETag a) (StrongETag b) = a == b
+strongETagEq _ _ = False
+weakETagEq = (==) `on` unETag
+  
+data RepresentationConditionalInformation = RepresentationConditionalInformation
+  { representationETag :: Maybe ETag
+  , representationLastModified :: Maybe UTCTime
+  , representationExists :: Bool
+  , requestedActionAlreadySucceeded :: Maybe Status
+  } deriving (Eq, Ord, Show, Generic, Typeable)
+
+newtype ETagMatch = ETagMatch (Set ETag)
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  deriving newtype (Semigroup, Monoid)
+
+instance FromHttpApiData ETagMatch where
+  parseUrlPiece = parseUrlPiece' parseIfMatch
+    where parseIfMatch :: A.Parser ETagMatch
+          parseIfMatch = parseEmptyIfMatch <|> parseNonEmptyIfMatch
+          parseEmptyIfMatch = mempty <* A.char '*'
+          parseNonEmptyIfMatch = ETagMatch . Set.fromList <$> httpList parseETag
+
+parseHTTPTime :: A.Parser UTCTime
+parseHTTPTime = do
+  inpT <- A.takeText
+  maybe (fail "Could not parse time specification") return . parseTimeM True defaultTimeLocale "%a, %d %b %Y %X %Z" $ unpack inpT
+
+newtype ModifiedMatch = ModifiedMatch UTCTime
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+instance FromHttpApiData ModifiedMatch where
+  parseUrlPiece = parseUrlPiece' $ ModifiedMatch <$> parseHTTPTime
+
+data IfRange = IfRangeETag ETag | IfRangeModified UTCTime
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+instance FromHttpApiData IfRange where
+  parseUrlPiece = parseUrlPiece' parseIfRange
+    where parseIfRange = parseIfRangeETag <|> parseIfRangeModified
+          parseIfRangeETag = IfRangeETag <$> parseETag
+          parseIfRangeModified = IfRangeModified <$> parseHTTPTime
+
+newtype RangeRequest req = RangeRequest { unRangeRequest :: req }
+  deriving (Generic, Typeable)
+  deriving newtype (Eq, Ord, Read, Show)
+
+instance IsRangeUnit req resp => FromHttpApiData (RangeRequest req) where
+  parseUrlPiece = parseUrlPiece' parseRangeRequest
+    where parseRangeRequest :: A.Parser (RangeRequest req)
+          parseRangeRequest = do
+            void . A.string $ rangeUnit (Proxy @req) (Proxy @resp)
+            void $ A.char '='
+            t <- A.takeText
+            either (fail . unpack) (return . RangeRequest) $ parseUrlPiece t
+
+newtype RangeResponse resp = RangeResponse resp
+  deriving (Generic, Typeable)
+  deriving newtype (Eq, Ord, Read, Show)
+
+instance IsRangeUnit req resp => ToHttpApiData (RangeResponse resp) where
+  toUrlPiece (RangeResponse r) = rangeUnit (Proxy @req) (Proxy @resp) <> " " <> toUrlPiece r
+
+newtype MultipartBoundary = MultipartBoundary ByteString
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+instance ToHttpApiData MultipartBoundary where
+  toUrlPiece (MultipartBoundary bs) = decodeUtf8 $ Base64.encodeUnpadded bs
+  
+mkResponseConditional :: forall rangeReq rangeResp builder m m'.
+                         ( MonadHandler m, Monad m'
+                         , IsRangeUnit rangeReq rangeResp
+                         , ToFlushBuilder builder
+                         )
+                      => RepresentationConditionalInformation
+                      -> ContentType
+                      -> Either (ConduitT () builder m' ()) (SingularRangeSpecification rangeReq -> (ConduitT () builder m' (), rangeResp))
+                      -> m (Status, ContentType, ConduitT () (Flush Builder) m' ())
+-- ^ Implementes https://tools.ietf.org/html/rfc7232#section-6
+--
+-- Assumes we are the origin server
+mkResponseConditional RepresentationConditionalInformation{..} cType cont = liftHandler $ do
+  isSafeMethod <- (`elem` safeMethods) . requestMethod <$> waiRequest
+
+  for_ representationETag $ \etag ->
+    replaceOrAddHeader (decodeUtf8 $ CI.original hETag) . decodeUtf8 $ toHeader etag
+  for_ representationLastModified $ \lModified ->
+    replaceOrAddHeader (decodeUtf8 $ CI.original hLastModified) $ formatRFC1123 lModified
+  
+  ifMatch <- lookupHeader' hIfMatch
+  for_ ifMatch $ \(ETagMatch ps) -> if
+    | null ps, representationExists -> return ()
+    | Just etag <- representationETag
+    , any (`strongETagEq` etag) ps -> return ()
+    | Just retCode <- requestedActionAlreadySucceeded -> sendResponseStatus retCode ()
+    | otherwise -> preconditionFailed
+
+  ifUnmodifiedSince <- lookupHeader' hIfUnmodifiedSince
+  for_ (guard (is _Nothing ifMatch) *> ifUnmodifiedSince) $ \(ModifiedMatch ts) -> if
+    | Just lModified <- representationLastModified
+    , lModified < addUTCTime (-precision) ts -> return ()
+    | Just retCode <- requestedActionAlreadySucceeded -> sendResponseStatus retCode ()
+    | otherwise -> preconditionFailed
+    
+  ifNoneMatch <- lookupHeader' hIfNoneMatch
+  for_ ifNoneMatch $ \(ETagMatch ps) -> if
+    | null ps, representationExists -> bool preconditionFailed notModified isSafeMethod
+    | Just etag <- representationETag
+    , any (`weakETagEq` etag) ps -> bool preconditionFailed notModified isSafeMethod
+    | otherwise -> return ()
+
+  ifModifiedSince <- lookupHeader' hIfModifiedSince
+  for_ (guard (isSafeMethod && is _Nothing ifNoneMatch) *> ifModifiedSince) $ \(ModifiedMatch ts) -> if
+    | Just lModified <- representationLastModified
+    , lModified <= addUTCTime precision ts -> notModified
+    | otherwise -> return ()
+
+  case cont of
+    Left evalNoRanges -> do
+      replaceOrAddHeader (decodeUtf8 $ CI.original hAcceptRanges) "none"
+      return (ok200, cType, evalNoRanges .| C.map toFlushBuilder)
+    Right evalRange -> do
+      replaceOrAddHeader (decodeUtf8 $ CI.original hAcceptRanges) $ rangeUnit (Proxy @rangeReq) (Proxy @rangeResp)
+
+      mRanges <- do
+        ifRange <- lookupHeader' hIfRange
+        range <- lookupHeader' @(RangeRequest rangeReq) hRange
+        case ifRange of
+          Just (IfRangeETag p)
+            | Just etag <- representationETag
+            , p `strongETagEq` etag -> return range
+          Just (IfRangeModified ts)
+            | Just lModified <- representationLastModified
+            , lModified < addUTCTime (-precision) ts -> return range
+          Just _ -> return Nothing
+          Nothing -> return range
+
+      let ranges = maybe (rangeRequestAll (Proxy @rangeReq) :| []) (toNonEmpty . view _RangeSpecifications . unRangeRequest) mRanges
+
+      when (length ranges > 5) $ do
+        invalidArgs ["Too many ranges"]
+
+      case ranges of
+        r :| [] -> do
+          let (respSrc, rResp) = evalRange r
+          when (is _Just mRanges) $
+            replaceOrAddHeader (decodeUtf8 $ CI.original hContentRange) . decodeUtf8 . toHeader $ RangeResponse rResp
+          return (bool partialContent206 ok200 $ r == rangeRequestAll (Proxy @rangeReq), cType, respSrc .| C.map toFlushBuilder)
+        (toList -> rs) -> do
+          boundary <- liftIO $ MultipartBoundary . BS.pack <$> replicateM 12 getRandom
+          let cType' = "multipart/byteranges; boundary=" <> toHeader boundary
+              bodySrc = do
+                forM_ rs $ \r -> do
+                  let (respSrc, rResp) = evalRange r
+                  sendChunkBS $ "--" <> toHeader boundary <> "\r\n"
+                  sendChunkBS $ CI.original hContentType <> ": " <> cType <> "\r\n"
+                  sendChunkBS $ CI.original hContentRange <> ": " <> toHeader (RangeResponse rResp) <> "\r\n"
+                  sendChunkBS   "\r\n"
+                  respSrc .| C.map toFlushBuilder
+                  sendChunkBS   "\r\n"
+                  sendFlush
+                sendChunkBS $ "--" <> toHeader boundary <> "--\r\n"
+          return (partialContent206, cType', bodySrc)
+  
+  where
+    lookupHeader' :: forall hdr n. (MonadHandler n, FromHttpApiData hdr) => CI ByteString -> n (Maybe hdr)
+    lookupHeader' hdrName = liftHandler . runMaybeT $ do
+      hdrBS <- MaybeT $ lookupHeader hdrName
+      case parseHeader hdrBS of
+        Left errMsg -> do
+          $logInfoS "lookupHeader'" $ "Could not parse value for request header “" <> decodeUtf8 (CI.original hdrName) <> "”, “" <> tshow hdrBS <> "”: " <> errMsg
+          mzero
+        Right val -> return val
+
+    precision :: NominalDiffTime
+    precision = 1
+
+    safeMethods = [ methodGet, methodHead, methodOptions ]
+
+    preconditionFailed = sendResponseStatus preconditionFailed412 ()
+
+respondSourceConditional :: forall rangeReq rangeResp builder m a.
+                            ( MonadHandler m
+                            , IsRangeUnit rangeReq rangeResp
+                            , ToFlushBuilder builder
+                            )
+                         => RepresentationConditionalInformation
+                         -> ContentType
+                         -> Either (ConduitT () builder (HandlerFor (HandlerSite m)) ()) (SingularRangeSpecification rangeReq -> (ConduitT () builder (HandlerFor (HandlerSite m)) (), rangeResp))
+                         -> m a
+respondSourceConditional cInfo cType cont = liftHandler $ do
+  (rStatus, cType', cont') <- mkResponseConditional cInfo cType cont
+  UnliftIO{..} <- askUnliftIO
+  sendResponseStatus rStatus ( cType'
+                             , toContent $
+                                 transPipe (lift @ResourceT . unliftIO) cont'
+                             )
+  
+respondSourceDBConditional :: forall rangeReq rangeResp builder m a.
+                              ( MonadHandler m, YesodPersistRunner (HandlerSite m)
+                              , IsRangeUnit rangeReq rangeResp
+                              , ToFlushBuilder builder
+                              )
+                           => RepresentationConditionalInformation
+                           -> ContentType
+                           -> Either (ConduitT () builder (YesodDB (HandlerSite m)) ()) (SingularRangeSpecification rangeReq -> (ConduitT () builder (YesodDB (HandlerSite m)) (), rangeResp))
+                           -> m a
+respondSourceDBConditional cInfo cType cont = liftHandler $ do
+  (rStatus, cType', cont') <- mkResponseConditional cInfo cType cont
+  UnliftIO{..} <- askUnliftIO
+  sendResponseStatus rStatus ( cType'
+                             , toContent . transPipe (lift @ResourceT . unliftIO) $ runDBSource cont'
+                             )

src/Utils/Icon.hs

@@ -91,6 +91,7 @@ data Icon
   | IconAllocationApplicationEdit
   | IconPersonalIdentification
   | IconMenuWorkflows
+  | IconVideo
   deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, Typeable)
 
 iconText :: Icon -> Text
@@ -162,6 +163,7 @@ iconText = \case
     IconAllocationApplicationEdit -> "pencil-alt"
     IconPersonalIdentification  -> "id-card"
     IconMenuWorkflows           -> "project-diagram"
+    IconVideo                   -> "video"
 
 instance Universe Icon
 instance Finite   Icon

src/Utils/Lang.hs

@@ -63,7 +63,7 @@ highPrioRequestedLangs = fmap (concatMap $ fromMaybe []) . mapM runMaybeT $
   , lookupRegisteredCookies pure CookieLang
   , fmap pure . MaybeT $ lookupSessionKey SessionLang
   ]
-lowPrioRequestedLangs = maybe [] (mapMaybe (either (const Nothing) Just . Text.decodeUtf8') . NWP.parseHttpAccept) <$> lookupHeader "Accept-Language"
+lowPrioRequestedLangs = maybe [] (mapMaybe (either (const Nothing) Just . Text.decodeUtf8') . NWP.parseHttpAccept) <$> lookupHeader hAcceptLanguage
 
 languagesMiddleware :: forall site a. NonEmpty Lang -> HandlerFor site a -> HandlerFor site a
 languagesMiddleware avL act = do

src/Utils/Lens.hs

@@ -264,6 +264,9 @@ makeLenses_ ''SentMail
 
 makePrisms ''AllocationPriority
 
+makePrisms ''RoomReference
+makeLenses_ ''RoomReference
+
 -- makeClassy_ ''Load
 
 --------------------------

src/Utils/Room.hs

@@ -0,0 +1,11 @@
+module Utils.Room
+  ( roomReferenceText
+  ) where
+
+import Import.NoModel
+import Model.Types.Room
+
+roomReferenceText :: RoomReference -> Text
+roomReferenceText = \case
+  RoomReferenceSimple{roomRefText} -> roomRefText
+  RoomReferenceLink{roomRefLink} -> pack $ uriToString id roomRefLink mempty

src/Web/ServerSession/Frontend/Yesod/Jwt.hs

@@ -92,7 +92,8 @@ findSession :: State sto
             -> Maybe Jwt
 findSession state req = do
   [raw] <- return $ do
-    ("Cookie", header) <- Wai.requestHeaders req
+    (hdrName, header) <- Wai.requestHeaders req
+    guard $ hdrName == hCookie
     (k, v) <- parseCookies header
     guard $ k == encodeUtf8 (getCookieName state)
     return v

stack.yaml

@@ -76,6 +76,7 @@ extra-deps:
   - aeson-1.5.3.0@sha256:05496710de6ae694e55dc77dbdaf7503f56c24e4aecc06045e42e75a02df8bc4,6906
   - data-fix-0.3.0@sha256:058a266d1e658500e0ffb8babe68195b0ce06a081dcfc3814afc784b083fd9a5,1645
   - strict-0.4@sha256:1b50c7c9c636c3a1bbc7f8873b9be48f6ca0faca4df6eec6a014de6208fb1c0e,4200
+  - network-arbitrary-0.6.0.0@sha256:a7034d63295dfc41cf559ee705fc95cac9a9a01b4715300f590eaa237b5ffd48,2506
 
 resolver: nightly-2020-08-08
 compiler: ghc-8.10.2

stack.yaml.lock

@@ -373,6 +373,13 @@ packages:
       sha256: fdf523b8990567d69277b999d68d492ed0b3a98a89b1acdfb3087e3b95eb9908
   original:
     hackage: strict-0.4@sha256:1b50c7c9c636c3a1bbc7f8873b9be48f6ca0faca4df6eec6a014de6208fb1c0e,4200
+- completed:
+    hackage: network-arbitrary-0.6.0.0@sha256:a7034d63295dfc41cf559ee705fc95cac9a9a01b4715300f590eaa237b5ffd48,2506
+    pantry-tree:
+      size: 915
+      sha256: 97b797944cf068eb5fde620e005e253818f03068b2c20e9cfdd3aaa6cafcb678
+  original:
+    hackage: network-arbitrary-0.6.0.0@sha256:a7034d63295dfc41cf559ee705fc95cac9a9a01b4715300f590eaa237b5ffd48,2506
 snapshots:
 - completed:
     size: 524392

templates/course.hamlet

@@ -113,9 +113,9 @@ $#                     #{summary}
   $maybe link <- courseLinkExternal course
     <dt .deflist__dt>_{MsgCourseHomepageExternal}
     <dd .deflist__dd>
-      <a href=#{link} target="_blank" rel="noopener" title="_{MsgCourseHomepageExternal}">
+      <a href=#{uriToString id link mempty} target="_blank" rel="noopener" title="_{MsgCourseHomepageExternal}">
         #{iconLink}
-        \ #{link}
+        \ #{uriToString id link mempty}
 
 $#    $if NTop (Just 0) < NTop (courseCapacity course)
   <dt .deflist__dt>_{MsgCourseParticipantsHeading}
@@ -232,10 +232,27 @@ $#    $if NTop (Just 0) < NTop (courseCapacity course)
   <dt .deflist__dt>
     _{MsgCourseMaterial}
   <dd .deflist__dd>
-    $if courseMaterialFree course
+    $if mayViewSheets
-      _{MsgCourseMaterialFree}
+      <p>
-    $else
+        $if mayViewAnySheet
-      _{MsgCourseMaterialNotFree}
+          _{MsgCourseSheetsFoundHere}: #
+          <a href=@{CourseR tid ssh csh SheetListR}>
+            _{MsgMenuSheetList}
+        $else
+          _{MsgCourseSheetsNoneVisible}
+    $if mayViewMaterials
+      <p>
+        $if mayViewAnyMaterial
+          _{MsgCourseMaterialsFoundHere}: #
+          <a href=@{CourseR tid ssh csh MaterialListR}>
+            _{MsgMenuMaterialList}
+        $else
+          _{MsgCourseMaterialsNoneVisible}
+    <p .explanation>
+      $if courseMaterialFree course
+        _{MsgCourseMaterialFree}
+      $else
+        _{MsgCourseMaterialNotFree}
   
   $if hasExams
     <dt .deflist__dt>_{MsgCourseExams}
@@ -265,7 +282,7 @@ $#    $if NTop (Just 0) < NTop (courseCapacity course)
                     _{MsgCourseEventActions}
                     \ #{iconInvisible}
             <tbody>
-              $forall (cID, CourseEvent{courseEventType, courseEventTime, courseEventRoom, courseEventNote}) <- events
+              $forall (cID, CourseEvent{courseEventType, courseEventTime, courseEventRoom, courseEventNote}, showRoom) <- events
                 <tr .table__row ##{"event-" <> toPathPiece cID}>
                   <td .table__td>
                     <div .table__td-content>
@@ -274,8 +291,15 @@ $#    $if NTop (Just 0) < NTop (courseCapacity course)
                     <div .table__td-content>
                       ^{occurrencesWidget courseEventTime}
                   <td .table__td>
-                    <div .table__td-content>
+                    $if showRoom
-                      #{courseEventRoom}
+                      <div .table__td-content>
+                        $maybe room <- courseEventRoom
+                          ^{roomReferenceWidget room}
+                        $nothing
+                          _{MsgCourseEventRoomIsUnset}
+                    $else
+                      <div .table__td-content .explanation>
+                        _{MsgCourseEventRoomIsHidden}
                   <td .table__td :hiddenEventNotes:.course-event-note--hidden>
                     <div .table__td-content>
                       #{courseEventNote}

templates/exam-show.hamlet

@@ -81,7 +81,7 @@ $maybe desc <- examDescription
         ^{notificationPersonalIdentification}
     $maybe room <- examRoom
       <dt .deflist__dt>_{MsgExamRoom}
-      <dd .deflist__dd>#{room}
+      <dd .deflist__dd>^{roomReferenceWidget room}
     $if examTimes
       <dt .deflist__dt>_{MsgExamTime}
       <dd .deflist__dd>
@@ -204,14 +204,22 @@ $if not (null occurrences)
               \ ^{isVisible False}
           <th .table__th>_{MsgExamRoomDescription}
       <tbody>
-        $forall (occurrence, registered, rCount) <- occurrences
+        $forall (occurrence, registered, rCount, showRoom) <- occurrences
           $with Entity _occId ExamOccurrence{examOccurrenceName, examOccurrenceRoom, examOccurrenceStart, examOccurrenceEnd, examOccurrenceDescription} <- occurrence
             $with registerWdgt <- registerWidget (Just occurrence)
               <tr .table__row :markUnregisteredOccurrences (Just occurrence) && not registered:.occurrence--not-registered>
                 $if occurrenceNamesShown
                   <td .table__td #exam-occurrence__#{examOccurrenceName}>#{examOccurrenceName}
                 $if is _Nothing examRoom
-                  <td .table__td>#{examOccurrenceRoom}
+                  $if showRoom
+                    <td .table__td>
+                      $maybe room <- examOccurrenceRoom
+                        ^{roomReferenceWidget room}
+                      $nothing
+                        _{MsgExamOccurrenceRoomIsUnset}
+                  $else
+                    <td .table__td .explanation>
+                      _{MsgExamOccurrenceRoomIsHidden}
                 $if not examTimes
                   <td .table__td>
                     ^{formatTimeRangeW SelFormatDateTime examOccurrenceStart examOccurrenceEnd}

templates/i18n/changelog/fix-personalised-sheet-files-keep.de-de-formal.hamlet

@@ -0,0 +1,2 @@
+$newline never
+„Bestehende Dateien behalten“ für personalisierte Angabe-Dateien funktioniert nun wie erwartet

templates/i18n/changelog/fix-personalised-sheet-files-keep.en-eu.hamlet

@@ -0,0 +1,2 @@
+$newline never
+“Keep existing files” for personalised sheet files now works as expected

templates/i18n/changelog/materials-video-streaming.de-de-formal.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Als Kursmaterial hochgeladene Videos können jetzt direkt in Uni2work gestreamt, statt nur komplett heruntergeladen, werden.

templates/i18n/changelog/materials-video-streaming.en-eu.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Videos uploaded as course material can now be streamed directly in Uni2work. Previously they could only be downloaded completely.

templates/i18n/changelog/stored-markup.de-de-formal.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Html-Felder speichern nun den genauen Markdown-Eingabetext, sodass erneutes Editieren nicht mehr zu verändertem oder invaliden Markup führen sollte.

templates/i18n/changelog/stored-markup.en-eu.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Html fields now store the exact markdown input. Therefore repeated editing should no longer result in changed or invalid markup.