From 7f7d2c795767fd6fac1fa4a10a304e3e3d2280c3 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sat, 10 Oct 2020 17:36:02 +0200 Subject: [PATCH 01/36] feat(allocations): include study features in users table --- messages/uniworx/de-de-formal.msg | 1 + messages/uniworx/en-eu.msg | 1 + src/Handler/Allocation/Users.hs | 24 +++++++++++++++++------- src/Handler/Utils/StudyFeatures.hs | 22 ++++++++++++++++++++++ 4 files changed, 41 insertions(+), 7 deletions(-) diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index e5965bb1d..9a9e2918d 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -2689,6 +2689,7 @@ CsvColumnAllocationUserSurname: Nachname(n) des Bewerbers CsvColumnAllocationUserFirstName: Vorname(n) des Bewerbers CsvColumnAllocationUserName: Voller Name des Bewerbers CsvColumnAllocationUserMatriculation: Matrikelnummer des Bewerber +CsvColumnAllocationUserStudyFeatures: Studiendaten CsvColumnAllocationUserRequested: Maximale Anzahl von Plätzen, die der Bewerber bereit ist, zu akzeptieren CsvColumnAllocationUserApplied: Anzahl von Bewerbungen, die der Bewerber eingereicht hat CsvColumnAllocationUserVetos: Anzahl von Bewerbungen, die von Kursverwaltern ein Veto oder eine Note erhalten haben, die äquivalent ist zu "Nicht Bestanden" (5.0) diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index c7650c428..c934e626e 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -2689,6 +2689,7 @@ CsvColumnAllocationUserSurname: Applicant's surname(s) CsvColumnAllocationUserFirstName: Applicants's first name(s) CsvColumnAllocationUserName: Applicant's full name CsvColumnAllocationUserMatriculation: Applicant's matriculation +CsvColumnAllocationUserStudyFeatures: Features of study CsvColumnAllocationUserRequested: Maximum number of placements the applicant is prepared to accept CsvColumnAllocationUserApplied: Number of applications the applicant has provided CsvColumnAllocationUserVetos: Number of applications that have received a veto from a course administrator or have been rated with a grade that is equivalent to "failed" (5.0) diff --git a/src/Handler/Allocation/Users.hs b/src/Handler/Allocation/Users.hs index e150f1d1b..af3793386 100644 --- a/src/Handler/Allocation/Users.hs +++ b/src/Handler/Allocation/Users.hs @@ -10,6 +10,7 @@ import Handler.Allocation.Accept import Handler.Utils import Handler.Utils.Allocation +import Handler.Utils.StudyFeatures import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E @@ -59,6 +60,7 @@ queryVetoedCourses = queryAllocationUser . to queryVetoedCourses' type UserTableData = DBRow ( Entity User + , UserTableStudyFeatures , Entity AllocationUser , Int -- ^ Applied , Int -- ^ Assigned @@ -68,13 +70,16 @@ type UserTableData = DBRow ( Entity User resultUser :: Lens' UserTableData (Entity User) resultUser = _dbrOutput . _1 +resultStudyFeatures :: Lens' UserTableData UserTableStudyFeatures +resultStudyFeatures = _dbrOutput . _2 + resultAllocationUser :: Lens' UserTableData (Entity AllocationUser) -resultAllocationUser = _dbrOutput . _2 +resultAllocationUser = _dbrOutput . _3 resultAppliedCourses, resultAssignedCourses, resultVetoedCourses :: Lens' UserTableData Int -resultAppliedCourses = _dbrOutput . _3 -resultAssignedCourses = _dbrOutput . _4 -resultVetoedCourses = _dbrOutput . _5 +resultAppliedCourses = _dbrOutput . _4 +resultAssignedCourses = _dbrOutput . _5 +resultVetoedCourses = _dbrOutput . _6 data AllocationUserTableCsv = AllocationUserTableCsv @@ -82,6 +87,7 @@ data AllocationUserTableCsv = AllocationUserTableCsv , csvAUserFirstName :: Text , csvAUserName :: Text , csvAUserMatriculation :: Maybe Text + , csvAUserStudyFeatures :: UserTableStudyFeatures , csvAUserRequested , csvAUserApplied , csvAUserVetos @@ -105,6 +111,7 @@ instance CsvColumnsExplained AllocationUserTableCsv where , singletonMap 'csvAUserFirstName MsgCsvColumnAllocationUserFirstName , singletonMap 'csvAUserName MsgCsvColumnAllocationUserName , singletonMap 'csvAUserMatriculation MsgCsvColumnAllocationUserMatriculation + , singletonMap 'csvAUserStudyFeatures MsgCsvColumnAllocationUserStudyFeatures , singletonMap 'csvAUserRequested MsgCsvColumnAllocationUserRequested , singletonMap 'csvAUserApplied MsgCsvColumnAllocationUserApplied , singletonMap 'csvAUserVetos MsgCsvColumnAllocationUserVetos @@ -148,13 +155,15 @@ postAUsersR tid ssh ash = do , assigned , vetoed) dbtRowKey = views queryAllocationUser (E.^. AllocationUserId) - dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $ - (,,,,) - <$> view _1 <*> view _2 <*> view (_3 . _Value) <*> view (_4 . _Value) <*> view (_5 . _Value) + dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $ do + feats <- lift . allocationUserStudyFeatures aId =<< views _1 entityKey + (,,,,,) + <$> view _1 <*> pure feats <*> view _2 <*> view (_3 . _Value) <*> view (_4 . _Value) <*> view (_5 . _Value) dbtColonnade :: Colonnade Sortable _ _ dbtColonnade = mconcat . catMaybes $ [ pure $ colUserDisplayName (resultUser . _entityVal . $(multifocusL 2) _userDisplayName _userSurname) , pure $ colUserMatriculation (resultUser . _entityVal . _userMatrikelnummer) + , pure $ colStudyFeatures resultStudyFeatures , pure $ colAllocationRequested (resultAllocationUser . _entityVal . _allocationUserTotalCourses) , pure . coursesModalApplied $ colAllocationApplied resultAppliedCourses , pure . coursesModalVetoed $ colAllocationVetoed resultVetoedCourses @@ -258,6 +267,7 @@ postAUsersR tid ssh ash = do <*> view (resultUser . _entityVal . _userFirstName) <*> view (resultUser . _entityVal . _userDisplayName) <*> view (resultUser . _entityVal . _userMatrikelnummer) + <*> view resultStudyFeatures <*> view (resultAllocationUser . _entityVal . _allocationUserTotalCourses) <*> view (resultAppliedCourses . to fromIntegral) <*> view (resultVetoedCourses . to fromIntegral) diff --git a/src/Handler/Utils/StudyFeatures.hs b/src/Handler/Utils/StudyFeatures.hs index 7a2b1c6cc..7e3dc481a 100644 --- a/src/Handler/Utils/StudyFeatures.hs +++ b/src/Handler/Utils/StudyFeatures.hs @@ -9,6 +9,7 @@ module Handler.Utils.StudyFeatures , isCourseStudyFeature, courseUserStudyFeatures , isExternalExamStudyFeature, externalExamUserStudyFeatures , isTermStudyFeature + , isAllocationStudyFeature, allocationUserStudyFeatures ) where import Import.NoFoundation @@ -184,3 +185,24 @@ externalExamUserStudyFeatures eeId uid = do isTermStudyFeature :: E.SqlExpr (Entity Term) -> E.SqlExpr (Entity StudyFeatures) -> E.SqlExpr (E.Value Bool) isTermStudyFeature = isRelevantStudyFeatureCached TermId + + +isAllocationStudyFeature :: E.SqlExpr (Entity Allocation) -> E.SqlExpr (Entity StudyFeatures) -> E.SqlExpr (E.Value Bool) +isAllocationStudyFeature = isRelevantStudyFeatureCached AllocationTerm + +allocationUserStudyFeatures :: MonadIO m => AllocationId -> UserId -> SqlPersistT m UserTableStudyFeatures +allocationUserStudyFeatures aId uid = do + feats <- E.select . E.from $ \(allocation `E.InnerJoin` studyFeatures `E.InnerJoin` terms `E.InnerJoin` degree) -> do + E.on $ degree E.^. StudyDegreeId E.==. studyFeatures E.^. StudyFeaturesDegree + E.on $ terms E.^. StudyTermsId E.==. studyFeatures E.^. StudyFeaturesField + E.on $ isAllocationStudyFeature allocation studyFeatures + E.where_ $ allocation E.^. AllocationId E.==. E.val aId + E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. E.val uid + return (terms, degree, studyFeatures) + return . UserTableStudyFeatures . Set.fromList . flip map feats $ + \(Entity _ StudyTerms{..}, Entity _ StudyDegree{..}, Entity _ StudyFeatures{..}) -> UserTableStudyFeature + { userTableField = fromMaybe (tshow studyTermsKey) studyTermsName + , userTableDegree = fromMaybe (tshow studyDegreeKey) studyDegreeName + , userTableSemester = studyFeaturesSemester + , userTableFieldType = studyFeaturesType + } From c97f1c0a9392229e3681f8e525270360504e8e3c Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sat, 10 Oct 2020 17:43:02 +0200 Subject: [PATCH 02/36] chore(release): 20.7.0 --- CHANGELOG.md | 7 +++++++ package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 4 files changed, 10 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index e6b2999fa..1c0172848 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,13 @@ 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. +## [20.7.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.6.0...v20.7.0) (2020-10-10) + + +### Features + +* **allocations:** include study features in users table ([7f7d2c7](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/7f7d2c795767fd6fac1fa4a10a304e3e3d2280c3)) + ## [20.6.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.5.1...v20.6.0) (2020-10-06) diff --git a/package-lock.json b/package-lock.json index c2a023d6e..06b978f4d 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "20.6.0", + "version": "20.7.0", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 57c4e377e..5326c581c 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "20.6.0", + "version": "20.7.0", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 6c59a87a6..e5bf27700 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 20.6.0 +version: 20.7.0 dependencies: - base From a4114a79f1bfd968bb9d300f0c39400a8904ee7c Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sat, 10 Oct 2020 21:22:43 +0200 Subject: [PATCH 03/36] feat(allocations): csv-export new-assigned --- messages/uniworx/de-de-formal.msg | 1 + messages/uniworx/en-eu.msg | 1 + src/Handler/Allocation/Users.hs | 73 ++++++++++++++++++++++++------- 3 files changed, 60 insertions(+), 15 deletions(-) diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 9a9e2918d..b59ae2ce7 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -2694,6 +2694,7 @@ CsvColumnAllocationUserRequested: Maximale Anzahl von Plätzen, die der Bewerber CsvColumnAllocationUserApplied: Anzahl von Bewerbungen, die der Bewerber eingereicht hat CsvColumnAllocationUserVetos: Anzahl von Bewerbungen, die von Kursverwaltern ein Veto oder eine Note erhalten haben, die äquivalent ist zu "Nicht Bestanden" (5.0) CsvColumnAllocationUserAssigned: Anzahl von Plätzen, die der Bewerber durch diese Zentralanmeldung bereits erhalten hat +CsvColumnAllocationUserNewAssigned: Anzahl von Plätzen, die der Bewerber, nach Akzeptieren der berechneten Verteilung, zusätzlich erhalten würde CsvColumnAllocationUserPriority: Zentrale Dringlichkeit des Bewerbers; entweder einzelne Zahl für Sortierungsbasierte Dringlichkeiten (höhere Dringlichkeit entspricht größerer Zahl) oder Komma-separierte Liste von numerischen Dringlichkeiten in eckigen Klammern (z.B. [1, 2, 3]) AllocationUsersCsvName tid@TermId ssh@SchoolId ash@AllocationShorthand: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase ash}-bewerber diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index c934e626e..12a20ad3c 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -2694,6 +2694,7 @@ CsvColumnAllocationUserRequested: Maximum number of placements the applicant is CsvColumnAllocationUserApplied: Number of applications the applicant has provided CsvColumnAllocationUserVetos: Number of applications that have received a veto from a course administrator or have been rated with a grade that is equivalent to "failed" (5.0) CsvColumnAllocationUserAssigned: Number of assignments the applicant has already received +CsvColumnAllocationUserNewAssigned: Number of assignments the applicant would receive, if the calculated matching is accepted CsvColumnAllocationUserPriority: Central priority of this applicant; either a number based on the applicants position in the list sorted by priority (higher numbers mean a higher priority) or a comma-separated list of numerical priorities in square brackets (e.g. [1, 2, 3]) AllocationUsersCsvName tid ssh ash: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase ash}-applicants diff --git a/src/Handler/Allocation/Users.hs b/src/Handler/Allocation/Users.hs index af3793386..43ea49e9f 100644 --- a/src/Handler/Allocation/Users.hs +++ b/src/Handler/Allocation/Users.hs @@ -23,6 +23,8 @@ import qualified Data.Set as Set import Text.Blaze (toMarkup) +import qualified Data.Conduit.Combinators as C + type UserTableExpr = E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity AllocationUser) @@ -92,6 +94,7 @@ data AllocationUserTableCsv = AllocationUserTableCsv , csvAUserApplied , csvAUserVetos , csvAUserAssigned :: Natural + , csvAUserNewAssigned :: Maybe Natural , csvAUserPriority :: Maybe AllocationPriority } deriving (Generic) makeLenses_ ''AllocationUserTableCsv @@ -100,10 +103,22 @@ allocationUserTableCsvOptions :: Csv.Options allocationUserTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 3} instance Csv.ToNamedRecord AllocationUserTableCsv where - toNamedRecord = Csv.genericToNamedRecord allocationUserTableCsvOptions - -instance Csv.DefaultOrdered AllocationUserTableCsv where - headerOrder = Csv.genericHeaderOrder allocationUserTableCsvOptions + toNamedRecord AllocationUserTableCsv{..} = Csv.namedRecord $ + [ "surname" Csv..= csvAUserSurname + , "first-name" Csv..= csvAUserFirstName + , "name" Csv..= csvAUserName + , "matriculation" Csv..= csvAUserMatriculation + , "study-features" Csv..= csvAUserStudyFeatures + , "requested" Csv..= csvAUserRequested + , "applied" Csv..= csvAUserApplied + , "vetos" Csv..= csvAUserVetos + , "assigned" Csv..= csvAUserAssigned + ] ++ + [ "new-assigned" Csv..= newAssigned + | newAssigned <- hoistMaybe csvAUserNewAssigned + ] ++ + [ "priority" Csv..= csvAUserPriority + ] instance CsvColumnsExplained AllocationUserTableCsv where csvColumnsExplanations = genericCsvColumnsExplanations allocationUserTableCsvOptions $ mconcat @@ -116,9 +131,28 @@ instance CsvColumnsExplained AllocationUserTableCsv where , singletonMap 'csvAUserApplied MsgCsvColumnAllocationUserApplied , singletonMap 'csvAUserVetos MsgCsvColumnAllocationUserVetos , singletonMap 'csvAUserAssigned MsgCsvColumnAllocationUserAssigned + , singletonMap 'csvAUserNewAssigned MsgCsvColumnAllocationUserNewAssigned , singletonMap 'csvAUserPriority MsgCsvColumnAllocationUserPriority ] +userTableCsvHeader :: Bool -> Csv.Header +userTableCsvHeader hasNewAssigned = Csv.header $ + [ "surname" + , "first-name" + , "name" + , "matriculation" + , "study-features" + , "requested" + , "applied" + , "vetos" + , "assigned" + ] ++ + [ "new-assigned" + | hasNewAssigned + ] ++ + [ "priority" + ] + getAUsersR, postAUsersR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html getAUsersR = postAUsersR @@ -262,17 +296,26 @@ postAUsersR tid ssh ash = do dbtParams = def dbtIdent :: Text dbtIdent = "allocation-users" - dbtCsvEncode = simpleCsvEncode csvName $ AllocationUserTableCsv - <$> view (resultUser . _entityVal . _userSurname) - <*> view (resultUser . _entityVal . _userFirstName) - <*> view (resultUser . _entityVal . _userDisplayName) - <*> view (resultUser . _entityVal . _userMatrikelnummer) - <*> view resultStudyFeatures - <*> view (resultAllocationUser . _entityVal . _allocationUserTotalCourses) - <*> view (resultAppliedCourses . to fromIntegral) - <*> view (resultVetoedCourses . to fromIntegral) - <*> view (resultAssignedCourses . to fromIntegral) - <*> view (resultAllocationUser . _entityVal . _allocationUserPriority) + dbtCsvEncode = return DBTCsvEncode + { dbtCsvExportForm = pure () + , dbtCsvDoEncode = \() -> C.mapM $ \(_, row) -> flip runReaderT row $ + AllocationUserTableCsv + <$> view (resultUser . _entityVal . _userSurname) + <*> view (resultUser . _entityVal . _userFirstName) + <*> view (resultUser . _entityVal . _userDisplayName) + <*> view (resultUser . _entityVal . _userMatrikelnummer) + <*> view resultStudyFeatures + <*> view (resultAllocationUser . _entityVal . _allocationUserTotalCourses) + <*> view (resultAppliedCourses . to fromIntegral) + <*> view (resultVetoedCourses . to fromIntegral) + <*> view (resultAssignedCourses . to fromIntegral) + <*> views (resultUser . _entityKey) (\uid -> maybe 0 (fromIntegral . olength) . Map.lookup uid <$> allocMatching) + <*> view (resultAllocationUser . _entityVal . _allocationUserPriority) + , dbtCsvName = unpack csvName + , dbtCsvNoExportData = Just id + , dbtCsvHeader = \_ -> return . userTableCsvHeader $ is _Just allocMatching + , dbtCsvExampleData = Nothing + } dbtCsvDecode = Nothing allocationUsersDBTableValidator = def & defaultSorting [SortAscBy "priority", SortAscBy "user-matriculation"] From cbb7ec53ad51345065538d4304c8646a88b0b9fd Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sat, 10 Oct 2020 21:35:57 +0200 Subject: [PATCH 04/36] chore(release): 20.8.0 --- CHANGELOG.md | 7 +++++++ package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 4 files changed, 10 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 1c0172848..8cfec5d3a 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,13 @@ 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. +## [20.8.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.7.0...v20.8.0) (2020-10-10) + + +### Features + +* **allocations:** csv-export new-assigned ([a4114a7](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a4114a79f1bfd968bb9d300f0c39400a8904ee7c)) + ## [20.7.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.6.0...v20.7.0) (2020-10-10) diff --git a/package-lock.json b/package-lock.json index 06b978f4d..d0c5b7cc8 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "20.7.0", + "version": "20.8.0", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 5326c581c..496846141 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "20.7.0", + "version": "20.8.0", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index e5bf27700..6793d5d02 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 20.7.0 +version: 20.8.0 dependencies: - base From b69481e88fb20890b4ece7a0023dcfdad21604d6 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 12 Oct 2020 10:54:27 +0200 Subject: [PATCH 05/36] fix(authorization): have AllocationTime consider ParticipantState --- src/Foundation/Authorization.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs index 9b7b211bd..3f479f5df 100644 --- a/src/Foundation/Authorization.hs +++ b/src/Foundation/Authorization.hs @@ -784,7 +784,7 @@ tagAccessPredicate AuthAllocationTime = APDB $ \mAuthId route _ -> case route of Nothing -> return Authorized Just (cid, Allocation{..}) -> do registered <- case mAuthId of - Just uid -> $cachedHereBinary (uid, cid) . existsBy $ UniqueParticipant uid cid + Just uid -> $cachedHereBinary (uid, cid) $ exists [ CourseParticipantUser ==. uid, CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ] _ -> return False if | not registered From d43b7caa4309462b76e52557a6b2f326ec32504a Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 12 Oct 2020 11:05:48 +0200 Subject: [PATCH 06/36] chore(release): 20.8.1 --- CHANGELOG.md | 7 +++++++ package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 4 files changed, 10 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 8cfec5d3a..faf277ab8 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,13 @@ 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. +### [20.8.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.8.0...v20.8.1) (2020-10-12) + + +### Bug Fixes + +* **authorization:** have AllocationTime consider ParticipantState ([b69481e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b69481e88fb20890b4ece7a0023dcfdad21604d6)) + ## [20.8.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.7.0...v20.8.0) (2020-10-10) diff --git a/package-lock.json b/package-lock.json index d0c5b7cc8..e6900e2a2 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "20.8.0", + "version": "20.8.1", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 496846141..0a2d7ce7c 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "20.8.0", + "version": "20.8.1", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 6793d5d02..311f5d405 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 20.8.0 +version: 20.8.1 dependencies: - base From 94436ee0e1ce2cbf13a66f9ad81883d7286acb9b Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 12 Oct 2020 13:29:43 +0200 Subject: [PATCH 07/36] feat(exams): exam staff & additional schools --- messages/uniworx/de-de-formal.msg | 6 +++ messages/uniworx/en-eu.msg | 8 +++- models/exams.model | 7 ++- src/Handler/Exam/Edit.hs | 4 +- src/Handler/Exam/Form.hs | 45 ++++++++++++++++++-- src/Handler/Exam/New.hs | 3 ++ src/Handler/Exam/Show.hs | 11 ++++- src/Utils/Form.hs | 22 +++++++++- templates/exam-show.hamlet | 10 +++++ templates/exam/schoolMassInput/add.hamlet | 6 +++ templates/exam/schoolMassInput/cell.hamlet | 3 ++ templates/exam/schoolMassInput/layout.hamlet | 11 +++++ test/Database/Fill.hs | 1 + 13 files changed, 127 insertions(+), 10 deletions(-) create mode 100644 templates/exam/schoolMassInput/add.hamlet create mode 100644 templates/exam/schoolMassInput/cell.hamlet create mode 100644 templates/exam/schoolMassInput/layout.hamlet diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index b59ae2ce7..0aa58cc7c 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -1832,6 +1832,11 @@ ExamRoomDescription: Beschreibung ExamTimeTip: Nur zur Information der Studierenden, die tatsächliche Zeitangabe erfolgt pro Prüfungstermin/Raum ExamRoomAssigned: Zugeteilt ExamRoomRegistered: Anmeldung +ExamStaff: Prüfer/Verantwortliche Hochschullehrer +ExamStaffTip: Geben Sie bitte in jedem Fall einen Namen an, der den Prüfer/Veranstalter/Verantwortlichen Hochschullehrer eindeutig identifiziert! Sollte der Name des Prüfers allein womöglich nicht eindeutig sein, so geben Sie bitte eindeutig identifizierende Zusatzinfos, wie beispielsweise den Lehrstuhl bzw. die LFE o.Ä., an. +ExamStaffRequired: „Prüfer/Verantwortilche Hochschullehrer” muss angegeben werden +ExamExamOfficeSchools: Zusätzliche Institute +ExamExamOfficeSchoolsTip: Prüfungsbeauftragte von Instituten, die Sie hier angeben, erhalten im System (zusätzlich zum primären Institut des zugehörigen Kurses) volle Einsicht in sämtliche für diese Prüfung hinterlegten Leistungen, unabhängig von den Studiendaten der Teilnehmer. ExamOccurrenceStart: Prüfungsbeginn @@ -1841,6 +1846,7 @@ ExamFormAutomaticFunctions: Automatische Funktionen ExamFormCorrection: Korrektur ExamFormParts: Teile ExamFormMode: Ausgestaltung der Prüfung +ExamFormGrades: Prüfungsleistungen ExamModeFormNone: Keine Angabe ExamModeFormCustom: Benutzerdefiniert diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 12a20ad3c..b493635d6 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -1831,6 +1831,11 @@ ExamRoomDescription: Description ExamTimeTip: Only for informational purposes. The actual times are set for each occurrence/room ExamRoomAssigned: Assigned ExamRoomRegistered: Registration +ExamStaff: Examiner/Responsible university teacher +ExamStaffTip: Please always specify a name that uniquely identifies the examiner/organiser/repsonsible university teacher! If there is a possibility that the name alone is ambiguous please also specify some additional information e.g. the professorial chair or the educational and research unit. +ExamStaffRequired: “Examiner/Responsible university teacher” must be specified +ExamExamOfficeSchools: Additional departments +ExamExamOfficeSchoolsTip: Exam offices of departments you specify here will also have full access to all results for this exam disregarding the individual participants' features of study. ExamOccurrenceStart: Exam starts @@ -1840,6 +1845,7 @@ ExamFormAutomaticFunctions: Automatic functions ExamFormCorrection: Correction ExamFormParts: Exam parts ExamFormMode: Exam design +ExamFormGrades: Exam achievements ExamModeFormNone: Not specified ExamModeFormCustom: Custom @@ -2838,4 +2844,4 @@ SystemExamOffice: Exam office SystemFaculty: Faculty member ChangelogItemFeature: Feature -ChangelogItemBugfix: Bugfix \ No newline at end of file +ChangelogItemBugfix: Bugfix diff --git a/models/exams.model b/models/exams.model index 95a5a50ab..7fbe1251d 100644 --- a/models/exams.model +++ b/models/exams.model @@ -18,6 +18,7 @@ Exam gradingMode ExamGradingMode description Html Maybe examMode ExamMode + staff Text Maybe UniqueExam course name ExamPart exam ExamId @@ -67,4 +68,8 @@ ExamCorrector ExamPartCorrector part ExamPartId corrector ExamCorrectorId - UniqueExamPartCorrector part corrector \ No newline at end of file + UniqueExamPartCorrector part corrector +ExamOfficeSchool + school SchoolId + exam ExamId + UniqueExamOfficeSchool exam school \ No newline at end of file diff --git a/src/Handler/Exam/Edit.hs b/src/Handler/Exam/Edit.hs index 16fcc6357..ff8046788 100644 --- a/src/Handler/Exam/Edit.hs +++ b/src/Handler/Exam/Edit.hs @@ -49,6 +49,7 @@ postEEditR tid ssh csh examn = do , examGradingMode = efGradingMode , examDescription = efDescription , examExamMode = efExamMode + , examStaff = efStaff } when (is _Nothing insertRes) $ do @@ -80,7 +81,6 @@ postEEditR tid ssh csh examn = do , examOccurrenceDescription = eofDescription } - pIds <- fmap catMaybes . forM (Set.toList efExamParts) $ traverse decrypt . epfId deleteWhere [ ExamPartExam ==. eId, ExamPartId /<-. pIds ] forM_ (Set.toList efExamParts) $ \case @@ -105,6 +105,8 @@ postEEditR tid ssh csh examn = do , examPartWeight = epfWeight } + deleteWhere [ ExamOfficeSchoolExam ==. eId ] + insertMany_ . map (flip ExamOfficeSchool eId) $ Set.toList efOfficeSchools let (invites, adds) = partitionEithers $ Set.toList efCorrectors diff --git a/src/Handler/Exam/Form.hs b/src/Handler/Exam/Form.hs index 666b5af2e..1fe31be33 100644 --- a/src/Handler/Exam/Form.hs +++ b/src/Handler/Exam/Form.hs @@ -28,7 +28,6 @@ import Text.Blaze.Html.Renderer.String (renderHtml) data ExamForm = ExamForm { efName :: ExamName , efDescription :: Maybe Html - , efGradingMode :: ExamGradingMode , efStart :: Maybe UTCTime , efEnd :: Maybe UTCTime , efVisibleFrom :: Maybe UTCTime @@ -43,6 +42,9 @@ data ExamForm = ExamForm , efBonusRule :: Maybe ExamBonusRule , efOccurrenceRule :: ExamOccurrenceRule , efExamMode :: ExamMode + , efGradingMode :: ExamGradingMode + , efOfficeSchools :: Set SchoolId + , efStaff :: Maybe Text , efCorrectors :: Set (Either UserEmail UserId) , efExamParts :: Set ExamPartForm } @@ -103,7 +105,6 @@ examForm template html = do flip (renderAForm FormStandard) html $ ExamForm <$> areq ciField (fslpI MsgExamName (mr MsgExamName) & setTooltip MsgExamNameTip) (efName <$> template) <*> aopt htmlField (fslI MsgExamDescription) (efDescription <$> template) - <*> apopt (selectField optionsFinite) (fslI MsgExamGradingMode & setTooltip MsgExamGradingModeTip) (efGradingMode <$> template <|> Just ExamGradingMixed) <* aformSection MsgExamFormTimes <*> aopt utcTimeField (fslpI MsgExamStart (mr MsgDate) & setTooltip MsgExamTimeTip) (efStart <$> template) <*> aopt utcTimeField (fslpI MsgExamEnd (mr MsgDate) & setTooltip MsgExamTimeTip) (efEnd <$> template) @@ -122,11 +123,39 @@ examForm template html = do <*> examOccurrenceRuleForm (efOccurrenceRule <$> template) <* aformSection MsgExamFormMode <*> examModeForm (efExamMode <$> template) + <* aformSection MsgExamFormGrades + <*> apopt (selectField optionsFinite) (fslI MsgExamGradingMode & setTooltip MsgExamGradingModeTip) (efGradingMode <$> template <|> Just ExamGradingMixed) + <*> officeSchoolsForm (efOfficeSchools <$> template) + <*> apreq' (textField & cfStrip) (fslpI MsgExamStaff (mr MsgExamStaff) & setTooltip MsgExamStaffTip) (efStaff <$> template) <* aformSection MsgExamFormCorrection <*> examCorrectorsForm (efCorrectors <$> template) <* aformSection MsgExamFormParts <*> examPartsForm (efExamParts <$> template) +officeSchoolsForm :: Maybe (Set SchoolId) -> AForm Handler (Set SchoolId) +officeSchoolsForm mPrev = wFormToAForm $ do + currentRoute <- fromMaybe (error "officeSchoolsForm called from 404-handler") <$> getCurrentRoute + + let + miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) + miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag + + miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([SchoolId] -> FormResult [SchoolId]) + miAdd' nudge submitView csrf = do + (schoolRes, addView) <- mpopt schoolField ("" & addName (nudge "school")) Nothing + let schoolRes' = schoolRes <&> \newDat oldDat -> FormSuccess (guardOn (newDat `notElem` oldDat) newDat) + return (schoolRes', $(widgetFile "exam/schoolMassInput/add")) + + miCell' :: SchoolId -> Widget + miCell' ssh = do + School{..} <- liftHandler . runDB $ getJust ssh + $(widgetFile "exam/schoolMassInput/cell") + + miLayout' :: MassInputLayout ListLength SchoolId () + miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "exam/schoolMassInput/layout") + + fmap Set.fromList <$> massInputAccumW miAdd' miCell' miButtonAction' miLayout' ("exam-schools" :: Text) (fslI MsgExamExamOfficeSchools & setTooltip MsgExamExamOfficeSchoolsTip) False (Set.toList <$> mPrev) + examCorrectorsForm :: Maybe (Set (Either UserEmail UserId)) -> AForm Handler (Set (Either UserEmail UserId)) examCorrectorsForm mPrev = wFormToAForm $ do MsgRenderer mr <- getMsgRenderer @@ -261,6 +290,7 @@ examFormTemplate (Entity eId Exam{..}) = do occurrences <- selectList [ ExamOccurrenceExam ==. eId ] [] correctors <- selectList [ ExamCorrectorExam ==. eId ] [] invitations <- Map.keysSet <$> sourceInvitationsF @ExamCorrector eId + extraSchools <- selectList [ ExamOfficeSchoolExam ==. eId ] [] examParts' <- forM examParts $ \(Entity pid part) -> (,) <$> encrypt pid <*> pure part occurrences' <- forM occurrences $ \(Entity oid occ) -> (,) <$> encrypt oid <*> pure occ @@ -308,13 +338,15 @@ examFormTemplate (Entity eId Exam{..}) = do return examCorrectorUser ] , efExamMode = examExamMode + , efOfficeSchools = Set.fromList $ examOfficeSchoolSchool . entityVal <$> extraSchools + , efStaff = examStaff } examTemplate :: CourseId -> DB (Maybe ExamForm) examTemplate cid = runMaybeT $ do newCourse <- MaybeT $ get cid - [(Entity _ oldCourse, Entity _ oldExam)] <- lift . E.select . E.from $ \(course `E.InnerJoin` exam) -> do + [(Entity _ oldCourse, Entity oldExamId oldExam)] <- lift . E.select . E.from $ \(course `E.InnerJoin` exam) -> do E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse E.where_ $ ( course E.^. CourseShorthand E.==. E.val (courseShorthand newCourse) E.||. course E.^. CourseName E.==. E.val (courseName newCourse) @@ -327,6 +359,8 @@ examTemplate cid = runMaybeT $ do E.limit 1 E.orderBy [ E.desc $ course E.^. CourseTerm, E.asc $ exam E.^. ExamVisibleFrom ] return (course, exam) + + extraSchools <- lift $ selectList [ ExamOfficeSchoolExam ==. oldExamId ] [] oldTerm <- MaybeT . get $ courseTerm oldCourse newTerm <- MaybeT . get $ courseTerm newCourse @@ -354,6 +388,8 @@ examTemplate cid = runMaybeT $ do , efExamParts = Set.empty , efCorrectors = Set.empty , efExamMode = examExamMode oldExam + , efStaff = examStaff oldExam + , efOfficeSchools = Set.fromList $ examOfficeSchoolSchool . entityVal <$> extraSchools } @@ -431,3 +467,6 @@ validateExam cId oldExam = do ] warnValidation MsgExamModeSchoolDiscouraged . not $ evalExamModeDNF schoolExamDiscouragedModes efExamMode + + unless (has (_Just . _examStaff . _Nothing) oldExam) $ + guardValidation MsgExamStaffRequired $ isn't _Nothing efStaff diff --git a/src/Handler/Exam/New.hs b/src/Handler/Exam/New.hs index 7b04df98a..6631977f8 100644 --- a/src/Handler/Exam/New.hs +++ b/src/Handler/Exam/New.hs @@ -50,6 +50,7 @@ postCExamNewR tid ssh csh = do , examPublicStatistics = efPublicStatistics , examDescription = efDescription , examExamMode = efExamMode + , examStaff = efStaff } whenIsJust insertRes $ \examid -> do insertMany_ @@ -74,6 +75,8 @@ postCExamNewR tid ssh csh = do examOccurrenceDescription = eofDescription ] + insertMany_ . map (flip ExamOfficeSchool examid) $ Set.toList efOfficeSchools + let (invites, adds) = partitionEithers $ Set.toList efCorrectors insertMany_ [ ExamCorrector{..} | let examCorrectorExam = examid diff --git a/src/Handler/Exam/Show.hs b/src/Handler/Exam/Show.hs index b90bde092..00584ff83 100644 --- a/src/Handler/Exam/Show.hs +++ b/src/Handler/Exam/Show.hs @@ -26,7 +26,7 @@ getEShowR tid ssh csh examn = do cTime <- liftIO getCurrentTime mUid <- maybeAuthId - (Entity eId Exam{..}, School{..}, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, bonus, occurrences, (registered, mayRegister), registeredCount, lecturerInfoShown) <- runDB $ do + (Entity eId Exam{..}, School{..}, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, bonus, occurrences, (registered, mayRegister), registeredCount, lecturerInfoShown, staffInfoShown, extraSchools) <- runDB $ do exam@(Entity eId Exam{..}) <- fetchExam tid ssh csh examn school <- getJust examCourse >>= belongsToJust courseSchool @@ -83,7 +83,14 @@ getEShowR tid ssh csh examn = do lecturerInfoShown <- hasReadAccessTo $ CExamR tid ssh csh examn EEditR - return (exam, school, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, bonus, occurrences, (registered, mayRegister), registeredCount, lecturerInfoShown) + staffInfoShown <- hasReadAccessTo $ CExamR tid ssh csh examn EGradesR + + extraSchools <- E.select . E.from $ \(school' `E.InnerJoin` examOfficeSchool) -> do + E.on $ school' E.^. SchoolId E.==. examOfficeSchool E.^. ExamOfficeSchoolSchool + E.where_ $ examOfficeSchool E.^. ExamOfficeSchoolExam E.==. E.val eId + return school' + + return (exam, school, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, bonus, occurrences, (registered, mayRegister), registeredCount, lecturerInfoShown, staffInfoShown, extraSchools) let occurrenceNamesShown = lecturerInfoShown partNumbersShown = lecturerInfoShown diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index a87f20b21..95d197cf9 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -1261,8 +1261,7 @@ mpreq :: (RenderMessage site (ValueRequired site), HandlerSite m ~ site, MonadHa -- Otherwise acts exactly like `mopt`. mpreq f fs@FieldSettings{..} mx = do mr <- getMessageRender - (res, fv) <- mopt f fs (Just <$> mx) - let fv' = fv { fvRequired = True } + (res, fv') <- mpreq' f fs $ Just <$> mx return $ case res of FormSuccess (Just res') -> (FormSuccess res', fv') @@ -1293,6 +1292,25 @@ wpreq :: (RenderMessage site (ValueRequired site), HandlerSite m ~ site, MonadHa wpreq f fs mx = mFormToWForm $ mpreq f fs mx +mpreq' :: (HandlerSite m ~ site, MonadHandler m) + => Field m a -> FieldSettings site -> Maybe (Maybe a) -> MForm m (FormResult (Maybe a), FieldView site) +-- ^ Pseudo required +-- +-- `FieldView` has `fvRequired` set to `True`. +-- Otherwise acts exactly like `mopt`. +mpreq' f fs mx = do + (res, fv) <- mopt f fs mx + return (res, fv { fvRequired = True }) + +apreq' :: (HandlerSite m ~ site, MonadHandler m) + => Field m a -> FieldSettings site -> Maybe (Maybe a) -> AForm m (Maybe a) +apreq' f fs mx = formToAForm $ over _2 pure <$> mpreq' f fs mx + +wpreq' :: (HandlerSite m ~ site, MonadHandler m) + => Field m a -> FieldSettings site -> Maybe (Maybe a) -> WForm m (FormResult (Maybe a)) +wpreq' f fs mx = mFormToWForm $ mpreq' f fs mx + + mpopt :: (RenderMessage site (ValueRequired site), HandlerSite m ~ site, MonadHandler m) => Field m a -> FieldSettings site -> Maybe a -> MForm m (FormResult a, FieldView site) -- ^ Pseudo optional diff --git a/templates/exam-show.hamlet b/templates/exam-show.hamlet index 040b3554a..8438a1835 100644 --- a/templates/exam-show.hamlet +++ b/templates/exam-show.hamlet @@ -94,6 +94,16 @@ $maybe desc <- examDescription $maybe closed <- examClosed
_{MsgExamClosed} ^{isVisible False}
^{formatTimeW SelFormatDateTime closed} + $maybe staff <- examStaff + $if staffInfoShown +
_{MsgExamStaff} ^{isVisible False} +
#{staff} + $if staffInfoShown && not (onull extraSchools) +
_{MsgExamExamOfficeSchools} ^{isVisible False} +
+