From 0fde59c19aefa708e10ff9349044eae9a4278540 Mon Sep 17 00:00:00 2001 From: Steffen Date: Wed, 31 Jul 2024 17:51:13 +0200 Subject: [PATCH] chore(profile): show user courses among enrolled course type list (Recall: course = tutorial, course type = course) --- src/Handler/Profile.hs | 107 ++++++++++++++++++++++++----------------- test/Database/Fill.hs | 14 +++++- 2 files changed, 75 insertions(+), 46 deletions(-) diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index d888678be..9bddff59c 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -31,9 +31,11 @@ import Utils.Print (validCmdArgument) import Data.Map ((!)) import qualified Data.Map as Map import qualified Data.Set as Set -import qualified Database.Esqueleto.Legacy as E +import Database.Esqueleto.Experimental ((:&)(..)) +import qualified Database.Esqueleto.Experimental as E +import qualified Database.Esqueleto.Legacy as EL (on,from) import qualified Database.Esqueleto.Utils as E --- import Database.Esqueleto ((^.)) + import qualified Data.Text as Text import Data.List (inits) @@ -192,28 +194,28 @@ notificationForm template = wFormToAForm $ do -> return False NTKCourseParticipant | Just uid <- mbUid - -> fmap not . E.selectExists . E.from $ \courseParticipant -> + -> fmap not . E.selectExists . EL.from $ \courseParticipant -> E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val uid E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive NTKSubmissionUser | Just uid <- mbUid - -> fmap not . E.selectExists . E.from $ \submissionUser -> + -> fmap not . E.selectExists . EL.from $ \submissionUser -> E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val uid NTKExamParticipant | Just uid <- mbUid - -> fmap not . E.selectExists . E.from $ \examRegistration -> + -> fmap not . E.selectExists . EL.from $ \examRegistration -> E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val uid NTKCorrector | Just uid <- mbUid - -> fmap not . E.selectExists . E.from $ \sheetCorrector -> + -> fmap not . E.selectExists . EL.from $ \sheetCorrector -> E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid NTKCourseLecturer | Just uid <- mbUid - -> fmap not . E.selectExists . E.from $ \lecturer -> + -> fmap not . E.selectExists . EL.from $ \lecturer -> E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid NTKFunctionary f | Just uid <- mbUid - -> fmap not . E.selectExists . E.from $ \userFunction -> + -> fmap not . E.selectExists . EL.from $ \userFunction -> E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val uid E.&&. userFunction E.^. UserFunctionFunction E.==. E.val f _ | Nothing <- mbUid -> return False -- Show everything for not-logged-in users (e.g. if they presented a token) @@ -428,8 +430,8 @@ serveProfileR :: (UserId, User) -> Handler Html serveProfileR (uid, user@User{..}) = do currentRoute <- fromMaybe ProfileR <$> getCurrentRoute (userSchools, userExamOfficeLabels) <- runDB $ do - userSchools <- fmap (setOf $ folded . _Value) . E.select . E.from $ \school -> do - E.where_ . E.exists . E.from $ \userSchool -> + userSchools <- fmap (setOf $ folded . _Value) . E.select . EL.from $ \school -> do + E.where_ . E.exists . EL.from $ \userSchool -> E.where_ $ E.not_ (userSchool E.^. UserSchoolIsOptOut) E.&&. userSchool E.^. UserSchoolUser E.==. E.val uid E.&&. userSchool E.^. UserSchoolSchool E.==. school E.^. SchoolId @@ -519,8 +521,8 @@ serveProfileR (uid, user@User{..}) = do oldExamLabels = userExamOfficeLabels newExamLabels = stgExamOfficeSettings & eosettingsLabels forM_ oldExamLabels $ \(Entity eolid ExamOfficeLabel{..}) -> unless (Right eolid `Map.member` newExamLabels || Left examOfficeLabelName `Map.member` newExamLabels) $ do - E.delete . E.from $ \examOfficeExternalExamLabel -> E.where_ $ examOfficeExternalExamLabel E.^. ExamOfficeExternalExamLabelLabel E.==. E.val eolid - E.delete . E.from $ \examOfficeExamLabel -> E.where_ $ examOfficeExamLabel E.^. ExamOfficeExamLabelLabel E.==. E.val eolid + E.delete . EL.from $ \examOfficeExternalExamLabel -> E.where_ $ examOfficeExternalExamLabel E.^. ExamOfficeExternalExamLabelLabel E.==. E.val eolid + E.delete . EL.from $ \examOfficeExamLabel -> E.where_ $ examOfficeExamLabel E.^. ExamOfficeExamLabelLabel E.==. E.val eolid when (csvExportLabel userCsvOptions == Just examOfficeLabelName) $ update uid [ UserCsvOptions =. userCsvOptions { csvExportLabel = Nothing } ] delete eolid @@ -633,19 +635,19 @@ makeProfileData usrEnt@(Entity uid usrVal@User{..}) = do addressLinkdIcon <- messageTooltip <$> messageIconI Info IconLink MsgAddressIsLinkedTip (actualPrefersPostal, (actualPostAddress, postalAutomatic), (actualDisplayEmail, emailAutomatic)) <- getPostalPreferenceAndAddress' usrEnt functions <- Map.fromListWith Set.union . map (\(Entity _ UserFunction{..}) -> (userFunctionFunction, Set.singleton userFunctionSchool)) <$> selectList [UserFunctionUser ==. uid] [] - lecture_corrector <- E.select $ E.distinct $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do - E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId - E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet + lecture_corrector <- E.select $ E.distinct $ EL.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do + EL.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId + EL.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand) - studies <- E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do - E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId - E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId + studies <- E.select $ EL.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do + EL.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId + EL.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid return (studyfeat, studydegree, studyterms) companies <- wgtCompanies uid - -- supervisors' <- E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do - -- E.on $ spvr E.^. UserSupervisorSupervisor E.==. usrSpvr E.^. UserId + -- supervisors' <- E.select $ EL.from $ \(spvr `E.InnerJoin` usrSpvr) -> do + -- EL.on $ spvr E.^. UserSupervisorSupervisor E.==. usrSpvr E.^. UserId -- E.where_ $ spvr E.^. UserSupervisorUser E.==. E.val uid -- E.orderBy [E.asc (usrSpvr E.^. UserDisplayName)] -- return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications) @@ -653,8 +655,8 @@ makeProfileData usrEnt@(Entity uid usrVal@User{..}) = do -- supervisors = intersperse (text2widget ", ") $ -- (\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisors' -- icnReroute = text2widget " " <> toWgt (icon IconReroute) - -- supervisees' <- E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do - -- E.on $ spvr E.^. UserSupervisorUser E.==. usrSpvr E.^. UserId + -- supervisees' <- E.select $ EL.from $ \(spvr `E.InnerJoin` usrSpvr) -> do + -- EL.on $ spvr E.^. UserSupervisorUser E.==. usrSpvr E.^. UserId -- E.where_ $ spvr E.^. UserSupervisorSupervisor E.==. E.val uid -- return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications) -- let numSupervisees = length supervisees' @@ -681,7 +683,7 @@ makeProfileData usrEnt@(Entity uid usrVal@User{..}) = do -- let examTable, ownTutorialTable, tutorialTable :: Widget -- examTable = i18n MsgPersonalInfoExamAchievementsWip -- ownTutorialTable = i18n MsgPersonalInfoOwnTutorialsWip - -- tutorialTable = i18n MsgPersonalInfoTutorialsWip + -- tutorialTable = i18n MsgPersonalInfoTutorialsWip -- note that tutorials are linked in enrolledCoursesTable cID <- encrypt uid mCRoute <- getCurrentRoute @@ -705,7 +707,7 @@ mkOwnedCoursesTable = withType = id dbtSQLQuery' uid (course `E.InnerJoin` lecturer) = do - E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse + EL.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid return ( course E.^. CourseTerm , course E.^. CourseSchool @@ -747,18 +749,28 @@ mkOwnedCoursesTable = -- | Table listing all courses that the given user is enrolled in mkEnrolledCoursesTable :: UserId -> DB (Bool, Widget) -mkEnrolledCoursesTable = - let withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a) +mkEnrolledCoursesTable uid = do + usrTuts <- E.select $ do + (tpar :& tut) <- E.from $ E.table @TutorialParticipant `E.innerJoin` E.table @Tutorial + `E.on` (\(tpar :& tut) -> tut E.^. TutorialId E.==. tpar E.^. TutorialParticipantTutorial) + E.where_ $ tpar E.^. TutorialParticipantUser E.==. E.val uid + E.orderBy [E.asc $ tut E.^. TutorialCourse, E.desc $ tut E.^. TutorialName] -- Data.Map.fromAscListWith reverses tutorials, hence E.desc + return (tut E.^. TutorialCourse, tut E.^. TutorialName) + + let usrTutMap :: Map CourseId [TutorialName] + usrTutMap = Map.fromAscListWith (++) [(tcid, [tnm]) | (E.Value tcid, E.Value tnm) <- usrTuts] + + withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a) -> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a) withType = id validator = def & defaultSorting [SortDescBy "time"] - in \uid -> (_1 %~ getAny) <$> dbTableWidget validator + (_1 %~ getAny) <$> dbTableWidget validator DBTable { dbtIdent = "courseMembership" :: Text , dbtSQLQuery = \(course `E.InnerJoin` participant) -> do - E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse + EL.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive return (course, participant E.^. CourseParticipantRegistration) @@ -775,7 +787,14 @@ mkEnrolledCoursesTable = , sortable (Just "time") (i18nCell MsgProfileRegistered) $ do regTime <- view $ _dbrOutput . _2 return $ dateTimeCell regTime - ] + , sortable Nothing (i18nCell MsgCourseTutorials) $ \(view $ _dbrOutput . _1 -> Entity{entityKey=cid, entityVal=Course{..}}) -> + cell [whamlet| +