chore(daily): show rooms for tutorial lessons
This commit is contained in:
parent
7d57a30be7
commit
ec2b09b20b
@ -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
|
||||
|
||||
@ -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 --
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 --
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -86,7 +86,7 @@ $maybe desc <- examDescription
|
||||
^{notificationPersonalIdentification}
|
||||
$maybe room <- examRoom
|
||||
<dt .deflist__dt>_{MsgExamRoom}
|
||||
<dd .deflist__dd>^{roomReferenceWidget room}
|
||||
<dd .deflist__dd>^{roomReferenceShortWidget room}
|
||||
$if examTimes
|
||||
<dt .deflist__dt>_{MsgTableExamTime}
|
||||
<dd .deflist__dd>
|
||||
@ -243,7 +243,7 @@ $if not (null occurrences)
|
||||
$if showRoom
|
||||
<td .table__td>
|
||||
$maybe room <- examOccurrenceRoom
|
||||
^{roomReferenceWidget room}
|
||||
^{roomReferenceShortWidget room}
|
||||
$nothing
|
||||
_{MsgExamOccurrenceRoomIsUnset}
|
||||
$else
|
||||
|
||||
11
templates/widgets/lesson/set.hamlet
Normal file
11
templates/widgets/lesson/set.hamlet
Normal file
@ -0,0 +1,11 @@
|
||||
$newline never
|
||||
|
||||
$# SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
|
||||
$#
|
||||
$# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
$if not (null lessons)
|
||||
<ul .list--iconless>
|
||||
$forall lsn <- lessons
|
||||
<li>
|
||||
^{lsn}
|
||||
9
templates/widgets/lesson/single.hamlet
Normal file
9
templates/widgets/lesson/single.hamlet
Normal file
@ -0,0 +1,9 @@
|
||||
$newline never
|
||||
|
||||
$# SPDX-FileCopyrightText: 20 24 Steffen Jost <s.jost@fraport.de>
|
||||
$#
|
||||
$# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
#{lStart}–#{lEnd}
|
||||
$if not roomHidden
|
||||
\ ^{foldMap roomReferenceWidget lessonRoom}
|
||||
@ -4,9 +4,9 @@ $# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
|
||||
$#
|
||||
$# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
$if not (null occurrencesScheduled')
|
||||
_{MsgExceptionKindOccur} #{exceptStart'}–#{exceptEnd'}
|
||||
$if not roomHidden
|
||||
^{foldMap roomReferenceWidget exceptRoom}
|
||||
$else
|
||||
$if null occurrencesScheduled'
|
||||
#{exceptStart'}–#{exceptEnd'}
|
||||
$else
|
||||
_{MsgExceptionKindOccur} #{exceptStart'}–#{exceptEnd'}
|
||||
$if not roomHidden
|
||||
\ ^{foldMap roomReferenceWidget exceptRoom}
|
||||
|
||||
@ -744,8 +744,8 @@ fillDb = do
|
||||
for_ [jost] $ \uid ->
|
||||
void . insert' $ UserSchool uid avn False
|
||||
void . insert' $ UserAvs (AvsPersonId 12345678) jost 87654321 (n_day' $ -12) (Just "Some Message here") Nothing Nothing Nothing
|
||||
void . insert' $ UserAvs (AvsPersonId 2) svaupel 2 (n_day' $ -22) Nothing Nothing Nothing (readAvsFullCardNo "12345.6")
|
||||
void . insert' $ UserAvs (AvsPersonId 3) gkleen 3 (n_day' $ -32) Nothing Nothing Nothing Nothing
|
||||
void . insert' $ UserAvs (AvsPersonId 99) svaupel 99 (n_day' $ -22) Nothing Nothing Nothing (readAvsFullCardNo "444444.4")
|
||||
void . insert' $ UserAvs (AvsPersonId 3) gkleen 3 (n_day' $ -32) Nothing Nothing Nothing (readAvsFullCardNo "5555.5")
|
||||
void . insert' $ UserAvs (AvsPersonId 4) sbarth 4 now Nothing Nothing Nothing Nothing
|
||||
void . insert' $ UserAvs (AvsPersonId 5) fhamann 5 now (Just "another message from avs synch") Nothing Nothing (readAvsFullCardNo "77777.7")
|
||||
void . insert' $ UserAvs (AvsPersonId 77) tinaTester 77 now Nothing Nothing Nothing Nothing
|
||||
@ -1102,13 +1102,13 @@ fillDb = do
|
||||
{ exceptDay = nTimes 8 succ secondDay
|
||||
, exceptStart = TimeOfDay 9 0 0
|
||||
, exceptEnd = TimeOfDay 16 0 0
|
||||
, exceptRoom = Just $ RoomReferenceSimple "B747"
|
||||
, exceptRoom = Nothing
|
||||
}
|
||||
, ExceptOccur
|
||||
{ exceptDay = nowaday
|
||||
, exceptStart = TimeOfDay 9 10 0
|
||||
, exceptEnd = TimeOfDay 16 10 0
|
||||
, exceptRoom = Nothing
|
||||
, exceptRoom = Just $ RoomReferenceSimple "B747"
|
||||
}
|
||||
]
|
||||
}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user