feat(rooms): different room types & hidden rooms

frontend/src/utils/inputs/inputs.sass

@@ -255,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

@@ -1694,10 +1694,14 @@ 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
-TutorialRegisterFrom: Anmeldungen ab
+TutorialRegisterFrom: Anmeldungen a
 TutorialRegisterTo: Anmeldungen bis
 TutorialDeregisterUntil: Abmeldungen bis
 TutorialsHeading: Tutorien
@@ -1843,6 +1847,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
@@ -1851,6 +1857,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
@@ -2579,6 +2587,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
@@ -2934,4 +2946,16 @@ InvalidCredentialsADAccountLockedOut: Benutzereintrag wurde durch Eindringlingse
 ExamCloseModeSeparate: Separat
 ExamCloseModeOnFinished: Mit Veröffentlichung
 ExamCloseModeOnFinishedHidden: Mit Veröffentlichung (versteckt)
-ExamCloseMode: Prüfungs-Abschluss
+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

@@ -1693,6 +1693,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
@@ -1842,6 +1846,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
@@ -1850,6 +1856,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
@@ -2579,6 +2587,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
@@ -2936,3 +2948,15 @@ 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/courses.model

@@ -6,7 +6,7 @@ DegreeCourse json   -- for which degree programmes this course is appropriate fo
 Course    -- Information about a single course; contained info is always visible to all users
     name             (CI Text)
     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
@@ -31,7 +31,8 @@ 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 StoredMarkup Maybe
     lastChanged UTCTime default=now()

models/exams.model

@@ -31,7 +31,8 @@ ExamPart
 ExamOccurrence
   exam ExamId
   name ExamOccurrenceName
-  room Text
+  room RoomReference Maybe
+  roomHidden Bool default=false
   capacity Natural
   start UTCTime
   end UTCTime Maybe

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

package.yaml

@@ -154,6 +154,7 @@ dependencies:
   - network-ip
   - data-textual
   - fastcdc
+  - network-uri
 
 other-extensions:
   - GeneralizedNewtypeDeriving
@@ -315,6 +316,7 @@ tests:
       - http-types
       - yesod-persistent
       - quickcheck-io
+      - network-arbitrary
     ghc-options:
       - -fno-warn-orphans
       - -threaded -rtsopts "-with-rtsopts=-N -T"

src/Database/Esqueleto/Utils.hs

@@ -364,17 +364,20 @@ 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 ->.
 

src/Foundation/I18n.hs

@@ -226,11 +226,14 @@ embedRenderMessage ''UniWorX ''ExamOnlinePreset id
 embedRenderMessage ''UniWorX ''ExamSynchronicityPreset id
 embedRenderMessage ''UniWorX ''ExamRequiredEquipmentPreset id
 embedRenderMessage ''UniWorX ''ChangelogItemKind id
+embedRenderMessage ''UniWorX ''RoomReference' $ dropSuffix "'"
 
 embedRenderMessage ''UniWorX ''AuthenticationMode id
 
 embedRenderMessage ''UniWorX ''RatingValidityException id
 
+embedRenderMessage ''UniWorX ''UrlFieldMessage id
+
 embedRenderMessageVariant ''UniWorX ''ADInvalidCredentials ("InvalidCredentials" <>)
 
 newtype ShortSex = ShortSex Sex

src/Handler/Course/Edit.hs

@@ -35,7 +35,7 @@ data CourseForm = CourseForm
         , cfSchool      :: SchoolId
         , cfTerm        :: TermId
         , cfDesc        :: Maybe StoredMarkup
-        , cfLink        :: Maybe Text
+        , cfLink        :: Maybe URI
         , cfVisFrom     :: Maybe UTCTime
         , cfVisTo       :: Maybe UTCTime
         , cfMatFree     :: Bool
@@ -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,7 +13,8 @@ import qualified Database.Esqueleto as E
 
 data CourseEventForm = CourseEventForm
   { cefType             :: CI Text
-  , cefRoom             :: Text
+  , cefRoom             :: Maybe RoomReference
+  , cefRoomHidden       :: Bool
   , cefTime             :: Occurrences
   , cefNote             :: Maybe StoredMarkup
   }
@@ -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/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
 
@@ -93,8 +95,10 @@ getCShowR tid ssh csh = do
 
       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
@@ -147,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
@@ -167,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)
@@ -181,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
@@ -232,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

@@ -460,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/Exam/Edit.hs

@@ -59,6 +59,7 @@ postEEditR tid ssh csh examn = do
               { examOccurrenceExam = eId
               , examOccurrenceName = eofName
               , examOccurrenceRoom = eofRoom
+              , examOccurrenceRoomHidden = eofRoomHidden
               , examOccurrenceCapacity = eofCapacity
               , examOccurrenceStart = eofStart
               , examOccurrenceEnd = eofEnd
@@ -73,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

@@ -54,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 StoredMarkup
-  } deriving (Read, Show, Eq, Generic, Typeable)
+  } deriving (Show, Eq, Generic, Typeable)
 
 instance Ord ExamOccurrenceForm where
   compare = mconcat
@@ -69,6 +70,7 @@ instance Ord ExamOccurrenceForm where
     , comparing eofEnd
     , comparing eofCapacity
     , comparing eofDescription
+    , comparing eofRoomHidden
     , comparing eofId
     ]
 
@@ -221,7 +223,11 @@ 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)
@@ -231,6 +237,7 @@ examOccurrenceForm prev = wFormToAForm $ do
                  <$> eofIdRes
                  <*> eofNameRes
                  <*> eofRoomRes
+                 <*> eofRoomHiddenRes
                  <*> eofCapacityRes
                  <*> eofStartRes
                  <*> eofEndRes
@@ -327,6 +334,7 @@ examFormTemplate (Entity eId Exam{..}) = do
           { eofId
           , eofName        = examOccurrenceName
           , eofRoom        = examOccurrenceRoom
+          , eofRoomHidden  = examOccurrenceRoomHidden
           , eofCapacity    = examOccurrenceCapacity
           , eofStart       = examOccurrenceStart
           , eofEnd         = examOccurrenceEnd
@@ -429,7 +437,8 @@ 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

src/Handler/Exam/New.hs

@@ -68,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
 
@@ -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/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/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/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/Form.hs

@@ -2175,3 +2175,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/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/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
          )
@@ -133,6 +133,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 ()
@@ -179,6 +181,7 @@ import Control.Monad.Trans.Memo.StateCache.Instances as Import (hoistStateCache)
 import Database.Persist.Sql.Types.Instances as Import ()
 import Control.Monad.Catch.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/Model/Migration.hs

@@ -992,6 +992,7 @@ customMigrations = Map.fromListWith (>>)
     )
   , ( 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);
@@ -1009,8 +1010,49 @@ customMigrations = Map.fromListWith (>>)
         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,4 @@ import Model.Types.File as Types
 import Model.Types.User as Types
 import Model.Types.Changelog as Types
 import Model.Types.Markup as Types
+import Model.Types.Room as Types

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/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
 
@@ -55,7 +55,7 @@ import Data.Proxy
 
 import Data.Monoid (Endo(..))
 
-
+import Network.URI (URI, parseURI, uriToString)
 
 
 --------------------
@@ -824,6 +824,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 --
@@ -869,9 +879,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
@@ -879,6 +894,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/Lens.hs

@@ -237,6 +237,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

stack.yaml

@@ -78,6 +78,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

@@ -380,6 +380,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}
@@ -282,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>
@@ -291,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/widgets/aform/aform.hamlet

@@ -9,16 +9,16 @@ $case formLayout
   $of _
     $forall view <- fieldViews
       $if fvId view == idFormSectionNoinput
-        <h3 .form-section-title>
+        <h3 .form-section-title :isFormVertical:.form--vertical>
           ^{fvLabel view}
         $maybe hint <- fvTooltip view
-          <div .form-section-title__hint>
+          <div .form-section-title__hint :isFormVertical:.form--vertical>
             ^{hint}
       $elseif fvId view == idFormMessageNoinput
-        <div .form-section-notification>
+        <div .form-section-notification :isFormVertical:.form--vertical>
           ^{fvInput view}
       $else
-        <div .form-group .interactive-fieldset__target :fvRequired view:.form-group--required :not $ fvRequired view:.form-group--optional :isJust $ fvErrors view:.form-group--has-error>
+        <div .form-group .interactive-fieldset__target :fvRequired view:.form-group--required :not $ fvRequired view:.form-group--optional :isJust $ fvErrors view:.form-group--has-error :isFormVertical:.form--vertical>
           $if not (Blaze.null $ fvLabel view)
             <label .form-group-label for=#{fvId view}>
               <span .form-group-label__caption>
@@ -30,7 +30,7 @@ $case formLayout
             $maybe err <- fvErrors view
               <div .form-error>
                 #{err}
-    $if formHasRequiredFields
+    $if formHasRequiredFields && not isFormVertical
       <div .form-section-legend>
         <span .form-group__required-marker>
         _{MsgAFormFieldRequiredTip}

templates/widgets/exam-occurrence-mapping.hamlet

@@ -36,7 +36,10 @@ $newline never
           $maybe mappingWgt <- occMapping occId
             ^{mappingWgt}
         <td .table__td>
-          #{examOccurrenceRoom}
+          $maybe room <- examOccurrenceRoom
+            ^{roomReferenceWidget room}
+          $nothing
+            _{MsgExamOccurrenceRoomIsUnset}
         <td .table__td>
           ^{formatTimeRangeW SelFormatDateTime examOccurrenceStart examOccurrenceEnd}
         <td .table__td>

templates/widgets/massinput/examRooms/form.hamlet

@@ -1,7 +1,7 @@
 $newline never
-<td>#{csrf}^{fvInput eofIdView}^{fvWidget eofNameView}
+<td .form--vertical__cell>#{csrf}^{fvInput eofIdView}^{fvWidget eofNameView}
-<td>^{fvWidget eofRoomView}
+<td .form--vertical__cell>^{eofRoomView}
-<td>^{fvWidget eofCapacityView}
+<td .form--vertical__cell>^{fvWidget eofCapacityView}
-<td>^{fvWidget eofStartView}
+<td .form--vertical__cell>^{fvWidget eofStartView}
-<td>^{fvWidget eofEndView}
+<td .form--vertical__cell>^{fvWidget eofEndView}
-<td>^{fvWidget eofDescView}
+<td .form--vertical__cell>^{fvWidget eofDescView}

templates/widgets/massinput/examRooms/layout.hamlet

@@ -6,8 +6,7 @@ $newline never
         _{MsgExamRoomName} #
         <span .form-group__required-marker>
       <th>
-        _{MsgExamRoom} #
+        _{MsgExamRoom}
-        <span .form-group__required-marker>
       <th>
         _{MsgExamRoomCapacity} #
         <span .form-group__required-marker>

templates/widgets/room-reference/link-instructions-modal.hamlet

@@ -0,0 +1,11 @@
+$newline never
+<dl .deflist>
+  <dt .deflist__dt>
+    _{MsgRoomReferenceLinkLink}
+  <dd .deflist__dd>
+    <a href=#{linkText}>
+      #{linkText}
+  <dt .deflist__dt>
+    _{MsgRoomReferenceLinkInstructions}
+  <dd .deflist__dd>
+    #{roomRefInstructions}

templates/widgets/room-reference/link.hamlet

@@ -0,0 +1,5 @@
+$newline never
+<a href=#{linkText}>
+  _{MsgRoomReferenceLinkLink}
+$if is _Just roomRefInstructions
+  , ^{instrModal}

test/Database/Fill.hs

@@ -909,6 +909,7 @@ fillDb = do
     , tutorialType = "Tutorium"
     , tutorialCapacity = Just 30
     , tutorialRoom = Just "Hilbert-Raum"
+    , tutorialRoomHidden = True
     , tutorialTime = Occurrences
       { occurrencesScheduled = Set.singleton $ ScheduleWeekly Tuesday (TimeOfDay 08 15 00) (TimeOfDay 10 00 00)
       , occurrencesExceptions = Set.empty
@@ -928,6 +929,7 @@ fillDb = do
     , tutorialType = "Tutorium"
     , tutorialCapacity = Just 30
     , tutorialRoom = Just "Hilbert-Raum"
+    , tutorialRoomHidden = True
     , tutorialTime = Occurrences
       { occurrencesScheduled  = Set.singleton $ ScheduleWeekly Tuesday (TimeOfDay 10 15 00) (TimeOfDay 12 00 00)
       , occurrencesExceptions = Set.empty

test/Handler/Exam/FormSpec.hs

@@ -16,6 +16,7 @@ instance Arbitrary ExamOccurrenceForm where
     <*> arbitrary
     <*> arbitrary
     <*> arbitrary
+    <*> arbitrary
 
 instance Arbitrary ExamPartForm where
   arbitrary = ExamPartForm
@@ -30,6 +31,6 @@ spec :: Spec
 spec = do
   parallel $ do
     lawsCheckHspec (Proxy @ExamOccurrenceForm)
-      [ eqLaws, ordLaws, showReadLaws ]
+      [ eqLaws, ordLaws ]
     lawsCheckHspec (Proxy @ExamPartForm)
       [ eqLaws, ordLaws ]

test/Model/TypesSpec.hs

@@ -39,6 +39,8 @@ import qualified Data.ByteString.Lazy as LBS
 
 import qualified Data.CaseInsensitive as CI
 
+import qualified Data.Text.Lazy as LT
+
 
 instance (Arbitrary a, MonoFoldable a) => Arbitrary (NonNull a) where
   arbitrary = arbitrary `suchThatMap` fromNullable
@@ -218,7 +220,7 @@ instance Arbitrary Html where
   shrink = map preEscapedToHtml . shrink . renderHtml
 
 instance Arbitrary StoredMarkup where
-  arbitrary = oneof
+  arbitrary = (`suchThat` (not . null . LT.strip . renderHtml . markupOutput)) $ oneof
     [ htmlToStoredMarkup <$> arbitrary
     , plaintextToStoredMarkup . getPrintableString <$> arbitrary
     ]
@@ -305,6 +307,17 @@ instance Arbitrary ExamCloseMode where
   arbitrary = genericArbitrary
   shrink = genericShrink
 
+instance Arbitrary RoomReference where
+  arbitrary = oneof
+    [ RoomReferenceSimple . pack <$> suchThat (getPrintableString <$> arbitrary) (not . null)
+    , RoomReferenceLink
+      <$> arbitrary
+      <*> arbitrary
+    ]
+
+instance Arbitrary RoomReference' where
+  arbitrary = genericArbitrary
+
 
 spec :: Spec
 spec = do
@@ -403,6 +416,10 @@ spec = do
       [ persistFieldLaws, jsonLaws, eqLaws, ordLaws, showReadLaws, monoidLaws, semigroupLaws, semigroupMonoidLaws, csvFieldLaws ]
     lawsCheckHspec (Proxy @ExamCloseMode)
       [ persistFieldLaws, jsonLaws, eqLaws, ordLaws, showReadLaws, pathPieceLaws, jsonKeyLaws, finiteLaws, httpApiDataLaws, binaryLaws ]
+    lawsCheckHspec (Proxy @RoomReference)
+      [ persistFieldLaws, jsonLaws, eqLaws, ordLaws ]
+    lawsCheckHspec (Proxy @RoomReference')
+      [ eqLaws, ordLaws, finiteLaws, showReadLaws, pathPieceLaws, boundedEnumLaws ]
 
   describe "TermIdentifier" $ do
     it "has compatible encoding/decoding to/from Text" . property $

test/ModelSpec.hs

@@ -84,7 +84,8 @@ instance Arbitrary Tutorial where
     <*> arbitrary
     <*> (CI.mk . pack . getPrintableString <$> arbitrary)
     <*> (fmap getPositive <$> arbitrary)
-    <*> (assertM' (not . null) . pack . getPrintableString <$> arbitrary)
+    <*> arbitrary
+    <*> arbitrary
     <*> arbitrary
     <*> (fmap (CI.mk . pack . getPrintableString) <$> arbitrary)
     <*> arbitrary

test/TestImport.hs

@@ -42,6 +42,7 @@ import Data.UUID as X (UUID)
 import System.IO as X (hPrint, hPutStrLn)
 import Jobs (handleJobs)
 import Numeric.Natural as X
+import Network.URI.Arbitrary as X ()
 
 import Control.Lens as X hiding ((<.), elements)