From e99a37cfd6ab617e1fbe533ac6eaf4d530afd744 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 17 May 2023 16:04:03 +0000 Subject: [PATCH 01/66] chore(occurrences): complete bounds function --- models/tutorials.model | 1 + src/Handler/Course/ParticipantInvite.hs | 40 +++++++++++++++++++++++++ src/Handler/Utils/DateTime.hs | 22 +++++++++++++- src/Jobs/Types.hs | 6 ++-- src/Model/Types/DateTime.hs | 15 +--------- src/Utils/Print/CourseCertificate.hs | 5 +++- 6 files changed, 70 insertions(+), 19 deletions(-) diff --git a/models/tutorials.model b/models/tutorials.model index 0a8558f29..76aed3e3a 100644 --- a/models/tutorials.model +++ b/models/tutorials.model @@ -16,6 +16,7 @@ Tutorial json deregisterUntil UTCTime Maybe lastChanged UTCTime default=now() tutorControlled Bool default=false + -- firstDay UTCTime Maybe -- to be computed from time, but needed for sorting within DB UniqueTutorial course name deriving Generic Tutor diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index e129b9d53..b79b6ccac 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -288,6 +288,46 @@ upsertNewTutorial cid tutorialName = do audit $ TransactionTutorialEdit tutId return tutId +tutorialTemplates :: [CI Text] +tutorialTemplates = ["Vorlage", "Template"] + +upsertNewTutorialTemplate :: CourseId -> TutorialName -> Handler TutorialId +upsertNewTutorialTemplate cid tutorialName = runDB $ do + now <- liftIO getCurrentTime + getBy UniqueTutorial cid tutorialName >>= \case + Just (Entity{entityVal=tid}) -> return tid -- no need to update + Nothing -> do + Course{..} <- getBy404 cid + Term{termLectureStart} <- getBy404 courseTerm + selectFirst [TutorialType <-. tutorialTemplates] [Desc TutorialType] >>= \case + Just (Entity {entityVal=template}) -> do + error "TODO" + Nothing -> do + Entity tutId _ <- upsert + Tutorial + { tutorialCourse = cid + , tutorialType = CI.mk "Schulung" + , tutorialCapacity = Nothing + , tutorialRoom = Nothing + , tutorialRoomHidden = False + , tutorialTime = Occurrences mempty mempty + , tutorialRegGroup = Nothing -- TODO: remove + , tutorialRegisterFrom = Nothing + , tutorialRegisterTo = Nothing + , tutorialDeregisterUntil = Nothing + , tutorialLastChanged = now + , tutorialTutorControlled = False + , .. + } + -- TODO: update should not happen + [ TutorialType =. CI.mk "Schulung" + , TutorialLastChanged =. now + ] + audit $ TransactionTutorialEdit tutId + return tutId + + + registerTutorialMembers :: TutorialId -> Set UserId -> Handler () registerTutorialMembers tutId (Set.toList -> users) = runDB $ do prevParticipants <- Set.fromList . fmap entityKey <$> selectList [TutorialParticipantUser <-. users, TutorialParticipantTutorial ==. tutId] [] diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index 80669b061..1dfad401f 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/src/Handler/Utils/DateTime.hs @@ -24,7 +24,7 @@ module Handler.Utils.DateTime , fromDays, fromMonths , weeksToAdd , setYear, getYear - , firstDayOfWeekOnAfter + , firstDayOfWeekOnAfter, daysOfWeekBetween, occurrencesBounds , ceilingQuarterHour , formatGregorianW ) where @@ -44,6 +44,7 @@ import qualified Data.Csv as Csv import qualified Data.Char as Char +import Data.List (iterate) ------------- -- UTCTime -- @@ -283,6 +284,25 @@ dayOfWeekDiff a b = mod (fromEnum a - fromEnum b) 7 firstDayOfWeekOnAfter :: DayOfWeek -> Day -> Day firstDayOfWeekOnAfter dw d = addDays (toInteger $ dayOfWeekDiff dw $ dayOfWeek d) d +daysOfWeekBetween :: (Day, Day) -> DayOfWeek -> Set Day +daysOfWeekBetween (dstart, dend) wday = Set.fromAscList $ takeWhile (dend >=) $ iterate (addDays 7) $ firstDayOfWeekOnAfter wday dstart + +-- | Get bounds for an Occurrences +occurrencesBounds :: Term -> Occurrences -> (Maybe Day, Maybe Day) +occurrencesBounds Term{..} Occurrences{..} = (Set.lookupMin occDays, Set.lookupMax occDays) + where + occDays = (scdDays <> plsDays) \\ excDays -- (excDays <> termHolidays term) -- TODO: should holidays be exluded here? Probably not, as they can be added as exceptions already + + scdDays = Set.foldr getOccDays mempty occurrencesScheduled + (plsDays,excDays) = Set.foldr getExcDays mempty occurrencesExceptions + + getExcDays :: OccurrenceException -> (Set Day, Set Day) -> (Set Day, Set Day) + getExcDays ExceptNoOccur{exceptTime} (occ,exc) = (occ, Set.insert (localDay exceptTime) exc) + getExcDays ExceptOccur{exceptDay} (occ,exc) = (Set.insert exceptDay occ, exc) + + getOccDays :: OccurrenceSchedule -> Set Day -> Set Day + getOccDays ScheduleWeekly{scheduleDayOfWeek=wday} = Set.union $ daysOfWeekBetween (termLectureStart,termLectureEnd) wday + addOneWeek :: UTCTime -> UTCTime addOneWeek = addWeeks 1 diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 4a2a9787e..f3e667f61 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -146,9 +146,9 @@ data Notification | NotificationSubmissionEdited { nInitiator :: UserId, nSubmission :: SubmissionId } | NotificationSubmissionUserCreated { nUser :: UserId, nSubmission :: SubmissionId } | NotificationSubmissionUserDeleted { nUser :: UserId, nSheet :: SheetId, nSubmission :: SubmissionId } - | NotificationQualificationExpiry { nQualification :: QualificationId, nExpiry :: Day } - | NotificationQualificationExpired { nQualification :: QualificationId } - | NotificationQualificationRenewal { nQualification :: QualificationId } + | NotificationQualificationExpiry { nQualification :: QualificationId, nExpiry :: Day } -- NotificationTrigger: NTQualification TODO: separate + | NotificationQualificationExpired { nQualification :: QualificationId } -- NotificationTrigger: NTQualification + | NotificationQualificationRenewal { nQualification :: QualificationId } -- NotificationTrigger: NTQualification deriving (Eq, Ord, Show, Read, Generic) instance Hashable Job diff --git a/src/Model/Types/DateTime.hs b/src/Model/Types/DateTime.hs index f36420657..e553eef85 100644 --- a/src/Model/Types/DateTime.hs +++ b/src/Model/Types/DateTime.hs @@ -15,7 +15,7 @@ module Model.Types.DateTime import Import.NoModel -import qualified Data.Set as Set +-- import qualified Data.Set as Set import Data.Ratio ((%)) import qualified Data.Text as Text -- import Data.Either.Combinators (maybeToRight, mapLeft) @@ -207,16 +207,3 @@ derivePersistFieldJSON ''Occurrences nullaryPathPiece ''DayOfWeek camelToPathPiece - - --- | Get bounds for an Occurrences --- TODO: unfinished function, only works for a few selected cases yet -occurrencesBounds :: Occurrences -> (Maybe Day, Maybe Day) -occurrencesBounds Occurrences{occurrencesScheduled=scd} | notNull scd = (Nothing, Nothing) -- TODO: case is not yet implemented -occurrencesBounds Occurrences{occurrencesExceptions=exc} = (Set.lookupMin occDays, Set.lookupMax occDays) - where - occDays = Set.foldr getOccDays mempty exc - - getOccDays :: OccurrenceException -> Set Day -> Set Day - getOccDays ExceptNoOccur{} acc = acc -- TODO: this case ignores ExceptNoOccur for now! - getOccDays ExceptOccur{exceptDay} acc = Set.insert exceptDay acc diff --git a/src/Utils/Print/CourseCertificate.hs b/src/Utils/Print/CourseCertificate.hs index 76d74533f..d26e0989b 100644 --- a/src/Utils/Print/CourseCertificate.hs +++ b/src/Utils/Print/CourseCertificate.hs @@ -16,6 +16,7 @@ import Data.FileEmbed (embedFile) import Utils.Print.Letters import Handler.Utils.Profile +import Handler.Utils.DateTime data LetterCourseCertificate = LetterCourseCertificate { ccCourseId :: CourseId @@ -79,8 +80,10 @@ makeCourseCertificates Tutorial{ tutorialName = CI.original -> ccTutorialName , courseShorthand = CI.original -> ccCourseShorthand , courseSchool = CI.original . unSchoolKey -> ccCourseSchool , courseDescription = fmap html2textlines -> ccCourseContent + , courseTerm = termId } <- get404 ccCourseId - let (ccCourseBegin, ccCourseEnd) = eq2nothing $ occurrencesBounds occurrences + term <- get404 termId + let (ccCourseBegin, ccCourseEnd) = eq2nothing $ occurrencesBounds term occurrences forM participants $ \uid -> do User{userDisplayName=ccParticipant, userCompanyDepartment, userCompanyPersonalNumber} <- get404 uid (ccFraNumber, ccFraDepartment, ccCompany) <- From 109f8ce86014fcfd7e4c9d8ac2f028bccd152618 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 22 May 2023 14:36:49 +0000 Subject: [PATCH 02/66] chore(tutorial): WIP towards tutorial templates --- models/tutorials.model | 2 +- src/Handler/Course/ParticipantInvite.hs | 82 +++++++++++++++---------- src/Handler/Utils/DateTime.hs | 18 +----- src/Handler/Utils/Occurrences.hs | 41 +++++++++++++ src/Utils/Holidays.hs | 10 +-- 5 files changed, 99 insertions(+), 54 deletions(-) diff --git a/models/tutorials.model b/models/tutorials.model index 76aed3e3a..be27d6a87 100644 --- a/models/tutorials.model +++ b/models/tutorials.model @@ -16,7 +16,7 @@ Tutorial json deregisterUntil UTCTime Maybe lastChanged UTCTime default=now() tutorControlled Bool default=false - -- firstDay UTCTime Maybe -- to be computed from time, but needed for sorting within DB + firstDay Day Maybe -- to be computed from time, but needed for sorting within DB UniqueTutorial course name deriving Generic Tutor diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index b79b6ccac..632da122a 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -291,40 +291,60 @@ upsertNewTutorial cid tutorialName = do tutorialTemplates :: [CI Text] tutorialTemplates = ["Vorlage", "Template"] -upsertNewTutorialTemplate :: CourseId -> TutorialName -> Handler TutorialId -upsertNewTutorialTemplate cid tutorialName = runDB $ do +upsertNewTutorialTemplate :: CourseId -> TutorialName -> Maybe Day -> Handler TutorialId +upsertNewTutorialTemplate cid tutorialName anchorDay = runDB $ do now <- liftIO getCurrentTime - getBy UniqueTutorial cid tutorialName >>= \case - Just (Entity{entityVal=tid}) -> return tid -- no need to update - Nothing -> do + existingTut <- getBy UniqueTutorial cid tutorialName + templateEnt <- selectFirst [TutorialType <-. tutorialTemplates] [Desc TutorialType] + case (existingTut, anchorDay) of + (Just (Entity{entityVal=tid}),_,_) -> return tid -- no need to update, we ignore the anchor day + (Nothing, Just firstDay, Just Entity{entityVal=Tutorial{tutorialFirstDay=Just tmplFirstDay}) -> do Course{..} <- getBy404 cid Term{termLectureStart} <- getBy404 courseTerm - selectFirst [TutorialType <-. tutorialTemplates] [Desc TutorialType] >>= \case - Just (Entity {entityVal=template}) -> do - error "TODO" - Nothing -> do - Entity tutId _ <- upsert - Tutorial - { tutorialCourse = cid - , tutorialType = CI.mk "Schulung" - , tutorialCapacity = Nothing - , tutorialRoom = Nothing - , tutorialRoomHidden = False - , tutorialTime = Occurrences mempty mempty - , tutorialRegGroup = Nothing -- TODO: remove - , tutorialRegisterFrom = Nothing - , tutorialRegisterTo = Nothing - , tutorialDeregisterUntil = Nothing - , tutorialLastChanged = now - , tutorialTutorControlled = False - , .. - } - -- TODO: update should not happen - [ TutorialType =. CI.mk "Schulung" - , TutorialLastChanged =. now - ] - audit $ TransactionTutorialEdit tutId - return tutId + let dayDiff = diffDays firstDay tmplFirstDay + addBusinessDays + Entity tutId _ <- upsert + Tutorial + { tutorialCourse = cid + , tutorialType = CI.mk "Schulung" + , tutorialCapacity = Nothing + , tutorialRoom = Nothing + , tutorialRoomHidden = False + , tutorialTime = Occurrences mempty mempty + , tutorialRegGroup = Nothing -- TODO: remove + , tutorialRegisterFrom = Nothing + , tutorialRegisterTo = Nothing + , tutorialDeregisterUntil = Nothing + , tutorialLastChanged = now + , tutorialTutorControlled = False + , tutorialFirstDay = anchorDay + , .. + } + error "TODO" -- CONTINUE HERE + audit $ TransactionTutorialEdit tutId + return tutId + + _ -> do + Entity tutId _ <- upsert + Tutorial + { tutorialCourse = cid + , tutorialType = CI.mk "Schulung" + , tutorialCapacity = Nothing + , tutorialRoom = Nothing + , tutorialRoomHidden = False + , tutorialTime = Occurrences mempty mempty + , tutorialRegGroup = Nothing -- TODO: remove + , tutorialRegisterFrom = Nothing + , tutorialRegisterTo = Nothing + , tutorialDeregisterUntil = Nothing + , tutorialLastChanged = now + , tutorialTutorControlled = False + , tutorialFirstDay = anchorDay + , .. + } + [ ] -- should alwyas be an insert + audit $ TransactionTutorialEdit tutId + return tutId diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index 1dfad401f..cfe920688 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/src/Handler/Utils/DateTime.hs @@ -24,7 +24,7 @@ module Handler.Utils.DateTime , fromDays, fromMonths , weeksToAdd , setYear, getYear - , firstDayOfWeekOnAfter, daysOfWeekBetween, occurrencesBounds + , firstDayOfWeekOnAfter, daysOfWeekBetween , ceilingQuarterHour , formatGregorianW ) where @@ -287,22 +287,6 @@ firstDayOfWeekOnAfter dw d = addDays (toInteger $ dayOfWeekDiff dw $ dayOfWeek d daysOfWeekBetween :: (Day, Day) -> DayOfWeek -> Set Day daysOfWeekBetween (dstart, dend) wday = Set.fromAscList $ takeWhile (dend >=) $ iterate (addDays 7) $ firstDayOfWeekOnAfter wday dstart --- | Get bounds for an Occurrences -occurrencesBounds :: Term -> Occurrences -> (Maybe Day, Maybe Day) -occurrencesBounds Term{..} Occurrences{..} = (Set.lookupMin occDays, Set.lookupMax occDays) - where - occDays = (scdDays <> plsDays) \\ excDays -- (excDays <> termHolidays term) -- TODO: should holidays be exluded here? Probably not, as they can be added as exceptions already - - scdDays = Set.foldr getOccDays mempty occurrencesScheduled - (plsDays,excDays) = Set.foldr getExcDays mempty occurrencesExceptions - - getExcDays :: OccurrenceException -> (Set Day, Set Day) -> (Set Day, Set Day) - getExcDays ExceptNoOccur{exceptTime} (occ,exc) = (occ, Set.insert (localDay exceptTime) exc) - getExcDays ExceptOccur{exceptDay} (occ,exc) = (Set.insert exceptDay occ, exc) - - getOccDays :: OccurrenceSchedule -> Set Day -> Set Day - getOccDays ScheduleWeekly{scheduleDayOfWeek=wday} = Set.union $ daysOfWeekBetween (termLectureStart,termLectureEnd) wday - addOneWeek :: UTCTime -> UTCTime addOneWeek = addWeeks 1 diff --git a/src/Handler/Utils/Occurrences.hs b/src/Handler/Utils/Occurrences.hs index 2551d57f3..262cad56c 100644 --- a/src/Handler/Utils/Occurrences.hs +++ b/src/Handler/Utils/Occurrences.hs @@ -4,12 +4,15 @@ module Handler.Utils.Occurrences ( occurrencesWidget + , occurrencesBounds + , occurrencesAddBusinessDays ) where import Import import qualified Data.Set as Set +import Utils.Holidays (isWeekend) import Utils.Occurrences import Handler.Utils.DateTime @@ -31,3 +34,41 @@ occurrencesWidget (normalizeOccurrences -> Occurrences{..}) = do exceptTime' <- formatTime SelFormatDateTime exceptTime $(widgetFile "widgets/occurrence/cell/except-no-occur") $(widgetFile "widgets/occurrence/cell") + +-- | Get bounds for an Occurrences +occurrencesBounds :: Term -> Occurrences -> (Maybe Day, Maybe Day) +occurrencesBounds Term{..} Occurrences{..} = (Set.lookupMin occDays, Set.lookupMax occDays) + where + occDays = (scdDays <> plsDays) \\ excDays -- (excDays <> termHolidays term) -- TODO: should holidays be exluded here? Probably not, as they can be added as exceptions already + + scdDays = Set.foldr getOccDays mempty occurrencesScheduled + (plsDays,excDays) = Set.foldr getExcDays mempty occurrencesExceptions + + getExcDays :: OccurrenceException -> (Set Day, Set Day) -> (Set Day, Set Day) + getExcDays ExceptNoOccur{exceptTime} (occ,exc) = (occ, Set.insert (localDay exceptTime) exc) + getExcDays ExceptOccur{exceptDay} (occ,exc) = (Set.insert exceptDay occ, exc) + + getOccDays :: OccurrenceSchedule -> Set Day -> Set Day + getOccDays ScheduleWeekly{scheduleDayOfWeek=wday} = Set.union $ daysOfWeekBetween (termLectureStart,termLectureEnd) wday + +occurrencesAddBusinessDays :: Term -> (Day,Day) -> Occurrences -> Occurrences +occurrencesAddBusinessDays Term{..} (dayOld, dayNew) Occurrences{..} = Occurrences newSchedule newExceptions + where + newSchedule = Set.map switchDayOfWeek occurrencesScheduled + dayDiff = diffDays dayNew dayOld + + switchDayOfWeek :: OccurrenceSchedule -> OccurrenceSchedule + switchDayOfWeek _ | 0 == dayDiff `mod` 7 = id + os{scheduleDayOfWeek=wday} = os{scheduleDayOfWeek= toEnum (dayDiff + fromEnum wday)} + + newExceptions = Set.map advanceExceptions occurrencesExceptions + + advanceExceptions :: OccurrenceException -> OccurrenceException + advanceExceptions ex@ExceptOccur{ exceptDay = ed } = ex{ exceptDay = pushSkip ed } + advanceExceptions ex@ExxceptNoOccur{ exceptTime = et@LocalTime { localDay = ed } } = ex{ exceptDay = et{ localDay = pushSkip ed}} + + pushSkip :: Day -> Day + pushSkip = let weekends = [d | d <- [(min termLectureStart termStart)..(max termEnd termLectureEnd)], isWeekend d] + offDays = Set.fromList $ termHolidays <> weekends + + in \ No newline at end of file diff --git a/src/Utils/Holidays.hs b/src/Utils/Holidays.hs index 649d0f16c..b8ae4fa18 100644 --- a/src/Utils/Holidays.hs +++ b/src/Utils/Holidays.hs @@ -150,11 +150,11 @@ index2year y = result -- | Test for Saturday/Sunday isWeekend :: Day -> Bool isWeekend = isWeekend' . dayOfWeek - where - isWeekend' :: WeekDay -> Bool - isWeekend' Sunday = True - isWeekend' Saturday = True - isWeekend' _ = False + +isWeekend' :: WeekDay -> Bool +isWeekend' Sunday = True +isWeekend' Saturday = True +isWeekend' _ = False -- | Always returns a business day. -- | Saturday/Sunday/Holiday treated like next (n>=0) or previous (n<0) working day From 5446ca5406c5b4f3950e98b441da9e390932df2c Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 23 May 2023 17:13:26 +0200 Subject: [PATCH 03/66] chore(tutorial): prepare occurrencesAddBusinessDays for templates --- src/Handler/Course/ParticipantInvite.hs | 29 ++++++++--------- src/Handler/Tutorial/Edit.hs | 7 +++-- src/Handler/Tutorial/New.hs | 4 ++- src/Handler/Utils/Occurrences.hs | 42 ++++++++++++++----------- src/Handler/Utils/Term.hs | 15 +++++++++ src/Model/Types/DateTime.hs | 35 ++++++++++++++++++++- src/Utils.hs | 11 ++++++- src/Utils/Print/CourseCertificate.hs | 3 +- test/Database/Fill.hs | 1 + test/Model/TypesSpec.hs | 2 ++ test/ModelSpec.hs | 1 + 11 files changed, 111 insertions(+), 39 deletions(-) diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index 632da122a..39b0246fe 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -279,6 +279,7 @@ upsertNewTutorial cid tutorialName = do , tutorialDeregisterUntil = Nothing , tutorialLastChanged = now , tutorialTutorControlled = False + , tutorialFirstDay = Nothing , .. } [ TutorialName =. tutorialName @@ -288,21 +289,22 @@ upsertNewTutorial cid tutorialName = do audit $ TransactionTutorialEdit tutId return tutId -tutorialTemplates :: [CI Text] -tutorialTemplates = ["Vorlage", "Template"] +-- tutorialTemplates :: [CI Text] +-- tutorialTemplates = ["Vorlage", "Template"] +{- upsertNewTutorialTemplate :: CourseId -> TutorialName -> Maybe Day -> Handler TutorialId upsertNewTutorialTemplate cid tutorialName anchorDay = runDB $ do now <- liftIO getCurrentTime - existingTut <- getBy UniqueTutorial cid tutorialName - templateEnt <- selectFirst [TutorialType <-. tutorialTemplates] [Desc TutorialType] - case (existingTut, anchorDay) of - (Just (Entity{entityVal=tid}),_,_) -> return tid -- no need to update, we ignore the anchor day - (Nothing, Just firstDay, Just Entity{entityVal=Tutorial{tutorialFirstDay=Just tmplFirstDay}) -> do - Course{..} <- getBy404 cid - Term{termLectureStart} <- getBy404 courseTerm + existingTut <- getBy $ UniqueTutorial cid tutorialName + templateEnt <- selectFirst [TutorialType <-. tutorialTemplates] [Desc TutorialType] + case (existingTut, anchorDay, templateEnt) of + (Just (Entity{entityKey=tid}),_,_) -> return tid -- no need to update, we ignore the anchor day + (Nothing, Just firstDay, Just Entity{entityVal=Tutorial{tutorialFirstDay=Just tmplFirstDay}}) -> do + Course{..} <- get404 cid + Term{termLectureStart} <- get404 courseTerm let dayDiff = diffDays firstDay tmplFirstDay - addBusinessDays + -- addBusinessDays Entity tutId _ <- upsert Tutorial { tutorialCourse = cid @@ -319,11 +321,10 @@ upsertNewTutorialTemplate cid tutorialName anchorDay = runDB $ do , tutorialTutorControlled = False , tutorialFirstDay = anchorDay , .. - } - error "TODO" -- CONTINUE HERE + } [] + -- error "TODO" -- CONTINUE HERE audit $ TransactionTutorialEdit tutId return tutId - _ -> do Entity tutId _ <- upsert Tutorial @@ -346,7 +347,7 @@ upsertNewTutorialTemplate cid tutorialName anchorDay = runDB $ do audit $ TransactionTutorialEdit tutId return tutId - +-} registerTutorialMembers :: TutorialId -> Set UserId -> Handler () registerTutorialMembers tutId (Set.toList -> users) = runDB $ do diff --git a/src/Handler/Tutorial/Edit.hs b/src/Handler/Tutorial/Edit.hs index 3c58cf3f1..65d616e0a 100644 --- a/src/Handler/Tutorial/Edit.hs +++ b/src/Handler/Tutorial/Edit.hs @@ -25,15 +25,14 @@ getTEditR, postTEditR :: TermId -> SchoolId -> CourseShorthand -> TutorialName - getTEditR = postTEditR postTEditR tid ssh csh tutn = do (cid, tutid, template) <- runDB $ do - (cid, Entity tutid Tutorial{..}) <- fetchCourseIdTutorial tid ssh csh tutn - + (cid, Entity tutid Tutorial{..}) <- fetchCourseIdTutorial tid ssh csh tutn tutorIds <- fmap (map E.unValue) . E.select . E.from $ \tutor -> do E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid return $ tutor E.^. TutorUser tutorInvites <- sourceInvitationsF @Tutor tutid - let + let template = TutorialForm { tfName = tutorialName , tfType = tutorialType @@ -56,6 +55,7 @@ postTEditR tid ssh csh tutn = do formResult newTutResult $ \TutorialForm{..} -> do insertRes <- runDBJobs $ do + term <- fetchTermByCID cid now <- liftIO getCurrentTime insertRes <- myReplaceUnique tutid Tutorial { tutorialName = tfName @@ -71,6 +71,7 @@ postTEditR tid ssh csh tutn = do , tutorialDeregisterUntil = tfDeregisterUntil , tutorialLastChanged = now , tutorialTutorControlled = tfTutorControlled + , tutorialFirstDay = fst $ occurrencesBounds term tfTime } when (is _Nothing insertRes) $ do audit $ TransactionTutorialEdit tutid diff --git a/src/Handler/Tutorial/New.hs b/src/Handler/Tutorial/New.hs index 8f81c5dcb..cfef01e19 100644 --- a/src/Handler/Tutorial/New.hs +++ b/src/Handler/Tutorial/New.hs @@ -25,8 +25,9 @@ postCTutorialNewR tid ssh csh = do ((newTutResult, newTutWidget), newTutEnctype) <- runFormPost $ tutorialForm cid Nothing formResult newTutResult $ \TutorialForm{..} -> do - insertRes <- runDBJobs $ do + insertRes <- runDBJobs $ do now <- liftIO getCurrentTime + term <- fetchTermByCID cid insertRes <- insertUnique Tutorial { tutorialName = tfName , tutorialCourse = cid @@ -41,6 +42,7 @@ postCTutorialNewR tid ssh csh = do , tutorialDeregisterUntil = tfDeregisterUntil , tutorialLastChanged = now , tutorialTutorControlled = tfTutorControlled + , tutorialFirstDay = fst $ occurrencesBounds term tfTime } whenIsJust insertRes $ \tutid -> do audit $ TransactionTutorialEdit tutid diff --git a/src/Handler/Utils/Occurrences.hs b/src/Handler/Utils/Occurrences.hs index 262cad56c..eb3022117 100644 --- a/src/Handler/Utils/Occurrences.hs +++ b/src/Handler/Utils/Occurrences.hs @@ -5,14 +5,14 @@ module Handler.Utils.Occurrences ( occurrencesWidget , occurrencesBounds - , occurrencesAddBusinessDays + -- , occurrencesAddBusinessDays ) where import Import import qualified Data.Set as Set -import Utils.Holidays (isWeekend) +-- import Utils.Holidays (isWeekend) import Utils.Occurrences import Handler.Utils.DateTime @@ -51,24 +51,30 @@ occurrencesBounds Term{..} Occurrences{..} = (Set.lookupMin occDays, Set.lookupM getOccDays :: OccurrenceSchedule -> Set Day -> Set Day getOccDays ScheduleWeekly{scheduleDayOfWeek=wday} = Set.union $ daysOfWeekBetween (termLectureStart,termLectureEnd) wday -occurrencesAddBusinessDays :: Term -> (Day,Day) -> Occurrences -> Occurrences -occurrencesAddBusinessDays Term{..} (dayOld, dayNew) Occurrences{..} = Occurrences newSchedule newExceptions - where - newSchedule = Set.map switchDayOfWeek occurrencesScheduled - dayDiff = diffDays dayNew dayOld +-- occurrencesAddBusinessDays :: Term -> (Day,Day) -> Occurrences -> Occurrences +-- occurrencesAddBusinessDays Term{..} (dayOld, dayNew) Occurrences{..} = Occurrences newSchedule newExceptions +-- where +-- newSchedule = Set.map switchDayOfWeek occurrencesScheduled +-- dayDiff = diffDays dayNew dayOld - switchDayOfWeek :: OccurrenceSchedule -> OccurrenceSchedule - switchDayOfWeek _ | 0 == dayDiff `mod` 7 = id - os{scheduleDayOfWeek=wday} = os{scheduleDayOfWeek= toEnum (dayDiff + fromEnum wday)} +-- switchDayOfWeek :: OccurrenceSchedule -> OccurrenceSchedule +-- switchDayOfWeek _ | 0 == dayDiff `mod` 7 = id +-- switchDayOfWeek os@ScheduleWeekly{scheduleDayOfWeek=wday} = os{scheduleDayOfWeek= toEnum (dayDiff + fromEnum wday)} - newExceptions = Set.map advanceExceptions occurrencesExceptions +-- newExceptions = snd $ Set.foldr advanceExceptions (dayDiff,mempty) occurrencesExceptions - advanceExceptions :: OccurrenceException -> OccurrenceException - advanceExceptions ex@ExceptOccur{ exceptDay = ed } = ex{ exceptDay = pushSkip ed } - advanceExceptions ex@ExxceptNoOccur{ exceptTime = et@LocalTime { localDay = ed } } = ex{ exceptDay = et{ localDay = pushSkip ed}} +-- advanceExceptions :: OccurrenceException -> (Integer, Set OccurrenceException) -> (Integer, Set OccurrenceException) +-- advanceExceptions ex@ExceptOccur{ exceptDay = ed } (offset, acc) = +-- | add - pushSkip :: Day -> Day - pushSkip = let weekends = [d | d <- [(min termLectureStart termStart)..(max termEnd termLectureEnd)], isWeekend d] - offDays = Set.fromList $ termHolidays <> weekends - in \ No newline at end of file +-- advanceExceptions ex@ExceptOccur{ exceptDay = ed } = ex{ exceptDay = pushSkip ed } +-- advanceExceptions ex@ExceptNoOccur{ exceptTime = et@LocalTime { localDay = ed } } = ex{ exceptDay = et{ localDay = pushSkip ed}} + +-- pushSkip +-- pushSkip :: Day -> Day +-- pushSkip = id -- TODO +-- -- pushSkip = let weekends = [d | d <- [(min termLectureStart termStart)..(max termEnd termLectureEnd)], isWeekend d] +-- -- offDays = Set.fromList $ termHolidays <> weekends + +-- -- in \ No newline at end of file diff --git a/src/Handler/Utils/Term.hs b/src/Handler/Utils/Term.hs index 49ef41a87..fe3bba7eb 100644 --- a/src/Handler/Utils/Term.hs +++ b/src/Handler/Utils/Term.hs @@ -6,6 +6,7 @@ module Handler.Utils.Term ( groupHolidays , getCurrentTerm , getActiveTerms + , fetchTermByCID , module Utils.Term ) where @@ -61,3 +62,17 @@ getActiveTerms = do fmap Set.fromDistinctAscList . runConduit $ E.selectSource activeTermsQuery .| C.map E.unValue .| C.sinkList + +fetchTermByCID :: ( MonadHandler m + , BackendCompatible SqlBackend backend + , PersistQueryRead backend, PersistUniqueRead backend + ) + => CourseId -> ReaderT backend m Term +fetchTermByCID cid = do + termList <- E.select . E.from $ \(course `E.InnerJoin` term) -> do + E.on $ course E.^. CourseTerm E.==. term E.^. TermId + E.where_ $ course E.^. CourseId E.==. E.val cid + return term + case termList of + [term] -> return $ entityVal term + _other -> notFound \ No newline at end of file diff --git a/src/Model/Types/DateTime.hs b/src/Model/Types/DateTime.hs index e553eef85..301a392cc 100644 --- a/src/Model/Types/DateTime.hs +++ b/src/Model/Types/DateTime.hs @@ -21,6 +21,7 @@ import qualified Data.Text as Text -- import Data.Either.Combinators (maybeToRight, mapLeft) import Text.Read (readMaybe) +-- import Data.Time.LocalTime import Data.Time.Calendar.WeekDate -- import Data.Time.Format.ISO8601 @@ -184,9 +185,21 @@ data OccurrenceException = ExceptOccur | ExceptNoOccur { exceptTime :: LocalTime } - deriving (Eq, Ord, Read, Show, Generic) + deriving (Eq, Read, Show, Generic) deriving anyclass (NFData) +instance Ord OccurrenceException where + compare ExceptOccur{exceptDay=ad, exceptStart=as, exceptEnd=ae} ExceptOccur{exceptDay=bd, exceptStart=bs, exceptEnd=be} + = compare (ad,as,ae) (bd,bs,be) + compare ExceptOccur{exceptDay=d, exceptStart=s} ExceptNoOccur{exceptTime=e} + = -- replaceEq GT $ + compare (LocalTime d s) e + compare ExceptNoOccur{exceptTime=e } ExceptOccur{exceptDay=d, exceptStart=s} + = -- replaceEq LT $ + compare e (LocalTime d s) + compare ExceptNoOccur{exceptTime=ae } ExceptNoOccur{exceptTime=be } + = compare ae be + deriveJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 , constructorTagModifier = camelToPathPiece' 1 @@ -207,3 +220,23 @@ derivePersistFieldJSON ''Occurrences nullaryPathPiece ''DayOfWeek camelToPathPiece + + +-- test :: IO [OccurrenceException] +-- test = do +-- now <- getCurrentTime +-- tz <- getCurrentTimeZone +-- let lt1 = utcToLocalTime tz now +-- tomorrow = addUTCTime nominalDay now +-- lt2 = utcToLocalTime tz tomorrow +-- yesterday = addUTCTime (negate nominalDay) now +-- lt3 = utcToLocalTime tz yesterday +-- pure +-- [ ExceptOccur (utctDay tomorrow ) midday midnight +-- , ExceptOccur (utctDay now ) midnight midnight +-- , ExceptOccur (utctDay now ) midday midnight +-- , ExceptOccur (utctDay yesterday) midday midnight +-- , ExceptNoOccur lt3 +-- , ExceptNoOccur lt1 +-- , ExceptNoOccur lt2 +-- ] \ No newline at end of file diff --git a/src/Utils.hs b/src/Utils.hs index be7a78eef..4ab7b9a57 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -1745,7 +1745,7 @@ maxOn = maxBy . comparing inBetween:: Ord a => a -> (a,a) -> Bool inBetween x (lower,upper) = lower <= x && x <= upper --- | Given to values and a criterion, returns the unique argument that fulfills the criterion, if it exists +-- | Given two values and a criterion, returns the unique argument that fulfills the criterion, if it exists pickBetter :: a -> a -> (a -> Bool) -> Maybe a pickBetter x y crit | cx == cy = Nothing @@ -1755,6 +1755,15 @@ pickBetter x y crit cx = crit x cy = crit y +reverseOrdering :: Ordering -> Ordering +reverseOrdering EQ = EQ +reverseOrdering GT = LT +reverseOrdering LT = GT + +replaceEq :: Ordering -> Ordering -> Ordering +replaceEq r EQ = r +replaceEq _ other = other + ------------ -- Random -- ------------ diff --git a/src/Utils/Print/CourseCertificate.hs b/src/Utils/Print/CourseCertificate.hs index d26e0989b..4474ac754 100644 --- a/src/Utils/Print/CourseCertificate.hs +++ b/src/Utils/Print/CourseCertificate.hs @@ -16,7 +16,8 @@ import Data.FileEmbed (embedFile) import Utils.Print.Letters import Handler.Utils.Profile -import Handler.Utils.DateTime +-- import Handler.Utils.DateTime +import Handler.Utils.Occurrences data LetterCourseCertificate = LetterCourseCertificate { ccCourseId :: CourseId diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 38f6331c2..d393e22cd 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -1014,6 +1014,7 @@ fillDb = do , tutorialDeregisterUntil = jtt TermDayLectureStart (-5) (Just Monday) toMidnight , tutorialLastChanged = now , tutorialTutorControlled = True + , tutorialFirstDay = Just firstDay } insert_ $ Tutor tut1 jost void . insert' $ Exam diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index 9f5598b68..d6fe5662d 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -445,6 +445,8 @@ spec = do [ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws, commutativeSemigroupLaws, commutativeMonoidLaws ] lawsCheckHspec (Proxy @TermIdentifier) [ eqLaws, showReadLaws, ordLaws, enumLaws, persistFieldLaws, jsonLaws, httpApiDataLaws, pathPieceLaws ] + lawsCheckHspec (Proxy @Occurrences) + [ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws ] lawsCheckHspec (Proxy @StudyFieldType) [ eqLaws, ordLaws, boundedEnumLaws, showReadLaws, persistFieldLaws ] lawsCheckHspec (Proxy @Theme) diff --git a/test/ModelSpec.hs b/test/ModelSpec.hs index 58220bdef..729f1a769 100644 --- a/test/ModelSpec.hs +++ b/test/ModelSpec.hs @@ -93,6 +93,7 @@ instance Arbitrary Tutorial where <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary shrink = genericShrink instance Arbitrary User where From c2521df20b6cfe1ac9a59b2c0d6a3a4d1398959a Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 23 May 2023 17:28:22 +0200 Subject: [PATCH 04/66] chore(tutorial): WIP templates advancement --- src/Handler/Course/ParticipantInvite.hs | 37 +++++++++---------- src/Handler/Tutorial/New.hs | 4 +- src/Handler/Utils/Occurrences.hs | 49 ++++++++++++------------- src/Handler/Utils/Term.hs | 2 +- src/Model/Types/DateTime.hs | 15 ++++++-- 5 files changed, 55 insertions(+), 52 deletions(-) diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index 39b0246fe..05757ee86 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -289,37 +289,34 @@ upsertNewTutorial cid tutorialName = do audit $ TransactionTutorialEdit tutId return tutId --- tutorialTemplates :: [CI Text] --- tutorialTemplates = ["Vorlage", "Template"] +tutorialTemplateNames :: Maybe (CI Text) -> [CI Text] +tutorialTemplateNames Nothing = ["Vorlage", "Template"] +tutorialTemplateNames (Just name) = [prefixes <> suffixes | prefixes <- tutorialTemplateNames Nothing, suffixes <- ["", Text.cons '_' name]] -{- -upsertNewTutorialTemplate :: CourseId -> TutorialName -> Maybe Day -> Handler TutorialId -upsertNewTutorialTemplate cid tutorialName anchorDay = runDB $ do +upsertNewTutorialTemplate :: CourseId -> TutorialName -> Maybe (CI Text) -> Maybe Day -> Handler TutorialId +upsertNewTutorialTemplate cid newTutorialName newTutorialType anchorDay = runDB $ do now <- liftIO getCurrentTime - existingTut <- getBy $ UniqueTutorial cid tutorialName - templateEnt <- selectFirst [TutorialType <-. tutorialTemplates] [Desc TutorialType] + existingTut <- getBy $ UniqueTutorial cid tutorialName + templateEnt <- selectFirst [TutorialType <-. tutorialTemplateNames newTutorialType] [Desc TutorialType] case (existingTut, anchorDay, templateEnt) of (Just (Entity{entityKey=tid}),_,_) -> return tid -- no need to update, we ignore the anchor day - (Nothing, Just firstDay, Just Entity{entityVal=Tutorial{tutorialFirstDay=Just tmplFirstDay}}) -> do + (Nothing, Just newFirstDay, Just Entity{entityVal=Tutorial{..}}) -> do Course{..} <- get404 cid - Term{termLectureStart} <- get404 courseTerm - let dayDiff = diffDays firstDay tmplFirstDay - -- addBusinessDays + term <- get404 courseTerm + let newTime = occurrencesAddBusinessDays term (tutorialFirstDay, newFirstDay) Entity tutId _ <- upsert Tutorial - { tutorialCourse = cid - , tutorialType = CI.mk "Schulung" - , tutorialCapacity = Nothing - , tutorialRoom = Nothing - , tutorialRoomHidden = False - , tutorialTime = Occurrences mempty mempty - , tutorialRegGroup = Nothing -- TODO: remove + { tutorialCourse = cid + , tutorialType = fromMaybe (CI.mk "Schulung") newTutorialType + , tutorialTime = newTime + , tutorialFirstDay = newFirstDay + , tutorialName = newTutorialName + -- TODO , tutorialRegisterFrom = Nothing , tutorialRegisterTo = Nothing , tutorialDeregisterUntil = Nothing , tutorialLastChanged = now - , tutorialTutorControlled = False - , tutorialFirstDay = anchorDay + , .. } [] -- error "TODO" -- CONTINUE HERE diff --git a/src/Handler/Tutorial/New.hs b/src/Handler/Tutorial/New.hs index cfef01e19..53a11c3c0 100644 --- a/src/Handler/Tutorial/New.hs +++ b/src/Handler/Tutorial/New.hs @@ -20,14 +20,14 @@ import Handler.Tutorial.TutorInvite getCTutorialNewR, postCTutorialNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCTutorialNewR = postCTutorialNewR postCTutorialNewR tid ssh csh = do - cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh + Entity{entityKey=cid, entityVal=course} <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh -- TODO: use getKeyBy404 if was optimized to no longer retrieve the full entity from the DB anyway ((newTutResult, newTutWidget), newTutEnctype) <- runFormPost $ tutorialForm cid Nothing formResult newTutResult $ \TutorialForm{..} -> do insertRes <- runDBJobs $ do now <- liftIO getCurrentTime - term <- fetchTermByCID cid + term <- get404 $ course ^. CourseTerm insertRes <- insertUnique Tutorial { tutorialName = tfName , tutorialCourse = cid diff --git a/src/Handler/Utils/Occurrences.hs b/src/Handler/Utils/Occurrences.hs index eb3022117..7e8dd5fee 100644 --- a/src/Handler/Utils/Occurrences.hs +++ b/src/Handler/Utils/Occurrences.hs @@ -5,14 +5,14 @@ module Handler.Utils.Occurrences ( occurrencesWidget , occurrencesBounds - -- , occurrencesAddBusinessDays + , occurrencesAddBusinessDays ) where import Import import qualified Data.Set as Set --- import Utils.Holidays (isWeekend) +import Utils.Holidays (isWeekend) import Utils.Occurrences import Handler.Utils.DateTime @@ -51,30 +51,29 @@ occurrencesBounds Term{..} Occurrences{..} = (Set.lookupMin occDays, Set.lookupM getOccDays :: OccurrenceSchedule -> Set Day -> Set Day getOccDays ScheduleWeekly{scheduleDayOfWeek=wday} = Set.union $ daysOfWeekBetween (termLectureStart,termLectureEnd) wday --- occurrencesAddBusinessDays :: Term -> (Day,Day) -> Occurrences -> Occurrences --- occurrencesAddBusinessDays Term{..} (dayOld, dayNew) Occurrences{..} = Occurrences newSchedule newExceptions --- where --- newSchedule = Set.map switchDayOfWeek occurrencesScheduled --- dayDiff = diffDays dayNew dayOld +occurrencesAddBusinessDays :: Term -> (Day,Day) -> Occurrences -> Occurrences +occurrencesAddBusinessDays Term{..} (dayOld, dayNew) Occurrences{..} = Occurrences newSchedule newExceptions + where + newSchedule = Set.map switchDayOfWeek occurrencesScheduled + dayDiff = diffDays dayNew dayOld --- switchDayOfWeek :: OccurrenceSchedule -> OccurrenceSchedule --- switchDayOfWeek _ | 0 == dayDiff `mod` 7 = id --- switchDayOfWeek os@ScheduleWeekly{scheduleDayOfWeek=wday} = os{scheduleDayOfWeek= toEnum (dayDiff + fromEnum wday)} + offDays = Set.fromList $ termHolidays <> weekends + weekends = [d | d <- [(min termLectureStart termStart)..(max termEnd termLectureEnd)], isWeekend d] --- newExceptions = snd $ Set.foldr advanceExceptions (dayDiff,mempty) occurrencesExceptions + switchDayOfWeek :: OccurrenceSchedule -> OccurrenceSchedule + switchDayOfWeek _ | 0 == dayDiff `mod` 7 = id + switchDayOfWeek os@ScheduleWeekly{scheduleDayOfWeek=wday} = os{scheduleDayOfWeek= toEnum (dayDiff + fromEnum wday)} --- advanceExceptions :: OccurrenceException -> (Integer, Set OccurrenceException) -> (Integer, Set OccurrenceException) --- advanceExceptions ex@ExceptOccur{ exceptDay = ed } (offset, acc) = --- | add + newExceptions = snd $ Set.foldr advanceExceptions (dayDiff,mempty) occurrencesExceptions - --- advanceExceptions ex@ExceptOccur{ exceptDay = ed } = ex{ exceptDay = pushSkip ed } --- advanceExceptions ex@ExceptNoOccur{ exceptTime = et@LocalTime { localDay = ed } } = ex{ exceptDay = et{ localDay = pushSkip ed}} - --- pushSkip --- pushSkip :: Day -> Day --- pushSkip = id -- TODO --- -- pushSkip = let weekends = [d | d <- [(min termLectureStart termStart)..(max termEnd termLectureEnd)], isWeekend d] --- -- offDays = Set.fromList $ termHolidays <> weekends - --- -- in \ No newline at end of file + -- we assume that instance Ord OccurrenceException is ordered chronologically + advanceExceptions :: OccurrenceException -> (Integer, Set OccurrenceException) -> (Integer, Set OccurrenceException) + advanceExceptions ex (offset, acc) + | ed `Set.notMember` offDays -- skip term-holidays and weekends, unless the original day was a holiday or weekend + , nd `Set.member` offDays + = advanceExceptions ex (succ offset, acc) + | otherwise + = (offset, Set.insert (setDayOfOccurrenceException nd ex) acc) + where + ed = dayOfOccurrenceException ex + nd = addDays offset ed diff --git a/src/Handler/Utils/Term.hs b/src/Handler/Utils/Term.hs index fe3bba7eb..841082745 100644 --- a/src/Handler/Utils/Term.hs +++ b/src/Handler/Utils/Term.hs @@ -69,7 +69,7 @@ fetchTermByCID :: ( MonadHandler m ) => CourseId -> ReaderT backend m Term fetchTermByCID cid = do - termList <- E.select . E.from $ \(course `E.InnerJoin` term) -> do + termList <- E.select . E.distinct . E.from $ \(course `E.InnerJoin` term) -> do E.on $ course E.^. CourseTerm E.==. term E.^. TermId E.where_ $ course E.^. CourseId E.==. E.val cid return term diff --git a/src/Model/Types/DateTime.hs b/src/Model/Types/DateTime.hs index 301a392cc..0771ce901 100644 --- a/src/Model/Types/DateTime.hs +++ b/src/Model/Types/DateTime.hs @@ -188,15 +188,14 @@ data OccurrenceException = ExceptOccur deriving (Eq, Read, Show, Generic) deriving anyclass (NFData) +-- Handler.Utils.Occurrences.occurrencesAddBusinessDays assumes that OccurrenceException is ordered chronologically instance Ord OccurrenceException where compare ExceptOccur{exceptDay=ad, exceptStart=as, exceptEnd=ae} ExceptOccur{exceptDay=bd, exceptStart=bs, exceptEnd=be} = compare (ad,as,ae) (bd,bs,be) compare ExceptOccur{exceptDay=d, exceptStart=s} ExceptNoOccur{exceptTime=e} - = -- replaceEq GT $ - compare (LocalTime d s) e + = replaceEq LT $ compare (LocalTime d s) e compare ExceptNoOccur{exceptTime=e } ExceptOccur{exceptDay=d, exceptStart=s} - = -- replaceEq LT $ - compare e (LocalTime d s) + = replaceEq GT $ compare e (LocalTime d s) compare ExceptNoOccur{exceptTime=ae } ExceptNoOccur{exceptTime=be } = compare ae be @@ -206,6 +205,14 @@ deriveJSON defaultOptions , sumEncoding = TaggedObject "exception" "for" } ''OccurrenceException +dayOfOccurrenceException :: OccurrenceException -> Day +dayOfOccurrenceException ExceptOccur{exceptDay=d} = d +dayOfOccurrenceException ExceptNoOccur{exceptTime=LocalTime{localDay=d}} = d + +setDayOfOccurrenceException :: Day -> OccurrenceException -> OccurrenceException +setDayOfOccurrenceException d ex@ExceptOccur{} = ex{exceptDay=d} +setDayOfOccurrenceException d ExceptNoOccur{exceptTime=lt} = ExceptNoOccur{exceptTime = lt{localDay=d}} + data Occurrences = Occurrences { occurrencesScheduled :: Set OccurrenceSchedule , occurrencesExceptions :: Set OccurrenceException From 5400c32477ea638b38b9c3ae4b75906887a84986 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 24 May 2023 13:29:53 +0000 Subject: [PATCH 05/66] chore(tutorial): WIP towards tutorial templates --- .../courses/courses/de-de-formal.msg | 1 + .../categories/courses/courses/en-eu.msg | 1 + .../utils/table_column/de-de-formal.msg | 1 + messages/uniworx/utils/table_column/en-eu.msg | 1 + src/Database/Esqueleto/Utils.hs | 19 ++- src/Handler/Course/ParticipantInvite.hs | 150 +++++++++--------- src/Handler/Tutorial/New.hs | 2 +- src/Handler/Utils/Avs.hs | 2 +- src/Handler/Utils/Occurrences.hs | 4 +- src/Model/Types/DateTime.hs | 2 +- 10 files changed, 102 insertions(+), 81 deletions(-) diff --git a/messages/uniworx/categories/courses/courses/de-de-formal.msg b/messages/uniworx/categories/courses/courses/de-de-formal.msg index fa44ab8cc..cf6e1b500 100644 --- a/messages/uniworx/categories/courses/courses/de-de-formal.msg +++ b/messages/uniworx/categories/courses/courses/de-de-formal.msg @@ -89,6 +89,7 @@ CourseParticipantsRegisterTutorialField: Übungsgruppe CourseParticipantsRegisterTutorialFieldTip: Ist aktuell keine Übungsgruppe mit diesem Namen vorhanden, wird eine neue erstellt. Ist bereits eine Übungsgruppe mit diesem Namen vorhanden, werden die Kursteilnehmenden dieser hinzugefügt. CourseParticipantsRegisterNoneGiven: Es wurden keine anzumeldenden Personen angegeben! CourseParticipantsRegisterNotFoundInAvs n@Int: Zu #{n} #{pluralDE n "Angabe konnte keine übereinstimmende Person" "Angaben konnten keine übereinstimmenden Personen"} im AVS gefunden werden +CourseParticipantsRegisterTutorialFirstDayTip: Wenn ein neus Tutorium gemäß eine Vorlage erstellt wird, werden die Zeiten gemäß dem Starttag angepasst CourseParticipantsInvited n@Int: #{n} #{pluralDE n "Einladung" "Einladungen"} per E-Mail verschickt CourseParticipantsAlreadyRegistered n@Int: #{n} #{pluralDE n "Teinehmer:in" "Teilnehmer:innen"} #{pluralDE n "ist" "sind"} bereits zum Kurs angemeldet diff --git a/messages/uniworx/categories/courses/courses/en-eu.msg b/messages/uniworx/categories/courses/courses/en-eu.msg index ae25a7187..abfbba6cc 100644 --- a/messages/uniworx/categories/courses/courses/en-eu.msg +++ b/messages/uniworx/categories/courses/courses/en-eu.msg @@ -89,6 +89,7 @@ CourseParticipantsRegisterTutorialField: Tutorial CourseParticipantsRegisterTutorialFieldTip: If there is no tutorial with this name, a new one will be created. If there is a tutorial with this name, the course participants will be registered for it. CourseParticipantsRegisterNoneGiven: No persons given to register! CourseParticipantsRegisterNotFoundInAvs n: For #{n} #{pluralEN n "entry no corresponding person" "entries no corresponding persons"} could be found in AVS +CourseParticipantsRegisterTutorialFirstDayTip: If a new tutorial is created and a template exists, its dates are adjusted according to the start date CourseParticipantsRegisterUnnecessary: All requested registrations have already been saved. No actions have been performed. CourseParticipantsInvited n: #{n} #{pluralEN n "invitation" "invitations"} sent via email diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index c3247ecf5..bee0fc158 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -54,6 +54,7 @@ TableTutorialRoomIsUnset !ident-ok: — TableTutorialRoomIsHidden: Raum wird nur Teilnehmern angezeigt TableTutorialTime: Zeit TableTutorialDeregisterUntil: Abmeldungen bis +TableTutorialFirstDay: Starttag TableActionsHead: Aktionen TableNoFilter: Keine Einschränkung TableUserMatriculation: ASV Nummer diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index 5ff701e6a..af505c942 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -53,6 +53,7 @@ TableTutorialRoomHidden: Room only for participants TableTutorialRoomIsUnset: — TableTutorialRoomIsHidden: Room is only displayed to participants TableTutorialDeregisterUntil: Deregister until +TableTutorialFirstDay: Start date TableActionsHead: Actions TableTutorialTime: Time TableNoFilter: No restriction diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 7064697e4..144eb99a6 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -10,6 +10,7 @@ module Database.Esqueleto.Utils , vals, justVal, justValList, toValues , isJust, alt , isInfixOf, hasInfix + , isPrefixOf_, hasPrefix_ , strConcat, substring , (=?.), (?=.) , (=~.), (~=.) @@ -142,9 +143,9 @@ alt :: PersistField typ => E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value -- alt a b = E.case_ [(isJust a, a), (isJust b, b)] b alt a b = E.coalesce [a,b] -infix 4 `isInfixOf`, `hasInfix` +infix 4 `isInfixOf`, `hasInfix`, `isPrefixOf_`, `hasPrefix_` --- | Check if the first string is contained in the text derived from the second argument +-- | Check if the first string is contained in the text derived from the second argument (case-insensitive) isInfixOf :: ( E.SqlString s1 , E.SqlString s2 ) @@ -157,6 +158,20 @@ hasInfix :: ( E.SqlString s1 => E.SqlExpr (E.Value s2) -> E.SqlExpr (E.Value s1) -> E.SqlExpr (E.Value Bool) hasInfix = flip isInfixOf +-- | Check if the first string is a prefix of the text derived from the second argument (case-insensitive) +isPrefixOf_ :: ( E.SqlString s1 + , E.SqlString s2 + ) + => E.SqlExpr (E.Value s1) -> E.SqlExpr (E.Value s2) -> E.SqlExpr (E.Value Bool) +isPrefixOf_ needle strExpr = E.castString strExpr `E.ilike` needle E.++. (E.%) + +hasPrefix_ :: ( E.SqlString s1 + , E.SqlString s2 + ) + => E.SqlExpr (E.Value s2) -> E.SqlExpr (E.Value s1) -> E.SqlExpr (E.Value Bool) +hasPrefix_ = flip isPrefixOf_ + + infixl 6 `strConcat` strConcat :: E.SqlString s diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index 05757ee86..1cf631b3d 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -1,7 +1,9 @@ --- SPDX-FileCopyrightText: 2022 Sarah Vaupel +-- SPDX-FileCopyrightText: 2022-23 Sarah Vaupel , Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later +{-# LANGUAGE TypeApplications #-} + module Handler.Course.ParticipantInvite ( getCAddUserR, postCAddUserR , getTAddUserR, postTAddUserR @@ -20,14 +22,27 @@ import Data.Map ((!)) import qualified Data.Map as Map import qualified Data.Time.Zones as TZ import qualified Data.Set as Set +-- import qualified Data.Text as Text import Control.Monad.Except (MonadError(..)) import Generics.Deriving.Monoid (memptydefault, mappenddefault) +-- import Database.Esqueleto.Experimental ((:&)(..)) +import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma +import qualified Database.Esqueleto.Utils as E + + type UserSearchKey = Text -type TutorialIdent = CI Text +type TutorialType = CI Text + +defaultTutorialType :: TutorialType +defaultTutorialType = "Schulung" + +tutorialTemplateNames :: Maybe TutorialType -> [TutorialType] +tutorialTemplateNames Nothing = ["Vorlage", "Template"] +tutorialTemplateNames (Just name) = [prefixes <> "_" <> suffixes | prefixes <- tutorialTemplateNames Nothing, suffixes <- [mempty, name]] data ButtonCourseRegisterMode = BtnCourseRegisterConfirm | BtnCourseRegisterAbort @@ -63,7 +78,7 @@ data CourseRegisterActionData | CourseRegisterActionAddTutorialMemberData { crActIdent :: UserSearchKey , crActUser :: (UserId, User) - , crActTutorial :: TutorialIdent + , crActTutorial :: TutorialName } -- | CourseRegisterActionUnknownPersonData -- pseudo-action; just for display -- { crActUnknownPersonIdent :: Text @@ -97,7 +112,7 @@ courseRegisterRenderAction act = [whamlet|^{userWidget (view _2 (crActUser act)) data AddUserRequest = AddUserRequest { auReqUsers :: Set UserSearchKey - , auReqTutorial :: Maybe TutorialIdent + , auReqTutorial :: Maybe (Maybe TutorialName, Maybe TutorialType, Maybe Day) } deriving (Eq, Ord, Read, Show, Generic) @@ -123,11 +138,26 @@ postCAddUserR tid ssh csh = do today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime postTAddUserR tid ssh csh (CI.mk $ tshow today) -- Don't use user date display setting, so that tutorial default names conform to all users +--TODO: Refactor above to send Day instead of TutorialName and refactor below to accept Either Day TutorialName or maybe even TutorialId? getTAddUserR, postTAddUserR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html getTAddUserR = postTAddUserR postTAddUserR tid ssh csh tut = do - cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh + now <- liftIO getCurrentTime + let nowaday = utctDay now + (cid,tutTypes,tutorial) <- runDB $ do + cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh + tutTypes <- E.select $ E.distinct $ do + tutorial <- E.from $ E.table @Tutorial + let ttyp = tutorial E.^. TutorialType + E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid + E.&&. E.not_ (E.any (E.hasPrefix_ ttyp . E.val) (tutorialTemplateNames Nothing)) + -- ((\pfx -> E.val pfx `E.isPrefixOf_` tutorial E.^. TutorialType) (tutorialTemplateNames Nothing)) + E.orderBy [E.asc ttyp] + return ttyp + tutorial <- getBy $ UniqueTutorial cid tut + return (cid, E.unValue <$> tutTypes, tutorial) + currentRoute <- fromMaybe (error "postCAddUserR called from 404-handler") <$> getCurrentRoute confirmedActs :: Set CourseRegisterActionData <- fmap Set.fromList . throwExceptT . mapMM encodedSecretBoxOpen . lookupPostParams $ toPathPiece PostCourseUserAddConfirmAction @@ -136,10 +166,10 @@ postTAddUserR tid ssh csh tut = do let users = Map.fromList . fmap (\act -> (crActIdent act, Just . view _1 $ crActUser act)) $ Set.toList confirmedActs tutActs = Set.filter (is _CourseRegisterActionAddTutorialMemberData) confirmedActs - actTutorial = crActTutorial <$> Set.lookupMin tutActs -- tutorial ident must be the same for every added member! + actTutorial = crActTutorial <$> Set.lookupMin tutActs -- tutorial ident must be the same for every added member! registeredUsers <- registerUsers cid users forM_ actTutorial $ \tutName -> do - tutId <- upsertNewTutorial cid tutName + tutId <- upsertNewTutorial cid tutName --TODO registerTutorialMembers tutId registeredUsers if @@ -148,11 +178,17 @@ postTAddUserR tid ssh csh tut = do -> redirect $ CTutorialR tid ssh csh tutName TUsersR | otherwise -> redirect $ CourseR tid ssh csh CUsersR - - ((usersToAdd :: FormResult AddUserRequest, formWgt), formEncoding) <- runFormPost . renderWForm FormStandard $ do + + ((usersToAdd :: FormResult AddUserRequest, formWgt), formEncoding) <- runFormPost . renderWForm FormStandard $ do + let tutTypesMsg = [(SomeMessage tt,tt)| tt <- tutTypes] auReqUsers <- wreq (textField & cfAnySeparatedSet) (fslI MsgCourseParticipantsRegisterUsersField & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) mempty auReqTutorial <- optionalActionW - ( areq (textField & cfCI) (fslI MsgCourseParticipantsRegisterTutorialField & setTooltip MsgCourseParticipantsRegisterTutorialFieldTip) (Just tut) ) + ( (,,) + <$> aopt (textField & cfCI) (fslI MsgCourseParticipantsRegisterTutorialField & setTooltip MsgCourseParticipantsRegisterTutorialFieldTip) (Just $ Just tut) + <*> aopt (selectFieldList tutTypesMsg) (fslI MsgTableTutorialType) (Just ((tutorial ^? _entityVal . _tutorialType) <|> listToMaybe tutTypes)) + <*> aopt dayField (fslI MsgTableTutorialFirstDay & setTooltip MsgCourseParticipantsRegisterTutorialFirstDayTip) + (Just ((tutorial ^? _entityVal . _tutorialFirstDay) <|> Just nowaday)) + ) ( fslI MsgCourseParticipantsRegisterTutorialOption ) ( Just True ) return $ AddUserRequest <$> auReqUsers <*> auReqTutorial @@ -261,91 +297,57 @@ registerUser cid (_avsIdent, Just uid) = exceptT return return $ do return $ mempty { aurRegisterSuccess = Set.singleton uid } -upsertNewTutorial :: CourseId -> TutorialIdent -> Handler TutorialId -upsertNewTutorial cid tutorialName = do +upsertNewTutorial :: CourseId -> TutorialName -> Maybe (CI Text) -> Maybe Day -> Handler TutorialId +upsertNewTutorial cid newTutorialName newTutorialType anchorDay = runDB $ do now <- liftIO getCurrentTime - runDB $ do - Entity tutId _ <- upsert - Tutorial - { tutorialCourse = cid - , tutorialType = CI.mk "Schulung" - , tutorialCapacity = Nothing - , tutorialRoom = Nothing - , tutorialRoomHidden = False - , tutorialTime = Occurrences mempty mempty - , tutorialRegGroup = Nothing -- TODO: remove - , tutorialRegisterFrom = Nothing - , tutorialRegisterTo = Nothing - , tutorialDeregisterUntil = Nothing - , tutorialLastChanged = now - , tutorialTutorControlled = False - , tutorialFirstDay = Nothing - , .. - } - [ TutorialName =. tutorialName - , TutorialType =. CI.mk "Schulung" - , TutorialLastChanged =. now - ] - audit $ TransactionTutorialEdit tutId - return tutId - -tutorialTemplateNames :: Maybe (CI Text) -> [CI Text] -tutorialTemplateNames Nothing = ["Vorlage", "Template"] -tutorialTemplateNames (Just name) = [prefixes <> suffixes | prefixes <- tutorialTemplateNames Nothing, suffixes <- ["", Text.cons '_' name]] - -upsertNewTutorialTemplate :: CourseId -> TutorialName -> Maybe (CI Text) -> Maybe Day -> Handler TutorialId -upsertNewTutorialTemplate cid newTutorialName newTutorialType anchorDay = runDB $ do - now <- liftIO getCurrentTime - existingTut <- getBy $ UniqueTutorial cid tutorialName + existingTut <- getBy $ UniqueTutorial cid newTutorialName templateEnt <- selectFirst [TutorialType <-. tutorialTemplateNames newTutorialType] [Desc TutorialType] case (existingTut, anchorDay, templateEnt) of (Just (Entity{entityKey=tid}),_,_) -> return tid -- no need to update, we ignore the anchor day (Nothing, Just newFirstDay, Just Entity{entityVal=Tutorial{..}}) -> do Course{..} <- get404 cid term <- get404 courseTerm - let newTime = occurrencesAddBusinessDays term (tutorialFirstDay, newFirstDay) + let oldFirstDay = fromMaybe newFirstDay $ tutorialFirstDay <|> fst (occurrencesBounds term tutorialTime) + newTime = occurrencesAddBusinessDays term (oldFirstDay, newFirstDay) tutorialTime + dayDiff = maybe 0 (diffDays newFirstDay) tutorialFirstDay + mvTime = fmap $ addLocalDays dayDiff Entity tutId _ <- upsert Tutorial - { tutorialCourse = cid - , tutorialType = fromMaybe (CI.mk "Schulung") newTutorialType - , tutorialTime = newTime - , tutorialFirstDay = newFirstDay - , tutorialName = newTutorialName - -- TODO - , tutorialRegisterFrom = Nothing - , tutorialRegisterTo = Nothing - , tutorialDeregisterUntil = Nothing - , tutorialLastChanged = now - + { tutorialName = newTutorialName + , tutorialCourse = cid + , tutorialType = fromMaybe defaultTutorialType newTutorialType + , tutorialFirstDay = anchorDay + , tutorialTime = newTime + , tutorialRegisterFrom = mvTime tutorialRegisterFrom + , tutorialRegisterTo = mvTime tutorialRegisterTo + , tutorialDeregisterUntil = mvTime tutorialDeregisterUntil + , tutorialLastChanged = now , .. - } [] - -- error "TODO" -- CONTINUE HERE + } [] -- update cannot happen due to previous case audit $ TransactionTutorialEdit tutId return tutId _ -> do Entity tutId _ <- upsert Tutorial - { tutorialCourse = cid - , tutorialType = CI.mk "Schulung" - , tutorialCapacity = Nothing - , tutorialRoom = Nothing - , tutorialRoomHidden = False - , tutorialTime = Occurrences mempty mempty - , tutorialRegGroup = Nothing -- TODO: remove - , tutorialRegisterFrom = Nothing - , tutorialRegisterTo = Nothing + { tutorialName = newTutorialName + , tutorialCourse = cid + , tutorialType = fromMaybe defaultTutorialType newTutorialType + , tutorialCapacity = Nothing + , tutorialRoom = Nothing + , tutorialRoomHidden = False + , tutorialTime = Occurrences mempty mempty + , tutorialRegGroup = Nothing + , tutorialRegisterFrom = Nothing + , tutorialRegisterTo = Nothing , tutorialDeregisterUntil = Nothing - , tutorialLastChanged = now + , tutorialLastChanged = now , tutorialTutorControlled = False - , tutorialFirstDay = anchorDay - , .. + , tutorialFirstDay = anchorDay } - [ ] -- should alwyas be an insert + [ ] -- update cannot happen due to previous cases audit $ TransactionTutorialEdit tutId return tutId --} - registerTutorialMembers :: TutorialId -> Set UserId -> Handler () registerTutorialMembers tutId (Set.toList -> users) = runDB $ do prevParticipants <- Set.fromList . fmap entityKey <$> selectList [TutorialParticipantUser <-. users, TutorialParticipantTutorial ==. tutId] [] diff --git a/src/Handler/Tutorial/New.hs b/src/Handler/Tutorial/New.hs index 53a11c3c0..4fa98b0d6 100644 --- a/src/Handler/Tutorial/New.hs +++ b/src/Handler/Tutorial/New.hs @@ -27,7 +27,7 @@ postCTutorialNewR tid ssh csh = do formResult newTutResult $ \TutorialForm{..} -> do insertRes <- runDBJobs $ do now <- liftIO getCurrentTime - term <- get404 $ course ^. CourseTerm + term <- get404 $ course ^. _courseTerm insertRes <- insertUnique Tutorial { tutorialName = tfName , tutorialCourse = cid diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 550f4edd6..6afc21150 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Steffen Jost +-- SPDX-FileCopyrightText: 2022-23 Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later diff --git a/src/Handler/Utils/Occurrences.hs b/src/Handler/Utils/Occurrences.hs index 7e8dd5fee..f3412e29b 100644 --- a/src/Handler/Utils/Occurrences.hs +++ b/src/Handler/Utils/Occurrences.hs @@ -61,8 +61,8 @@ occurrencesAddBusinessDays Term{..} (dayOld, dayNew) Occurrences{..} = Occurrenc weekends = [d | d <- [(min termLectureStart termStart)..(max termEnd termLectureEnd)], isWeekend d] switchDayOfWeek :: OccurrenceSchedule -> OccurrenceSchedule - switchDayOfWeek _ | 0 == dayDiff `mod` 7 = id - switchDayOfWeek os@ScheduleWeekly{scheduleDayOfWeek=wday} = os{scheduleDayOfWeek= toEnum (dayDiff + fromEnum wday)} + switchDayOfWeek os | 0 == dayDiff `mod` 7 = os + switchDayOfWeek os@ScheduleWeekly{scheduleDayOfWeek=wday} = os{scheduleDayOfWeek= toEnum (fromIntegral dayDiff + fromEnum wday)} newExceptions = snd $ Set.foldr advanceExceptions (dayDiff,mempty) occurrencesExceptions diff --git a/src/Model/Types/DateTime.hs b/src/Model/Types/DateTime.hs index 0771ce901..bc31638b4 100644 --- a/src/Model/Types/DateTime.hs +++ b/src/Model/Types/DateTime.hs @@ -211,7 +211,7 @@ dayOfOccurrenceException ExceptNoOccur{exceptTime=LocalTime{localDay=d}} = d setDayOfOccurrenceException :: Day -> OccurrenceException -> OccurrenceException setDayOfOccurrenceException d ex@ExceptOccur{} = ex{exceptDay=d} -setDayOfOccurrenceException d ExceptNoOccur{exceptTime=lt} = ExceptNoOccur{exceptTime = lt{localDay=d}} +setDayOfOccurrenceException d ExceptNoOccur{exceptTime=t} = ExceptNoOccur{exceptTime = t{localDay=d}} data Occurrences = Occurrences { occurrencesScheduled :: Set OccurrenceSchedule From 314e6611080232f654dca807aaced90a6101a5f4 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 24 May 2023 13:59:05 +0000 Subject: [PATCH 06/66] chore(tutorial): WIP towards tutorial templates, part 2 --- src/Handler/Course/ParticipantInvite.hs | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index 1cf631b3d..2702fdc5b 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -78,7 +78,7 @@ data CourseRegisterActionData | CourseRegisterActionAddTutorialMemberData { crActIdent :: UserSearchKey , crActUser :: (UserId, User) - , crActTutorial :: TutorialName + , crActTutorial :: (Maybe TutorialName, Maybe TutorialType, Maybe Day) } -- | CourseRegisterActionUnknownPersonData -- pseudo-action; just for display -- { crActUnknownPersonIdent :: Text @@ -168,8 +168,8 @@ postTAddUserR tid ssh csh tut = do tutActs = Set.filter (is _CourseRegisterActionAddTutorialMemberData) confirmedActs actTutorial = crActTutorial <$> Set.lookupMin tutActs -- tutorial ident must be the same for every added member! registeredUsers <- registerUsers cid users - forM_ actTutorial $ \tutName -> do - tutId <- upsertNewTutorial cid tutName --TODO + forM_ actTutorial $ \(tutName,tutType,tutDay) -> do + tutId <- upsertNewTutorial cid (fromMaybe "TODO" tutName) tutType tutDay registerTutorialMembers tutId registeredUsers if @@ -323,7 +323,7 @@ upsertNewTutorial cid newTutorialName newTutorialType anchorDay = runDB $ do , tutorialDeregisterUntil = mvTime tutorialDeregisterUntil , tutorialLastChanged = now , .. - } [] -- update cannot happen due to previous case + } [] -- update cannot happen due to previous case audit $ TransactionTutorialEdit tutId return tutId _ -> do @@ -343,8 +343,7 @@ upsertNewTutorial cid newTutorialName newTutorialType anchorDay = runDB $ do , tutorialLastChanged = now , tutorialTutorControlled = False , tutorialFirstDay = anchorDay - } - [ ] -- update cannot happen due to previous cases + } [] -- update cannot happen due to previous cases audit $ TransactionTutorialEdit tutId return tutId From a0e37fb1537e397b080fa9cac794ea700d813b4d Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 24 May 2023 16:45:34 +0000 Subject: [PATCH 07/66] chore(tutorial): WIP towards tutorial templates, part 3 --- src/Handler/Course/ParticipantInvite.hs | 21 ++++++++++++++------- 1 file changed, 14 insertions(+), 7 deletions(-) diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index 2702fdc5b..88e2f2e97 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -22,7 +22,7 @@ import Data.Map ((!)) import qualified Data.Map as Map import qualified Data.Time.Zones as TZ import qualified Data.Set as Set --- import qualified Data.Text as Text +import qualified Data.Text as Text import Control.Monad.Except (MonadError(..)) @@ -40,9 +40,12 @@ type TutorialType = CI Text defaultTutorialType :: TutorialType defaultTutorialType = "Schulung" +tutorialTypeSeparator :: Text +tutorialTypeSeparator = "___" + tutorialTemplateNames :: Maybe TutorialType -> [TutorialType] tutorialTemplateNames Nothing = ["Vorlage", "Template"] -tutorialTemplateNames (Just name) = [prefixes <> "_" <> suffixes | prefixes <- tutorialTemplateNames Nothing, suffixes <- [mempty, name]] +tutorialTemplateNames (Just name) = [prefixes <> suffixes | prefixes <- tutorialTemplateNames Nothing, suffixes <- [mempty, CI.mk tutorialTypeSeparator <> name]] data ButtonCourseRegisterMode = BtnCourseRegisterConfirm | BtnCourseRegisterAbort @@ -173,7 +176,7 @@ postTAddUserR tid ssh csh tut = do registerTutorialMembers tutId registeredUsers if - | Just tutName <- actTutorial + | Just tutName <- actTutorial -- CONTINUE HERE , Set.size tutActs == Set.size confirmedActs -> redirect $ CTutorialR tid ssh csh tutName TUsersR | otherwise @@ -308,14 +311,18 @@ upsertNewTutorial cid newTutorialName newTutorialType anchorDay = runDB $ do Course{..} <- get404 cid term <- get404 courseTerm let oldFirstDay = fromMaybe newFirstDay $ tutorialFirstDay <|> fst (occurrencesBounds term tutorialTime) - newTime = occurrencesAddBusinessDays term (oldFirstDay, newFirstDay) tutorialTime - dayDiff = maybe 0 (diffDays newFirstDay) tutorialFirstDay - mvTime = fmap $ addLocalDays dayDiff + newTime = occurrencesAddBusinessDays term (oldFirstDay, newFirstDay) tutorialTime + dayDiff = maybe 0 (diffDays newFirstDay) tutorialFirstDay + mvTime = fmap $ addLocalDays dayDiff + newType0 = CI.mk . snd . Text.breakOnEnd tutorialTypeSeparator $ CI.original tutorialType + newType = if newType0 `elem` tutorialTemplateNames Nothing + then fromMaybe defaultTutorialType newTutorialType + else newType0 Entity tutId _ <- upsert Tutorial { tutorialName = newTutorialName , tutorialCourse = cid - , tutorialType = fromMaybe defaultTutorialType newTutorialType + , tutorialType = newType , tutorialFirstDay = anchorDay , tutorialTime = newTime , tutorialRegisterFrom = mvTime tutorialRegisterFrom From 930bcef9cddb4f95813d5e1ddeb1568b7144435f Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 26 May 2023 16:03:10 +0000 Subject: [PATCH 08/66] chore(tutorial): towards #37 by adding new tutorials from template --- src/Handler/Course/ParticipantInvite.hs | 75 +++++++++++++------------ src/Handler/Tutorial/List.hs | 14 +++-- src/Utils.hs | 2 +- test/Database/Fill.hs | 44 ++++++++++++++- 4 files changed, 92 insertions(+), 43 deletions(-) diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index 88e2f2e97..41b5a11dc 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -47,6 +47,10 @@ tutorialTemplateNames :: Maybe TutorialType -> [TutorialType] tutorialTemplateNames Nothing = ["Vorlage", "Template"] tutorialTemplateNames (Just name) = [prefixes <> suffixes | prefixes <- tutorialTemplateNames Nothing, suffixes <- [mempty, CI.mk tutorialTypeSeparator <> name]] +tutorialDefaultName :: Maybe TutorialType -> Day -> TutorialName +-- tutorialDefaultName Nothing = tutorialDefaultName $ Just defaultTutorialType +tutorialDefaultName _ = CI.mk . tshow -- Don't use user date display setting, so that tutorial default names conform to all users + data ButtonCourseRegisterMode = BtnCourseRegisterConfirm | BtnCourseRegisterAbort deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) @@ -139,27 +143,28 @@ getCAddUserR, postCAddUserR :: TermId -> SchoolId -> CourseShorthand -> Handler getCAddUserR = postCAddUserR postCAddUserR tid ssh csh = do today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime - postTAddUserR tid ssh csh (CI.mk $ tshow today) -- Don't use user date display setting, so that tutorial default names conform to all users + handleAddUserR tid ssh csh (Right today) Nothing + -- postTAddUserR tid ssh csh (CI.mk $ tshow today) -- Don't use user date display setting, so that tutorial default names conform to all users ---TODO: Refactor above to send Day instead of TutorialName and refactor below to accept Either Day TutorialName or maybe even TutorialId? getTAddUserR, postTAddUserR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html getTAddUserR = postTAddUserR -postTAddUserR tid ssh csh tut = do - now <- liftIO getCurrentTime - let nowaday = utctDay now - (cid,tutTypes,tutorial) <- runDB $ do +postTAddUserR tid ssh csh tutn = handleAddUserR tid ssh csh (Left tutn) Nothing + + +handleAddUserR :: TermId -> SchoolId -> CourseShorthand -> Either TutorialName Day -> Maybe TutorialType -> Handler Html +handleAddUserR tid ssh csh tdesc ttyp = do + (cid, tutTypes) <- runDB $ do cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh tutTypes <- E.select $ E.distinct $ do tutorial <- E.from $ E.table @Tutorial - let ttyp = tutorial E.^. TutorialType + let tuTyp = tutorial E.^. TutorialType E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid - E.&&. E.not_ (E.any (E.hasPrefix_ ttyp . E.val) (tutorialTemplateNames Nothing)) + E.&&. E.not_ (E.any (E.hasPrefix_ tuTyp . E.val) (tutorialTemplateNames Nothing)) -- ((\pfx -> E.val pfx `E.isPrefixOf_` tutorial E.^. TutorialType) (tutorialTemplateNames Nothing)) - E.orderBy [E.asc ttyp] - return ttyp - tutorial <- getBy $ UniqueTutorial cid tut - return (cid, E.unValue <$> tutTypes, tutorial) + E.orderBy [E.asc tuTyp] + return tuTyp + return (cid, E.unValue <$> tutTypes) currentRoute <- fromMaybe (error "postCAddUserR called from 404-handler") <$> getCurrentRoute @@ -171,26 +176,26 @@ postTAddUserR tid ssh csh tut = do tutActs = Set.filter (is _CourseRegisterActionAddTutorialMemberData) confirmedActs actTutorial = crActTutorial <$> Set.lookupMin tutActs -- tutorial ident must be the same for every added member! registeredUsers <- registerUsers cid users - forM_ actTutorial $ \(tutName,tutType,tutDay) -> do - tutId <- upsertNewTutorial cid (fromMaybe "TODO" tutName) tutType tutDay - registerTutorialMembers tutId registeredUsers - - if - | Just tutName <- actTutorial -- CONTINUE HERE - , Set.size tutActs == Set.size confirmedActs - -> redirect $ CTutorialR tid ssh csh tutName TUsersR - | otherwise - -> redirect $ CourseR tid ssh csh CUsersR + whenIsJust actTutorial $ \(tutName,tutType,tutDay) -> do + whenIsJust (tutName <|> fmap (tutorialDefaultName tutType) tutDay) $ \tName -> do + tutId <- upsertNewTutorial cid tName tutType tutDay + registerTutorialMembers tutId registeredUsers + -- when (Set.size tutActs == Set.size confirmedActs) $ -- not sure how this condition might be false at this point + redirect $ CTutorialR tid ssh csh tName TUsersR + redirect $ CourseR tid ssh csh CUsersR ((usersToAdd :: FormResult AddUserRequest, formWgt), formEncoding) <- runFormPost . renderWForm FormStandard $ do - let tutTypesMsg = [(SomeMessage tt,tt)| tt <- tutTypes] + let tutTypesMsg = [(SomeMessage tt,tt)| tt <- tutTypes] + tutDefType = ttyp >>= (\ty -> if ty `elem` tutTypes then Just ty else Nothing) auReqUsers <- wreq (textField & cfAnySeparatedSet) (fslI MsgCourseParticipantsRegisterUsersField & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) mempty auReqTutorial <- optionalActionW ( (,,) - <$> aopt (textField & cfCI) (fslI MsgCourseParticipantsRegisterTutorialField & setTooltip MsgCourseParticipantsRegisterTutorialFieldTip) (Just $ Just tut) - <*> aopt (selectFieldList tutTypesMsg) (fslI MsgTableTutorialType) (Just ((tutorial ^? _entityVal . _tutorialType) <|> listToMaybe tutTypes)) + <$> aopt (textField & cfCI) (fslI MsgCourseParticipantsRegisterTutorialField & setTooltip MsgCourseParticipantsRegisterTutorialFieldTip) + (Just $ maybeLeft tdesc) + <*> aopt (selectFieldList tutTypesMsg) (fslI MsgTableTutorialType) + (Just tutDefType) <*> aopt dayField (fslI MsgTableTutorialFirstDay & setTooltip MsgCourseParticipantsRegisterTutorialFirstDayTip) - (Just ((tutorial ^? _entityVal . _tutorialFirstDay) <|> Just nowaday)) + (Just $ maybeRight tdesc) ) ( fslI MsgCourseParticipantsRegisterTutorialOption ) ( Just True ) @@ -300,19 +305,19 @@ registerUser cid (_avsIdent, Just uid) = exceptT return return $ do return $ mempty { aurRegisterSuccess = Set.singleton uid } -upsertNewTutorial :: CourseId -> TutorialName -> Maybe (CI Text) -> Maybe Day -> Handler TutorialId -upsertNewTutorial cid newTutorialName newTutorialType anchorDay = runDB $ do +upsertNewTutorial :: CourseId -> TutorialName -> Maybe TutorialType -> Maybe Day -> Handler TutorialId +upsertNewTutorial cid newTutorialName newTutorialType newFirstDay = runDB $ do now <- liftIO getCurrentTime existingTut <- getBy $ UniqueTutorial cid newTutorialName templateEnt <- selectFirst [TutorialType <-. tutorialTemplateNames newTutorialType] [Desc TutorialType] - case (existingTut, anchorDay, templateEnt) of + case (existingTut, newFirstDay, templateEnt) of (Just (Entity{entityKey=tid}),_,_) -> return tid -- no need to update, we ignore the anchor day - (Nothing, Just newFirstDay, Just Entity{entityVal=Tutorial{..}}) -> do + (Nothing, Just moveDay, Just Entity{entityVal=Tutorial{..}}) -> do Course{..} <- get404 cid term <- get404 courseTerm - let oldFirstDay = fromMaybe newFirstDay $ tutorialFirstDay <|> fst (occurrencesBounds term tutorialTime) - newTime = occurrencesAddBusinessDays term (oldFirstDay, newFirstDay) tutorialTime - dayDiff = maybe 0 (diffDays newFirstDay) tutorialFirstDay + let oldFirstDay = fromMaybe moveDay $ tutorialFirstDay <|> fst (occurrencesBounds term tutorialTime) + newTime = occurrencesAddBusinessDays term (oldFirstDay, moveDay) tutorialTime + dayDiff = maybe 0 (diffDays moveDay) tutorialFirstDay mvTime = fmap $ addLocalDays dayDiff newType0 = CI.mk . snd . Text.breakOnEnd tutorialTypeSeparator $ CI.original tutorialType newType = if newType0 `elem` tutorialTemplateNames Nothing @@ -323,7 +328,7 @@ upsertNewTutorial cid newTutorialName newTutorialType anchorDay = runDB $ do { tutorialName = newTutorialName , tutorialCourse = cid , tutorialType = newType - , tutorialFirstDay = anchorDay + , tutorialFirstDay = newFirstDay , tutorialTime = newTime , tutorialRegisterFrom = mvTime tutorialRegisterFrom , tutorialRegisterTo = mvTime tutorialRegisterTo @@ -349,7 +354,7 @@ upsertNewTutorial cid newTutorialName newTutorialType anchorDay = runDB $ do , tutorialDeregisterUntil = Nothing , tutorialLastChanged = now , tutorialTutorControlled = False - , tutorialFirstDay = anchorDay + , tutorialFirstDay = Nothing } [] -- update cannot happen due to previous cases audit $ TransactionTutorialEdit tutId return tutId diff --git a/src/Handler/Tutorial/List.hs b/src/Handler/Tutorial/List.hs index fa24a5966..24f2e87ee 100644 --- a/src/Handler/Tutorial/List.hs +++ b/src/Handler/Tutorial/List.hs @@ -44,9 +44,10 @@ getCTutorialListR tid ssh csh = do dbtRowKey = (E.^. TutorialId) dbtProj = over (_dbrOutput . _2) E.unValue . over (_dbrOutput . _3) E.unValue <$> dbtProjId dbtColonnade = dbColonnade $ mconcat - [ sortable (Just "type") (i18nCell MsgTableTutorialType) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> textCell $ CI.original tutorialType - , sortable (Just "name") (i18nCell MsgTableTutorialName) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) [whamlet|#{tutorialName}|] - , sortable (Just "tutors") (i18nCell MsgTableTutorialTutors) $ \(view $ resultTutorial . _entityKey -> tutid) -> sqlCell $ do + [ sortable (Just "type") (i18nCell MsgTableTutorialType) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> textCell $ CI.original tutorialType + , sortable (Just "first-day") (i18nCell MsgTableTutorialFirstDay) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> cellMaybe dayCell tutorialFirstDay + , sortable (Just "name") (i18nCell MsgTableTutorialName) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) [whamlet|#{tutorialName}|] + , sortable (Just "tutors") (i18nCell MsgTableTutorialTutors) $ \(view $ resultTutorial . _entityKey -> tutid) -> sqlCell $ do tutors <- fmap (map $(unValueN 3)) . E.select . E.from $ \(tutor `E.InnerJoin` user) -> do E.on $ tutor E.^. TutorUser E.==. user E.^. UserId E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid @@ -73,8 +74,9 @@ getCTutorialListR tid ssh csh = do linkButton mempty [whamlet|_{MsgTutorialDelete}|] [BCIsButton, BCDanger] . SomeRoute $ CTutorialR tid ssh csh tutorialName TDeleteR ] dbtSorting = Map.fromList - [ ("type", SortColumn $ \tutorial -> tutorial E.^. TutorialType ) - , ("name", SortColumn $ \tutorial -> tutorial E.^. TutorialName ) + [ ("type" , SortColumn $ \tutorial -> tutorial E.^. TutorialType ) + , ("name" , SortColumn $ \tutorial -> tutorial E.^. TutorialName ) + , ("first-day", SortColumn $ \tutorial -> tutorial E.^. TutorialFirstDay ) , ( "tutors" , SortColumn $ \tutorial -> E.subSelectMaybe . E.from $ \(tutor `E.InnerJoin` user) -> do E.on $ tutor E.^. TutorUser E.==. user E.^. UserId @@ -104,7 +106,7 @@ getCTutorialListR tid ssh csh = do dbtExtraReps = [] tutorialDBTableValidator = def - & defaultSorting [SortAscBy "type", SortAscBy "name"] + & defaultSorting [SortAscBy "type", SortDescBy "first-day", SortAscBy "name"] ((), tutorialTable) <- runDB $ dbTable tutorialDBTableValidator tutorialDBTable siteLayoutMsg (prependCourseTitle tid ssh csh MsgTutorialsHeading) $ do diff --git a/src/Utils.hs b/src/Utils.hs index 4ab7b9a57..78e47edc9 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -870,7 +870,7 @@ deepAlt altFst _ = altFst maybeEmpty :: Monoid m => Maybe a -> (a -> m) -> m maybeEmpty = flip foldMap --- | also referred to as whenJust +-- | also referred to as whenJust and forM_ whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m () whenIsJust (Just x) f = f x whenIsJust Nothing _ = return () diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index d393e22cd..3fa808102 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -46,6 +46,13 @@ insertFile residual fileTitle = do -} +-- | Apply a function @n@ times to a given value. From GHC.Utils.Misc +nTimes :: Int -> (a -> a) -> (a -> a) +nTimes 0 _ = id +nTimes 1 f = f +nTimes n f = f . nTimes (n-1) f + + fillDb :: DB () fillDb = do AppSettings{ appUserDefaults = UserDefaultConf{..} } <- getsYesod $ view appSettings @@ -993,6 +1000,42 @@ fillDb = do Thursday -> "A380" _ -> "B777" , tutorialRoomHidden = False + , tutorialTime = Occurrences + { occurrencesScheduled = Set.empty + , occurrencesExceptions = Set.fromList + [ ExceptOccur + { exceptDay = nTimes 7 succ firstDay + , exceptStart = TimeOfDay 8 30 0 + , exceptEnd = TimeOfDay 16 0 0 + } + , ExceptOccur + { exceptDay = nTimes 8 succ secondDay + , exceptStart = TimeOfDay 9 0 0 + , exceptEnd = TimeOfDay 16 0 0 + } + ] + } + , tutorialRegGroup = Just "Schulung" + , tutorialRegisterFrom = jtt TermDayStart 0 Nothing toMidnight + , tutorialRegisterTo = jtt TermDayLectureStart (-1) Nothing toMidnight + , tutorialDeregisterUntil = jtt TermDayLectureStart (-5) (Just Monday) toMidnight + , tutorialLastChanged = now + , tutorialTutorControlled = True + , tutorialFirstDay = Just firstDay + } + insert_ $ Tutor tut1 jost + insert_ Tutorial + { tutorialName = mkName "Vorlage" + , tutorialCourse = c + , tutorialType = "Schulung" + , tutorialCapacity = capacity + , tutorialRoom = Just $ case weekDay of + Monday -> "A380" + Tuesday -> "B747" + Wednesday -> "MD11" + Thursday -> "A380" + _ -> "B777" + , tutorialRoomHidden = False , tutorialTime = Occurrences { occurrencesScheduled = Set.empty , occurrencesExceptions = Set.fromList @@ -1016,7 +1059,6 @@ fillDb = do , tutorialTutorControlled = True , tutorialFirstDay = Just firstDay } - insert_ $ Tutor tut1 jost void . insert' $ Exam { examCourse = c , examName = mkName "Theorieprüfung" From ac57b1cd32909c8314f3a3b15431d280911af643 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 26 May 2023 19:21:04 +0000 Subject: [PATCH 09/66] fix(build): linter complains --- src/Handler/Course/ParticipantInvite.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index 41b5a11dc..d1b53069a 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -311,7 +311,7 @@ upsertNewTutorial cid newTutorialName newTutorialType newFirstDay = runDB $ do existingTut <- getBy $ UniqueTutorial cid newTutorialName templateEnt <- selectFirst [TutorialType <-. tutorialTemplateNames newTutorialType] [Desc TutorialType] case (existingTut, newFirstDay, templateEnt) of - (Just (Entity{entityKey=tid}),_,_) -> return tid -- no need to update, we ignore the anchor day + (Just Entity{entityKey=tid},_,_) -> return tid -- no need to update, we ignore the anchor day (Nothing, Just moveDay, Just Entity{entityVal=Tutorial{..}}) -> do Course{..} <- get404 cid term <- get404 courseTerm From fb56c3c0cf40996d30354dc908fbc4a96ae81637 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 29 May 2023 10:41:32 +0000 Subject: [PATCH 10/66] chore(release): 27.4.7 --- CHANGELOG.md | 8 ++++++++ nix/docker/demo-version.json | 2 +- nix/docker/version.json | 2 +- package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 6 files changed, 13 insertions(+), 5 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index feb13d0da..b1f791cb1 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,14 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +## [27.4.7](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.6...v27.4.7) (2023-05-29) + + +### Bug Fixes + +* **build:** linter complains ([ac57b1c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ac57b1cd32909c8314f3a3b15431d280911af643)) +* **qualifications:** fix [#78](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/78) block/unblock no longer deletes company association ([3cb66c6](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3cb66c6211b9f15127d88f448557acb4a3a2dd5c)) + ## [27.4.6](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.5...v27.4.6) (2023-05-24) ## [27.4.5](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.4...v27.4.5) (2023-05-23) diff --git a/nix/docker/demo-version.json b/nix/docker/demo-version.json index ca34cd277..6b22a574e 100644 --- a/nix/docker/demo-version.json +++ b/nix/docker/demo-version.json @@ -1,3 +1,3 @@ { - "version": "27.4.6" + "version": "27.4.7" } diff --git a/nix/docker/version.json b/nix/docker/version.json index ca34cd277..6b22a574e 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.6" + "version": "27.4.7" } diff --git a/package-lock.json b/package-lock.json index de776ba53..14dae4e55 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.6", + "version": "27.4.7", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index c36c4aab0..3678be05d 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.6", + "version": "27.4.7", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 67710a91d..b354d0d71 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.6 +version: 27.4.7 dependencies: - base - yesod From 67f8ef754099ba578d466150456a085658d30c32 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 1 Jun 2023 09:44:13 +0000 Subject: [PATCH 11/66] chore(tutorial): sort nulls last for dates --- src/Handler/Tutorial/List.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Handler/Tutorial/List.hs b/src/Handler/Tutorial/List.hs index 24f2e87ee..3f0c6a48d 100644 --- a/src/Handler/Tutorial/List.hs +++ b/src/Handler/Tutorial/List.hs @@ -74,9 +74,9 @@ getCTutorialListR tid ssh csh = do linkButton mempty [whamlet|_{MsgTutorialDelete}|] [BCIsButton, BCDanger] . SomeRoute $ CTutorialR tid ssh csh tutorialName TDeleteR ] dbtSorting = Map.fromList - [ ("type" , SortColumn $ \tutorial -> tutorial E.^. TutorialType ) - , ("name" , SortColumn $ \tutorial -> tutorial E.^. TutorialName ) - , ("first-day", SortColumn $ \tutorial -> tutorial E.^. TutorialFirstDay ) + [ ("type" , SortColumn $ \tutorial -> tutorial E.^. TutorialType ) + , ("name" , SortColumn $ \tutorial -> tutorial E.^. TutorialName ) + , ("first-day", SortColumnNullsInv $ \tutorial -> tutorial E.^. TutorialFirstDay ) , ( "tutors" , SortColumn $ \tutorial -> E.subSelectMaybe . E.from $ \(tutor `E.InnerJoin` user) -> do E.on $ tutor E.^. TutorUser E.==. user E.^. UserId @@ -91,9 +91,9 @@ getCTutorialListR tid ssh csh = do , ("capacity", SortColumn $ \tutorial -> tutorial E.^. TutorialCapacity ) , ("room", SortColumn $ \tutorial -> tutorial E.^. TutorialRoom ) , ("register-group", SortColumn $ \tutorial -> tutorial E.^. TutorialRegGroup ) - , ("register-from", SortColumn $ \tutorial -> tutorial E.^. TutorialRegisterFrom ) - , ("register-to", SortColumn $ \tutorial -> tutorial E.^. TutorialRegisterTo ) - , ("deregister-until", SortColumn $ \tutorial -> tutorial E.^. TutorialDeregisterUntil ) + , ("register-from" , SortColumnNullsInv $ \tutorial -> tutorial E.^. TutorialRegisterFrom ) + , ("register-to" , SortColumnNullsInv $ \tutorial -> tutorial E.^. TutorialRegisterTo ) + , ("deregister-until" , SortColumnNullsInv $ \tutorial -> tutorial E.^. TutorialDeregisterUntil ) ] dbtFilter = Map.empty dbtFilterUI = const mempty From a5dff16d3541a9093532063de1ad14e5e0e636bd Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 2 Jun 2023 09:27:31 +0000 Subject: [PATCH 12/66] chore(fill): change tutorial template type --- test/Database/Fill.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 3fa808102..8b91824f0 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -1027,7 +1027,7 @@ fillDb = do insert_ Tutorial { tutorialName = mkName "Vorlage" , tutorialCourse = c - , tutorialType = "Schulung" + , tutorialType = "Vorlage___Schulung" , tutorialCapacity = capacity , tutorialRoom = Just $ case weekDay of Monday -> "A380" From 798a4bdf0a3596049040d330637b8a7002ec370e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 2 Jun 2023 09:28:34 +0000 Subject: [PATCH 13/66] chore(lms): filter lms by qualification id --- src/Jobs/Handler/LMS.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 1795167c0..46dafb10a 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -93,16 +93,16 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act dispatchJobLmsEnqueueUser :: QualificationId -> UserId -> JobHandler UniWorX dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act - where + where act :: YesodJobDB UniWorX () act = do identsInUseVs <- E.select $ do lui <- E.from $ - ( (E.^. LmsUserlistIdent) <$> E.from (E.table @LmsUserlist) ) + do { u <- E.from (E.table @LmsUserlist); E.where_ (u E.^. LmsUserlistQualification E.==. E.val qid); pure (u E.^. LmsUserlistIdent) } `E.union_` - ( (E.^. LmsResultIdent) <$> E.from (E.table @LmsResult) ) + do { u <- E.from (E.table @LmsResult ); E.where_ (u E.^. LmsResultQualification E.==. E.val qid); pure (u E.^. LmsResultIdent) } `E.union_` - ( (E.^. LmsUserIdent) <$> E.from (E.table @LmsUser) ) + do { u <- E.from (E.table @LmsUser ); E.where_ (u E.^. LmsUserQualification E.==. E.val qid); pure (u E.^. LmsUserIdent) } E.orderBy [E.asc lui] pure lui now <- liftIO getCurrentTime From 88d43560ae8de1480502914d9c95d6376a3c68cc Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 2 Jun 2023 09:57:02 +0000 Subject: [PATCH 14/66] fix(qualification): prevent qualification mixups --- src/Jobs/Handler/LMS.hs | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 46dafb10a..6e8a48f51 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -93,16 +93,16 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act dispatchJobLmsEnqueueUser :: QualificationId -> UserId -> JobHandler UniWorX dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act - where + where act :: YesodJobDB UniWorX () act = do identsInUseVs <- E.select $ do lui <- E.from $ - do { u <- E.from (E.table @LmsUserlist); E.where_ (u E.^. LmsUserlistQualification E.==. E.val qid); pure (u E.^. LmsUserlistIdent) } + ( (E.^. LmsUserlistIdent) <$> E.from (E.table @LmsUserlist) ) -- no filter by Qid, since LmsIdents must be unique across all `E.union_` - do { u <- E.from (E.table @LmsResult ); E.where_ (u E.^. LmsResultQualification E.==. E.val qid); pure (u E.^. LmsResultIdent) } + ( (E.^. LmsResultIdent) <$> E.from (E.table @LmsResult ) ) `E.union_` - do { u <- E.from (E.table @LmsUser ); E.where_ (u E.^. LmsUserQualification E.==. E.val qid); pure (u E.^. LmsUserIdent) } + ( (E.^. LmsUserIdent) <$> E.from (E.table @LmsUser ) ) E.orderBy [E.asc lui] pure lui now <- liftIO getCurrentTime @@ -150,22 +150,26 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act `E.on` (\(quser :& luser) -> luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser E.&&. luser E.^. LmsUserQualification E.==. quser E.^. QualificationUserQualification) - E.where_ $ E.isNothing (luser E.^. LmsUserStatus) + E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid + E.&&. luser E.^. LmsUserQualification E.==. E.val qid + E.&&. E.isNothing (luser E.^. LmsUserStatus) E.&&. E.isNothing (luser E.^. LmsUserEnded) E.&&. E.not_ (validQualification nowaday quser) pure (luser E.^. LmsUserId) nrExpired <- E.updateCount $ \luser -> do E.set luser [LmsUserStatus E.=. E.justVal (LmsExpired nowaday)] E.where_ $ (luser E.^. LmsUserId) `E.in_` E.valList (E.unValue <$> expiredLearners) + E.&&. luser E.^. LmsUserQualification E.==. E.val qid $logInfoS "LMS" $ "Expired lms users " <> tshow nrExpired <> " for qualification " <> qshort notifyInvalidDrivers <- E.select $ do quser <- E.from $ E.table @QualificationUser - E.where_ $ E.not_ (validQualification nowaday quser) - E.&&. (( E.isNothing (quser E.^. QualificationUserBlockedDue) + E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid + E.&&. E.not_ (validQualification nowaday quser) + E.&&. (( E.isNothing (quser E.^. QualificationUserBlockedDue) E.&&. (E.day (quser E.^. QualificationUserLastNotified) E.<. quser E.^. QualificationUserValidUntil) ) E.||. ( - E.isJust (quser E.^. QualificationUserBlockedDue) + E.isJust (quser E.^. QualificationUserBlockedDue) E.&&. (E.day (quser E.^. QualificationUserLastNotified) E.<. E.day' ((quser E.^. QualificationUserBlockedDue) E.->>. "day")) )) pure (quser E.^. QualificationUserUser) From 79b45be5b67c96a00e35475cec8f8c2aea92d742 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 2 Jun 2023 11:17:20 +0000 Subject: [PATCH 15/66] debug(occurrences): find error in occurrencesAddBusinessDays --- src/Handler/Utils/Occurrences.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Handler/Utils/Occurrences.hs b/src/Handler/Utils/Occurrences.hs index f3412e29b..2d3aa97e2 100644 --- a/src/Handler/Utils/Occurrences.hs +++ b/src/Handler/Utils/Occurrences.hs @@ -51,8 +51,8 @@ occurrencesBounds Term{..} Occurrences{..} = (Set.lookupMin occDays, Set.lookupM getOccDays :: OccurrenceSchedule -> Set Day -> Set Day getOccDays ScheduleWeekly{scheduleDayOfWeek=wday} = Set.union $ daysOfWeekBetween (termLectureStart,termLectureEnd) wday -occurrencesAddBusinessDays :: Term -> (Day,Day) -> Occurrences -> Occurrences -occurrencesAddBusinessDays Term{..} (dayOld, dayNew) Occurrences{..} = Occurrences newSchedule newExceptions +occurrencesAddBusinessDays :: Term -> (Day,Day) -> Occurrences -> (Occurrences,_) +occurrencesAddBusinessDays Term{..} (dayOld, dayNew) Occurrences{..} = (Occurrences newSchedule newExceptions,(dayDiff, offDays,loff,dgb)) where newSchedule = Set.map switchDayOfWeek occurrencesScheduled dayDiff = diffDays dayNew dayOld @@ -64,16 +64,16 @@ occurrencesAddBusinessDays Term{..} (dayOld, dayNew) Occurrences{..} = Occurrenc switchDayOfWeek os | 0 == dayDiff `mod` 7 = os switchDayOfWeek os@ScheduleWeekly{scheduleDayOfWeek=wday} = os{scheduleDayOfWeek= toEnum (fromIntegral dayDiff + fromEnum wday)} - newExceptions = snd $ Set.foldr advanceExceptions (dayDiff,mempty) occurrencesExceptions + (loff,newExceptions,dgb) = Set.foldl (flip advanceExceptions) (dayDiff,mempty,mempty) occurrencesExceptions -- we assume that instance Ord OccurrenceException is ordered chronologically - advanceExceptions :: OccurrenceException -> (Integer, Set OccurrenceException) -> (Integer, Set OccurrenceException) - advanceExceptions ex (offset, acc) + advanceExceptions :: OccurrenceException -> (Integer, Set OccurrenceException,_) -> (Integer, Set OccurrenceException,_) + advanceExceptions ex (offset, acc, dbg) | ed `Set.notMember` offDays -- skip term-holidays and weekends, unless the original day was a holiday or weekend , nd `Set.member` offDays - = advanceExceptions ex (succ offset, acc) + = advanceExceptions ex (succ offset, acc, ("skip"<>show offset) :dbg) | otherwise - = (offset, Set.insert (setDayOfOccurrenceException nd ex) acc) + = (offset, Set.insert (setDayOfOccurrenceException nd ex) acc, show ex : dbg) where ed = dayOfOccurrenceException ex nd = addDays offset ed From b982e59b630fbdb3fe8f37c979de8e8726b78ea9 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 2 Jun 2023 11:50:50 +0000 Subject: [PATCH 16/66] fix(tutorial): template moving works now --- src/Handler/Course/ParticipantInvite.hs | 3 ++- src/Handler/Utils/Occurrences.hs | 14 +++++++------- test/Database/Fill.hs | 9 +++++++-- 3 files changed, 16 insertions(+), 10 deletions(-) diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index d1b53069a..2c079fdbd 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -32,6 +32,7 @@ import Generics.Deriving.Monoid (memptydefault, mappenddefault) import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma import qualified Database.Esqueleto.Utils as E +import Utils.Occurrences type UserSearchKey = Text @@ -316,7 +317,7 @@ upsertNewTutorial cid newTutorialName newTutorialType newFirstDay = runDB $ do Course{..} <- get404 cid term <- get404 courseTerm let oldFirstDay = fromMaybe moveDay $ tutorialFirstDay <|> fst (occurrencesBounds term tutorialTime) - newTime = occurrencesAddBusinessDays term (oldFirstDay, moveDay) tutorialTime + newTime = normalizeOccurrences $ occurrencesAddBusinessDays term (oldFirstDay, moveDay) tutorialTime dayDiff = maybe 0 (diffDays moveDay) tutorialFirstDay mvTime = fmap $ addLocalDays dayDiff newType0 = CI.mk . snd . Text.breakOnEnd tutorialTypeSeparator $ CI.original tutorialType diff --git a/src/Handler/Utils/Occurrences.hs b/src/Handler/Utils/Occurrences.hs index 2d3aa97e2..984a4b7a2 100644 --- a/src/Handler/Utils/Occurrences.hs +++ b/src/Handler/Utils/Occurrences.hs @@ -51,8 +51,8 @@ occurrencesBounds Term{..} Occurrences{..} = (Set.lookupMin occDays, Set.lookupM getOccDays :: OccurrenceSchedule -> Set Day -> Set Day getOccDays ScheduleWeekly{scheduleDayOfWeek=wday} = Set.union $ daysOfWeekBetween (termLectureStart,termLectureEnd) wday -occurrencesAddBusinessDays :: Term -> (Day,Day) -> Occurrences -> (Occurrences,_) -occurrencesAddBusinessDays Term{..} (dayOld, dayNew) Occurrences{..} = (Occurrences newSchedule newExceptions,(dayDiff, offDays,loff,dgb)) +occurrencesAddBusinessDays :: Term -> (Day,Day) -> Occurrences -> Occurrences +occurrencesAddBusinessDays Term{..} (dayOld, dayNew) Occurrences{..} = Occurrences newSchedule newExceptions where newSchedule = Set.map switchDayOfWeek occurrencesScheduled dayDiff = diffDays dayNew dayOld @@ -64,16 +64,16 @@ occurrencesAddBusinessDays Term{..} (dayOld, dayNew) Occurrences{..} = (Occurren switchDayOfWeek os | 0 == dayDiff `mod` 7 = os switchDayOfWeek os@ScheduleWeekly{scheduleDayOfWeek=wday} = os{scheduleDayOfWeek= toEnum (fromIntegral dayDiff + fromEnum wday)} - (loff,newExceptions,dgb) = Set.foldl (flip advanceExceptions) (dayDiff,mempty,mempty) occurrencesExceptions + newExceptions = snd $ Set.foldl' advanceExceptions (dayDiff,mempty) occurrencesExceptions -- we assume that instance Ord OccurrenceException is ordered chronologically - advanceExceptions :: OccurrenceException -> (Integer, Set OccurrenceException,_) -> (Integer, Set OccurrenceException,_) - advanceExceptions ex (offset, acc, dbg) + advanceExceptions :: (Integer, Set OccurrenceException) -> OccurrenceException -> (Integer, Set OccurrenceException) + advanceExceptions (offset, acc) ex | ed `Set.notMember` offDays -- skip term-holidays and weekends, unless the original day was a holiday or weekend , nd `Set.member` offDays - = advanceExceptions ex (succ offset, acc, ("skip"<>show offset) :dbg) + = advanceExceptions (succ offset, acc) ex | otherwise - = (offset, Set.insert (setDayOfOccurrenceException nd ex) acc, show ex : dbg) + = (offset, Set.insert (setDayOfOccurrenceException nd ex) acc) where ed = dayOfOccurrenceException ex nd = addDays offset ed diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 8b91824f0..147edec6f 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -1027,7 +1027,7 @@ fillDb = do insert_ Tutorial { tutorialName = mkName "Vorlage" , tutorialCourse = c - , tutorialType = "Vorlage___Schulung" + , tutorialType = "Vorlage" , tutorialCapacity = capacity , tutorialRoom = Just $ case weekDay of Monday -> "A380" @@ -1045,10 +1045,15 @@ fillDb = do , exceptEnd = TimeOfDay 16 0 0 } , ExceptOccur - { exceptDay = secondDay + { exceptDay = succ firstDay , exceptStart = TimeOfDay 9 0 0 , exceptEnd = TimeOfDay 16 0 0 } + , ExceptOccur + { exceptDay = secondDay + , exceptStart = TimeOfDay 10 12 0 + , exceptEnd = TimeOfDay 12 13 0 + } ] } , tutorialRegGroup = Just "schulung" From b72ee99e3e6407c1148d1d9d8c3540215fd0d68c Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 2 Jun 2023 15:20:57 +0200 Subject: [PATCH 17/66] chore(qualification): add expiry option and diversify expiry letter --- .../categories/qualification/de-de-formal.msg | 2 + .../categories/qualification/en-eu.msg | 2 + models/lms.model | 5 +- src/Handler/Qualification.hs | 3 + src/Jobs/Handler/LMS.hs | 35 ++--- src/Utils/Print/ExpireQualification.hs | 16 +- templates/letter/fraport_generic_expiry.md | 139 ++++++++++++++++++ test/Database/Fill.hs | 6 +- 8 files changed, 182 insertions(+), 26 deletions(-) create mode 100644 templates/letter/fraport_generic_expiry.md diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index 77f754e62..66cc53f00 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -11,6 +11,8 @@ QualificationAuditDuration: Aufbewahrung Audit Log QualificationRefreshWithin: Erneurerungszeitraum QualificationRefreshWithinTooltip: Zeitraum für Versand einer Benachrichtigung oder für automatischen Start des E‑Learning QualificationElearningStart: Wird das E‑Learning automatisch gestartet? +QualificationExpiryNotification: Ungültigkeitsbenachrichtigung? +QualificationExpiryNotificationTooltip: Nutzer werden benachrichtigt, wenn die Qualifikation ungültig wird, sofern der jeweilige Nutzer in seinen Benutzereinstellungen diese Art Benachrichtigung aktiviert hat. TableQualificationCountActive: Aktive TableQualificationCountActiveTooltip: Anzahl Personen mit momentan gültiger Qualifikation TableQualificationCountTotal: Gesamt diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 57dcf853b..6cbd6f95d 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -11,6 +11,8 @@ QualificationAuditDuration: Audit log keept QualificationRefreshWithin: Refresh within QualificationRefreshWithinTooltip: Period before expiry to send a notification or to start e‑learning QualificationElearningStart: Is e‑learning automatically started? +QualificationExpiryNotification: Invalidity notification? +QualificationExpiryNotificationTooltip: Qualification holder are notfied upon invalidity, provided they have activated such notification in their user settings. TableQualificationCountActive: Active TableQualificationCountActiveTooltip: Number of currently valid qualification holders TableQualificationCountTotal: Total diff --git a/models/lms.model b/models/lms.model index 4f841f984..805bdc83c 100644 --- a/models/lms.model +++ b/models/lms.model @@ -12,9 +12,8 @@ Qualification auditDuration Int Maybe -- > 0, number of months to keep audit log and LmsUserIdents; or indefinitely (dangerous, since LmsIdents may run out) refreshWithin CalendarDiffDays Maybe -- notify users about renewal within this number of month/days before expiry; to be used with addGregorianDurationClip elearningStart Bool -- automatically schedule e-refresher - -- elearningOnly Bool -- successful E-learing automatically increases validity. NO! - -- refreshInvitation StoredMarkup -- hard-coded I18N-MSGs used instead, but displayed on qualification page NO! - -- expiryNotification StoredMarkup Maybe -- configurable user-profile-notifcations are used instead NO! + -- elearningOnly Bool -- successful E-learing automatically increases validity. NO! + expiryNotification Bool default=true -- should expiryNotification be generated for this qualification? avsLicence AvsLicence Maybe -- if set, valid QualificationUsers are synchronized to AVS as a driving licence sapId Text Maybe -- if set, valid QualificationUsers with userCompanyPersonalNumber are transmitted via SAP interface under this id SchoolQualificationShort school shorthand -- must be unique per school and shorthand diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index a1863add9..810ff57cf 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -101,6 +101,8 @@ mkQualificationAllTable isAdmin = do -- , sortable Nothing (i18nCell MsgQualificationRefreshWithin) $ foldMap textCell . view (resultAllQualification . _qualificationRefreshWithin . to formatCalendarDiffDays) -- does not work, since there is a maybe in between , sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart) $ tickmarkCell . view (resultAllQualification . _qualificationElearningStart) + , sortable (Just "noteexpiry") (i18nCell MsgQualificationExpiryNotification & cellTooltip MsgQualificationExpiryNotificationTooltip) + $ tickmarkCell . view (resultAllQualification . _qualificationExpiryNotification) , sortable Nothing (i18nCell MsgTableQualificationIsAvsLicence & cellTooltip MsgTableQualificationIsAvsLicenceTooltip) $ \(view (resultAllQualification . _qualificationAvsLicence) -> licence) -> maybeCell licence $ textCell . T.singleton . licence2char , sortable Nothing (i18nCell MsgTableQualificationSapExport & cellTooltip MsgTableQualificationSapExportTooltip) @@ -115,6 +117,7 @@ mkQualificationAllTable isAdmin = do , singletonMap "qshort" $ SortColumn (E.^. QualificationShorthand) , singletonMap "qname" $ SortColumn (E.^. QualificationName) , singletonMap "qelearning" $ SortColumn (E.^. QualificationElearningStart) + , singletonMap "noteexpiry" $ SortColumn (E.^. QualificationExpiryNotification) ] dbtFilter = mconcat [ diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 6e8a48f51..4da33143c 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -162,23 +162,24 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act E.&&. luser E.^. LmsUserQualification E.==. E.val qid $logInfoS "LMS" $ "Expired lms users " <> tshow nrExpired <> " for qualification " <> qshort - notifyInvalidDrivers <- E.select $ do - quser <- E.from $ E.table @QualificationUser - E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid - E.&&. E.not_ (validQualification nowaday quser) - E.&&. (( E.isNothing (quser E.^. QualificationUserBlockedDue) - E.&&. (E.day (quser E.^. QualificationUserLastNotified) E.<. quser E.^. QualificationUserValidUntil) - ) E.||. ( - E.isJust (quser E.^. QualificationUserBlockedDue) - E.&&. (E.day (quser E.^. QualificationUserLastNotified) E.<. E.day' ((quser E.^. QualificationUserBlockedDue) E.->>. "day")) - )) - pure (quser E.^. QualificationUserUser) - - forM_ notifyInvalidDrivers $ \(E.Value uid) -> - queueDBJob JobSendNotification - { jRecipient = uid - , jNotification = NotificationQualificationExpired { nQualification = qid } - } + when (quali ^. _qualificationExpiryNotification) $ do + notifyInvalidDrivers <- E.select $ do + quser <- E.from $ E.table @QualificationUser + E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid + E.&&. E.not_ (validQualification nowaday quser) + E.&&. (( E.isNothing (quser E.^. QualificationUserBlockedDue) + E.&&. (E.day (quser E.^. QualificationUserLastNotified) E.<. quser E.^. QualificationUserValidUntil) + ) E.||. ( + E.isJust (quser E.^. QualificationUserBlockedDue) + E.&&. (E.day (quser E.^. QualificationUserLastNotified) E.<. E.day' ((quser E.^. QualificationUserBlockedDue) E.->>. "day")) + )) + pure (quser E.^. QualificationUserUser) + + forM_ notifyInvalidDrivers $ \(E.Value uid) -> + queueDBJob JobSendNotification + { jRecipient = uid + , jNotification = NotificationQualificationExpired { nQualification = qid } + } -- purge outdated LmsUsers case qualificationAuditDuration quali of diff --git a/src/Utils/Print/ExpireQualification.hs b/src/Utils/Print/ExpireQualification.hs index 1d73a3c6a..d261d0f8d 100644 --- a/src/Utils/Print/ExpireQualification.hs +++ b/src/Utils/Print/ExpireQualification.hs @@ -33,11 +33,11 @@ data LetterExpireQualificationF = LetterExpireQualificationF } deriving (Eq, Show) --- TODO: use markdown to generate the Letter +-- TODO: use markdown to generate the Letter -- this is no linger used, I believe instance MDMail LetterExpireQualificationF where attachPDFLetter _ = False getMailSubject l = SomeMessage $ MsgMailSubjectQualificationExpired $ leqfShort l - getMailBody LetterExpireQualificationF{..} DateTimeFormatter{ format } = return $ + getMailBody LetterExpireQualificationF{..} DateTimeFormatter{ format } = return $ -- TODO: can we use render Letter here? let expiryDate = format SelFormatDate <$> leqfExpiry userDisplayName = leqfHolderDN userSurname = leqfHolderSN @@ -59,7 +59,11 @@ instance MDLetter LetterExpireQualificationF where encryptPDFfor _ = NoPassword getLetterKind _ = Din5008 getLetterEnvelope _ = 'e' - getTemplate _ = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/fraport_f_expiry.md") + + getTemplate LetterExpireQualificationF{leqfShort="F"} + = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/fraport_f_expiry.md") + getTemplate _ = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/fraport_generic_expiry.md") + letterMeta LetterExpireQualificationF{..} DateTimeFormatter{ format } lang Entity{entityKey=rcvrId, entityVal=User{userDisplayName}} = let isSupervised = rcvrId /= leqfHolderID @@ -68,11 +72,17 @@ instance MDLetter LetterExpireQualificationF where [ toMeta "supervisor" userDisplayName ] <> [ toMeta "lang" lang + , toMeta "licencename" leqfName + , toMeta "licenceshort" leqfShort , toMeta "licenceholder" leqfHolderDN , mbMeta "expiry" (format SelFormatDate <$> leqfExpiry) , mbMeta "licence-url" leqfUrl , toMeta "de-opening" $ bool ("Guten Tag " <> leqfHolderDN <> ",") "Sehr geehrte Damen und Herren," isSupervised , toMeta "en-opening" $ bool ("Dear " <> leqfHolderDN <> ",") "Dear supervisor," isSupervised + , toMeta "de-subject" $ "Entzug \"" <> leqfShort <> "\" (" <> leqfName <> ")" + , toMeta "en-subject" $ case leqfShort of + "F" -> "Revocation of apron driving license" + _ -> "Revocation of licence \"" <> leqfShort <> "\" (" <> leqfName <> ")" ] getPJId LetterExpireQualificationF{..} = diff --git a/templates/letter/fraport_generic_expiry.md b/templates/letter/fraport_generic_expiry.md new file mode 100644 index 000000000..6b508e3a0 --- /dev/null +++ b/templates/letter/fraport_generic_expiry.md @@ -0,0 +1,139 @@ +--- +### Metadaten, welche hier eingestellt werden: +# Absender +de-subject: Qualifikationsentzug +en-subject: Qualification revocation +author: Fraport AG - Fahrerausbildung (AVN-AR) +phone: +49 69 690-30306 +email: fahrerausbildung@fraport.de +place: Frankfurt am Main +return-address: + - 60547 Frankfurt +de-opening: Liebe Fahrberechtigungsinhaber, +en-opening: Dear driver, +de-closing: | + Mit freundlichen Grüßen, + Ihre Fraport Fahrerausbildung +en-closing: | + With kind regards, + Your Fraport Driver Training +encludes: +hyperrefoptions: hidelinks + +### Metadaten, welche automatisch ersetzt werden: +date: 11.11.1111 +lang: de-de +is-de: true +# Emfpänger +licenceholder: P. Rüfling +address: + - E. M. Pfänger + - Musterfirma GmbH + - Musterstraße 11 + - 12345 Musterstadt +... +$if(titleblock)$ +$titleblock$ + +$endif$ +$for(header-includes)$ +$header-includes$ + +$endfor$ +$for(include-before)$ +$include-before$ + +$endfor$ + +$if(is-de)$ + + +leider ist die Fahrlizenz $licencename$ +$if(supervisor)$ + für **$licenceholder$** +$else$ + Ihre +$endif$ +ungültig geworden, z.B. weil die Ablauffrist erreicht wurde. + + +Die Qualifikation „$licencename$“ ist somit +$if(expiry)$ + seit $expiry$ +$endif$ +nicht mehr gültig. + + +$if(supervisor)$ +$if(licence-url)$ +[$licenceholder$]($licence-url$) +$else$ +$licenceholder$ +$endif$ +darf +$else$ + Sie dürfen +$endif$ +ab sofort diese Qualifikation nicht mehr am Frankfurter Flughafens nutzen. + +Wenden Sie sich zur Wiedererlangung der Qualifikation bitte +$if(supervisor)$ +an die Fahrerausbildung der Fraport AG unter: + +Telefon + + : [$phone$](tel:$phone$) + +Email + + : [$email$](mailto:$email$) + +$else$ +an Ihren Arbeitgeber. +$endif$ + +$else$ + +we regret to inform you that the driving licence $licencename$ has expired for +$if(supervisor)$ + **$licenceholder$**. +$else$ + you. +$endif$ + +The qualification „$licencename$“ is therefore invalid +$if(expiry)$ + since $expiry$. +$else$ + now. +$endif$ + +$if(supervisor)$ +$if(licence-url)$ +[$licenceholder$]($licence-url$) +$else$ +$licenceholder$ +$endif$ +$else$ + You +$endif$ +may no use this qualification at Frankfurt airport, effective immediately. + + +Please contact +$if(supervisor)$ +the Fraport driving school team, if you want to book a course to regain this licence: + +Phone + + : [$phone$](tel:$phone$) + +Email + + : [$email$](mailto:$email$) + +$else$ +your employer to book a course for you in order to regain this licence. +$endif$ + +$endif$ diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 147edec6f..67780ec37 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -695,9 +695,9 @@ fillDb = do let f_descr = Just $ htmlToStoredMarkup [shamlet|

Berechtigung zum Führen eines Fahrzeuges auf den Fahrstrassen des Vorfeldes.|] let r_descr = Just $ htmlToStoredMarkup [shamlet|

Berechtigung zum Führen eines Fahrzeuges auf dem gesamten Rollfeld.|] let l_descr = Just $ htmlToStoredMarkup [shamlet|

für unhabilitierte|] - qid_f <- insert' $ Qualification avn "F" "Vorfeldführerschein" f_descr (Just 24) (Just 6) (Just $ CalendarDiffDays 0 60) True (Just AvsLicenceVorfeld) $ Just "F4466" - qid_r <- insert' $ Qualification avn "R" "Rollfeldführerschein" r_descr (Just 12) (Just 6) (Just $ CalendarDiffDays 2 3) False (Just AvsLicenceRollfeld) $ Just "R2801" - qid_l <- insert' $ Qualification ifi "L" "Lehrbefähigung" l_descr Nothing (Just 6) Nothing True Nothing Nothing + qid_f <- insert' $ Qualification avn "F" "Vorfeldführerschein" f_descr (Just 24) (Just 6) (Just $ CalendarDiffDays 0 60) True True (Just AvsLicenceVorfeld) $ Just "F4466" + qid_r <- insert' $ Qualification avn "R" "Rollfeldführerschein" r_descr (Just 12) (Just 6) (Just $ CalendarDiffDays 2 3) False False (Just AvsLicenceRollfeld) $ Just "R2801" + qid_l <- insert' $ Qualification ifi "L" "Lehrbefähigung" l_descr Nothing (Just 6) Nothing True False Nothing Nothing void . insert' $ QualificationUser jost qid_f (n_day 9) (n_day $ -1) (n_day $ -22) (Just $ QualificationBlocked (n_day $ -5) "LMS") True (n_day' $ -9) -- TODO: better dates! void . insert' $ QualificationUser jost qid_r (n_day 99) (n_day $ -11) (n_day $ -222) Nothing True (n_day' $ -9) -- TODO: better dates! void . insert' $ QualificationUser jost qid_l (n_day 999) (n_day $ -111) (n_day $ -2222) Nothing True (n_day' $ -9) -- TODO: better dates! From b613f22363072ba6ccaee6ead70ad2c2c0e21ad5 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 2 Jun 2023 21:02:03 +0000 Subject: [PATCH 18/66] chore(haddock): fix problematic comments --- src/Foundation/Yesod/Auth.hs | 4 ++-- src/Handler/Admin/Avs.hs | 2 +- src/Model/Types/Avs.hs | 2 +- src/Utils/Avs.hs | 2 +- src/Utils/Csv/Mail.hs | 10 +++++----- 5 files changed, 10 insertions(+), 10 deletions(-) diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index b3fbced9b..efabadc80 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -263,8 +263,8 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do userEmail <- if -- TODO: refactor! NOTE: LDAP doesnt know email for all users; we use userPrincialName instead; however validEmail refutes `E return $ CI.mk userEmail - -- | userEmail : _ <- mapMaybe (assertM validEmail . either (const Nothing) Just . Text.decodeUtf8') (lookupSome ldapMap $ toList ldapUserEmail) -- TOO STRONG, see above! - -- -> return $ CI.mk userEmail + -- | userEmail : _ <- mapMaybe (assertM validEmail . either (const Nothing) Just . Text.decodeUtf8') (lookupSome ldapMap $ toList ldapUserEmail) -- TOO STRONG, see above! + -- -> return $ CI.mk userEmail | otherwise -> throwM CampusUserInvalidEmail diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 99751e95c..90fd59ad6 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -44,7 +44,7 @@ single = uncurry Map.singleton -- Button only needed in AVS TEST; further buttons see below -data ButtonAvsTest = BtnCheckLicences -- | BtnSynchLicences +data ButtonAvsTest = BtnCheckLicences -- | BtnSynchLicences deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic) instance Universe ButtonAvsTest instance Finite ButtonAvsTest diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index f1937c736..dc58f1087 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -254,7 +254,7 @@ instance FromJSON AvsLicence where parseJSON (Number n) | n == 1 = pure AvsLicenceVorfeld -- ordered by occurrence, n==1 is most common case | n == 2 = pure AvsLicenceRollfeld | n == 0 = pure AvsNoLicence - -- | n ==(-1) = pure AvsNoLicenceGuest -- InfoContact may send -1 for Guest unable to obtain a licence + {- | n ==(-1) = pure AvsNoLicenceGuest -- InfoContact may send -1 for Guest unable to obtain a licence -} #ifdef DEVELOPMENT parseJSON invalid = prependFailure "parsing AvsLicence failed, " $ fail $ "expected Int value being 0, 1 or 2. Found " ++ show invalid #else diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs index 9f19af2b6..27932acda 100644 --- a/src/Utils/Avs.hs +++ b/src/Utils/Avs.hs @@ -101,7 +101,7 @@ splitQuery :: (Wrapped a, Wrapped c, Unwrapped a ~ Set b, Semigroup (Unwrapped c splitQuery rawQuery q | avsMaxQueryAtOnce >= Set.size s = rawQuery q | otherwise = do - -- $logInfoS "AVS" $ "Splitting large query for input Set " <> tshow (Set.size s) -- would require MonadLogger ClientM + -- logInfoS "AVS" $ "Splitting large query for input Set " <> tshow (Set.size s) -- would require MonadLogger ClientM let (avsid1, avsid2) = Set.splitAt avsMaxQueryAtOnce s res1 <- rawQuery $ view _Unwrapped' avsid1 res2 <- splitQuery rawQuery $ view _Unwrapped' avsid2 diff --git a/src/Utils/Csv/Mail.hs b/src/Utils/Csv/Mail.hs index f88fe6974..b14fc73cc 100644 --- a/src/Utils/Csv/Mail.hs +++ b/src/Utils/Csv/Mail.hs @@ -56,11 +56,11 @@ recodeCsv encOpts toUser act = fromMaybe act $ do inp <- C.sinkLazy inp' <- recode inp sourceLazy inp' .| act - -- -- | FormatXlsx <- fmt -> do - -- -- inp <- C.sinkLazy - -- -- archive <- throwLeft $ Zip.toArchiveOrFail inp - -- -- archive' <- traverseOf (_zEntries . traverse . _Entrty . _3) recode archive - -- -- sourceLazy (Zip.fromArchive inp') .| act + -- | FormatXlsx <- fmt -> do + -- inp <- C.sinkLazy + -- archive <- throwLeft $ Zip.toArchiveOrFail inp + -- archive' <- traverseOf (_zEntries . traverse . _Entrty . _3) recode archive + -- sourceLazy (Zip.fromArchive inp') .| act | otherwise -> act where From 4f589161a7ae4c6ace4ae131a8b4589ab6cb2888 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 2 Jun 2023 21:03:56 +0000 Subject: [PATCH 19/66] chore(gitignore): ignore /.vscode --- .gitignore | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/.gitignore b/.gitignore index 36bc7572f..b642776ca 100644 --- a/.gitignore +++ b/.gitignore @@ -50,4 +50,5 @@ tunnel.log .develop.env **/result **/result-* -.develop.cmd \ No newline at end of file +.develop.cmd +/.vscode \ No newline at end of file From 22922e8ec616b69c966d43d928ded56119a31e96 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Sat, 3 Jun 2023 01:19:40 +0000 Subject: [PATCH 20/66] chore(release): 27.4.8 --- CHANGELOG.md | 8 ++++++++ nix/docker/demo-version.json | 2 +- nix/docker/version.json | 2 +- package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 6 files changed, 13 insertions(+), 5 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index b1f791cb1..61384a531 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,14 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +## [27.4.8](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.7...v27.4.8) (2023-06-03) + + +### Bug Fixes + +* **qualification:** prevent qualification mixups ([88d4356](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/88d43560ae8de1480502914d9c95d6376a3c68cc)) +* **tutorial:** template moving works now ([b982e59](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b982e59b630fbdb3fe8f37c979de8e8726b78ea9)) + ## [27.4.7](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.6...v27.4.7) (2023-05-29) diff --git a/nix/docker/demo-version.json b/nix/docker/demo-version.json index 6b22a574e..155d3135e 100644 --- a/nix/docker/demo-version.json +++ b/nix/docker/demo-version.json @@ -1,3 +1,3 @@ { - "version": "27.4.7" + "version": "27.4.8" } diff --git a/nix/docker/version.json b/nix/docker/version.json index 6b22a574e..155d3135e 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.7" + "version": "27.4.8" } diff --git a/package-lock.json b/package-lock.json index 14dae4e55..58b5899e1 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.7", + "version": "27.4.8", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 3678be05d..62506c189 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.7", + "version": "27.4.8", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index b354d0d71..a84f3bce4 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.7 +version: 27.4.8 dependencies: - base - yesod From 7d3ccd1183f390e8fbd331d1d874cfc7491a5265 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Sat, 3 Jun 2023 03:36:30 +0000 Subject: [PATCH 21/66] chore(release): 27.4.8 --- CHANGELOG.md | 8 ++++++++ nix/docker/demo-version.json | 2 +- nix/docker/version.json | 2 +- package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 6 files changed, 13 insertions(+), 5 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index b1f791cb1..61384a531 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,14 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +## [27.4.8](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.7...v27.4.8) (2023-06-03) + + +### Bug Fixes + +* **qualification:** prevent qualification mixups ([88d4356](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/88d43560ae8de1480502914d9c95d6376a3c68cc)) +* **tutorial:** template moving works now ([b982e59](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b982e59b630fbdb3fe8f37c979de8e8726b78ea9)) + ## [27.4.7](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.6...v27.4.7) (2023-05-29) diff --git a/nix/docker/demo-version.json b/nix/docker/demo-version.json index 6b22a574e..155d3135e 100644 --- a/nix/docker/demo-version.json +++ b/nix/docker/demo-version.json @@ -1,3 +1,3 @@ { - "version": "27.4.7" + "version": "27.4.8" } diff --git a/nix/docker/version.json b/nix/docker/version.json index 6b22a574e..155d3135e 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.7" + "version": "27.4.8" } diff --git a/package-lock.json b/package-lock.json index 14dae4e55..58b5899e1 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.7", + "version": "27.4.8", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 3678be05d..62506c189 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.7", + "version": "27.4.8", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index b354d0d71..a84f3bce4 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.7 +version: 27.4.8 dependencies: - base - yesod From c57ab17d25578a49b57027aea889530150ab5505 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 5 Jun 2023 11:20:31 +0000 Subject: [PATCH 22/66] refactor(letter): remove class MDMail --- .../courses/courses/de-de-formal.msg | 3 +- .../categories/courses/courses/en-eu.msg | 3 +- src/Handler/PrintCenter.hs | 22 ++--- .../Handler/SendNotification/Qualification.hs | 22 ++--- src/Utils/Print.hs | 40 ++++----- src/Utils/Print/CourseCertificate.hs | 1 + src/Utils/Print/ExpireQualification.hs | 82 +++++++------------ src/Utils/Print/Letters.hs | 17 +--- src/Utils/Print/RenewQualification.hs | 11 ++- src/Utils/Print/SomeLetter.hs | 8 +- templates/mail/qualificationExpired.hamlet | 37 --------- 11 files changed, 86 insertions(+), 160 deletions(-) delete mode 100644 templates/mail/qualificationExpired.hamlet diff --git a/messages/uniworx/categories/courses/courses/de-de-formal.msg b/messages/uniworx/categories/courses/courses/de-de-formal.msg index cf6e1b500..e93ead7ba 100644 --- a/messages/uniworx/categories/courses/courses/de-de-formal.msg +++ b/messages/uniworx/categories/courses/courses/de-de-formal.msg @@ -244,4 +244,5 @@ CourseAvsRegisterTitle: Teilnehmer:innen anmelden CourseAvsRegisterParticipants: Teilnehmer:innen CourseAvsRegisterParticipantsTip: Mehrere Teilnehmer:innen mit Komma separieren -CourseQualifications n@Int: Assoziierte #{pluralDE n "Qualifikation" "Qualifikationen"} \ No newline at end of file +CourseQualifications n@Int: Assoziierte #{pluralDE n "Qualifikation" "Qualifikationen"} +CourseCertificate course@Text: Teilnahmebescheinung #{course} \ No newline at end of file diff --git a/messages/uniworx/categories/courses/courses/en-eu.msg b/messages/uniworx/categories/courses/courses/en-eu.msg index abfbba6cc..087463a3c 100644 --- a/messages/uniworx/categories/courses/courses/en-eu.msg +++ b/messages/uniworx/categories/courses/courses/en-eu.msg @@ -243,4 +243,5 @@ CourseAvsRegisterTitle: Register participants CourseAvsRegisterParticipants: Participants CourseAvsRegisterParticipantsTip: Separate multiple participants with comma -CourseQualifications n: Associated #{pluralENs n "Qualification"} \ No newline at end of file +CourseQualifications n: Associated #{pluralENs n "Qualification"} +CourseCertificate course@Text: Certificate of attendance: #{course} \ No newline at end of file diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index f12f5b9af..98fe75cca 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -94,17 +94,17 @@ lrqf2letter LRQF{..} usrShrt <- encrypt $ entityKey usr usrUuid <- encrypt $ entityKey usr urender <- liftHandler getUrlRender - let letter = LetterExpireQualificationF - { leqfHolderCFN = usrShrt - , leqfHolderID = usr ^. _entityKey - , leqfHolderDN = usr ^. _userDisplayName - , leqfHolderSN = usr ^. _userSurname - , leqfExpiry = lrqfExpiry - , leqfId = lrqfQuali ^. _entityKey - , leqfName = lrqfQuali ^. _qualificationName . _CI - , leqfShort = lrqfQuali ^. _qualificationShorthand . _CI - , leqfSchool = lrqfQuali ^. _qualificationSchool - , leqfUrl = pure . urender $ ForProfileDataR usrUuid + let letter = LetterExpireQualification + { leqHolderCFN = usrShrt + , leqHolderID = usr ^. _entityKey + , leqHolderDN = usr ^. _userDisplayName + , leqHolderSN = usr ^. _userSurname + , leqExpiry = lrqfExpiry + , leqId = lrqfQuali ^. _entityKey + , leqName = lrqfQuali ^. _qualificationName . _CI + , leqShort = lrqfQuali ^. _qualificationShorthand . _CI + , leqSchool = lrqfQuali ^. _qualificationSchool + , leqUrl = pure . urender $ ForProfileDataR usrUuid } return (fromMaybe usr rcvr, SomeLetter letter) | otherwise = error "Unknown Letter Type encountered. Use 'e' or 'r' only." diff --git a/src/Jobs/Handler/SendNotification/Qualification.hs b/src/Jobs/Handler/SendNotification/Qualification.hs index 241af0bc3..2200b12c3 100644 --- a/src/Jobs/Handler/SendNotification/Qualification.hs +++ b/src/Jobs/Handler/SendNotification/Qualification.hs @@ -57,17 +57,17 @@ dispatchNotificationQualificationExpired nQualification jRecipient = do let expDay = maybe qualificationUserValidUntil (min qualificationUserValidUntil . qualificationBlockedDay) qualificationUserBlockedDue qname = CI.original qualificationName qshort = CI.original qualificationShorthand - letter = LetterExpireQualificationF - { leqfHolderCFN = encRecShort - , leqfHolderID = jRecipient - , leqfHolderDN = userDisplayName - , leqfHolderSN = userSurname - , leqfExpiry = Just expDay - , leqfId = nQualification - , leqfName = qname - , leqfShort = qshort - , leqfSchool = qualificationSchool - , leqfUrl = pure . urender $ ForProfileDataR encRecipient + letter = LetterExpireQualification + { leqHolderCFN = encRecShort + , leqHolderID = jRecipient + , leqHolderDN = userDisplayName + , leqHolderSN = userSurname + , leqExpiry = Just expDay + , leqId = nQualification + , leqName = qname + , leqShort = qshort + , leqSchool = qualificationSchool + , leqUrl = pure . urender $ ForProfileDataR encRecipient } if expDay > utctDay qualificationUserLastNotified then do diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index f1d3054de..0d17e1781 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -22,7 +22,7 @@ module Utils.Print -- , MDLetter , SomeLetter(..) , LetterRenewQualificationF(..) - , LetterExpireQualificationF(..) + , LetterExpireQualification(..) -- , LetterCourseCertificate() , makeCourseCertificates ) where @@ -287,18 +287,24 @@ printLetter'' _ = do } -} -sendEmailOrLetter :: (MDLetter l, MDMail l) => UserId -> l -> Handler Bool +sendEmailOrLetter :: (MDLetter l) => UserId -> l -> Handler Bool sendEmailOrLetter recipient letter = do (underling, receivers, undercopy) <- updateReceivers recipient -- TODO: check to avoid this almost circular dependency now <- liftIO getCurrentTime + mr <- getMessageRender let pjid = getPJId letter fName = letterFileName letter - mailSubject = getMailSubject letter -- these are only needed if sent by email, but we're lazy anyway - undername = underling ^. _userDisplayName -- nameHtml' underling - undermail = CI.original $ underling ^. _userEmail - mr <- getMessageRender - let mailSupervisorSubject = SomeMessage $ "[SUPERVISOR] " <> mr mailSubject + -- these are only needed if sent by email, but we're lazy anyway + undername = underling ^. _userDisplayName -- nameHtml' underling + undermail = CI.original $ underling ^. _userEmail + mailSubjectRaw = getMailSubject letter + mailSubjectSuper = SomeMessage $ "[SUPERVISOR] " <> mr mailSubjectRaw + mkMailSubject = bool mailSubjectRaw mailSubjectSuper + mkMailBody = getMailBody letter oks <- forM receivers $ \rcvrEnt@Entity{ entityKey = svr, entityVal = rcvrUsr } -> do + let supername = rcvrUsr ^. _userDisplayName -- nameHtml' rcvrUsr + isSupervised = recipient /= svr + mailSubject = mkMailSubject isSupervised encRecipient :: CryptoUUIDUser <- encrypt svr apcIdent <- letterApcIdent letter encRecipient now case getPostalPreferenceAndAddress rcvrUsr of @@ -323,7 +329,7 @@ sendEmailOrLetter recipient letter = do $logWarnS "LETTER" $ "PDF printing to send letter with lpr returned ExitSuccess and the following message: " <> msg return True - (False, _) | attachPDFLetter letter -> renderLetterPDF rcvrEnt letter apcIdent >>= \case -- send Email, with pdf attached + (False, _) | Just mkMail <- mkMailBody -> renderLetterPDF rcvrEnt letter apcIdent >>= \case -- send Email, but with pdf attached Left err -> do -- pdf generation failed let msg = "Notification failed for " <> tshow encRecipient <> ". PDF attachment generation failed: "<> cropText err <> "For Notification: " <> tshow pjid $logErrorS "LETTER" msg @@ -342,14 +348,12 @@ sendEmailOrLetter recipient letter = do $logWarnS "LETTER" msg return pdf formatter <- getDateTimeFormatterUser' rcvrUsr -- not too expensive, only calls getTimeLocale - let isSupervised = recipient /= svr - supername = rcvrUsr ^. _userDisplayName -- nameHtml' rcvrUsr - mailBody <- getMailBody letter formatter + let mailBody = mkMail formatter userMailTdirect svr $ do replaceMailHeader "Auto-Submitted" $ Just "auto-generated" setSubjectI mailSubject editNotifications <- mkEditNotifications svr - addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/genericMailLetter.hamlet") + addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/genericMailLetter.hamlet") -- wrapper for mailBody addPart (File { fileTitle = fName , fileModified = now , fileContent = Just $ yield $ LBS.toStrict attachment @@ -361,18 +365,10 @@ sendEmailOrLetter recipient letter = do let msg = "Notification failed for " <> tshow encRecipient <> ". HTML generation failed: "<> cropText err <> "For Notification: " <> tshow pjid $logErrorS "LETTER" msg return False - Right html -> do -- html generated, send directly now - let isSupervised = recipient /= svr - -- subject = if isSupervised - -- then "[SUPERVISOR] " <> mailSubject - -- else mailSubject - subject = if isSupervised - then mailSupervisorSubject - else mailSubject + Right html -> do -- html generated, send directly now userMailTdirect svr $ do replaceMailHeader "Auto-Submitted" $ Just "auto-generated" - setSubjectI subject - -- when isSupervised $ mapSubject ("[SUPERVISOR] " <>) + setSubjectI mailSubject addHtmlMarkdownAlternatives html return True return $ or oks diff --git a/src/Utils/Print/CourseCertificate.hs b/src/Utils/Print/CourseCertificate.hs index 4474ac754..babcdfa54 100644 --- a/src/Utils/Print/CourseCertificate.hs +++ b/src/Utils/Print/CourseCertificate.hs @@ -45,6 +45,7 @@ instance MDLetter LetterCourseCertificate where Text.replace "%%%course-content%%%" (unlines ccc) $ decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/fraport_qualification.md") getTemplate _ = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/fraport_qualification.md") + getMailSubject l = SomeMessage . MsgCourseCertificate $ ccCourseName l letterMeta LetterCourseCertificate{..} DateTimeFormatter{ format } lang _rcvrEnt = mkMeta diff --git a/src/Utils/Print/ExpireQualification.hs b/src/Utils/Print/ExpireQualification.hs index d261d0f8d..ddbba609e 100644 --- a/src/Utils/Print/ExpireQualification.hs +++ b/src/Utils/Print/ExpireQualification.hs @@ -7,7 +7,6 @@ module Utils.Print.ExpireQualification where import Import -import Text.Hamlet -- import Data.Char as Char -- import qualified Data.Text as Text @@ -16,85 +15,64 @@ import qualified Data.CaseInsensitive as CI import Data.FileEmbed (embedFile) import Utils.Print.Letters -import Handler.Utils.Widgets (nameHtml) -- , nameHtml') -data LetterExpireQualificationF = LetterExpireQualificationF - { leqfHolderCFN :: CryptoFileNameUser - , leqfHolderID :: UserId - , leqfHolderDN :: UserDisplayName - , leqfHolderSN :: UserSurname - , leqfExpiry :: Maybe Day - , leqfId :: QualificationId - , leqfName :: Text - , leqfShort :: Text - , leqfSchool :: SchoolId - , leqfUrl :: Maybe Text +data LetterExpireQualification = LetterExpireQualification + { leqHolderCFN :: CryptoFileNameUser + , leqHolderID :: UserId + , leqHolderDN :: UserDisplayName + , leqHolderSN :: UserSurname + , leqExpiry :: Maybe Day + , leqId :: QualificationId + , leqName :: Text + , leqShort :: Text + , leqSchool :: SchoolId + , leqUrl :: Maybe Text } deriving (Eq, Show) --- TODO: use markdown to generate the Letter -- this is no linger used, I believe -instance MDMail LetterExpireQualificationF where - attachPDFLetter _ = False - getMailSubject l = SomeMessage $ MsgMailSubjectQualificationExpired $ leqfShort l - getMailBody LetterExpireQualificationF{..} DateTimeFormatter{ format } = return $ -- TODO: can we use render Letter here? - let expiryDate = format SelFormatDate <$> leqfExpiry - userDisplayName = leqfHolderDN - userSurname = leqfHolderSN - qualificationName = leqfName - qualificationShorthand = CI.mk leqfShort - qualificationSchool = leqfSchool - qname = qualificationName - ihamletSomeMessage _ _ _ = (mempty :: Html) -- TODO: use markdown for letter - editNotifications = () -- TODO: use markdown for letter - in $(ihamletFile "templates/mail/qualificationExpired.hamlet") - -- const $ const html - -- Html -> HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX) - -- foo _ _ html -> html - -- [shamlet|#Ansprache #{html}|] um Html umzuwandeln! - -- - -instance MDLetter LetterExpireQualificationF where +instance MDLetter LetterExpireQualification where encryptPDFfor _ = NoPassword getLetterKind _ = Din5008 getLetterEnvelope _ = 'e' + getMailSubject l = SomeMessage $ MsgMailSubjectQualificationExpired $ leqShort l - getTemplate LetterExpireQualificationF{leqfShort="F"} + getTemplate LetterExpireQualification{leqShort="F"} = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/fraport_f_expiry.md") getTemplate _ = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/fraport_generic_expiry.md") - letterMeta LetterExpireQualificationF{..} DateTimeFormatter{ format } lang Entity{entityKey=rcvrId, entityVal=User{userDisplayName}} = - let isSupervised = rcvrId /= leqfHolderID + letterMeta LetterExpireQualification{..} DateTimeFormatter{ format } lang Entity{entityKey=rcvrId, entityVal=User{userDisplayName}} = + let isSupervised = rcvrId /= leqHolderID in mkMeta $ guardMonoid isSupervised [ toMeta "supervisor" userDisplayName ] <> [ toMeta "lang" lang - , toMeta "licencename" leqfName - , toMeta "licenceshort" leqfShort - , toMeta "licenceholder" leqfHolderDN - , mbMeta "expiry" (format SelFormatDate <$> leqfExpiry) - , mbMeta "licence-url" leqfUrl - , toMeta "de-opening" $ bool ("Guten Tag " <> leqfHolderDN <> ",") "Sehr geehrte Damen und Herren," isSupervised - , toMeta "en-opening" $ bool ("Dear " <> leqfHolderDN <> ",") "Dear supervisor," isSupervised - , toMeta "de-subject" $ "Entzug \"" <> leqfShort <> "\" (" <> leqfName <> ")" - , toMeta "en-subject" $ case leqfShort of + , toMeta "licencename" leqName + , toMeta "licenceshort" leqShort + , toMeta "licenceholder" leqHolderDN + , mbMeta "expiry" (format SelFormatDate <$> leqExpiry) + , mbMeta "licence-url" leqUrl + , toMeta "de-opening" $ bool ("Guten Tag " <> leqHolderDN <> ",") "Sehr geehrte Damen und Herren," isSupervised + , toMeta "en-opening" $ bool ("Dear " <> leqHolderDN <> ",") "Dear supervisor," isSupervised + , toMeta "de-subject" $ "Entzug \"" <> leqShort <> "\" (" <> leqName <> ")" + , toMeta "en-subject" $ case leqShort of "F" -> "Revocation of apron driving license" - _ -> "Revocation of licence \"" <> leqfShort <> "\" (" <> leqfName <> ")" + _ -> "Revocation of licence \"" <> leqShort <> "\" (" <> leqName <> ")" ] - getPJId LetterExpireQualificationF{..} = + getPJId LetterExpireQualification{..} = PrintJobIdentification { pjiName = "Expiry" - , pjiApcAcknowledge = "ex-" <> toPathPiece leqfHolderCFN + , pjiApcAcknowledge = "ex-" <> toPathPiece leqHolderCFN , pjiRecipient = Nothing -- to be filled later , pjiSender = Nothing , pjiCourse = Nothing - , pjiQualification = Just leqfId + , pjiQualification = Just leqId , pjiLmsUser = Nothing - , pjiFileName = "expire_" <> CI.original (unSchoolKey leqfSchool) <> "-" <> leqfShort <> "_" <> leqfHolderSN + , pjiFileName = "expire_" <> CI.original (unSchoolKey leqSchool) <> "-" <> leqShort <> "_" <> leqHolderSN -- let nameRecipient = abbrvName <$> recipient -- nameSender = abbrvName <$> sender -- nameCourse = CI.original . courseShorthand <$> course diff --git a/src/Utils/Print/Letters.hs b/src/Utils/Print/Letters.hs index 7fe8b4a68..37ffde18c 100644 --- a/src/Utils/Print/Letters.hs +++ b/src/Utils/Print/Letters.hs @@ -226,6 +226,9 @@ class MDLetter l where getLetterKind :: l -> LetterKind getTemplate :: l -> Text encryptPDFfor :: l -> EncryptPDFfor + getMailSubject :: l -> SomeMessage UniWorX -- currently only used as email subject + getMailBody :: l -> Maybe (DateTimeFormatter -> HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)) -- Just returns cover-lettter for attaching PDF to, Nothing indicates that the letter should be sent as direct Html Email + getMailBody = const Nothing letterApcIdent :: (MDLetter l, MonadHandler m) => l -> CryptoUUIDUser -> UTCTime -> m Text letterApcIdent l uuid now = do @@ -242,17 +245,3 @@ addApcIdent = P.Meta . toMeta "apc-ident" getApcIdent :: P.Meta -> Maybe Text getApcIdent (P.lookupMeta "apc-ident" -> Just (P.MetaString t)) = Just t getApcIdent _ = Nothing - - ----------------- --- Mail Class -- ----------------- - --- this is for letters that may alternatively be sent as attachments to emails - -class MDMail l where -- - getMailSubject :: l -> SomeMessage UniWorX -- only used if letter is sent by email as pdf attachment - getMailBody :: (MonadHandler m) => l -> DateTimeFormatter -> m (HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)) -- only used if letter is sent by email as pdf attachment - -- | should the email also contain the letter as a PDF attachment? - attachPDFLetter :: l -> Bool - attachPDFLetter = const True diff --git a/src/Utils/Print/RenewQualification.hs b/src/Utils/Print/RenewQualification.hs index a7900105c..31a5a23dc 100644 --- a/src/Utils/Print/RenewQualification.hs +++ b/src/Utils/Print/RenewQualification.hs @@ -46,17 +46,16 @@ letterRenewalQualificationFData LetterRenewQualificationF{lmsLogin} = LetterRene lmsUrlLogin = lmsUrl <> "/?login=" <> lmsIdent lmsIdent = getLmsIdent lmsLogin -instance MDMail LetterRenewQualificationF where - getMailSubject l = SomeMessage $ MsgMailSubjectQualificationRenewal $ qualShort l - getMailBody l@LetterRenewQualificationF{..} DateTimeFormatter{ format } = return $ - let LetterRenewQualificationFData{..} = letterRenewalQualificationFData l - in $(ihamletFile "templates/mail/body/qualificationRenewal.hamlet") instance MDLetter LetterRenewQualificationF where - encryptPDFfor _ = PasswordUnderling + encryptPDFfor _ = PasswordUnderling getLetterKind _ = PinLetter getLetterEnvelope _ = 'f' -- maybe 'q' (Char.toLower . fst) $ Text.uncons (qualShort l) getTemplate _ = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/fraport_renewal.md") + getMailSubject l = SomeMessage $ MsgMailSubjectQualificationRenewal $ qualShort l + getMailBody l@LetterRenewQualificationF{..} = Just $ \DateTimeFormatter{ format } -> + let LetterRenewQualificationFData{..} = letterRenewalQualificationFData l + in $(ihamletFile "templates/mail/body/qualificationRenewal.hamlet") letterMeta l@LetterRenewQualificationF{..} DateTimeFormatter{ format } lang Entity{entityKey=rcvrId, entityVal=User{userDisplayName}} = let LetterRenewQualificationFData{..} = letterRenewalQualificationFData l diff --git a/src/Utils/Print/SomeLetter.hs b/src/Utils/Print/SomeLetter.hs index b10ed63c0..e0ba66645 100644 --- a/src/Utils/Print/SomeLetter.hs +++ b/src/Utils/Print/SomeLetter.hs @@ -8,11 +8,7 @@ module Utils.Print.SomeLetter where import Utils.Print.Letters -data SomeLetter = forall l . (MDLetter l, MDMail l) => SomeLetter l -- a record selector would be useless here due to the escaped type variable - -instance MDMail SomeLetter where - getMailSubject (SomeLetter l) = getMailSubject l - getMailBody (SomeLetter l) = getMailBody l +data SomeLetter = forall l . (MDLetter l) => SomeLetter l -- a record selector would be useless here due to the escaped type variable instance MDLetter SomeLetter where letterMeta (SomeLetter l) = letterMeta l @@ -20,4 +16,6 @@ instance MDLetter SomeLetter where getLetterEnvelope (SomeLetter l) = getLetterEnvelope l getLetterKind (SomeLetter l) = getLetterKind l getTemplate (SomeLetter l) = getTemplate l + getMailSubject (SomeLetter l) = getMailSubject l + getMailBody (SomeLetter l) = getMailBody l encryptPDFfor (SomeLetter l) = encryptPDFfor l \ No newline at end of file diff --git a/templates/mail/qualificationExpired.hamlet b/templates/mail/qualificationExpired.hamlet deleted file mode 100644 index a7d84f549..000000000 --- a/templates/mail/qualificationExpired.hamlet +++ /dev/null @@ -1,37 +0,0 @@ -$newline never - -$# SPDX-FileCopyrightText: 2022 Steffen Jost -$# -$# SPDX-License-Identifier: AGPL-3.0-or-later - -\ - - - -