diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index 08f24cc72..5d44d8987 100644 --- a/src/Handler/School/DayTasks.hs +++ b/src/Handler/School/DayTasks.hs @@ -76,7 +76,7 @@ data OccurrenceCacheKey = OccurrenceCacheKeyTutorials SchoolId (Day,Day) getDayTutorials :: SchoolId -> (Day,Day) -> DB [TutorialId] getDayTutorials ssh dlimit@(dstart, dend ) | dstart > dend = return mempty - | otherwise = memcachedByClass MemcachedKeyClassTutorialOccurrences (Just . Right $ 9 * diffDay) (OccurrenceCacheKeyTutorials ssh dlimit) $ do + | otherwise = memcachedByClass MemcachedKeyClassTutorialOccurrences (Just . Right $ 12 * diffDay) (OccurrenceCacheKeyTutorials ssh dlimit) $ do candidates <- E.select $ do (trm :& crs :& tut) <- E.from $ E.table @Term `E.innerJoin` E.table @Course `E.on` (\(trm :& crs) -> crs E.^. CourseTerm E.==. trm E.^. TermId) @@ -97,6 +97,40 @@ getDayTutorials ssh dlimit@(dstart, dend ) | otherwise = Nothing +-- Datatype to be used for memcaching occurrences +data LessonCacheKey = LessonCacheKeyTutorials SchoolId (Day,Day) + deriving (Eq, Ord, Read, Show, Generic) + deriving anyclass (Hashable, Binary) + + +-- | like getDayTutorials, but also returns the lessons occurring within the given time frame +getDayTutorials' :: SchoolId -> (Day,Day) -> DB (Map TutorialId [LessonTime]) +getDayTutorials' ssh dlimit@(dstart, dend ) + | dstart > dend = return mempty + | otherwise = memcachedByClass MemcachedKeyClassTutorialOccurrences (Just . Right $ 12 * diffDay) (LessonCacheKeyTutorials ssh dlimit) $ do + candidates <- E.select $ do + (trm :& crs :& tut) <- E.from $ E.table @Term + `E.innerJoin` E.table @Course `E.on` (\(trm :& crs) -> crs E.^. CourseTerm E.==. trm E.^. TermId) + `E.innerJoin` E.table @Tutorial `E.on` (\(_ :& crs :& tut) -> crs E.^. CourseId E.==. tut E.^. TutorialCourse) + E.where_ $ crs E.^. CourseSchool E.==. E.val ssh + E.&&. trm E.^. TermStart E.<=. E.val dend + E.&&. trm E.^. TermEnd E.>=. E.val dstart + return (trm, tut) + -- logErrorS "DAILY" $ foldMap (\(Entity{entityVal=someTerm},Entity{entityVal=Tutorial{..}},_) -> tshow someTerm <> " *** " <> ciOriginal tutorialName <> ": " <> tshow (unJSONB tutorialTime)) candidates + return $ foldMap checkCandidate candidates + where + checkCandidate :: (Entity Term, Entity Tutorial) -> Map TutorialId [LessonTime] + checkCandidate (Entity{entityVal=trm}, Entity{entityKey=tutId, entityVal=Tutorial{tutorialTime=JSONB occ}}) + | let lessons = Set.filter lessonFltr $ occurringLessons trm occ + , notNull lessons + = Map.singleton tutId $ Set.toAscList lessons -- due to Set not having a Functor instance, we need mostly need lists anyway + | otherwise + = mempty + + lessonFltr :: LessonTime -> Bool + lessonFltr LessonTime{..} = dstart <= localDay lessonStart + && dend >= localDay lessonEnd + type DailyTableExpr = ( E.SqlExpr (Entity Course) @@ -178,15 +212,16 @@ instance HasUser DailyTableData where mkDailyTable :: Bool -> SchoolId -> Day -> DB (FormResult (DailyTableActionData, Set TutorialId), Widget) mkDailyTable isAdmin ssh nd = do - tuts <- getDayTutorials ssh (nd,nd) + tutLessons <- getDayTutorials' ssh (nd,nd) let + tutIds = Map.keys tutLessons dbtSQLQuery :: DailyTableExpr -> DailyTableOutput dbtSQLQuery (crs `E.InnerJoin` tut `E.InnerJoin` tpu `E.InnerJoin` usr `E.LeftOuterJoin` avs) = do EL.on $ tut E.^. TutorialCourse E.==. crs E.^. CourseId EL.on $ tut E.^. TutorialId E.==. tpu E.^. TutorialParticipantTutorial EL.on $ usr E.^. UserId E.==. tpu E.^. TutorialParticipantUser EL.on $ usr E.^. UserId E.=?. avs E.?. UserAvsUser - E.where_ $ tut E.^. TutorialId `E.in_` E.valList tuts + E.where_ $ tut E.^. TutorialId `E.in_` E.valList tutIds let associatedQualifications = E.subSelectMaybe . EL.from $ \cq -> do E.where_ $ cq E.^. CourseQualificationCourse E.==. crs E.^. CourseId let cqQual = cq E.^. CourseQualificationQualification @@ -200,9 +235,14 @@ mkDailyTable isAdmin ssh nd = do sortable (Just "course") (i18nCell MsgFilterCourse) $ \(view $ resultCourse . _entityVal -> c) -> courseCell c , sortable (Just "tutorial") (i18nCell MsgCourseTutorial) $ \row -> let Course{courseTerm=tid, courseSchool=cssh, courseShorthand=csh} - = row ^. resultCourse . _entityVal + = row ^. resultCourse . _entityVal tutName = row ^. resultTutorial . _entityVal . _tutorialName in anchorCell (CTutorialR tid cssh csh tutName TUsersR) $ citext2widget tutName + , sortable Nothing (i18nCell MsgTableTutorialOccurrence) $ \(view $ resultTutorial . _entityKey -> tutId) -> cellMaybe (lessonTimesCell False) $ Map.lookup tutId tutLessons + , sortable Nothing (i18nCell MsgTableTutorialRoom) $ \(view $ resultTutorial . _entityKey -> tutId) -> + -- listInlineCell (foldMap (fmap lessonRoom) $ Map.lookup tutId tutLessons) $ cellMaybe roomReferenceCell + -- listInlineCell (concat $ mapMM lessonRoom $ Map.lookup tutId tutLessons) roomReferenceCell + cellMaybe (`listInlineCell` roomReferenceCell) $ mapMM lessonRoom $ Map.lookup tutId tutLessons , sortable Nothing (i18nCell $ MsgCourseQualifications 3) $ \(preview resultCourseQualis -> cqs) -> maybeCell cqs $ flip listInlineCell qualificationIdShortCell , sortable (Just "user-company") (i18nCell MsgTablePrimeCompany) $ \(preview resultCompanyId -> mcid) -> cellMaybe companyIdCell mcid , sortable (Just "booking-company") (i18nCell MsgTableBookingCompany) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantCompany -> mcid) -> cellMaybe companyIdCell mcid diff --git a/src/Handler/Utils/Occurrences.hs b/src/Handler/Utils/Occurrences.hs index 3a5e511e1..9190f6abf 100644 --- a/src/Handler/Utils/Occurrences.hs +++ b/src/Handler/Utils/Occurrences.hs @@ -4,6 +4,7 @@ module Handler.Utils.Occurrences ( LessonTime(..) + , lessonTimeWidget, lessonTimesWidget , occurringLessons , occurrencesWidget , occurrencesCompute, occurrencesCompute' @@ -31,8 +32,8 @@ import Handler.Utils.Widgets (roomReferenceWidget) -- Model time intervals to compute lecture/tutorial lessons more intuitively -- -data LessonTime = LessonTime { lessonStart, lessonEnd :: LocalTime } - deriving (Eq, Ord, Read, Show, Generic) -- BEWARE: Ord instance might not be intuitive, but needed for Set +data LessonTime = LessonTime { lessonStart, lessonEnd :: LocalTime, lessonRoom :: Maybe RoomReference } + deriving (Eq, Ord, Show, Generic, Binary) -- BEWARE: Ord instance might not be intuitive, but needed for Set occurringLessons :: Term -> Occurrences -> Set LessonTime occurringLessons term Occurrences{..} = Set.union exceptOcc $ Set.filter isExcept scheduledLessons @@ -48,6 +49,7 @@ occurrenceScheduleToLessons Term{..} = let occDays = daysOfWeekBetween (termLectureStart, termLectureEnd) scheduleDayOfWeek \\ setHolidays toLesson d = LessonTime { lessonStart = LocalTime d scheduleStart , lessonEnd = LocalTime d scheduleEnd + , lessonRoom = scheduleRoom } in Set.map toLesson occDays @@ -57,11 +59,23 @@ occurrenceExceptionToLessons = Set.foldr aux mempty aux ExceptOccur{..} (oc,no) = let t = LessonTime { lessonStart = LocalTime exceptDay exceptStart , lessonEnd = LocalTime exceptDay exceptEnd + , lessonRoom = exceptRoom } in (Set.insert t oc,no) aux ExceptNoOccur{..} (oc,no) = (oc, Set.insert exceptTime no) +lessonTimeWidget :: Bool -> LessonTime -> Widget +lessonTimeWidget roomHidden LessonTime{..} = do + lStart <- formatTime SelFormatTime lessonStart + lEnd <- formatTime SelFormatTime lessonEnd + $(widgetFile "widgets/lesson/single") + +lessonTimesWidget :: (Traversable t, MonoFoldable (t Widget)) => Bool -> t LessonTime -> Widget +lessonTimesWidget roomHidden lessonsSet = do + let lessons = lessonTimeWidget roomHidden <$> lessonsSet + $(widgetFile "widgets/lesson/set") + ----------------- -- Occurrences -- diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 0d43a13fe..85f1fc68e 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -510,11 +510,14 @@ correctorLoadCell :: IsDBTable m a => SheetCorrector -> DBCell m a correctorLoadCell sc = i18nCell $ sheetCorrectorLoad sc +lessonTimesCell :: IsDBTable m a => Bool -> [LessonTime] -> DBCell m a +lessonTimesCell roomHidden lessons = cell $ lessonTimesWidget roomHidden lessons + occurrencesCell :: IsDBTable m a => Bool -> JSONB Occurrences -> DBCell m a occurrencesCell roomHidden occs = cell $ occurrencesWidget roomHidden occs roomReferenceCell :: IsDBTable m a => RoomReference -> DBCell m a -roomReferenceCell = cell . roomReferenceWidget +roomReferenceCell = cell . roomReferenceShortWidget cryptoidCell :: (IsDBTable m a, PathPiece cid) => cid -> DBCell m a cryptoidCell = addCellClass ("cryptoid" :: Text) . textCell . toPathPiece diff --git a/src/Handler/Utils/Widgets.hs b/src/Handler/Utils/Widgets.hs index fc5c7bfc0..fe93cc9c8 100644 --- a/src/Handler/Utils/Widgets.hs +++ b/src/Handler/Utils/Widgets.hs @@ -299,6 +299,13 @@ roomReferenceWidget RoomReferenceLink{..} = $(widgetFile "widgets/room-referen linkText = uriToString id roomRefLink mempty instrModal = modal (i18n MsgRoomReferenceLinkInstructions) $ Right $(widgetFile "widgets/room-reference/link-instructions-modal") +roomReferenceShortWidget :: RoomReference -> Widget +roomReferenceShortWidget RoomReferenceSimple{..} = text2widget roomRefText +roomReferenceShortWidget RoomReferenceLink{..} = $(widgetFile "widgets/room-reference/link") + where + linkText = uriToString id roomRefLink mempty + instrModal = modal (i18n MsgRoomReferenceLinkInstructions) $ Right $(widgetFile "widgets/room-reference/link-instructions-modal") + ---------- -- JSON -- diff --git a/src/Model/Types/DateTime.hs b/src/Model/Types/DateTime.hs index 55ec90530..abc157295 100644 --- a/src/Model/Types/DateTime.hs +++ b/src/Model/Types/DateTime.hs @@ -170,7 +170,7 @@ data OccurrenceSchedule = ScheduleWeekly , scheduleEnd :: TimeOfDay , scheduleRoom :: Maybe RoomReference } - deriving (Eq, Ord, Show, Generic) + deriving (Eq, Ord, Show, Generic,Binary) deriving anyclass (NFData) deriveJSON defaultOptions @@ -189,7 +189,7 @@ data OccurrenceException = ExceptOccur | ExceptNoOccur { exceptTime :: LocalTime } - deriving (Eq, Show, Generic) + deriving (Eq, Show, Generic,Binary) deriving anyclass (NFData) -- Handler.Utils.Occurrences.occurrencesAddBusinessDays assumes that OccurrenceException is ordered chronologically @@ -221,7 +221,7 @@ data Occurrences = Occurrences { occurrencesScheduled :: Set OccurrenceSchedule , occurrencesExceptions :: Set OccurrenceException } - deriving (Eq, Ord, Show, Generic) + deriving (Eq, Ord, Show, Generic, Binary) deriving anyclass (NFData) deriveJSON defaultOptions diff --git a/src/Model/Types/Room.hs b/src/Model/Types/Room.hs index 0db43e887..4fcd6ddbd 100644 --- a/src/Model/Types/Room.hs +++ b/src/Model/Types/Room.hs @@ -19,7 +19,7 @@ data RoomReference { roomRefLink :: URI , roomRefInstructions :: Maybe StoredMarkup } - deriving (Eq, Ord, Show, Generic) + deriving (Eq, Ord, Show, Generic, Binary) deriving anyclass (NFData) deriveJSON defaultOptions diff --git a/src/Network/URI/Instances.hs b/src/Network/URI/Instances.hs index 15097ea6d..065765647 100644 --- a/src/Network/URI/Instances.hs +++ b/src/Network/URI/Instances.hs @@ -18,6 +18,7 @@ import Data.Swagger import Data.Swagger.Internal.Schema import Data.Proxy +import Data.Binary import Servant.Docs @@ -28,6 +29,8 @@ import Control.Monad.Fail (MonadFail(..)) import Database.Persist import Database.Persist.Sql +deriving instance Binary URIAuth +deriving instance Binary URI instance ToHttpApiData URI where toQueryParam = pack . ($ mempty) . uriToString id @@ -54,7 +57,7 @@ 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 + 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 diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs index f9f276c2f..531821433 100644 --- a/src/Utils/Avs.hs +++ b/src/Utils/Avs.hs @@ -86,7 +86,7 @@ mkAvsQuery _ _ _ = AvsQuery fakePerson :: AvsQueryPerson -> AvsResponsePerson fakePerson = let - sarah = Set.singleton $ AvsDataPerson "Sarah" "Vaupel" Nothing 2 (AvsPersonId 2) mempty + sarah = Set.singleton $ AvsDataPerson "Sarah" "Vaupel" Nothing 2 (AvsPersonId 2) $ Set.singleton $ AvsDataPersonCard True Nothing Nothing AvsCardColorRot mempty Nothing Nothing Nothing Nothing (AvsCardNo "424242") "8" stephan = Set.singleton $ AvsDataPerson "Stephan" "Barth" Nothing 4 (AvsPersonId 4) mempty steffen = Set.singleton $ AvsDataPerson "Steffen" "Jost" (Just $ mkAvsInternalPersonalNo "47138") 12345678 (AvsPersonId 12345678) mempty sumpfi1 = Set.singleton $ AvsDataPerson "Heribert" "Sumpfmeier" Nothing 12345678 (AvsPersonId 12345678) mempty diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index eaff72ba0..7ab25710a 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -93,6 +93,10 @@ _Integral = iso fromIntegral fromIntegral _not :: Iso' Bool Bool _not = iso not not +instance Wrapped (JSONB a) where + type Unwrapped (JSONB a) = a + _Wrapped' = iso unJSONB JSONB + ----------------------------------- -- Lens Definitions for our Types diff --git a/templates/exam-show.hamlet b/templates/exam-show.hamlet index a21e0f57b..73177a5e2 100644 --- a/templates/exam-show.hamlet +++ b/templates/exam-show.hamlet @@ -86,7 +86,7 @@ $maybe desc <- examDescription ^{notificationPersonalIdentification} $maybe room <- examRoom
_{MsgExamRoom} -
^{roomReferenceWidget room} +
^{roomReferenceShortWidget room} $if examTimes
_{MsgTableExamTime}
@@ -243,7 +243,7 @@ $if not (null occurrences) $if showRoom $maybe room <- examOccurrenceRoom - ^{roomReferenceWidget room} + ^{roomReferenceShortWidget room} $nothing _{MsgExamOccurrenceRoomIsUnset} $else diff --git a/templates/widgets/lesson/set.hamlet b/templates/widgets/lesson/set.hamlet new file mode 100644 index 000000000..b42ff8ae0 --- /dev/null +++ b/templates/widgets/lesson/set.hamlet @@ -0,0 +1,11 @@ +$newline never + +$# SPDX-FileCopyrightText: 2024 Steffen Jost +$# +$# SPDX-License-Identifier: AGPL-3.0-or-later + +$if not (null lessons) +