refactor(occurrences): remove RoomReference from model and add migration

models/courses.model

@@ -30,7 +30,6 @@ Course    -- Information about a single course; contained info is always visible
 CourseEvent
     type            (CI Text)
     course          CourseId OnDeleteCascade OnUpdateCascade    
-    room            RoomReference Maybe
     roomHidden      Bool default=false
     time            (JSONB Occurrences)
     note            StoredMarkup Maybe

models/tutorials.model

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

src/Handler/Course/Events/Delete.hs

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

src/Handler/Course/Events/Edit.hs

@@ -26,7 +26,6 @@ postCEvEditR tid ssh csh cID = do
       replace eId CourseEvent
         { courseEventCourse
         , courseEventType = cefType
-        , courseEventRoom = cefRoom
         , courseEventRoomHidden = cefRoomHidden
         , courseEventTime = cefTime & JSONB
         , courseEventNote = cefNote

src/Handler/Course/Events/Form.hs

@@ -17,7 +17,6 @@ import qualified Database.Esqueleto.Legacy as E
 
 data CourseEventForm = CourseEventForm
   { cefType             :: CI Text
-  , cefRoom             :: Maybe RoomReference
   , cefRoomHidden       :: Bool
   , cefTime             :: Occurrences
   , cefNote             :: Maybe StoredMarkup
@@ -37,14 +36,12 @@ courseEventForm template = identifyForm FIDCourseEvent . renderWForm FormStandar
   let courseEventTypes = optionsPairs [ (courseEventType, courseEventType) | Entity _ CourseEvent{..} <- existingEvents ]
 
   cefType' <- wreq (textField & cfStrip & cfCI & addDatalist courseEventTypes) (fslI MsgCourseEventType & addPlaceholder (mr MsgCourseEventTypePlaceholder)) (cefType <$> 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'
@@ -52,7 +49,6 @@ courseEventForm template = identifyForm FIDCourseEvent . renderWForm FormStandar
 courseEventToForm :: CourseEvent -> CourseEventForm
 courseEventToForm CourseEvent{..} = CourseEventForm
   { cefType = courseEventType
-  , cefRoom = courseEventRoom
   , cefRoomHidden = courseEventRoomHidden
   , cefTime = courseEventTime & unJSONB
   , cefNote = courseEventNote

src/Handler/Course/Events/New.hs

@@ -24,7 +24,6 @@ postCEventsNewR tid ssh csh = do
       eId <- insert CourseEvent
         { courseEventCourse      = cid
         , courseEventType        = cefType
-        , courseEventRoom        = cefRoom
         , courseEventRoomHidden  = cefRoomHidden
         , courseEventTime        = cefTime & JSONB
         , courseEventNote        = cefNote

src/Handler/Course/ParticipantInvite.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022-23 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Steffen Jost <s.jost@fraport.de>
+-- SPDX-FileCopyrightText: 2022-24 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Steffen Jost <s.jost@fraport.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -384,7 +384,6 @@ upsertNewTutorial cid newTutorialName newTutorialType newFirstDay = runDB $ do
           , tutorialCourse          = cid
           , tutorialType            = fromMaybe defaultTutorialType newTutorialType
           , tutorialCapacity        = Nothing
-          , tutorialRoom            = Nothing
           , tutorialRoomHidden      = False
           , tutorialTime            = mempty
           , tutorialRegGroup        = Nothing

src/Handler/Course/Show.hs

@@ -180,9 +180,6 @@ getCShowR tid ssh csh = do
                            <li>
                              ^{nameEmailWidget' tutor}
                      |]
-          , sortable (Just "room") (i18nCell MsgTableTutorialRoom) $ \res -> if -- TODO REMOVE
-              | res ^. resultHideRoom . _not -> maybe (i18nCell MsgTableTutorialRoomIsUnset) roomReferenceCell $ views (resultTutorial . _entityVal) tutorialRoom res
-              | otherwise -> i18nCell MsgTableTutorialRoomIsHidden & addCellClass ("explanation" :: Text)
           , sortable Nothing (i18nCell MsgTableTutorialTime) $ \res ->
               let roomHidden = res ^. resultHideRoom
                   ttime      = res ^. resultTutorial . _entityVal . _tutorialTime
@@ -223,7 +220,6 @@ getCShowR tid ssh csh = do
           [ ("type", SortColumn $ \tutorial -> tutorial E.^. TutorialType )
           , ("name", SortColumn $ \tutorial -> tutorial E.^. TutorialName )
           , ("first-day", SortColumnNullsInv  $ \tutorial -> tutorial E.^. TutorialFirstDay )
-          , ("room", SortColumn $ \tutorial -> tutorial E.^. TutorialRoom )
           , ("register-from", SortColumn $ \tutorial -> tutorial E.^. TutorialRegisterFrom )
           , ("register-to", SortColumn $ \tutorial -> tutorial E.^. TutorialRegisterTo )
           , ("deregister-until", SortColumn $ \tutorial -> tutorial E.^. TutorialDeregisterUntil )

src/Handler/Course/User.hs

@@ -444,13 +444,11 @@ courseUserTutorialsSection (Entity cid Course{..}) (Entity uid _) = do
                     <li>
                       ^{userEmailWidget usr}
               |]
-          , sortable (Just "room") (i18nCell MsgTableTutorialRoom) $ maybe (i18nCell MsgTableTutorialRoomIsUnset) roomReferenceCell . view (_dbrOutput . _1 . _entityVal . _tutorialRoom)
           , sortable Nothing (i18nCell MsgTableTutorialTime) $ occurrencesCell False . view (_dbrOutput . _1 . _entityVal . _tutorialTime)
           ]
         dbtSorting = mconcat
           [ singletonMap "type" . SortColumn $ \(tutorial `E.InnerJoin` _) -> tutorial E.^. TutorialType
           , singletonMap "name" . SortColumn $ \(tutorial `E.InnerJoin` _) -> tutorial E.^. TutorialName
-          , singletonMap "room" . SortColumn $ \(tutorial `E.InnerJoin` _) -> tutorial E.^. TutorialRoom
           , singletonMap "tutors" . SortColumn $ \(tutorial `E.InnerJoin` _) -> E.subSelectMaybe . E.from $ \(tutor `E.InnerJoin` user) -> do
               E.on $ tutor E.^. TutorUser E.==. user E.^. UserId
               E.where_ $ tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial

src/Handler/Tutorial/Edit.hs

@@ -37,7 +37,6 @@ postTEditR tid ssh csh tutn = do
         { tfName            = tutorialName
         , tfType            = tutorialType
         , tfCapacity        = tutorialCapacity
-        , tfRoom            = tutorialRoom
         , tfRoomHidden      = tutorialRoomHidden
         , tfTime            = tutorialTime & unJSONB
         , tfRegGroup        = tutorialRegGroup
@@ -62,7 +61,6 @@ postTEditR tid ssh csh tutn = do
         , tutorialCourse          = cid
         , tutorialType            = tfType
         , tutorialCapacity        = tfCapacity
-        , tutorialRoom            = tfRoom
         , tutorialRoomHidden      = tfRoomHidden
         , tutorialTime            = tfTime & JSONB
         , tutorialRegGroup        = tfRegGroup

src/Handler/Tutorial/Form.hs

@@ -25,7 +25,6 @@ data TutorialForm = TutorialForm
   , tfRegGroup        :: Maybe (CI Text)
   , tfTutorControlled :: Bool
   , tfCapacity        :: Maybe Int
-  , tfRoom            :: Maybe RoomReference
   , tfRoomHidden      :: Bool
   , tfTime            :: Occurrences
   , tfRegisterFrom    :: Maybe UTCTime
@@ -75,7 +74,6 @@ 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)
-    <*> roomReferenceFormOpt (fslI MsgTableTutorialRoom) (tfRoom <$> template)
     <*> apopt checkBoxField (fslI MsgTableTutorialRoomHidden & setTooltip MsgTutorialRoomHiddenTip) (tfRoomHidden <$> template <|> Just False)
     <*> occurrencesAForm ("occurrences" :: Text) (tfTime <$> template)
     <*> aopt utcTimeField   (fslpI MsgRegisterFrom (mr MsgTutorialDate)

src/Handler/Tutorial/List.hs

@@ -61,9 +61,6 @@ getCTutorialListR tid ssh csh = do
                      |]
           , 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) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybe mempty (textCell . tshow) tutorialCapacity
-          , sortable (Just "room") (i18nCell MsgTableTutorialRoom) $ \res -> if -- TODO REMOVE
-              | res ^. resultHideRoom . _not -> cellMaybe roomReferenceCell $ views (resultTutorial . _entityVal) tutorialRoom res
-              | otherwise -> i18nCell MsgTableTutorialRoomIsHidden & addCellClass ("explanation" :: Text)
           , sortable Nothing (i18nCell MsgTableTutorialTime) $ \res ->
               let roomHidden = res ^. resultHideRoom
                   ttime      = res ^. resultTutorial . _entityVal . _tutorialTime
@@ -92,7 +89,6 @@ getCTutorialListR tid ssh csh = do
                                                         in participantCount
             )
           , ("capacity", SortColumn $ \tutorial -> tutorial E.^. TutorialCapacity )
-          , ("room", SortColumn $ \tutorial -> tutorial E.^. TutorialRoom )
           , ("register-group", SortColumn $ \tutorial -> tutorial E.^. TutorialRegGroup )
           , ("register-from"    , SortColumnNullsInv $ \tutorial -> tutorial E.^. TutorialRegisterFrom )
           , ("register-to"      , SortColumnNullsInv $ \tutorial -> tutorial E.^. TutorialRegisterTo )

src/Handler/Tutorial/New.hs

@@ -33,7 +33,6 @@ postCTutorialNewR tid ssh csh = do
         , tutorialCourse          = cid
         , tutorialType            = tfType
         , tutorialCapacity        = tfCapacity
-        , tutorialRoom            = tfRoom
         , tutorialRoomHidden      = tfRoomHidden
         , tutorialTime            = JSONB tfTime
         , tutorialRegGroup        = tfRegGroup

src/Handler/Utils/Form/Occurrences.hs

@@ -61,7 +61,9 @@ occurrencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do
                                 <$> apreq (selectField' Nothing optionsFinite) (fslI MsgOccurrenceWeekDay & addName (nudge "occur-week-day")) Nothing
                                 <*> apreq timeFieldTypeTime (fslI MsgOccurrenceStart & addName (nudge "occur-start")) Nothing
                                 <*> apreq timeFieldTypeTime (fslI MsgOccurrenceEnd & addName (nudge "occur-end")) Nothing
-                                <*> roomReferenceFormOpt (fslI MsgTableTutorialRoom) Nothing
+                                -- DEBUG TODO
+                                -- <*> roomReferenceFormOpt (fslI MsgTableTutorialRoom) Nothing
+                                <*> pure Nothing
                             )
                           ]
             ) (fslI MsgScheduleRegularKind & addName (nudge "kind")) Nothing
@@ -98,7 +100,9 @@ occurrencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do
                                 <$> apreq dayField (fslI MsgDay & addName (nudge "occur-day")) Nothing
                                 <*> apreq timeFieldTypeTime (fslI MsgOccurrenceStart & addName (nudge "occur-start")) Nothing
                                 <*> apreq timeFieldTypeTime (fslI MsgOccurrenceEnd & addName (nudge "occur-end")) Nothing
+                                -- DEBUG TODO
                                 <*> roomReferenceFormOpt (fslI MsgTableTutorialRoom) Nothing
+                                -- <*> pure Nothing
                             )
                           , ( ExceptionKindNoOccur
                             , ExceptNoOccur

src/Model/Migration/Definitions.hs

@@ -51,6 +51,7 @@ data ManualMigration
   | Migration20230703LmsUserStatus
   | Migration20240212InitInterfaceHealth        -- create table interface_health and fill with default values
   | Migration20240224UniquenessCompanyAvsNr
+  | Migration20240930RoomOccurrences            -- rooms become a part of occurrences
   deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
   deriving anyclass (Universe, Finite)
 
@@ -204,6 +205,81 @@ customMigrations = mapF $ \case
         ALTER TABLE "company" DROP CONSTRAINT IF EXISTS "unique_company_shorthand";
       |]
 
+  Migration20240930RoomOccurrences -> do
+    whenM (tableColumnExists "tutorial" "room")
+      [executeQQ|
+        WITH updated_scheduled AS (
+            SELECT id
+                , jsonb_agg(
+                    CASE
+                        WHEN jsonb_exists(elem, 'room') THEN elem
+                        ELSE jsonb_set(elem, '{room}', to_jsonb(t.room))
+                    END
+                ) AS new_scheduled
+            FROM tutorial AS t
+            CROSS JOIN jsonb_array_elements(t."time"->'scheduled') AS elem
+            GROUP BY t.id, t.room
+        ), updated_exceptions AS (
+            SELECT id
+                , jsonb_agg(
+                    CASE
+                        WHEN jsonb_exists(elem, 'room') THEN elem
+                        ELSE jsonb_set(elem, '{room}', to_jsonb(t.room))
+                    END
+                ) AS new_exceptions
+            FROM tutorial AS t
+            CROSS JOIN jsonb_array_elements(t."time"->'exceptions') AS elem
+            GROUP BY t.id, t.room
+        )
+        UPDATE tutorial AS t
+        SET "time" = jsonb_set(
+                        jsonb_set(t."time", '{scheduled}', us.new_scheduled),
+                        '{exceptions}', ue.new_exceptions
+                    )
+        FROM updated_scheduled AS us JOIN updated_exceptions AS ue ON us.id = ue.id
+        WHERE t.id = us.id
+        ;
+
+        ALTER TABLE "tutorial" DROP COLUMN "room";
+      |]
+
+    whenM (tableColumnExists "course_event" "room")
+      [executeQQ|
+        WITH updated_scheduled AS (
+            SELECT id
+                , jsonb_agg(
+                    CASE
+                        WHEN jsonb_exists(elem, 'room') THEN elem
+                        ELSE jsonb_set(elem, '{room}', to_jsonb(t.room))
+                    END
+                ) AS new_scheduled
+            FROM course_event AS t
+            CROSS JOIN jsonb_array_elements(t."time"->'scheduled') AS elem
+            GROUP BY t.id, t.room
+        ), updated_exceptions AS (
+            SELECT id
+                , jsonb_agg(
+                    CASE
+                        WHEN jsonb_exists(elem, 'room') THEN elem
+                        ELSE jsonb_set(elem, '{room}', to_jsonb(t.room))
+                    END
+                ) AS new_exceptions
+            FROM course_event AS t
+            CROSS JOIN jsonb_array_elements(t."time"->'exceptions') AS elem
+            GROUP BY t.id, t.room
+        )
+        UPDATE course_event AS t
+        SET "time" = jsonb_set(
+                        jsonb_set(t."time", '{scheduled}', us.new_scheduled),
+                        '{exceptions}', ue.new_exceptions
+                    )
+        FROM updated_scheduled AS us JOIN updated_exceptions AS ue ON us.id = ue.id
+        WHERE t.id = us.id
+        ;
+
+        ALTER TABLE "course_event" DROP COLUMN "room";
+      |]
+
 
 tableExists :: MonadIO m => Text -> ReaderT SqlBackend m Bool
 tableExists table = do
@@ -239,6 +315,13 @@ columnExists table column = do
     [_]    -> return True
     _other -> return False
 
+-- | checks table existence before checking column existence to avoid errors
+tableColumnExists :: MonadIO m
+             => Text -- ^ Table
+             -> Text -- ^ Column
+             -> ReaderT SqlBackend m Bool
+tableColumnExists table column = and2M (tableExists table) (columnExists table column)
+
 -- | equivalent to andM [ tableExists, not <$> columnExists]
 columnNotExists :: MonadIO m
              => Text -- ^ Table

templates/course.hamlet

@@ -239,8 +239,6 @@ $#    $if NTop (Just 0) < NTop (courseCapacity course)
                   _{MsgCourseEventType}
                 <th .table__th uw-hide-column-header="time">
                   _{MsgCourseEventTime}
-                <th .table__th uw-hide-column-header="room">
-                  _{MsgCourseEventRoom}
                 <th .table__th uw-hide-column-header="note" :hiddenEventNotes:.course-event-note--hidden>
                   _{MsgCourseEventNote}
                 $if mayCreateEvents
@@ -248,7 +246,7 @@ $#    $if NTop (Just 0) < NTop (courseCapacity course)
                     _{MsgCourseEventActions}
                     \ #{iconInvisible}
             <tbody>
-              $forall (cID, CourseEvent{courseEventType, courseEventTime, courseEventRoom, courseEventNote}, showRoom) <- events
+              $forall (cID, CourseEvent{courseEventType, courseEventTime, courseEventNote}, showRoom) <- events
                 <tr .table__row ##{"event-" <> toPathPiece cID}>
                   <td .table__td>
                     <div .table__td-content>
@@ -256,16 +254,6 @@ $#    $if NTop (Just 0) < NTop (courseCapacity course)
                   <td .table__td>
                     <div .table__td-content>
                       ^{occurrencesWidget (not showRoom) courseEventTime}
-                  <td .table__td>
-                    $if showRoom
-                      <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/widgets/occurrence/cell/weekly.hamlet

@@ -1,9 +1,11 @@
 $newline never
 
-$# SPDX-FileCopyrightText: 2022 Sarah Vaupel <vaupel.sarah@campus.lmu.de>
+$# SPDX-FileCopyrightText: 2022-24 Sarah Vaupel <vaupel.sarah@campus.lmu.de>, Steffen Jost <s.jost@fraport.de>
 $#
 $# SPDX-License-Identifier: AGPL-3.0-or-later
 
 _{ShortWeekDay scheduleDayOfWeek} #{scheduleStart'}–#{scheduleEnd'} 
-$if not roomHidden
+$if roomHidden
+  _{MsgTableTutorialRoomIsHidden}
+$else 
   ^{foldMap roomReferenceWidget scheduleRoom}

test/Database/Fill.hs

@@ -1005,7 +1005,6 @@ fillDb = do
          firstDay  = utctDay $ termTime tid TermDayLectureStart 0 Nothing toMidnight
          secondDay = utctDay $ termTime tid TermDayLectureStart 1 Nothing toMidnight
          tyear = year tid
-         weekDay = dayOfWeek firstDay
          -- thirdDay  = utctDay $ termTime tid TermDayLectureStart 2 Nothing toMidnight
          capacity = Just 8
          mkName = CI.mk
@@ -1068,12 +1067,6 @@ fillDb = do
           , tutorialCourse = c
           , tutorialType = "Schulung"
           , tutorialCapacity = capacity
-          , tutorialRoom = Just $ case weekDay of
-                Monday -> "A380"
-                Tuesday -> "B747"
-                Wednesday -> "MD11"
-                Thursday -> "A380"
-                _ -> "B777"
           , tutorialRoomHidden = False
           , tutorialTime = JSONB $ Occurrences
             { occurrencesScheduled = Set.fromList
@@ -1131,12 +1124,6 @@ fillDb = do
           , tutorialCourse = c
           , tutorialType = "Vorlage"
           , tutorialCapacity = capacity
-          , tutorialRoom = Just $ case weekDay of
-                Monday -> "A380"
-                Tuesday -> "B747"
-                Wednesday -> "MD11"
-                Thursday -> "A380"
-                _ -> "B777"
           , tutorialRoomHidden = False
           , tutorialTime = JSONB $ Occurrences
             { occurrencesScheduled = Set.empty
@@ -1180,13 +1167,7 @@ fillDb = do
           , tutorialCourse = c
           , tutorialType = "Vorlage_Sondertutorium"
           , tutorialCapacity = capacity
-          , tutorialRoom = Just $ case weekDay of
+          , tutorialRoomHidden = True
-                Monday -> "A380"
-                Tuesday -> "B747"
-                Wednesday -> "MD11"
-                Thursday -> "A380"
-                _ -> "B777"
-          , tutorialRoomHidden = False
           , tutorialTime = JSONB $ Occurrences
             { occurrencesScheduled = Set.empty
             , occurrencesExceptions = Set.fromList
@@ -1194,13 +1175,13 @@ fillDb = do
                     { exceptDay   = succ $ succ firstDay
                     , exceptStart = TimeOfDay  8  25  0
                     , exceptEnd   = TimeOfDay 16  25  0
-                    , exceptRoom  = Nothing
+                    , exceptRoom  = Just $ RoomReferenceSimple "E175"
                     }
                 , ExceptOccur
                     { exceptDay   = succ $ succ $ succ $ succ firstDay
                     , exceptStart = TimeOfDay  9  20  0
                     , exceptEnd   = TimeOfDay 16  20  0
-                    , exceptRoom  = Nothing
+                    , exceptRoom  = Just $ RoomReferenceSimple "LJ45"
                     }
                 , ExceptOccur
                     { exceptDay   = succ $ succ secondDay