From 04bea764f4dcafda1a07ca3a98f290433c207bc5 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 10 Jul 2019 13:51:02 +0200 Subject: [PATCH 01/14] feat(exams): show study features of registered users BREAKING CHANGE: E.isInfixOf and E.hasInfix --- src/Database/Esqueleto/Utils.hs | 41 +++++++++---- src/Handler/Corrections.hs | 8 +-- src/Handler/Course.hs | 10 +-- src/Handler/Exam.hs | 72 +++++++++++++++++----- src/Handler/Users.hs | 12 ++-- src/Handler/Utils/Table/Cells.hs | 12 ++++ src/Handler/Utils/Table/Columns.hs | 99 ++++++++++++++++++++++++++---- src/Utils/Lens.hs | 26 +++++--- src/Utils/Lens/TH.hs | 15 +++-- 9 files changed, 223 insertions(+), 72 deletions(-) diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index bd8120ba7..cc8ffbb24 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -7,7 +7,7 @@ module Database.Esqueleto.Utils , any, all , SqlIn(..) , mkExactFilter, mkExactFilterWith - , mkContainsFilter + , mkContainsFilter, mkContainsFilterWith , mkExistsFilter , anyFilter, allFilter ) where @@ -40,12 +40,18 @@ isJust :: (E.Esqueleto query expr backend, PersistField typ) => expr (E.Value (M isJust = E.not_ . E.isNothing -- | Check if the first string is contained in the text derived from the second argument -isInfixOf :: (E.Esqueleto query expr backend, E.SqlString s2) => - Text -> expr (E.Value s2) -> expr (E.Value Bool) -isInfixOf needle strExpr = E.castString strExpr `E.ilike` (E.%) E.++. E.val needle E.++. (E.%) +isInfixOf :: ( E.Esqueleto query expr backend + , E.SqlString s1 + , E.SqlString s2 + ) + => expr (E.Value s1) -> expr (E.Value s2) -> expr (E.Value Bool) +isInfixOf needle strExpr = E.castString strExpr `E.ilike` (E.%) E.++. needle E.++. (E.%) -hasInfix :: (E.Esqueleto query expr backend, E.SqlString s2) => - expr (E.Value s2) -> Text -> expr (E.Value Bool) +hasInfix :: ( E.Esqueleto query expr backend + , E.SqlString s1 + , E.SqlString s2 + ) + => expr (E.Value s2) -> expr (E.Value s1) -> expr (E.Value Bool) hasInfix = flip isInfixOf -- | Given a test and a set of values, check whether anyone succeeds the test @@ -101,14 +107,23 @@ mkExactFilterWith cast lenslike row criterias -- | generic filter creation for dbTable -- Given a lens-like function, make filter searching for needles in String-like elements -- (Keep Set here to ensure that there are no duplicates) -mkContainsFilter :: (E.SqlString a) - => (t -> E.SqlExpr (E.Value a)) -- ^ getter from query to searched element - -> t -- ^ query row - -> Set.Set Text -- ^ needle collection - -> E.SqlExpr (E.Value Bool) -mkContainsFilter lenslike row criterias +mkContainsFilter :: E.SqlString a + => (t -> E.SqlExpr (E.Value a)) -- ^ getter from query to searched element + -> t -- ^ query row + -> Set.Set a -- ^ needle collection + -> E.SqlExpr (E.Value Bool) +mkContainsFilter = mkContainsFilterWith id + +-- | like `mkContainsFiler` but allows for conversion; convenient in conjunction with `anyFilter` and `allFilter` +mkContainsFilterWith :: E.SqlString b + => (a -> b) + -> (t -> E.SqlExpr (E.Value b)) -- ^ getter from query to searched element + -> t -- ^ query row + -> Set.Set a -- ^ needle collection + -> E.SqlExpr (E.Value Bool) +mkContainsFilterWith cast lenslike row criterias | Set.null criterias = true - | otherwise = any (hasInfix $ lenslike row) criterias + | otherwise = any (hasInfix $ lenslike row) (E.val . cast <$> Set.toList criterias) mkExistsFilter :: PathPiece a => (t -> a -> E.SqlQuery ()) diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index fcdcb32e4..94508b990 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -348,9 +348,9 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d ) , ( "corrector-name-email" -- corrector filter does not work for text-filtering , FilterColumn $ E.anyFilter - [ E.mkContainsFilter $ queryCorrector >>> (E.?. UserSurname) - , E.mkContainsFilter $ queryCorrector >>> (E.?. UserDisplayName) - , E.mkContainsFilter $ queryCorrector >>> (E.?. UserEmail) + [ E.mkContainsFilterWith Just $ queryCorrector >>> (E.?. UserSurname) + , E.mkContainsFilterWith Just $ queryCorrector >>> (E.?. UserDisplayName) + , E.mkContainsFilterWith (Just . CI.mk) $ queryCorrector >>> (E.?. UserEmail) ] ) , ( "user-name-email" @@ -360,7 +360,7 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d E.where_ $ (\f -> f user $ Set.singleton needle) $ E.anyFilter [ E.mkContainsFilter (E.^. UserSurname) , E.mkContainsFilter (E.^. UserDisplayName) - , E.mkContainsFilter (E.^. UserEmail) + , E.mkContainsFilterWith CI.mk (E.^. UserEmail) ] ) , ( "user-matriclenumber" diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 3340c6894..156fc77ae 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -1140,13 +1140,13 @@ makeCourseUserTable cid restrict colChoices psValidator = do , ("field-short" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand)) , ("field-key" , FilterColumn $ E.mkExactFilter $ queryFeaturesField >>> (E.?. StudyTermsKey)) , ("field" , FilterColumn $ E.anyFilter - [ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsName) - , E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand) + [ E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsName) + , E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsShorthand) , E.mkExactFilterWith readMay $ queryFeaturesField >>> (E.?. StudyTermsKey) ] ) , ("degree" , FilterColumn $ E.anyFilter - [ E.mkContainsFilter $ queryFeaturesDegree >>> (E.?. StudyDegreeName) - , E.mkContainsFilter $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand) + [ E.mkContainsFilterWith Just $ queryFeaturesDegree >>> E.joinV . (E.?. StudyDegreeName) + , E.mkContainsFilterWith Just $ queryFeaturesDegree >>> E.joinV . (E.?. StudyDegreeShorthand) , E.mkExactFilterWith readMay $ queryFeaturesDegree >>> (E.?. StudyDegreeKey) ] ) , ("semesternr" , FilterColumn $ E.mkExactFilter $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester)) @@ -1154,7 +1154,7 @@ makeCourseUserTable cid restrict colChoices psValidator = do E.from $ \(tutorial `E.InnerJoin` tutorialParticipant) -> do E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid - E.&&. E.hasInfix (tutorial E.^. TutorialName) criterion + E.&&. E.hasInfix (tutorial E.^. TutorialName) (E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser row E.^. UserId ) -- , ("course-registration", error "TODO") -- TODO diff --git a/src/Handler/Exam.hs b/src/Handler/Exam.hs index c93195d9b..b3f15b334 100644 --- a/src/Handler/Exam.hs +++ b/src/Handler/Exam.hs @@ -733,8 +733,8 @@ getEShowR tid ssh csh examn = do examBonusW bonusRule = $(widgetFile "widgets/bonusRule") $(widgetFile "exam-show") -type ExamUserTableExpr = (E.SqlExpr (Entity ExamRegistration) `E.InnerJoin` E.SqlExpr (Entity User)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamOccurrence)) -type ExamUserTableData = DBRow (Entity ExamRegistration, Entity User, Maybe (Entity ExamOccurrence)) +type ExamUserTableExpr = (E.SqlExpr (Entity ExamRegistration) `E.InnerJoin` E.SqlExpr (Entity User)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamOccurrence)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity CourseParticipant)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity StudyFeatures)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms)))) +type ExamUserTableData = DBRow (Entity ExamRegistration, Entity User, Maybe (Entity ExamOccurrence), Maybe (Entity StudyFeatures), Maybe (Entity StudyDegree), Maybe (Entity StudyTerms)) instance HasEntity ExamUserTableData User where hasEntity = _dbrOutput . _2 @@ -746,44 +746,82 @@ _userTableOccurrence :: Lens' ExamUserTableData (Maybe (Entity ExamOccurrence)) _userTableOccurrence = _dbrOutput . _3 queryUser :: ExamUserTableExpr -> E.SqlExpr (Entity User) -queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 2 1) +queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1) + +queryStudyFeatures :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures)) +queryStudyFeatures = $(sqlIJproj 3 1) . $(sqlLOJproj 2 2) . $(sqlLOJproj 3 3) queryExamRegistration :: ExamUserTableExpr -> E.SqlExpr (Entity ExamRegistration) -queryExamRegistration = $(sqlIJproj 2 1) . $(sqlLOJproj 2 1) +queryExamRegistration = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1) + +queryStudyDegree :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyDegree)) +queryStudyDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 2 2) . $(sqlLOJproj 3 3) + +queryStudyField :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyTerms)) +queryStudyField = $(sqlIJproj 3 3) . $(sqlLOJproj 2 2) . $(sqlLOJproj 3 3) + +resultStudyFeatures :: Traversal' ExamUserTableData (Entity StudyFeatures) +resultStudyFeatures = _dbrOutput . _4 . _Just + +resultStudyDegree :: Traversal' ExamUserTableData (Entity StudyDegree) +resultStudyDegree = _dbrOutput . _5 . _Just + +resultStudyField :: Traversal' ExamUserTableData (Entity StudyTerms) +resultStudyField = _dbrOutput . _6 . _Just getEUsersR, postEUsersR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html getEUsersR = postEUsersR postEUsersR tid ssh csh examn = do - eid <- runDB $ fetchExamId tid ssh csh examn + Entity eid Exam{..} <- runDB $ fetchExam tid ssh csh examn let examUsersDBTable = DBTable{..} where - dbtSQLQuery ((examRegistration `E.InnerJoin` user) `E.LeftOuterJoin` occurrence) = do + dbtSQLQuery ((examRegistration `E.InnerJoin` user) `E.LeftOuterJoin` occurrence `E.LeftOuterJoin` (courseParticipant `E.LeftOuterJoin` (studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyField))) = do + E.on $ studyField E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField + E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree + E.on $ studyFeatures E.?. StudyFeaturesId E.==. E.joinV (courseParticipant E.?. CourseParticipantField) + E.on $ courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val examCourse) + E.&&. courseParticipant E.?. CourseParticipantUser E.==. E.just (user E.^. UserId) E.on $ occurrence E.?. ExamOccurrenceExam E.==. E.just (E.val eid) E.&&. occurrence E.?. ExamOccurrenceId E.==. examRegistration E.^. ExamRegistrationOccurrence E.on $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eid - return (examRegistration, user, occurrence) + return (examRegistration, user, occurrence, studyFeatures, studyDegree, studyField) dbtRowKey = queryExamRegistration >>> (E.^. ExamRegistrationId) dbtProj = return dbtColonnade = dbColonnade $ mconcat [ colUserNameLink (CourseR tid ssh csh . CUserR) , colUserMatriclenr - -- , colUserDegreeShort - -- , colUserField - -- , colUserSemester + , colField resultStudyField + , colDegreeShort resultStudyDegree + , colFeaturesSemester resultStudyFeatures , sortable (Just "room") (i18nCell MsgExamRoom) (maybe mempty (cell . toWgt . examOccurrenceRoom . entityVal) . view _userTableOccurrence) ] dbtSorting = Map.fromList - [ sortUserNameLink queryUser - , sortUserSurname queryUser - , sortUserDisplayName queryUser - , sortUserMatriclenr queryUser + [ sortUserNameLink queryUser + , sortUserSurname queryUser + , sortUserDisplayName queryUser + , sortUserMatriclenr queryUser + , sortField queryStudyField + , sortDegreeShort queryStudyDegree + , sortFeaturesSemester queryStudyFeatures ] - dbtFilter = Map.empty - dbtFilterUI = const mempty - dbtStyle = def + dbtFilter = Map.fromList + [ fltrUserNameEmail queryUser + , fltrUserMatriclenr queryUser + , fltrField queryStudyField + , fltrDegree queryStudyDegree + , fltrFeaturesSemester queryStudyFeatures + ] + dbtFilterUI mPrev = mconcat + [ fltrUserNameEmailUI mPrev + , fltrUserMatriclenrUI mPrev + , fltrFieldUI mPrev + , fltrDegreeUI mPrev + , fltrFeaturesSemesterUI mPrev + ] + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtParams = def dbtIdent :: Text dbtIdent = "exam-users" diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 01b0055d9..cf089cb58 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -108,14 +108,14 @@ getUsersR = do ) ] , dbtFilter = Map.fromList -- OverloadedLists does not work with the templates - [ ( "user-search", FilterColumn $ \user criterion -> - if Set.null criterion then E.true else -- TODO: why is this condition not needed? + [ ( "user-search", FilterColumn $ \user (criteria :: Set.Set Text) -> + if Set.null criteria then E.true else -- TODO: why is this condition not needed? -- Set.foldr (\needle acc -> acc E.||. (user E.^. UserDisplayName) `E.hasInfix` needle) eFalse (criterion :: Set.Set Text) - E.any (user E.^. UserDisplayName `E.hasInfix`) criterion + E.any (\c -> user E.^. UserDisplayName `E.hasInfix` E.val c) criteria ) - , ( "matriculation", FilterColumn $ \user (criterion :: Set.Set Text) -> if - | Set.null criterion -> E.true -- TODO: why can this be eFalse and work still? - | otherwise -> E.any (user E.^. UserMatrikelnummer `E.hasInfix`) criterion + , ( "matriculation", FilterColumn $ \user (criteria :: Set.Set Text) -> if + | Set.null criteria -> E.true -- TODO: why can this be eFalse and work still? + | otherwise -> E.any (\c -> user E.^. UserMatrikelnummer `E.hasInfix` E.val c) criteria ) , ( "school", FilterColumn $ \user criterion -> if | Set.null criterion -> E.val True :: E.SqlExpr (E.Value Bool) diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index a4a9a2fb2..df62bbdbb 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -194,6 +194,18 @@ cellHasEMail :: (IsDBTable m a, HasUser u) => u -> DBCell m a cellHasEMail = emailCell . view _userEmail +cellHasSemester :: (IsDBTable m c, HasStudyFeatures a) => a -> DBCell m c +cellHasSemester = numCell . view _studyFeaturesSemester + + +cellHasField :: (IsDBTable m c, HasStudyTerms a) => a -> DBCell m c +cellHasField x = maybe (numCell $ x ^. _studyTermsKey) textCell $ x ^. _studyTermsName <|> x ^. _studyTermsShorthand + + +cellHasDegreeShort :: (IsDBTable m c, HasStudyDegree a) => a -> DBCell m c +cellHasDegreeShort x = maybe (numCell $ x ^. _studyDegreeKey) textCell $ x ^. _studyDegreeShorthand <|> x ^. _studyDegreeName + + -- Just for documentation purposes; inline this code instead: maybeDateTimeCell :: IsDBTable m a => Maybe UTCTime -> DBCell m a diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index 09db6649d..c5a637efc 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -11,7 +11,6 @@ import Import -- import Text.Blaze (ToMarkup(..)) -import Data.Monoid (Any(..)) import qualified Database.Esqueleto as E import Database.Esqueleto.Utils as E @@ -19,6 +18,8 @@ import Utils.Lens import Handler.Utils import Handler.Utils.Table.Cells +import qualified Data.CaseInsensitive as CI + -------------------------------- -- Generic Columns @@ -156,9 +157,9 @@ fltrUserNameEmail :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool => (a -> E.SqlExpr (Entity User)) -> (d, FilterColumn t) fltrUserNameEmail queryUser = ( "user-name-email", FilterColumn $ anyFilter - [ mkContainsFilter $ queryUser >>> (E.^. UserDisplayName) - , mkContainsFilter $ queryUser >>> (E.^. UserSurname) - , mkContainsFilter $ queryUser >>> (E.^. UserEmail) + [ mkContainsFilter $ queryUser >>> (E.^. UserDisplayName) + , mkContainsFilter $ queryUser >>> (E.^. UserSurname) + , mkContainsFilterWith CI.mk $ queryUser >>> (E.^. UserEmail) ] ) @@ -179,12 +180,14 @@ colUserMatriclenr :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell colUserMatriclenr = sortable (Just "user-matriclenumber") (i18nCell MsgMatrikelNr) cellHasMatrikelnummer sortUserMatriclenr :: IsString d => (t -> E.SqlExpr (Entity User)) -> (d, SortColumn t) -sortUserMatriclenr queryUser = ( "user-matriclenumber", SortColumn $ queryUser >>> (E.^. UserMatrikelnummer)) +sortUserMatriclenr queryUser = ("user-matriclenumber", SortColumn $ queryUser >>> (E.^. UserMatrikelnummer)) -fltrUserMatriclenr :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d) - => (a -> E.SqlExpr (Entity User)) - -> (d, FilterColumn t) -fltrUserMatriclenr queryUser = ( "user-matriclenumber", FilterColumn $ mkContainsFilter $ queryUser >>> (E.^. UserMatrikelnummer)) +fltrUserMatriclenr :: ( IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)) + , IsString d + ) + => (a -> E.SqlExpr (Entity User)) + -> (d, FilterColumn t) +fltrUserMatriclenr queryUser = ("user-matriclenumber", FilterColumn . mkContainsFilterWith Just $ queryUser >>> (E.^. UserMatrikelnummer)) fltrUserMatriclenrUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) fltrUserMatriclenrUI mPrev = @@ -199,13 +202,83 @@ colUserEmail = sortable (Just "user-email") (i18nCell MsgEMail) cellHasEMail sortUserEmail :: IsString d => (t -> E.SqlExpr (Entity User)) -> (d, SortColumn t) sortUserEmail queryUser = ( "user-email", SortColumn $ queryUser >>> (E.^. UserEmail)) -fltrUserEmail :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d) - => (a -> E.SqlExpr (Entity User)) - -> (d, FilterColumn t) -fltrUserEmail queryUser = ( "user-email", FilterColumn $ mkContainsFilter $ queryUser >>> (E.^. UserEmail)) +fltrUserEmail :: ( IsFilterColumn t (a -> Set (CI Text) -> E.SqlExpr (E.Value Bool)) + , IsString d + ) + => (a -> E.SqlExpr (Entity User)) + -> (d, FilterColumn t) +fltrUserEmail queryUser = ("user-email", FilterColumn . mkContainsFilter $ queryUser >>> (E.^. UserEmail)) fltrUserEmailUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) fltrUserEmailUI mPrev = prismAForm (singletonFilter "user-email") mPrev $ aopt textField (fslI MsgEMail) +-------------------- +-- Study features -- +-------------------- + +colFeaturesSemester :: (IsDBTable m c, HasStudyFeatures x) => Getting (Leftmost x) a x -> Colonnade Sortable a (DBCell m c) +colFeaturesSemester feature = sortable (Just "features-semester") (i18nCell MsgStudyFeatureAge) $ maybe mempty cellHasSemester . firstOf feature + +sortFeaturesSemester :: IsString d => (t -> E.SqlExpr (Maybe (Entity StudyFeatures))) -> (d, SortColumn t) +sortFeaturesSemester queryFeatures = ("features-semester", SortColumn $ queryFeatures >>> (E.?. StudyFeaturesSemester)) + +fltrFeaturesSemester :: ( IsFilterColumn t (a -> Set Int -> E.SqlExpr (E.Value Bool)) + , IsString d + ) + => (a -> E.SqlExpr (Maybe (Entity StudyFeatures))) + -> (d, FilterColumn t) +fltrFeaturesSemester queryFeatures = ("features-semester", FilterColumn . mkExactFilterWith Just $ queryFeatures >>> (E.?. StudyFeaturesSemester)) + +fltrFeaturesSemesterUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) +fltrFeaturesSemesterUI mPrev = + prismAForm (singletonFilter "features-semester" . maybePrism _PathPiece) mPrev $ aopt (intField :: Field (YesodDB UniWorX) Int) (fslI MsgStudyFeatureAge) + + +colField :: (IsDBTable m c, HasStudyTerms x) => Getting (Leftmost x) a x -> Colonnade Sortable a (DBCell m c) +colField terms = sortable (Just "terms") (i18nCell MsgStudyTerm) $ maybe mempty cellHasField . firstOf terms + +sortField :: IsString d => (t -> E.SqlExpr (Maybe (Entity StudyTerms))) -> (d, SortColumn t) +sortField queryTerms = ("terms", SortColumn $ queryTerms >>> (E.?. StudyTermsName)) + +fltrField :: ( IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)) + , IsString d + ) + => (a -> E.SqlExpr (Maybe (Entity StudyTerms))) + -> (d, FilterColumn t) +fltrField queryFeatures = ( "terms" + , FilterColumn $ anyFilter + [ mkContainsFilterWith Just $ queryFeatures >>> E.joinV . (E.?. StudyTermsName) + , mkContainsFilterWith Just $ queryFeatures >>> E.joinV . (E.?. StudyTermsShorthand) + , mkExactFilterWith readMay $ queryFeatures >>> (E.?. StudyTermsKey) + ] + ) + +fltrFieldUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) +fltrFieldUI mPrev = + prismAForm (singletonFilter "terms") mPrev $ aopt textField (fslI MsgStudyTerm) + + +colDegreeShort :: (IsDBTable m c, HasStudyDegree x) => Getting (Leftmost x) a x -> Colonnade Sortable a (DBCell m c) +colDegreeShort terms = sortable (Just "degree-short") (i18nCell MsgDegreeShort) $ maybe mempty cellHasDegreeShort . firstOf terms + +sortDegreeShort :: IsString d => (t -> E.SqlExpr (Maybe (Entity StudyDegree))) -> (d, SortColumn t) +sortDegreeShort queryTerms = ("degree-short", SortColumn $ queryTerms >>> (E.?. StudyDegreeShorthand)) + +fltrDegree :: ( IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)) + , IsString d + ) + => (a -> E.SqlExpr (Maybe (Entity StudyDegree))) + -> (d, FilterColumn t) +fltrDegree queryFeatures = ( "degree" + , FilterColumn $ anyFilter + [ mkContainsFilterWith Just $ queryFeatures >>> E.joinV . (E.?. StudyDegreeName) + , mkContainsFilterWith Just $ queryFeatures >>> E.joinV . (E.?. StudyDegreeShorthand) + , mkExactFilterWith readMay $ queryFeatures >>> (E.?. StudyDegreeKey) + ] + ) + +fltrDegreeUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) +fltrDegreeUI mPrev = + prismAForm (singletonFilter "degree") mPrev $ aopt textField (fslI MsgDegreeName) diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 0f3deec79..8fdd73d46 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -41,13 +41,13 @@ _nullable = prism' toNullable fromNullable -- makeLenses_ ''Course -makeClassyFor_ "HasCourse" "hasCourse" ''Course +makeClassyFor_ ''Course -- class HasCourse c where -- hasCourse :: Lens' c Course -- makeLenses_ ''User -makeClassyFor_ "HasUser" "hasUser" ''User +makeClassyFor_ ''User -- > :info HasUser -- class HasUser c where -- hasUser :: Lens' c User -- MINIMAL @@ -56,8 +56,24 @@ makeClassyFor_ "HasUser" "hasUser" ''User -- _user... -- +makeClassyFor_ ''StudyFeatures + +makeClassyFor_ ''StudyDegree + +makeClassyFor_ ''StudyTerms + makeLenses_ ''Entity + +instance HasStudyFeatures a => HasStudyFeatures (Entity a) where + hasStudyFeatures = _entityVal . hasStudyFeatures + +instance HasStudyTerms a => HasStudyTerms (Entity a) where + hasStudyTerms = _entityVal . hasStudyTerms + +instance HasStudyDegree a => HasStudyDegree (Entity a) where + hasStudyDegree = _entityVal . hasStudyDegree + -- BUILD SERVER FAILS TO MAKE HADDOCK FOR THE ONE BELOW: -- makeClassyFor_ "HasEntity" "hasEntity" ''Entity -- class HasEntity c record | c -> record where @@ -96,12 +112,6 @@ makePrisms ''AuthResult makePrisms ''FormResult -makeLenses_ ''StudyFeatures - -makeLenses_ ''StudyDegree - -makeLenses_ ''StudyTerms - makeLenses_ ''StudyTermCandidate makeLenses_ ''FieldView diff --git a/src/Utils/Lens/TH.hs b/src/Utils/Lens/TH.hs index b8d8857a7..701c87b76 100644 --- a/src/Utils/Lens/TH.hs +++ b/src/Utils/Lens/TH.hs @@ -1,6 +1,6 @@ module Utils.Lens.TH where -import ClassyPrelude (String, Maybe(..)) +import ClassyPrelude (Maybe(..), (<>)) import Control.Lens import Control.Lens.Internal.FieldTH import Language.Haskell.TH @@ -56,9 +56,12 @@ makeLenses_ = makeFieldOptics lensRules_ -- | like makeClassyFor but only specifies names for class and its function, -- otherwise lenses are created with underscore like `makeLenses_` -makeClassyFor_ :: String -> String -> Name -> DecsQ -makeClassyFor_ clsName funName = makeFieldOptics (classyRulesFor_ clNamer) +makeClassyFor_ :: Name -> DecsQ +makeClassyFor_ recName = makeFieldOptics (classyRulesFor_ clNamer) recName where - clNamer :: ClassyNamer - -- clNamer _ = Just (clsName, funName) -- for newer versions >= 4.17 - clNamer _ = Just (mkName clsName, mkName funName) \ No newline at end of file + clsName = "Has" <> nameBase recName + funName = "has" <> nameBase recName + + clNamer :: ClassyNamer + -- clNamer _ = Just (clsName, funName) -- for newer versions >= 4.17 + clNamer _ = Just (mkName clsName, mkName funName) From 7bcae7f3e13ec0db1486130b9d3c810905696c4e Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 10 Jul 2019 13:53:18 +0200 Subject: [PATCH 02/14] chore(release): 2.0.0 --- CHANGELOG.md | 22 ++++++++++++++++++++++ package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 4 files changed, 25 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index dbe06bfac..9679e5d3f 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,28 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +## [2.0.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v1.4.1...v2.0.0) (2019-07-10) + + +### Bug Fixes + +* **correction:** comment column made wide in online correction form ([d83b1f6](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/d83b1f6)), closes [#373](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/issues/373) +* **number-input-fields:** number inputs made HTML5 compatible ([6098215](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/6098215)), closes [#412](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/issues/412) +* **ratings:** disallow ratings for graded sheets without point value ([c0b90c4](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/c0b90c4)) +* **tooltips:** fixes font-color when used in tableheaders ([f4bb70e](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/f4bb70e)) + + +### Features + +* **exams:** show study features of registered users ([04bea76](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/04bea76)) + + +### BREAKING CHANGES + +* **exams:** E.isInfixOf and E.hasInfix + + + ### [1.4.1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v1.4.0...v1.4.1) (2019-07-04) diff --git a/package-lock.json b/package-lock.json index d6f8ba499..8bd7b5878 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "1.4.1", + "version": "2.0.0", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index b1be3bc94..c4bd3126d 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "1.4.1", + "version": "2.0.0", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index ef2ddeefb..455e60729 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 1.4.1 +version: 2.0.0 dependencies: # Due to a bug in GHC 8.0.1, we block its usage From caff34326556f9c1f74d6902af1a643105b59093 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 10 Jul 2019 14:33:14 +0200 Subject: [PATCH 03/14] chore(npm): add build script --- package.json | 2 ++ 1 file changed, 2 insertions(+) diff --git a/package.json b/package.json index c4bd3126d..65ac6f6ea 100644 --- a/package.json +++ b/package.json @@ -9,10 +9,12 @@ "start": "run-p frontend:build:watch yesod:start", "test": "run-s frontend:test yesod:test", "lint": "run-s frontend:lint yesod:lint", + "build": "run-s frontend:build yesod:build", "yesod:db": "./db.sh", "yesod:start": "./start.sh", "yesod:lint": "./hlint.sh", "yesod:test": "./test.sh", + "yesod:build": "./build.sh", "frontend:lint": "eslint frontend/src", "frontend:test": "karma start --conf karma.conf.js", "frontend:test:watch": "karma start --conf karma.conf.js --single-run false", From ac3f7bb8b48d64b0db05f292211b6c7df955649b Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 10 Jul 2019 14:49:52 +0200 Subject: [PATCH 04/14] fix(translation): fix typos in translations; add bug to known bugs --- messages/uniworx/de.msg | 2 +- templates/i18n/knownBugs/de.hamlet | 4 +++- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index ab4cb18fc..5993a911e 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -705,7 +705,7 @@ NotificationTriggerSheetActive: Ich kann ein neues Übungsblatt herunterladen NotificationTriggerSheetSoonInactive: Ich kann ein Übungsblatt bald nicht mehr abgeben NotificationTriggerSheetInactive: Abgabezeitraum eines meiner Übungsblätter ist abgelaufen NotificationTriggerCorrectionsAssigned: Mir wurden Abgaben zur Korrektur zugeteilt -NotificationTriggerCorrectionsNotDistributed: Abgaben eines meiner Übungsblätter konnten keinem Korrektur zugeteilt werden +NotificationTriggerCorrectionsNotDistributed: Nicht alle Abgaben eines meiner Übungsblätter konnten einem Korrektor zugeteilt werden NotificationTriggerUserRightsUpdate: Meine Berechtigungen wurden geändert CorrCreate: Abgaben erstellen diff --git a/templates/i18n/knownBugs/de.hamlet b/templates/i18n/knownBugs/de.hamlet index f609cd287..82201f80e 100644 --- a/templates/i18n/knownBugs/de.hamlet +++ b/templates/i18n/knownBugs/de.hamlet @@ -1,6 +1,8 @@ $newline never

- Stand: Mai 2019 + Stand: July 2019