From ffaaf9c86d5caa7eaec2d2bcd06bc6963310a7eb Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 6 Mar 2023 17:27:57 +0000 Subject: [PATCH] feat(course): associate qualifications with courses --- models/courses.model | 7 +++++ src/Handler/Tutorial/Users.hs | 57 ++++++++++++++++++++++------------- test/Database/Fill.hs | 14 ++++++--- 3 files changed, 52 insertions(+), 26 deletions(-) diff --git a/models/courses.model b/models/courses.model index 3bfee5a1b..0d278f295 100644 --- a/models/courses.model +++ b/models/courses.model @@ -90,3 +90,10 @@ CourseUserExamOfficeOptOut school SchoolId UniqueCourseUserExamOfficeOptOut course user school deriving Generic + +CourseQualification + course CourseId + qualification QualificationId + sortOrder Int default=0 + UniqueCourseQualification course qualification + deriving Generic \ No newline at end of file diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index 8ece41d3a..e01ff2223 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -2,6 +2,8 @@ -- -- SPDX-License-Identifier: AGPL-3.0-or-later +{-# LANGUAGE TypeApplications #-} + module Handler.Tutorial.Users ( getTUsersR, postTUsersR ) where @@ -20,7 +22,8 @@ import qualified Data.Map as Map -- import qualified Data.Time.Zones as TZ -import qualified Database.Esqueleto.Legacy as E +import Database.Esqueleto.Experimental ((:&)(..)) +import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma import Handler.Course.Users @@ -54,8 +57,17 @@ getTUsersR = postTUsersR postTUsersR tid ssh csh tutn = do showSex <- getShowSex (Entity tutid Tutorial{..}, (participantRes, participantTable)) <- runDB $ do + cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh tut@(Entity tutid _) <- fetchTutorial tid ssh csh tutn - qualifications <- selectList [QualificationSchool ==. ssh] [Asc QualificationShorthand] + -- qualifications <- selectList [QualificationSchool ==. ssh] [Asc QualificationShorthand] + qualifications <- E.select $ do + (qual :& courseQual) <- + E.from $ E.table @Qualification + `E.innerJoin` E.table @CourseQualification + `E.on` (\(qual :& courseQual) -> qual E.^. QualificationId E.==. courseQual E.^. CourseQualificationQualification) + E.where_ $ courseQual E.^. CourseQualificationCourse E.==. E.val cid + E.orderBy [E.asc $ courseQual E.^. CourseQualificationSortOrder] + pure qual now <- liftIO getCurrentTime let minDur :: Maybe Int = minimumMaybe $ catMaybes (view _qualificationValidDuration <$> qualifications) -- no instance Ord CalendarDiffDays dayExpiry = flip addGregorianDurationClip (utctDay now) . fromMonths <$> minDur @@ -71,12 +83,12 @@ postTUsersR tid ssh csh tutn = do & defaultSortingByName & restrictSorting (\name _ -> none (== name) ["note", "registration", "tutorials", "exams", "submission-group", "state"]) -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information & restrictFilter (\name _ -> none (== name) ["tutorial", "exam", "submission-group", "active", "has-personalised-sheet-files"]) - isInTut q = E.exists . E.from $ \tutorialParticipant -> + isInTut q = E.exists $ do + tutorialParticipant <- E.from $ E.table @TutorialParticipant E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser q E.^. UserId E.&&. tutorialParticipant E.^. TutorialParticipantTutorial E.==. E.val tutid csvColChoices = flip elem ["name", "matriculation", "email", "qualifications"] - - cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh + let qualOpt :: Entity Qualification -> Handler (Option QualificationId) qualOpt (Entity qualId qual) = do @@ -87,17 +99,20 @@ postTUsersR tid ssh csh tutn = do , optionExternalValue = tshow cQualId } acts :: Map TutorialUserAction (AForm Handler TutorialUserActionData) - acts = Map.fromList - [ ( TutorialUserRenewQualification - , TutorialUserRenewQualificationData - <$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing - ) - , ( TutorialUserGrantQualification - , TutorialUserGrantQualificationData - <$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing - <*> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry - ) - , ( TutorialUserSendMail, pure TutorialUserSendMailData ) + acts = Map.fromList $ + (if null qualifications then mempty else + [ ( TutorialUserRenewQualification + , TutorialUserRenewQualificationData + <$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing + ) + , ( TutorialUserGrantQualification + , TutorialUserGrantQualificationData + <$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing + <*> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry + ) + ] + ) ++ + [ ( TutorialUserSendMail, pure TutorialUserSendMailData ) , ( TutorialUserDeregister, pure TutorialUserDeregisterData ) ] table <- makeCourseUserTable cid acts isInTut colChoices psValidator (Just csvColChoices) @@ -125,11 +140,11 @@ postTUsersR tid ssh csh tutn = do addMessageI Success $ MsgTutorialUsersDeregistered nrDel redirect $ CTutorialR tid ssh csh tutn TUsersR - tutors <- runDB $ - 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 - return user + tutors <- runDB $ E.select $ do + (tutor :& user) <- E.from $ E.table @Tutor `E.innerJoin` E.table @User + `E.on` (\(tutor :& user) -> tutor E.^. TutorUser E.==. user E.^. UserId) + E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid + return user let heading = prependCourseTitle tid ssh csh $ CI.original tutorialName siteLayoutMsg heading $ do diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 87f3e38ae..995ae5f48 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -57,8 +57,8 @@ fillDb = do addBDays = addBusinessDays Fraport -- holiday area to use n_day n = addBDays n $ utctDay now n_day' n = now { utctDay = n_day n } - currentTerm = TermIdentifier . fst3 . toGregorian $ utctDay now - -- (currentYear, currentMonth, currentDay) = toGregorian $ getTermDay currentTerm + (currentYear, _currentMonth, _currentDay) = toGregorian $ utctDay now + currentTerm = TermIdentifier currentYear nextTerm n = toEnum . (+n) $ fromEnum currentTerm termTime :: TermIdentifier -- ^ Term @@ -172,7 +172,7 @@ fillDb = do , userTitle = Just "Dr." , userMaxFavourites = 14 , userMaxFavouriteTerms = 4 - , userTheme = userDefaultTheme + , userTheme = ThemeSkyLove , userDateTimeFormat = userDefaultDateTimeFormat , userDateFormat = userDefaultDateFormat , userTimeFormat = userDefaultTimeFormat @@ -402,7 +402,7 @@ fillDb = do , userTitle = Nothing , userMaxFavourites = userDefaultMaxFavourites , userMaxFavouriteTerms = userDefaultMaxFavourites - , userTheme = userDefaultTheme + , userTheme = ThemeAberdeenReds , userDateTimeFormat = userDefaultDateTimeFormat , userDateFormat = userDefaultDateFormat , userTimeFormat = userDefaultTimeFormat @@ -786,6 +786,7 @@ fillDb = do jtt = (((Just .) .) .) . termTime tid firstDay = utctDay $ termTime tid TermDayLectureStart 0 Nothing toMidnight secondDay = utctDay $ termTime tid TermDayLectureStart 1 Nothing toMidnight + tyear = year tid weekDay = dayOfWeek firstDay -- thirdDay = utctDay $ termTime tid TermDayLectureStart 2 Nothing toMidnight capacity = Just 8 @@ -816,8 +817,11 @@ fillDb = do , courseDeregisterUntil = jtt TermDayLectureStart (-5) (Just Monday) toMidnight , courseRegisterSecret = Nothing , courseMaterialFree = True - } + } insert_ $ CourseEdit jost now c + when (tyear >= currentYear) $ insert_ $ CourseQualification c qid_f 2 + when (tyear >= succ currentYear) $ insert_ $ CourseQualification c qid_r 3 + when (tyear >= succ (succ currentYear)) $ insert_ $ CourseQualification c qid_l 1 insert_ Sheet { sheetCourse = c , sheetName = mkName "Sehtest"