refactor(occurrences): fold RoomReference into Occurrences, completed

2024-10-08 13:01:44 +02:00 · 2024-10-08 13:01:44 +02:00 · 56c2be7b79
commit 56c2be7b79
parent 4e171a7a1a
10 changed files with 43 additions and 31 deletions
--- a/messages/uniworx/utils/table_column/de-de-formal.msg
+++ b/messages/uniworx/utils/table_column/de-de-formal.msg
@ -48,11 +48,11 @@ TableNotPassed: Nicht bestanden
 TableTutorialTutors: Ausbilder
 TableTutorialName: Bezeichnung
 TableTutorialType: Art
-TableTutorialRoom: Regulärer Raum
+TableTutorialRoom: Raum
 TableTutorialRoomHidden: Raum nur für Teilnehmer
 TableTutorialRoomIsUnset !ident-ok: —
 TableTutorialRoomIsHidden: Raum wird nur Teilnehmern angezeigt
-TableTutorialTime: Zeit
+TableTutorialOccurrence: Termin
 TableTutorialDeregisterUntil: Abmeldungen bis
 TableTutorialFirstDay: Starttag
 TableActionsHead: Aktionen
--- a/messages/uniworx/utils/table_column/en-eu.msg
+++ b/messages/uniworx/utils/table_column/en-eu.msg
@ -48,14 +48,14 @@ TableNotPassed: Failed
 TableTutorialTutors: Instructors
 TableTutorialName: Name
 TableTutorialType: Type
-TableTutorialRoom: Regular room
+TableTutorialRoom: Room
 TableTutorialRoomHidden: Room only for participants
 TableTutorialRoomIsUnset: —
 TableTutorialRoomIsHidden: Room is only displayed to participants
 TableTutorialDeregisterUntil: Deregister until
 TableTutorialFirstDay: Start date
 TableActionsHead: Actions
-TableTutorialTime: Time
+TableTutorialOccurrence: Session
 TableNoFilter: No restriction
 TableUserMatriculation: AVS number
 TableColumnStudyFeatures: Features of study
--- a/src/Handler/Course/Show.hs
+++ b/src/Handler/Course/Show.hs
@ -180,7 +180,7 @@ getCShowR tid ssh csh = do
                           <li>
                             ^{nameEmailWidget' tutor}
                     |]
-          , sortable Nothing (i18nCell MsgTableTutorialTime) $ \res ->
+          , sortable Nothing (i18nCell MsgTableTutorialOccurrence) $ \res ->
              let roomHidden = res ^. resultHideRoom
                  ttime      = res ^. resultTutorial . _entityVal . _tutorialTime
              in occurrencesCell roomHidden ttime
--- a/src/Handler/Course/User.hs
+++ b/src/Handler/Course/User.hs
@ -444,7 +444,7 @@ courseUserTutorialsSection (Entity cid Course{..}) (Entity uid _) = do
                    <li>
                      ^{userEmailWidget usr}
              |]
-          , sortable Nothing (i18nCell MsgTableTutorialTime) $ occurrencesCell False . view (_dbrOutput . _1 . _entityVal . _tutorialTime)
+          , sortable Nothing (i18nCell MsgTableTutorialOccurrence) $ occurrencesCell False . view (_dbrOutput . _1 . _entityVal . _tutorialTime)
          ]
        dbtSorting = mconcat
          [ singletonMap "type" . SortColumn $ \(tutorial `E.InnerJoin` _) -> tutorial E.^. TutorialType
--- a/src/Handler/Tutorial/List.hs
+++ b/src/Handler/Tutorial/List.hs
@ -61,7 +61,7 @@ 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 Nothing (i18nCell MsgTableTutorialTime) $ \res ->
+          , sortable Nothing (i18nCell MsgTableTutorialOccurrence) $ \res ->
              let roomHidden = res ^. resultHideRoom
                  ttime      = res ^. resultTutorial . _entityVal . _tutorialTime
              in occurrencesCell roomHidden ttime
--- a/src/Handler/Utils/Form.hs
+++ b/src/Handler/Utils/Form.hs
@ -285,7 +285,7 @@ multiActionOpts :: forall action a.
                -> FieldSettings UniWorX
                -> Maybe action
                -> (Html -> MForm Handler (FormResult a, [FieldView UniWorX]))
-multiActionOpts = multiActionOpts' mpreq
+multiActionOpts = multiActionOpts' mpopt

 multiAction' :: forall action a.
                ( RenderMessage UniWorX action, PathPiece action, Ord action )
@ -2348,21 +2348,22 @@ roomReferenceSimpleField =

 roomReferenceSimpleSuggestions :: HandlerFor UniWorX (OptionList Text)
 roomReferenceSimpleSuggestions = do
-  suggsRaw :: [Text] <- $(memcachedByHere) (Just $ Right $ 30 * diffSecond) ("rooms-recently-used"::Text) (E.unSingle  <<$>> runDB
-    [sqlQQ|
-      SELECT room FROM (
-        SELECT DISTINCT ON (room)
-            j.value #>> '{room,text}' AS room
-          , t.@{TutorialLastChanged} AS changed
-        FROM ^{Tutorial} AS t
-          , jsonb_array_elements((@{TutorialTime}->'exceptions') || (@{TutorialTime}->'scheduled')) AS j
-        ORDER BY 1, 2 DESC
-      ) AS sq
-      WHERE room IS NOT NULL
-      ORDER BY changed DESC
-      LIMIT 7;
-    |] )
-  $logDebugS "Room" $ mconcat suggsRaw
+  -- suggsRaw :: [Text] <- $(memcachedByHere) (Just $ Right $ 30 * diffSecond) ("rooms-recently-used"::Text) (E.unSingle <<$>> runDB
+  suggsRaw :: [Text] <- $(memcachedHere) (Just $ Right $ 42 * diffSecond) $ catchAllMonoid $ E.unSingle <<$>> runDB
+      [sqlQQ|
+        SELECT room FROM (
+          SELECT DISTINCT ON (room)
+              j.value #>> '{room,text}' AS room
+            , t.@{TutorialLastChanged} AS changed
+          FROM ^{Tutorial} AS t
+            , jsonb_array_elements((@{TutorialTime}->'exceptions') || (@{TutorialTime}->'scheduled')) AS j
+          ORDER BY 1, 2 DESC
+        ) AS sq
+        WHERE room IS NOT NULL
+        ORDER BY changed DESC
+        LIMIT 7;
+      |]
+  --  $logDebugS "Room" $ mconcat suggsRaw
  return $ mkOptionList $ fmap (\t -> Option t t t) suggsRaw
  -- suggs <- liftHandler $ runDBRead $ E.select $ do
  --       tut <- E.from $ E.table @Tutorial
--- a/src/Handler/Utils/Form/Occurrences.hs
+++ b/src/Handler/Utils/Form/Occurrences.hs
@ -59,9 +59,9 @@ occurrencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do
            (Map.fromList [ ( ScheduleKindWeekly
                            , ScheduleWeekly
                                <$> 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
-                                <*> roomReferenceForm' Nothing (fslI MsgTableTutorialRoom & addName (nudge "occur-room")) Nothing
+                                <*> apreq timeFieldTypeTime (fslI MsgOccurrenceStart   & addName (nudge "occur-start")) Nothing
+                                <*> apreq timeFieldTypeTime (fslI MsgOccurrenceEnd     & addName (nudge "occur-end"  )) Nothing
+                                <*> roomReferenceFormOpt    (fslI MsgTableTutorialRoom & addName (nudge "occur-room" )) (Just Nothing)
                                --   <*> aopt roomReferenceSimpleField (fslI MsgTableTutorialRoom & addName (nudge "occur-room")) (Just Nothing)
                            )
                          ]
@ -97,9 +97,9 @@ occurrencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do
            (Map.fromList [ ( ExceptionKindOccur
                            , ExceptOccur
                                <$> 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
-                                <*> roomReferenceForm' Nothing (fslI MsgTableTutorialRoom & addName (nudge "occur-room")) Nothing
+                                <*> apreq timeFieldTypeTime (fslI MsgOccurrenceStart   & addName (nudge "occur-start"))       Nothing
+                                <*> apreq timeFieldTypeTime (fslI MsgOccurrenceEnd     & addName (nudge "occur-end"  ))       Nothing
+                                <*> roomReferenceFormOpt    (fslI MsgTableTutorialRoom & addName (nudge "occur-room" )) (Just Nothing)
                                --   <*> aopt roomReferenceSimpleField (fslI MsgTableTutorialRoom & addName (nudge "occur-room")) Nothing
                            )
                          , ( ExceptionKindNoOccur
--- a/src/Utils.hs
+++ b/src/Utils.hs
@ -1190,6 +1190,17 @@ maybeCatchAll act = catch act ignore
    ignore :: Monad m => SomeException -> m (Maybe a)
    ignore _ = return Nothing

+-- | Ignore all errors by returning a monadic default value.
+catchAllDefault :: MonadCatch m => m a -> m (Maybe a) -> m a
+catchAllDefault dft = fromMaybeM dft .  maybeCatchAll
+
+-- | Ignore all errors by returning mempty. (Not sure if this function is a good idea)
+catchAllMonoid :: (MonadCatch m, Monoid a) => m a -> m a
+catchAllMonoid act = catch act ignore
+  where
+    ignore :: (Monad m, Monoid a) => SomeException -> m a
+    ignore _ = pure mempty
+
 maybeExceptT :: Monad m => e -> m (Maybe b) -> ExceptT e m b
 maybeExceptT err act = lift act >>= maybe (throwE err) return

--- a/templates/tutorial-participants.hamlet
+++ b/templates/tutorial-participants.hamlet
@ -6,7 +6,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later

 <section>
  <dl .deflist>
-    <dt .deflist__dt>_{MsgTableTutorialTime}
+    <dt .deflist__dt>_{MsgTableTutorialOccurrence}
    <dd .deflist__dd>
      ^{occurrencesWidget tutorialRoomHidden tutorialTime}
    <dt .deflist__dt>_{MsgTableTutorialTutors}
--- a/templates/widgets/occurrence/cell/except-occur.hamlet
+++ b/templates/widgets/occurrence/cell/except-occur.hamlet
@ -5,7 +5,7 @@ $#
 $# SPDX-License-Identifier: AGPL-3.0-or-later

 $if not (null occurrencesScheduled')
-  _{MsgExceptionKindOccur}: #{exceptStart'}–#{exceptEnd'} 
+  _{MsgExceptionKindOccur} #{exceptStart'}–#{exceptEnd'} 
  $if not roomHidden
    ^{foldMap roomReferenceWidget exceptRoom}
 $else