feat: study feature filtering

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])

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

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

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 --
 -----------------