diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index d8ef3d1de..092ef2538 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -406,6 +406,7 @@ UnauthorizedExamOffice: Sie sind nicht mit Prüfungsverwaltung beauftragt. UnauthorizedExamExamOffice: Es existieren keine Prüfungsergebnisse für Nutzer, für die Sie mit der Prüfungsverwaltung beauftragt sind. UnauthorizedExternalExamExamOffice: Es existieren keine Prüfungsergebnisse für Nutzer, für die Sie mit der Prüfungsverwaltung beauftragt sind. UnauthorizedEvaluation: Sie sind nicht mit der Kursumfragenverwaltung beauftragt. +UnauthorizedAllocationAdmin: Sie sind nicht mit der Administration von Zentralanmeldungen beauftragt. UnauthorizedSchoolLecturer: Sie sind nicht als Veranstalter für dieses Institut eingetragen. UnauthorizedLecturer: Sie sind nicht als Veranstalter für diese Veranstaltung eingetragen. UnauthorizedAllocationLecturer: Sie sind nicht als Veranstalter für eine Veranstaltung dieser Zentralanmeldung eingetragen. @@ -1013,6 +1014,7 @@ NotificationTriggerKindEvaluation: Für Vorlesungsumfragen NotificationTriggerKindAllocationStaff: Für Zentralanmeldungen (Dozenten) NotificationTriggerKindAllocationParticipant: Für Zentralanmeldungen NotificationTriggerKindSubmissionUser: Für Mitabgebende einer Übungsblatt-Abgabe +NotificationTriggerKindAllocationAdmin: Für Administratoren von Zentralanmeldungen CorrCreate: Abgaben registrieren UnknownPseudonymWord pseudonymWord@Text: Unbekanntes Pseudonym-Wort "#{pseudonymWord}" @@ -1210,6 +1212,7 @@ MenuExternalExamNew: Neue externe Prüfung MenuExternalExamList: Externe Prüfungen MenuParticipantsList: Kursteilnehmerlisten MenuParticipantsIntersect: Überschneidung von Kursteilnehmern +MenuAllocationUsers: Bewerber BreadcrumbSubmissionFile: Datei BreadcrumbSubmissionUserInvite: Einladung zur Abgabe @@ -1275,6 +1278,7 @@ BreadcrumbParticipantsList: Kursteilnehmerlisten BreadcrumbParticipants: Kursteilnehmerliste BreadcrumbExamAutoOccurrence: Automatische Termin-/Raumverteilung BreadcrumbStorageKey: Lokalen Schlüssel generieren +BreadcrumbAllocationUsers: Bewerber ExternalExamEdit coursen@CourseName examn@ExamName: Bearbeiten: #{coursen}, #{examn} ExternalExamGrades coursen@CourseName examn@ExamName: Prüfungsleistungen: #{coursen}, #{examn} @@ -1289,6 +1293,7 @@ AuthTagFree: Seite ist universell zugänglich AuthTagAdmin: Nutzer ist Administrator AuthTagExamOffice: Nutzer ist mit Prüfungsverwaltung beauftragt AuthTagEvaluation: Nutzer ist mit Kursumfragenverwaltung beauftragt +AuthTagAllocationAdmin: Nutzer ist mit der Administration von Zentralanmeldungen beauftragt AuthTagToken: Nutzer präsentiert Authorisierungs-Token AuthTagNoEscalation: Nutzer-Rechte werden nicht auf fremde Institute ausgeweitet AuthTagDeprecated: Seite ist nicht überholt @@ -2003,6 +2008,7 @@ SchoolAdmin: Admin SchoolLecturer: Dozent SchoolEvaluation: Kursumfragenverwaltung SchoolExamOffice: Prüfungsverwaltung +SchoolAllocation: Zentralanmeldungs-Administration ApplicationEditTip: Während des Bewerbungszeitraums können eigene Bewerbungen beliebig angepasst und auch wieder zurückgezogen werden. @@ -2335,4 +2341,20 @@ InfoLecturerExams: Prüfungen InfoLecturerAllocations: Zentralanmeldungen ParticipantsIntersectCourseOption tid@TermId ssh@SchoolId coursen@CourseName: #{tid} - #{ssh} - #{coursen} -ParticipantsIntersectCourses: Kurse \ No newline at end of file +ParticipantsIntersectCourses: Kurse + +AllocationUsersTitle tid@TermId ssh@SchoolId ash@AllocationShorthand: #{tid}-#{ssh}-#{ash}: Bewerber +AllocationUsersApplied: Bewerbungen +AllocationUsersAssigned: Zuweisungen +AllocationUsersVetoed: Vetos +AllocationUsersRequested: Angefragte Plätze + +CsvColumnAllocationUserSurname: Nachname(n) des Bewerbers +CsvColumnAllocationUserFirstName: Vorname(n) des Bewerbers +CsvColumnAllocationUserName: Voller Name des Bewerbers +CsvColumnAllocationUserMatriculation: Matrikelnummer des Bewerber +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) +CsvColumnAllocationUserAssigned: Anzahl von Plätzen, die der Bewerber durch diese Zentralanmeldung bereits erhalten hat +AllocationUsersCsvName tid@TermId ssh@SchoolId ash@AllocationShorthand: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase ash}-bewerber \ No newline at end of file diff --git a/routes b/routes index c44925aa1..a3cb83bec 100644 --- a/routes +++ b/routes @@ -108,6 +108,7 @@ / AShowR GET !free /register ARegisterR POST !time /course/#CryptoUUIDCourse/apply AApplyR POST !timeANDallocation-registered + /users AUsersR GET POST !allocation-admin /participants ParticipantsListR GET !evaluation /participants/#TermId/#SchoolId ParticipantsR GET !evaluation diff --git a/src/Foundation.hs b/src/Foundation.hs index 12f430ab8..cbb198e44 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -424,7 +424,7 @@ tagAccessPredicate AuthExamOffice = APDB $ \mAuthId route _ -> case route of guardMExceptT isExamOffice (unauthorizedI MsgUnauthorizedExamOffice) return Authorized tagAccessPredicate AuthEvaluation = APDB $ \mAuthId route _ -> case route of - ParticipantsR tid ssh -> $cachedHereBinary (mAuthId, tid, ssh) . exceptT return return $ do + ParticipantsR _ ssh -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolEvaluation guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedEvaluation @@ -434,6 +434,17 @@ tagAccessPredicate AuthEvaluation = APDB $ \mAuthId route _ -> case route of isEvaluation <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolEvaluation] guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedEvaluation return Authorized +tagAccessPredicate AuthAllocationAdmin = APDB $ \mAuthId route _ -> case route of + AllocationR _ ssh _ _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolAllocation + guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedAllocationAdmin + return Authorized + _other -> $cachedHereBinary mAuthId . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isEvaluation <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAllocation] + guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedAllocationAdmin + return Authorized tagAccessPredicate AuthToken = APDB $ \mAuthId route isWrite -> exceptT return return $ lift . validateToken mAuthId route isWrite =<< askTokenUnsafe tagAccessPredicate AuthNoEscalation = APDB $ \mAuthId route _ -> case route of @@ -2004,18 +2015,20 @@ instance YesodBreadcrumbs UniWorX where return (CI.original $ unSchoolKey ssh, Just $ TermCourseListR tid) breadcrumb AllocationListR = i18nCrumb MsgAllocationListTitle $ Just NewsR - breadcrumb (AllocationR tid ssh ash AShowR) = maybeT (i18nCrumb MsgBreadcrumbAllocation $ Just AllocationListR) $ do - mr <- getMessageRender - Entity _ Allocation{allocationName} <- MaybeT . runDB . getBy $ TermSchoolAllocationShort tid ssh ash - return ([st|#{allocationName} (#{mr (ShortTermIdentifier (unTermKey tid))}, #{CI.original (unSchoolKey ssh)})|], Just $ AllocationListR) - breadcrumb (AllocationR tid ssh ash ARegisterR) = i18nCrumb MsgBreadcrumbAllocationRegister . Just $ AllocationR tid ssh ash AShowR - breadcrumb (AllocationR tid ssh ash (AApplyR cID)) = maybeT (i18nCrumb MsgBreadcrumbCourse . Just $ AllocationR tid ssh ash AShowR) $ do - cid <- decrypt cID - Course{..} <- hoist runDB $ do - aid <- MaybeT . getKeyBy $ TermSchoolAllocationShort tid ssh ash - guardM . lift $ exists [ AllocationCourseAllocation ==. aid, AllocationCourseCourse ==. cid ] - MaybeT $ get cid - return (CI.original courseName, Just $ AllocationR tid ssh ash AShowR) + breadcrumb (AllocationR tid ssh ash sRoute) = case sRoute of + AShowR -> maybeT (i18nCrumb MsgBreadcrumbAllocation $ Just AllocationListR) $ do + mr <- getMessageRender + Entity _ Allocation{allocationName} <- MaybeT . runDB . getBy $ TermSchoolAllocationShort tid ssh ash + return ([st|#{allocationName} (#{mr (ShortTermIdentifier (unTermKey tid))}, #{CI.original (unSchoolKey ssh)})|], Just $ AllocationListR) + ARegisterR -> i18nCrumb MsgBreadcrumbAllocationRegister . Just $ AllocationR tid ssh ash AShowR + AApplyR cID -> maybeT (i18nCrumb MsgBreadcrumbCourse . Just $ AllocationR tid ssh ash AShowR) $ do + cid <- decrypt cID + Course{..} <- hoist runDB $ do + aid <- MaybeT . getKeyBy $ TermSchoolAllocationShort tid ssh ash + guardM . lift $ exists [ AllocationCourseAllocation ==. aid, AllocationCourseCourse ==. cid ] + MaybeT $ get cid + return (CI.original courseName, Just $ AllocationR tid ssh ash AShowR) + AUsersR -> i18nCrumb MsgBreadcrumbAllocationUsers . Just $ AllocationR tid ssh ash AShowR breadcrumb ParticipantsListR = i18nCrumb MsgBreadcrumbParticipantsList $ Just CourseListR breadcrumb (ParticipantsR _ _) = i18nCrumb MsgBreadcrumbParticipants $ Just ParticipantsListR @@ -2984,7 +2997,7 @@ pageActions TermShowR = do , navChildren = participantsSecondary } ] -pageActions (AllocationR _tid _ssh _ash AShowR) = return +pageActions (AllocationR tid ssh ash AShowR) = return [ NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuAllocationInfo @@ -2996,6 +3009,17 @@ pageActions (AllocationR _tid _ssh _ash AShowR) = return } , navChildren = [] } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuAllocationUsers + , navRoute = AllocationR tid ssh ash AUsersR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } ] pageActions CourseListR = do participantsSecondary <- pageQuickActions NavQuickViewPageActionSecondary ParticipantsListR diff --git a/src/Handler/Allocation.hs b/src/Handler/Allocation.hs index 3cb35e7cc..b31ba58db 100644 --- a/src/Handler/Allocation.hs +++ b/src/Handler/Allocation.hs @@ -7,3 +7,4 @@ import Handler.Allocation.Show as Handler.Allocation import Handler.Allocation.Application as Handler.Allocation import Handler.Allocation.Register as Handler.Allocation import Handler.Allocation.List as Handler.Allocation +import Handler.Allocation.Users as Handler.Allocation diff --git a/src/Handler/Allocation/Users.hs b/src/Handler/Allocation/Users.hs new file mode 100644 index 000000000..a7764decc --- /dev/null +++ b/src/Handler/Allocation/Users.hs @@ -0,0 +1,196 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + +module Handler.Allocation.Users + ( getAUsersR, postAUsersR + ) where + +import Import + +import Handler.Utils +import Handler.Utils.Allocation + +import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils.TH as E + +import qualified Data.Csv as Csv + + +type UserTableExpr = E.SqlExpr (Entity User) + `E.InnerJoin` E.SqlExpr (Entity AllocationUser) + +queryUser :: Getter UserTableExpr (E.SqlExpr (Entity User)) +queryUser = to $(E.sqlIJproj 2 1) + +queryAllocationUser :: Getter UserTableExpr (E.SqlExpr (Entity AllocationUser)) +queryAllocationUser = to $(E.sqlIJproj 2 2) + +queryAppliedCourses :: Getter UserTableExpr (E.SqlExpr (E.Value Int)) +queryAppliedCourses = queryAllocationUser . to queryAppliedCourses' + where queryAppliedCourses' allocationUser = E.subSelectCount . E.from $ \courseApplication -> + E.where_ $ courseApplication E.^. CourseApplicationUser E.==. allocationUser E.^. AllocationUserUser + E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.just (allocationUser E.^. AllocationUserAllocation) + +queryAssignedCourses :: Getter UserTableExpr (E.SqlExpr (E.Value Int)) +queryAssignedCourses = queryAllocationUser . to queryAssignedCourses' + where queryAssignedCourses' allocationUser = E.subSelectCount . E.from $ \courseParticipant -> + E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. allocationUser E.^. AllocationUserUser + E.&&. courseParticipant E.^. CourseParticipantAllocated E.==. E.just (allocationUser E.^. AllocationUserAllocation) + +queryVetoedCourses :: Getter UserTableExpr (E.SqlExpr (E.Value Int)) +queryVetoedCourses = queryAllocationUser . to queryVetoedCourses' + where queryVetoedCourses' allocationUser = E.subSelectCount . E.from $ \courseApplication -> do + E.where_ $ courseApplication E.^. CourseApplicationUser E.==. allocationUser E.^. AllocationUserUser + E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.just (allocationUser E.^. AllocationUserAllocation) + E.where_ $ courseApplication E.^. CourseApplicationRatingVeto + E.||. courseApplication E.^. CourseApplicationRatingPoints `E.in_` E.valList (map Just $ filter (view $ passingGrade . _Wrapped . to not) universeF) + + +type UserTableData = DBRow ( Entity User + , Entity AllocationUser + , Int -- ^ Applied + , Int -- ^ Assigned + , Int -- ^ Vetoed + ) + +resultUser :: Lens' UserTableData (Entity User) +resultUser = _dbrOutput . _1 + +resultAllocationUser :: Lens' UserTableData (Entity AllocationUser) +resultAllocationUser = _dbrOutput . _2 + +resultAppliedCourses, resultAssignedCourses, resultVetoedCourses :: Lens' UserTableData Int +resultAppliedCourses = _dbrOutput . _3 +resultAssignedCourses = _dbrOutput . _4 +resultVetoedCourses = _dbrOutput . _5 + + +data AllocationUserTableCsv = AllocationUserTableCsv + { csvAUserSurname :: Text + , csvAUserFirstName :: Text + , csvAUserName :: Text + , csvAUserMatriculation :: Maybe Text + , csvAUserRequested + , csvAUserApplied + , csvAUserVetos + , csvAUserAssigned :: Natural + } deriving (Generic) +makeLenses_ ''AllocationUserTableCsv + +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 + +instance CsvColumnsExplained AllocationUserTableCsv where + csvColumnsExplanations = genericCsvColumnsExplanations allocationUserTableCsvOptions $ mconcat + [ singletonMap 'csvAUserSurname MsgCsvColumnAllocationUserSurname + , singletonMap 'csvAUserFirstName MsgCsvColumnAllocationUserFirstName + , singletonMap 'csvAUserName MsgCsvColumnAllocationUserName + , singletonMap 'csvAUserMatriculation MsgCsvColumnAllocationUserMatriculation + , singletonMap 'csvAUserRequested MsgCsvColumnAllocationUserRequested + , singletonMap 'csvAUserApplied MsgCsvColumnAllocationUserApplied + , singletonMap 'csvAUserVetos MsgCsvColumnAllocationUserVetos + , singletonMap 'csvAUserAssigned MsgCsvColumnAllocationUserAssigned + ] + + +getAUsersR, postAUsersR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html +getAUsersR = postAUsersR +postAUsersR tid ssh ash = do + usersTable <- runDB $ do + Entity aId _ <- getBy404 $ TermSchoolAllocationShort tid ssh ash + now <- liftIO getCurrentTime + resultsDone <- (<= NTop (Just now)) . NTop <$> allocationDone aId + + csvName <- getMessageRender <*> pure (MsgAllocationUsersCsvName tid ssh ash) + + let + allocationUsersDBTable = DBTable{..} + where + dbtSQLQuery = runReaderT $ do + user <- view queryUser + allocationUser <- view queryAllocationUser + applied <- view queryAppliedCourses + assigned <- view queryAssignedCourses + vetoed <- view queryVetoedCourses + + lift $ do + E.on $ user E.^. UserId E.==. allocationUser E.^. AllocationUserUser + E.&&. allocationUser E.^. AllocationUserAllocation E.==. E.val aId + E.where_ $ applied E.>. E.val 0 + E.||. assigned E.>. E.val 0 + + return ( user + , allocationUser + , applied + , 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) + dbtColonnade :: Colonnade Sortable _ _ + dbtColonnade = mconcat + [ colUserDisplayName $ resultUser . _entityVal . $(multifocusL 2) _userDisplayName _userSurname + , colUserMatriculation $ resultUser . _entityVal . _userMatrikelnummer + , colAllocationRequested $ resultAllocationUser . _entityVal . _allocationUserTotalCourses + , colAllocationApplied resultAppliedCourses + , colAllocationVetoed resultVetoedCourses + , assignedHeated $ colAllocationAssigned resultAssignedCourses + ] + where + assignedHeated + | resultsDone = imapColonnade assignedHeated' + | otherwise = id + where + assignedHeated' res + = let maxAssign = min (res ^. resultAllocationUser . _entityVal . _allocationUserTotalCourses . to fromIntegral) + (res ^. resultAppliedCourses) + assigned = res ^. resultAssignedCourses + in cellAttrs <>~ [ ("class", "heated") + , ("style", [st|--hotness: #{tshow (heat maxAssign assigned)}|]) + ] + dbtSorting = mconcat + [ sortUserName' $ queryUser . $(multifocusG 2) (to (E.^. UserDisplayName)) (to (E.^. UserSurname)) + , sortUserMatriculation $ queryUser . (to (E.^. UserMatrikelnummer)) + , sortAllocationApplied queryAppliedCourses + , sortAllocationAssigned queryAssignedCourses + , sortAllocationRequested $ queryAllocationUser . (to (E.^. AllocationUserTotalCourses)) + , sortAllocationVetoed queryVetoedCourses + ] + dbtFilter = mconcat + [ fltrUserName' $ queryUser . (to (E.^. UserDisplayName)) + , fltrUserMatriculation $ queryUser . (to (E.^. UserMatrikelnummer)) + ] + dbtFilterUI = mconcat + [ fltrUserNameUI' + , fltrUserMatriculationUI + ] + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } + 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 (resultAllocationUser . _entityVal . _allocationUserTotalCourses) + <*> view (resultAppliedCourses . to fromIntegral) + <*> view (resultVetoedCourses . to fromIntegral) + <*> view (resultAssignedCourses . to fromIntegral) + dbtCsvDecode = Nothing + allocationUsersDBTableValidator = def + & defaultSorting [SortAscBy "user-matriculation"] + & defaultPagesize PagesizeAll + + dbTableWidget' allocationUsersDBTableValidator allocationUsersDBTable + + siteLayoutMsg MsgMenuAllocationUsers $ do + setTitleI $ MsgAllocationUsersTitle tid ssh ash + + usersTable diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index b2988b775..285517656 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -74,6 +74,7 @@ instance RenderMessage UniWorX NotificationTriggerKind where NTKFunctionary SchoolLecturer -> mr MsgNotificationTriggerKindLecturer NTKFunctionary SchoolExamOffice -> mr MsgNotificationTriggerKindExamOffice NTKFunctionary SchoolEvaluation -> mr MsgNotificationTriggerKindEvaluation + NTKFunctionary SchoolAllocation -> mr MsgNotificationTriggerKindAllocationAdmin where mr = renderMessage f ls diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index ea581a7cb..e63122ea4 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -784,6 +784,46 @@ fltrDegreeUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map Fil fltrDegreeUI mPrev = prismAForm (singletonFilter "degree") mPrev $ aopt textField (fslI MsgDegreeName) +----------------- +-- Allocations -- +----------------- + +colAllocationApplied :: OpticColonnade Int +colAllocationApplied resultApplied = Colonnade.singleton (fromSortable header) body + where + header = Sortable (Just "applied") (i18nCell MsgAllocationUsersApplied) + body = views resultApplied $ cell . toWidget . toMarkup + +sortAllocationApplied :: forall applied. PersistField applied => OpticSortColumn applied +sortAllocationApplied queryApplied = singletonMap "applied" . SortColumn $ view queryApplied + +colAllocationAssigned :: OpticColonnade Int +colAllocationAssigned resultAssigned = Colonnade.singleton (fromSortable header) body + where + header = Sortable (Just "assigned") (i18nCell MsgAllocationUsersAssigned) + body = views resultAssigned $ cell . toWidget . toMarkup + +sortAllocationAssigned :: forall assigned. PersistField assigned => OpticSortColumn assigned +sortAllocationAssigned queryAssigned = singletonMap "assigned" . SortColumn $ view queryAssigned + +colAllocationVetoed :: OpticColonnade Int +colAllocationVetoed resultVetoed = Colonnade.singleton (fromSortable header) body + where + header = Sortable (Just "vetoed") (i18nCell MsgAllocationUsersVetoed) + body = views resultVetoed $ cell . toWidget . toMarkup + +sortAllocationVetoed :: forall vetoed. PersistField vetoed => OpticSortColumn vetoed +sortAllocationVetoed queryVetoed = singletonMap "vetoed" . SortColumn $ view queryVetoed + +colAllocationRequested :: OpticColonnade Natural +colAllocationRequested resultRequested = Colonnade.singleton (fromSortable header) body + where + header = Sortable (Just "requested") (i18nCell MsgAllocationUsersRequested) + body = views resultRequested $ cell . toWidget . toMarkup + +sortAllocationRequested :: forall requested. PersistField requested => OpticSortColumn requested +sortAllocationRequested queryRequested = singletonMap "requested" . SortColumn $ view queryRequested + ---------------------------- -- Colonnade manipulation -- ---------------------------- diff --git a/src/Model/Types/School.hs b/src/Model/Types/School.hs index dcbb5ecc6..ef695831f 100644 --- a/src/Model/Types/School.hs +++ b/src/Model/Types/School.hs @@ -8,6 +8,7 @@ data SchoolFunction | SchoolLecturer | SchoolEvaluation | SchoolExamOffice + | SchoolAllocation deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) instance Universe SchoolFunction instance Finite SchoolFunction diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs index 3b5142bce..71e35fbdf 100644 --- a/src/Model/Types/Security.hs +++ b/src/Model/Types/Security.hs @@ -50,6 +50,7 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä | AuthTutorControl | AuthExamOffice | AuthEvaluation + | AuthAllocationAdmin | AuthAllocationRegistered | AuthCourseRegistered | AuthTutorialRegistered diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index af91720e8..fa9bc59b9 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -219,6 +219,7 @@ makeLenses_ ''CourseUserExamOfficeOptOut makeLenses_ ''CourseNewsFile makeLenses_ ''AllocationCourse +makeLenses_ ''AllocationUser makeLenses_ ''Tutorial