feat(allocations): table of allocation users
This commit is contained in:
Gregor Kleen
parent
aef7fad5d8
commit
2735d465eb
@ -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
|
||||
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
|
||||
1
routes
1
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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
196
src/Handler/Allocation/Users.hs
Normal file
196
src/Handler/Allocation/Users.hs
Normal file
@ -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
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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 --
|
||||
----------------------------
|
||||
|
||||
@ -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
|
||||
|
||||
@ -50,6 +50,7 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä
|
||||
| AuthTutorControl
|
||||
| AuthExamOffice
|
||||
| AuthEvaluation
|
||||
| AuthAllocationAdmin
|
||||
| AuthAllocationRegistered
|
||||
| AuthCourseRegistered
|
||||
| AuthTutorialRegistered
|
||||
|
||||
@ -219,6 +219,7 @@ makeLenses_ ''CourseUserExamOfficeOptOut
|
||||
makeLenses_ ''CourseNewsFile
|
||||
|
||||
makeLenses_ ''AllocationCourse
|
||||
makeLenses_ ''AllocationUser
|
||||
|
||||
makeLenses_ ''Tutorial
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user