diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 26d29a2f9..23daf5679 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -8,6 +8,7 @@ module Database.Esqueleto.Utils , isInfixOf, hasInfix , or, and , any, all + , subSelectAnd, subSelectOr , mkExactFilter, mkExactFilterWith , mkContainsFilter, mkContainsFilterWith , mkExistsFilter @@ -109,6 +110,10 @@ any test = or . map test . otoList all :: MonoFoldable f => (Element f -> E.SqlExpr (E.Value Bool)) -> f -> E.SqlExpr (E.Value Bool) all test = and . map test . otoList +subSelectAnd, subSelectOr :: E.SqlQuery (E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool) +subSelectAnd q = E.subSelectUnsafe $ E.unsafeSqlFunction "bool_and" <$> q +subSelectOr q = E.subSelectUnsafe $ E.unsafeSqlFunction "bool_or" <$> q + -- Allow usage of Tuples as DbtRowKey, i.e. SqlIn instances for tuples $(sqlInTuples [2..16]) diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index 2a74a8d0b..8db6e791c 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -409,6 +409,18 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do E.where_ $ sheet E.^. SheetCourse E.==. E.val cid E.&&. sheet E.^. SheetName E.==. E.val shn ) + , fltrRelevantStudyFeaturesTerms (to $ + \t -> ( E.subSelectForeign (queryParticipant t) CourseParticipantCourse (E.^. CourseTerm) + , queryUser t E.^. UserId + )) + , fltrRelevantStudyFeaturesDegree (to $ + \t -> ( E.subSelectForeign (queryParticipant t) CourseParticipantCourse (E.^. CourseTerm) + , queryUser t E.^. UserId + )) + , fltrRelevantStudyFeaturesSemester (to $ + \t -> ( E.subSelectForeign (queryParticipant t) CourseParticipantCourse (E.^. CourseTerm) + , queryUser t E.^. UserId + )) ] where single = uncurry Map.singleton dbtFilterUI mPrev = mconcat $ @@ -420,6 +432,9 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do [ prismAForm (singletonFilter "submission-group") mPrev $ aopt textField (fslI MsgSubmissionGroup) , prismAForm (singletonFilter "tutorial") mPrev $ aopt textField (fslI MsgCourseUserTutorial) , prismAForm (singletonFilter "exam") mPrev $ aopt textField (fslI MsgCourseUserExam) + , fltrRelevantStudyFeaturesDegreeUI mPrev + , fltrRelevantStudyFeaturesTermsUI mPrev + , fltrRelevantStudyFeaturesSemesterUI mPrev ] ++ [ prismAForm (singletonFilter "has-personalised-sheet-files". maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgNoFilter) . optionsF $ map E.unValue personalisedSheets) (fslI MsgCourseUserHasPersonalisedSheetFilesFilter) | not $ null personalisedSheets diff --git a/src/Handler/Utils/StudyFeatures.hs b/src/Handler/Utils/StudyFeatures.hs index 5e4a0ee59..359f6780a 100644 --- a/src/Handler/Utils/StudyFeatures.hs +++ b/src/Handler/Utils/StudyFeatures.hs @@ -4,6 +4,7 @@ module Handler.Utils.StudyFeatures , _userTableField, _userTableDegree, _userTableSemester, _userTableFieldType , UserTableStudyFeatures(..) , _UserTableStudyFeatures + , isRelevantStudyFeature , isCourseStudyFeature, courseUserStudyFeatures , isExternalExamStudyFeature, externalExamUserStudyFeatures ) where diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index 41483756f..3d66fcace 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -786,6 +786,57 @@ colStudyFeatures resultFeatures = Colonnade.singleton (fromSortable header) body header = Sortable Nothing (i18nCell MsgColumnStudyFeatures) body = views (resultFeatures . _UserTableStudyFeatures) . flip listCell $ \UserTableStudyFeature{..} -> cell $(widgetFile "table/cell/user-study-feature") +fltrRelevantStudyFeaturesTerms :: OpticFilterColumn' t (Set Text) (E.SqlExpr (E.Value TermId), E.SqlExpr (E.Value UserId)) +fltrRelevantStudyFeaturesTerms queryTermUser = singletonMap "features-terms" . FilterColumn $ \t criterias -> + E.subSelectOr . E.from $ \(term `E.InnerJoin` studyFeatures) -> do + E.on $ isRelevantStudyFeature TermId term studyFeatures + + let (tid, uid) = t ^. queryTermUser + E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. uid + E.&&. term E.^. TermId E.==. tid + + return $ anyFilter + [ mkContainsFilterWith Just $ \t' -> E.subSelectForeign t' StudyFeaturesField (E.^. StudyTermsName) + , mkContainsFilterWith Just $ \t' -> E.subSelectForeign t' StudyFeaturesField (E.^. StudyTermsShorthand) + , mkExactFilterWith readMay $ \t' -> E.subSelectForeign t' StudyFeaturesField $ E.just . (E.^. StudyTermsKey) + ] studyFeatures criterias + +fltrRelevantStudyFeaturesTermsUI :: DBFilterUI +fltrRelevantStudyFeaturesTermsUI = fltrStudyTermsUI + +fltrRelevantStudyFeaturesDegree :: OpticFilterColumn' t (Set Text) (E.SqlExpr (E.Value TermId), E.SqlExpr (E.Value UserId)) +fltrRelevantStudyFeaturesDegree queryTermUser = singletonMap "features-degree" . FilterColumn $ \t criterias -> + E.subSelectOr . E.from $ \(term `E.InnerJoin` studyFeatures) -> do + E.on $ isRelevantStudyFeature TermId term studyFeatures + + let (tid, uid) = t ^. queryTermUser + E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. uid + E.&&. term E.^. TermId E.==. tid + + return $ anyFilter + [ mkContainsFilterWith Just $ \t' -> E.subSelectForeign t' StudyFeaturesDegree (E.^. StudyDegreeName) + , mkContainsFilterWith Just $ \t' -> E.subSelectForeign t' StudyFeaturesDegree (E.^. StudyDegreeShorthand) + , mkExactFilterWith readMay $ \t' -> E.subSelectForeign t' StudyFeaturesDegree $ E.just . (E.^. StudyDegreeKey) + ] studyFeatures criterias + +fltrRelevantStudyFeaturesDegreeUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) +fltrRelevantStudyFeaturesDegreeUI mPrev = + prismAForm (singletonFilter "features-degree") mPrev $ aopt textField (fslI MsgDegreeName) + +fltrRelevantStudyFeaturesSemester :: OpticFilterColumn' t (Set Text) (E.SqlExpr (E.Value TermId), E.SqlExpr (E.Value UserId)) +fltrRelevantStudyFeaturesSemester queryTermUser = singletonMap "features-semester" . FilterColumn $ \t criterias -> + E.subSelectOr . E.from $ \(term `E.InnerJoin` studyFeatures) -> do + E.on $ isRelevantStudyFeature TermId term studyFeatures + + let (tid, uid) = t ^. queryTermUser + E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. uid + E.&&. term E.^. TermId E.==. tid + + return $ mkExactFilterWith (readMay :: Text -> Maybe Int) (E.just . (E.^. StudyFeaturesSemester)) studyFeatures criterias + +fltrRelevantStudyFeaturesSemesterUI :: DBFilterUI +fltrRelevantStudyFeaturesSemesterUI = fltrFeaturesSemesterUI + ----------------- -- Allocations -- -----------------