feat(allocations): table of allocation users

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.
 
@@ -2336,3 +2342,19 @@ InfoLecturerAllocations: Zentralanmeldungen
 
 ParticipantsIntersectCourseOption tid@TermId ssh@SchoolId coursen@CourseName: #{tid} - #{ssh} - #{coursen}
 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

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

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
+  breadcrumb (AllocationR tid ssh ash sRoute) = case sRoute of
-    mr <- getMessageRender
+    AShowR      -> maybeT (i18nCrumb MsgBreadcrumbAllocation $ Just AllocationListR) $ do
-    Entity _ Allocation{allocationName} <- MaybeT . runDB . getBy $ TermSchoolAllocationShort tid ssh ash
+      mr <- getMessageRender
-    return ([st|#{allocationName} (#{mr (ShortTermIdentifier (unTermKey tid))}, #{CI.original (unSchoolKey ssh)})|], Just $ AllocationListR)
+      Entity _ Allocation{allocationName} <- MaybeT . runDB . getBy $ TermSchoolAllocationShort tid ssh ash
-  breadcrumb (AllocationR tid ssh ash ARegisterR) = i18nCrumb MsgBreadcrumbAllocationRegister . Just $ AllocationR tid ssh ash AShowR
+      return ([st|#{allocationName} (#{mr (ShortTermIdentifier (unTermKey tid))}, #{CI.original (unSchoolKey ssh)})|], Just $ AllocationListR)
-  breadcrumb (AllocationR tid ssh ash (AApplyR cID)) = maybeT (i18nCrumb MsgBreadcrumbCourse . Just $ AllocationR tid ssh ash AShowR) $ do
+    ARegisterR  -> i18nCrumb MsgBreadcrumbAllocationRegister . Just $ AllocationR tid ssh ash AShowR
-    cid <- decrypt cID
+    AApplyR cID -> maybeT (i18nCrumb MsgBreadcrumbCourse . Just $ AllocationR tid ssh ash AShowR) $ do
-    Course{..} <- hoist runDB $ do
+      cid <- decrypt cID
-      aid <- MaybeT . getKeyBy $ TermSchoolAllocationShort tid ssh ash 
+      Course{..} <- hoist runDB $ do
-      guardM . lift $ exists [ AllocationCourseAllocation ==. aid, AllocationCourseCourse ==. cid ]
+        aid <- MaybeT . getKeyBy $ TermSchoolAllocationShort tid ssh ash 
-      MaybeT $ get cid
+        guardM . lift $ exists [ AllocationCourseAllocation ==. aid, AllocationCourseCourse ==. cid ]
-    return (CI.original courseName, Just $ AllocationR tid ssh ash AShowR)
+        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

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

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

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
 

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 --
 ----------------------------

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

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

src/Utils/Lens.hs

@@ -219,6 +219,7 @@ makeLenses_ ''CourseUserExamOfficeOptOut
 makeLenses_ ''CourseNewsFile
 
 makeLenses_ ''AllocationCourse
+makeLenses_ ''AllocationUser
 
 makeLenses_ ''Tutorial