fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
Steffen Jost 2024-09-30 13:56:45 +02:00
parent e29e6f3db8
commit 83fe750b15
18 changed files with 127 additions and 95 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
models/courses.model
View File

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

1
models/tutorials.model
View File

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

2
src/Handler/Course/Events/Delete.hs
View File

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

1
src/Handler/Course/Events/Edit.hs
View File

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

4
src/Handler/Course/Events/Form.hs
View File

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

1
src/Handler/Course/Events/New.hs
View File

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

3
src/Handler/Course/ParticipantInvite.hs
View File

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

4
src/Handler/Course/Show.hs
View File

@ -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 )

2
src/Handler/Course/User.hs
View File

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

2
src/Handler/Tutorial/Edit.hs
View File

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

2
src/Handler/Tutorial/Form.hs
View File

@ -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)

4
src/Handler/Tutorial/List.hs
View File

@ -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 )

1
src/Handler/Tutorial/New.hs
View File

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

6
src/Handler/Utils/Form/Occurrences.hs
View File

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

83
src/Model/Migration/Definitions.hs
View File

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

14
templates/course.hamlet
View File

@ -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}

6
templates/widgets/occurrence/cell/weekly.hamlet
View File

@ -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}

25
test/Database/Fill.hs
View File

@ -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
Monday -> "A380"
Tuesday -> "B747"
Wednesday -> "MD11"
Thursday -> "A380"
_ -> "B777"
, tutorialRoomHidden = False
, tutorialRoomHidden = True
, 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