From 90c18b50cd81edf2859074ac7a836d47b3456dcd Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 4 Apr 2019 10:50:55 +0200 Subject: [PATCH 1/3] minor --- messages/uniworx/de.msg | 4 ++-- src/Handler/Admin.hs | 2 -- src/Handler/Course.hs | 6 +++--- 3 files changed, 5 insertions(+), 7 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index da8e563fa..93ab4b266 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -65,8 +65,8 @@ CourseCapacity: Kapazität CourseCapacityTip: Anzahl erlaubter Kursanmeldungen, leer lassen für unbeschränkte Kurskapazität CourseNoCapacity: In diesem Kurs sind keine Plätze mehr frei. CourseNotEmpty: In diesem Kurs sind momentan Teilnehmer angemeldet. -CourseRegisterOk: Sie wurden angemeldet -CourseDeregisterOk: Sie wurden abgemeldet +CourseRegisterOk: Anmeldung erfolgreich +CourseDeregisterOk: Erfolgreich abgemeldet CourseStudyFeature: Assoziiertes Hauptfach CourseStudyFeatureTooltip: Korrekte Angabe kann Notenweiterleitungen beschleunigen CourseSecretWrong: Falsches Kennwort diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 19b84adf3..4d53f5eed 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -305,7 +305,6 @@ postAdminFeaturesR = do unless (null infRedundant) . addMessageI Info . MsgRedundantCandidatesRemoved $ length infRedundant let newKeys = map (StudyTermsKey' . fst) infAccepted setSessionJson sessionKeyNewStudyTerms newKeys - -- addMessageI Error $ MsgPrintDebugForStupid $ tshow newKeys if | null infAccepted -> addMessageI Info MsgNoCandidatesInferred | otherwise @@ -324,7 +323,6 @@ postAdminFeaturesR = do _other -> runDB Candidates.conflicts newStudyTermKeys <- fromMaybe [] <$> lookupSessionJson sessionKeyNewStudyTerms - -- addMessageI Error $ MsgPrintDebugForStupid $ tshow newStudyTermKeys ( (degreeResult,degreeTable) , (studyTermsResult,studytermsTable) , ((), candidateTable)) <- runDB $ (,,) diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index fd7ae019e..aa9e37fde 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -705,7 +705,7 @@ validateCourse CourseForm{..} = do uid <- liftHandlerT requireAuthId userAdmin <- liftHandlerT . runDB . getBy $ UniqueUserAdmin uid cfSchool -- FIXME: This /needs/ to be a call to `isAuthorized` on a route MsgRenderer mr <- getMsgRenderer - + return [ mr msg | (False, msg) <- [ @@ -852,8 +852,8 @@ makeCourseUserTable cid colChoices psValidator = , fltrUserMatriclenr queryUser , fltrUserNameEmail queryUser -- , ("course-user-degree", error "TODO") -- TODO - -- , ("course-user-field" , error "TODO") -- TODO - , ("course-user-semesternr", FilterColumn $ E.mkExactFilter $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester)) + -- , ("field" , FilterColumn $ queryFeaturesField error "TODO") -- TODO + , ("semesternr", FilterColumn $ E.mkExactFilter $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester)) -- , ("course-registration", error "TODO") -- TODO -- , ("course-user-note", error "TODO") -- TODO ] From 431affe6ec06f9bad6307212fdc079b7cba0456a Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 4 Apr 2019 14:20:20 +0200 Subject: [PATCH 2/3] Course User Deregister --- messages/uniworx/de.msg | 3 + routes | 2 +- src/Handler/Course.hs | 141 +++++++++++++++++++++++++--------------- 3 files changed, 94 insertions(+), 52 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 93ab4b266..e5eed4900 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -112,6 +112,9 @@ CourseUserNote: Notiz CourseUserNoteTooltip: Nur für Dozenten dieses Kurses einsehbar CourseUserNoteSaved: Notizänderungen gespeichert CourseUserNoteDeleted: Teilnehmernotiz gelöscht +CourseUserDeregister: Abmelden +CourseUsersDeregistered count@Int64: #{show count} Teilnehmer abgemeldet + CourseLecturers: Kursverwalter CourseLecturer: Dozent CourseAssistant: Assistent diff --git a/routes b/routes index f76fd47b7..d558de967 100644 --- a/routes +++ b/routes @@ -75,7 +75,7 @@ /register CRegisterR POST !timeANDcapacity /edit CEditR GET POST /delete CDeleteR GET POST !lecturerANDempty - /users CUsersR GET + /users CUsersR GET POST /users/#CryptoUUIDUser CUserR GET POST !lecturerANDparticipant /correctors CHiWisR GET /notes CNotesR GET POST !corrector diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index aa9e37fde..5d4ec2bf9 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -14,6 +14,7 @@ import Handler.Utils.Delete import Handler.Utils.Database import Handler.Utils.Table.Cells import Handler.Utils.Table.Columns +import Database.Persist.Sql (deleteWhereCount) import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH @@ -819,57 +820,87 @@ colUserDegreeShort :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell colUserDegreeShort = sortable (Just "degree-short") (i18nCell MsgStudyFeatureDegree) $ foldMap (i18nCell . ShortStudyDegree) . preview (_userTableFeatures . _2 . _Just) -makeCourseUserTable :: CourseId -> _ -> _ -> DB Widget -makeCourseUserTable cid colChoices psValidator = - -- -- psValidator has default sorting and filtering - let dbtIdent = "courseUsers" :: Text - dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } - dbtSQLQuery = userTableQuery cid - dbtRowKey = queryUser >>> (E.^. UserId) - dbtProj = traverse $ \(user, E.Value registrationTime , E.Value userNoteId, (feature,degree,terms)) -> return (user, registrationTime, userNoteId, (entityVal <$> feature, entityVal <$> degree, entityVal <$> terms)) - dbtColonnade = colChoices - dbtSorting = Map.fromList - [ sortUserNameLink queryUser -- slower sorting through clicking name column header - , sortUserSurname queryUser -- needed for initial sorting - , sortUserDisplayName queryUser -- needed for initial sorting - , sortUserEmail queryUser - , sortUserMatriclenr queryUser - , ("degree" , SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeName)) - , ("degree-short", SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand)) - , ("field" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsName)) - , ("field-short" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsShorthand)) - , ("semesternr" , SortColumn $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester)) - , ("registration", SortColumn $ queryParticipant >>> (E.^. CourseParticipantRegistration)) - , ("note" , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date - E.sub_select . E.from $ \edit -> do - E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote) - return . E.max_ $ edit E.^. CourseUserNoteEditTime - ) - ] - dbtFilter = Map.fromList - [ fltrUserNameLink queryUser - , fltrUserEmail queryUser - , fltrUserMatriclenr queryUser - , fltrUserNameEmail queryUser - -- , ("course-user-degree", error "TODO") -- TODO - -- , ("field" , FilterColumn $ queryFeaturesField error "TODO") -- TODO - , ("semesternr", FilterColumn $ E.mkExactFilter $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester)) - -- , ("course-registration", error "TODO") -- TODO - -- , ("course-user-note", error "TODO") -- TODO - ] - dbtFilterUI mPrev = mconcat - [ fltrUserNameEmailUI mPrev - , fltrUserMatriclenrUI mPrev - ] - dbtParams = def - in dbTableWidget' psValidator DBTable{..} +data CourseUserAction = CourseUserDeregister + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) -getCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html -getCUsersR tid ssh csh = do - (course, numParticipants, participantTable) <- runDB $ do +instance Universe CourseUserAction +instance Finite CourseUserAction +nullaryPathPiece ''CourseUserAction $ camelToPathPiece' 2 +embedRenderMessage ''UniWorX ''CourseUserAction id + +makeCourseUserTable :: CourseId -> _ -> _ -> DB (FormResult (CourseUserAction, Set UserId), Widget) +makeCourseUserTable cid colChoices psValidator = do + Just currentRoute <- liftHandlerT getCurrentRoute + -- -- psValidator has default sorting and filtering + let dbtIdent = "courseUsers" :: Text + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } + dbtSQLQuery = userTableQuery cid + dbtRowKey = queryUser >>> (E.^. UserId) + dbtProj = traverse $ \(user, E.Value registrationTime , E.Value userNoteId, (feature,degree,terms)) -> return (user, registrationTime, userNoteId, (entityVal <$> feature, entityVal <$> degree, entityVal <$> terms)) + dbtColonnade = colChoices + dbtSorting = Map.fromList + [ sortUserNameLink queryUser -- slower sorting through clicking name column header + , sortUserSurname queryUser -- needed for initial sorting + , sortUserDisplayName queryUser -- needed for initial sorting + , sortUserEmail queryUser + , sortUserMatriclenr queryUser + , ("degree" , SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeName)) + , ("degree-short", SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand)) + , ("field" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsName)) + , ("field-short" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsShorthand)) + , ("semesternr" , SortColumn $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester)) + , ("registration", SortColumn $ queryParticipant >>> (E.^. CourseParticipantRegistration)) + , ("note" , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date + E.sub_select . E.from $ \edit -> do + E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote) + return . E.max_ $ edit E.^. CourseUserNoteEditTime + ) + ] + dbtFilter = Map.fromList + [ fltrUserNameLink queryUser + , fltrUserEmail queryUser + , fltrUserMatriclenr queryUser + , fltrUserNameEmail queryUser + -- , ("course-user-degree", error "TODO") -- TODO + -- , ("field" , FilterColumn $ queryFeaturesField error "TODO") -- TODO + , ("semesternr", FilterColumn $ E.mkExactFilter $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester)) + -- , ("course-registration", error "TODO") -- TODO + -- , ("course-user-note", error "TODO") -- TODO + ] + dbtFilterUI mPrev = mconcat + [ fltrUserNameEmailUI mPrev + , fltrUserMatriclenrUI mPrev + ] + dbtParams = DBParamsForm + { dbParamsFormMethod = POST + , dbParamsFormAction = Just $ SomeRoute currentRoute + , dbParamsFormAttrs = [] + , dbParamsFormSubmit = FormSubmit + , dbParamsFormAdditional = \csrf -> do + (res,vw) <- mreq (selectField optionsFinite) "" Nothing + let formWgt = toWidget csrf <> fvInput vw + formRes = (, mempty) . First . Just <$> res + return (formRes,formWgt) + , dbParamsFormEvaluate = liftHandlerT . runFormPost + , dbParamsFormResult = id + , dbParamsFormIdent = def + } + over _1 postprocess <$> dbTable psValidator DBTable{..} + where + postprocess :: FormResult (First CourseUserAction, DBFormResult UserId Bool UserTableData) -> FormResult (CourseUserAction, Set UserId) + postprocess inp = do + (First (Just act), usrMap) <- inp + let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap + return (act, usrSet) + +getCUsersR, postCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +getCUsersR = postCUsersR +postCUsersR tid ssh csh = do + (Entity cid course, numParticipants, (participantRes,participantTable)) <- runDB $ do let colChoices = mconcat - [ colUserNameLink (CourseR tid ssh csh . CUserR) + [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) + , colUserNameLink (CourseR tid ssh csh . CUserR) , colUserEmail , colUserMatriclenr , colUserDegreeShort @@ -879,10 +910,18 @@ getCUsersR tid ssh csh = do , colUserComment tid ssh csh ] psValidator = def & defaultSortingByName - Entity cid course <- getBy404 $ TermSchoolCourseShort tid ssh csh + ent@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh numParticipants <- count [CourseParticipantCourse ==. cid] - participantTable <- makeCourseUserTable cid colChoices psValidator - return (course, numParticipants, participantTable) + table <- makeCourseUserTable cid colChoices psValidator + return (ent, numParticipants, table) + formResult participantRes $ \case + (CourseUserDeregister,selectedUsers) -> do + nrDel <- runDB $ deleteWhereCount + [ CourseParticipantCourse ==. cid + , CourseParticipantUser <-. Set.toList selectedUsers + ] + addMessageI Success $ MsgCourseUsersDeregistered nrDel + redirect $ CourseR tid ssh csh CUsersR let headingLong = [whamlet|_{MsgMenuCourseMembers} #{courseName course} #{display tid}|] headingShort = prependCourseTitle tid ssh csh MsgCourseMembers siteLayout headingLong $ do From 6da0850add13840203ac7d4eec71a5ce90262099 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 4 Apr 2019 18:01:46 +0200 Subject: [PATCH 3/3] Filter-UI course participants improved --- src/Database/Esqueleto/Utils.hs | 41 +++++++++++++++++++++++++-------- src/Handler/Course.hs | 19 ++++++++++++--- 2 files changed, 48 insertions(+), 12 deletions(-) diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index f3aec73aa..6c89e6c96 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -5,8 +5,9 @@ module Database.Esqueleto.Utils , isInfixOf, hasInfix , any, all , SqlIn(..) - , mkExactFilter, mkContainsFilter - , anyFilter + , mkExactFilter, mkExactFilterWith + , mkContainsFilter + , anyFilter, allFilter ) where import ClassyPrelude.Yesod hiding (isInfixOf, any, all) @@ -74,13 +75,22 @@ _queryFeaturesDegree = $(sqlIJproj 3 2) -- Given a lens-like function, make filter for exact matches in a collection -- (Generalizing from Set to Foldable ok here, but gives ambigouus types elsewhere) mkExactFilter :: (PersistField a) - => (t -> E.SqlExpr (E.Value a)) -- ^ getter from query to searched element + => (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) -mkExactFilter lenslike row criterias +mkExactFilter = mkExactFilterWith id + +-- | like @mkExactFiler@ but allows for conversion; convenient in conjunction with @anyFilter@ and @allFilter@ +mkExactFilterWith :: (PersistField b) + => (a -> b) -- ^ type conversion + -> (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) +mkExactFilterWith cast lenslike row criterias | Set.null criterias = true - | otherwise = lenslike row `E.in_` E.valList (Set.toList criterias) + | otherwise = lenslike row `E.in_` E.valList (cast <$> Set.toList criterias) -- | generic filter creation for dbTable -- Given a lens-like function, make filter searching for needles in String-like elements @@ -94,9 +104,22 @@ mkContainsFilter lenslike row criterias | Set.null criterias = true | otherwise = any (hasInfix $ lenslike row) criterias - -anyFilter :: (Foldable f) => f (t -> Set.Set Text-> E.SqlExpr (E.Value Bool)) - -> t -> Set.Set Text-> E.SqlExpr (E.Value Bool) +-- | Combine several filters, using logical or +anyFilter :: (Foldable f) + => f (t -> Set.Set Text-> E.SqlExpr (E.Value Bool)) + -> t + -> Set.Set Text + -> E.SqlExpr (E.Value Bool) anyFilter fltrs needle criterias = F.foldr aux false fltrs where - aux fltr acc = fltr needle criterias E.||. acc \ No newline at end of file + aux fltr acc = fltr needle criterias E.||. acc + +-- | Combine several filters, using logical and +allFilter :: (Foldable f) + => f (t -> Set.Set Text-> E.SqlExpr (E.Value Bool)) + -> t + -> Set.Set Text + -> E.SqlExpr (E.Value Bool) +allFilter fltrs needle criterias = F.foldr aux true fltrs + where + aux fltr acc = fltr needle criterias E.&&. acc \ No newline at end of file diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 5d4ec2bf9..98016ca8e 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -862,15 +862,28 @@ makeCourseUserTable cid colChoices psValidator = do , fltrUserEmail queryUser , fltrUserMatriclenr queryUser , fltrUserNameEmail queryUser - -- , ("course-user-degree", error "TODO") -- TODO - -- , ("field" , FilterColumn $ queryFeaturesField error "TODO") -- TODO - , ("semesternr", FilterColumn $ E.mkExactFilter $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester)) + , ("field-name" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsName)) + , ("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.mkExactFilterWith readMay $ queryFeaturesField >>> (E.?. StudyTermsKey) + ] ) + , ("degree" , FilterColumn $ E.anyFilter + [ E.mkContainsFilter $ queryFeaturesDegree >>> (E.?. StudyDegreeName) + , E.mkContainsFilter $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand) + , E.mkExactFilterWith readMay $ queryFeaturesDegree >>> (E.?. StudyDegreeKey) + ] ) + , ("semesternr" , FilterColumn $ E.mkExactFilter $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester)) -- , ("course-registration", error "TODO") -- TODO -- , ("course-user-note", error "TODO") -- TODO ] dbtFilterUI mPrev = mconcat [ fltrUserNameEmailUI mPrev , fltrUserMatriclenrUI mPrev + , prismAForm (singletonFilter "degree") mPrev $ aopt (searchField False) (fslI MsgStudyFeatureDegree) + , prismAForm (singletonFilter "field") mPrev $ aopt (searchField False) (fslI MsgCourseStudyFeature) ] dbtParams = DBParamsForm { dbParamsFormMethod = POST