diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index fcd767b01..98a0788b5 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -879,6 +879,8 @@ SubmissionReplace: Abgabe ersetzen SubmissionCreated: Abgabe erfolgreich angelegt SubmissionUpdated: Abgabe erfolgreich ersetzt +ColumnStudyFeatures: Studiendaten + AdminFeaturesHeading: Studiengänge StudyTerms: Studiengänge StudyTerm: Studiengang diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index e633cd1b1..26d29a2f9 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -21,17 +21,18 @@ module Database.Esqueleto.Utils , maybe, maybeEq, unsafeCoalesce , bool , max, min + , abs , SqlProject(..) , (->.) , fromSqlKey , selectCountRows , selectMaybe - , day + , day, diffDays , module Database.Esqueleto.Utils.TH ) where -import ClassyPrelude.Yesod hiding (isInfixOf, any, all, or, and, isJust, maybe, bool, max, min) +import ClassyPrelude.Yesod hiding (isInfixOf, any, all, or, and, isJust, maybe, bool, max, min, abs) import Data.Universe import qualified Data.Set as Set import qualified Data.List as List @@ -290,6 +291,11 @@ max, min :: PersistField a max a b = bool a b $ b E.>. a min a b = bool a b $ b E.<. a +abs :: (PersistField a, Num a) + => E.SqlExpr (E.Value a) + -> E.SqlExpr (E.Value a) +abs x = bool (E.val 0 E.-. x) x $ x E.>. E.val 0 + unsafeCoalesce :: E.PersistField a => [E.SqlExpr (E.Value (Maybe a))] -> E.SqlExpr (E.Value a) unsafeCoalesce = E.veryUnsafeCoerceSqlExprValue . E.coalesce @@ -330,3 +336,9 @@ selectMaybe = fmap listToMaybe . E.select . (<* E.limit 1) day :: E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Day) day = E.unsafeSqlCastAs "date" + +infixl 6 `diffDays` + +diffDays :: E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Int) +-- ^ PostgreSQL is weird. +diffDays a b = E.veryUnsafeCoerceSqlExprValue $ a E.-. b diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs index 211b9b524..de8747fc4 100644 --- a/src/Handler/Course/User.hs +++ b/src/Handler/Course/User.hs @@ -95,10 +95,10 @@ courseUserProfileSection (Entity cid Course{..}) (Entity uid User{ userShowSex = (mRegistration, studies) <- lift . runDB $ do registration <- fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid - studies <- E.select $ E.from $ \(course `E.InnerJoin` studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do - E.on $ isCourseStudyFeature course studyfeat + studies <- E.select $ E.from $ \(course `E.InnerJoin` studyfeat `E.InnerJoin` studydegree `E.InnerJoin` studyterms) -> do E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId + E.on $ isCourseStudyFeature course studyfeat E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid E.where_ $ course E.^. CourseId E.==. E.val cid return (studyfeat, studydegree, studyterms) diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index a948e0bef..2a74a8d0b 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -524,6 +524,7 @@ postCUsersR tid ssh csh = do , guardOn showSex . cap' $ colUserSex' , pure . cap' $ colUserEmail , pure . cap' $ colUserMatriclenr + , pure . cap' $ colStudyFeatures _userStudyFeatures , guardOn hasSubmissionGroups $ cap' colUserSubmissionGroup , guardOn hasTutorials . cap' $ colUserTutorials tid ssh csh , guardOn hasExams . cap' $ colUserExams tid ssh csh diff --git a/src/Handler/Utils/StudyFeatures.hs b/src/Handler/Utils/StudyFeatures.hs index 10dffa21e..5e4a0ee59 100644 --- a/src/Handler/Utils/StudyFeatures.hs +++ b/src/Handler/Utils/StudyFeatures.hs @@ -3,6 +3,7 @@ module Handler.Utils.StudyFeatures , UserTableStudyFeature(..) , _userTableField, _userTableDegree, _userTableSemester, _userTableFieldType , UserTableStudyFeatures(..) + , _UserTableStudyFeatures , isCourseStudyFeature, courseUserStudyFeatures , isExternalExamStudyFeature, externalExamUserStudyFeatures ) where @@ -42,6 +43,9 @@ newtype UserTableStudyFeatures = UserTableStudyFeatures (Set UserTableStudyFeatu deriving newtype (ToJSON, FromJSON) makeWrapped ''UserTableStudyFeatures +_UserTableStudyFeatures :: Iso' UserTableStudyFeatures [UserTableStudyFeature] +_UserTableStudyFeatures = iso (sortBy userTableStudyFeatureSort . Set.toList . view _Wrapped) (UserTableStudyFeatures . Set.fromList) + instance Csv.ToField UserTableStudyFeature where toField UserTableStudyFeature{..} = encodeUtf8 [st|#{userTableField} #{userTableDegree} (#{userTableFieldType'} #{tshow userTableSemester})|] @@ -50,7 +54,7 @@ instance Csv.ToField UserTableStudyFeature where [] $ ShortStudyFieldType userTableFieldType instance Csv.ToField UserTableStudyFeatures where - toField = ByteString.intercalate "; " . map Csv.toField . sortBy userTableStudyFeatureSort . Set.toList . view _Wrapped + toField = ByteString.intercalate "; " . map Csv.toField . view _UserTableStudyFeatures userTableStudyFeatureSort :: UserTableStudyFeature -> UserTableStudyFeature @@ -61,14 +65,35 @@ userTableStudyFeatureSort = mconcat , comparing userTableFieldType , compareUnicode `on` userTableField ] - + + +isRelevantStudyFeature :: PersistEntity record + => EntityField record TermId + -> E.SqlExpr (Entity record) + -> E.SqlExpr (Entity StudyFeatures) + -> E.SqlExpr (E.Value Bool) +isRelevantStudyFeature termField record studyFeatures + = overlap studyFeatures E.>. E.val 0 + E.&&. E.not_ (E.exists betterOverlap) + where termEnd = E.subSelectForeign record termField (E.^. TermEnd) + termStart = E.subSelectForeign record termField (E.^. TermStart) + + overlap :: E.SqlExpr (Entity StudyFeatures) -> E.SqlExpr (E.Value Int) + overlap studyFeatures' + = E.min (E.day $ studyFeatures' E.^. StudyFeaturesLastObserved) termEnd + `E.diffDays` E.maybe termStart (E.max termStart . E.day) (studyFeatures' E.^. StudyFeaturesFirstObserved) + + betterOverlap = E.from $ \studyFeatures' -> do + E.where_ $ studyFeatures' E.^. StudyFeaturesUser E.==. studyFeatures E.^. StudyFeaturesUser + E.&&. studyFeatures' E.^. StudyFeaturesDegree E.==. studyFeatures E.^. StudyFeaturesDegree + E.&&. studyFeatures' E.^. StudyFeaturesField E.==. studyFeatures E.^. StudyFeaturesField + E.&&. studyFeatures' E.^. StudyFeaturesSuperField `E.maybeEq` studyFeatures E.^. StudyFeaturesSuperField + E.&&. studyFeatures' E.^. StudyFeaturesType E.==. studyFeatures E.^. StudyFeaturesType + E.where_ $ E.abs (studyFeatures' E.^. StudyFeaturesSemester E.-. studyFeatures E.^. StudyFeaturesSemester) E.==. E.val 1 + E.&&. overlap studyFeatures' E.>. overlap studyFeatures isCourseStudyFeature :: E.SqlExpr (Entity Course) -> E.SqlExpr (Entity StudyFeatures) -> E.SqlExpr (E.Value Bool) -isCourseStudyFeature course studyFeatures - = E.maybe E.true ((E.<=. termEnd) . E.day) (studyFeatures E.^. StudyFeaturesFirstObserved) - E.&&. E.day (studyFeatures E.^. StudyFeaturesLastObserved) E.>=. termStart - where termEnd = E.subSelectForeign course CourseTerm (E.^. TermEnd) - termStart = E.subSelectForeign course CourseTerm (E.^. TermStart) +isCourseStudyFeature = isRelevantStudyFeature CourseTerm courseUserStudyFeatures :: MonadIO m => CourseId -> UserId -> SqlPersistT m UserTableStudyFeatures courseUserStudyFeatures cId uid = do @@ -88,11 +113,7 @@ courseUserStudyFeatures cId uid = do } isExternalExamStudyFeature :: E.SqlExpr (Entity ExternalExam) -> E.SqlExpr (Entity StudyFeatures) -> E.SqlExpr (E.Value Bool) -isExternalExamStudyFeature externalExam studyFeatures - = E.maybe E.true ((E.<=. termEnd) . E.day) (studyFeatures E.^. StudyFeaturesFirstObserved) - E.&&. E.day (studyFeatures E.^. StudyFeaturesLastObserved) E.>=. termStart - where termEnd = E.subSelectForeign externalExam ExternalExamTerm (E.^. TermEnd) - termStart = E.subSelectForeign externalExam ExternalExamTerm (E.^. TermStart) +isExternalExamStudyFeature = isRelevantStudyFeature ExternalExamTerm externalExamUserStudyFeatures :: MonadIO m => ExternalExamId -> UserId -> SqlPersistT m UserTableStudyFeatures externalExamUserStudyFeatures eeId uid = do diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index b3329f0c5..41483756f 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -24,6 +24,7 @@ import Handler.Utils.Table.Pagination import Handler.Utils.Form import Handler.Utils.Widgets import Handler.Utils.DateTime +import Handler.Utils.StudyFeatures import qualified Data.CaseInsensitive as CI @@ -778,6 +779,13 @@ fltrDegreeUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map Fil fltrDegreeUI mPrev = prismAForm (singletonFilter "degree") mPrev $ aopt textField (fslI MsgDegreeName) + +colStudyFeatures :: OpticColonnade UserTableStudyFeatures +colStudyFeatures resultFeatures = Colonnade.singleton (fromSortable header) body + where + header = Sortable Nothing (i18nCell MsgColumnStudyFeatures) + body = views (resultFeatures . _UserTableStudyFeatures) . flip listCell $ \UserTableStudyFeature{..} -> cell $(widgetFile "table/cell/user-study-feature") + ----------------- -- Allocations -- ----------------- diff --git a/templates/table/cell/user-study-feature.hamlet b/templates/table/cell/user-study-feature.hamlet new file mode 100644 index 000000000..94cd12b61 --- /dev/null +++ b/templates/table/cell/user-study-feature.hamlet @@ -0,0 +1,2 @@ +$newline never +#{userTableField} #{userTableDegree} (_{userTableFieldType} #{userTableSemester})