fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

feat: study feature filtering

Browse Source
This commit is contained in:
Gregor Kleen 2020-08-27 11:51:16 +02:00
parent 51a98f0670
commit 96d0ba8f7a
4 changed files with 72 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
src/Database/Esqueleto/Utils.hs
View File

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

15
src/Handler/Course/Users.hs
View File

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

1
src/Handler/Utils/StudyFeatures.hs
View File

@ -4,6 +4,7 @@ module Handler.Utils.StudyFeatures
, _userTableField, _userTableDegree, _userTableSemester, _userTableFieldType
, UserTableStudyFeatures(..)
, _UserTableStudyFeatures
, isRelevantStudyFeature
, isCourseStudyFeature, courseUserStudyFeatures
, isExternalExamStudyFeature, externalExamUserStudyFeatures
) where

51
src/Handler/Utils/Table/Columns.hs
View File

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