fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

feat(allocations): display new allocations in user table

Browse Source
This commit is contained in:
Gregor Kleen 2020-03-11 14:48:02 +01:00
parent 3422fd70a7
commit bb20062d9f
2 changed files with 28 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
messages/uniworx/de-de-formal.msg
View File

@ -2419,5 +2419,6 @@ AllocationUnmatchedCourses: Kurse ohne zugeteilte Teilnehmer
AllocationTime: Zeitpunkt der Vergabe AllocationTime: Zeitpunkt der Vergabe
AllocationRequestedPlaces: Angefragte Plätze AllocationRequestedPlaces: Angefragte Plätze
AllocationOfferedPlaces: Angebotene Plätze AllocationOfferedPlaces: Angebotene Plätze
AllocationUserNewMatches: Neue Zuteilungen
CourseOption tid@TermId ssh@SchoolId coursen@CourseName: #{tid} - #{ssh} - #{coursen} CourseOption tid@TermId ssh@SchoolId coursen@CourseName: #{tid} - #{ssh} - #{coursen}

39
src/Handler/Allocation/Users.hs
View File

@ -6,7 +6,7 @@ module Handler.Allocation.Users
import Import import Import
import Handler.Allocation.Accept (allocationAcceptForm, AllocationAcceptButton(..)) import Handler.Allocation.Accept
import Handler.Utils import Handler.Utils
import Handler.Utils.Allocation import Handler.Utils.Allocation
@ -16,6 +16,12 @@ import qualified Database.Esqueleto.Utils as E
import qualified Data.Csv as Csv import qualified Data.Csv as Csv
import Data.Map ((!?))
import qualified Data.Map as Map
import qualified Data.Set as Set
import Text.Blaze (toMarkup)
type UserTableExpr = E.SqlExpr (Entity User) type UserTableExpr = E.SqlExpr (Entity User)
`E.InnerJoin` E.SqlExpr (Entity AllocationUser) `E.InnerJoin` E.SqlExpr (Entity AllocationUser)
@ -108,6 +114,10 @@ postAUsersR tid ssh ash = do
(usersTable, acceptForm) <- runDB $ do (usersTable, acceptForm) <- runDB $ do
Entity aId _ <- getBy404 $ TermSchoolAllocationShort tid ssh ash Entity aId _ <- getBy404 $ TermSchoolAllocationShort tid ssh ash
resultsDone <- is _Just <$> allocationStarted aId resultsDone <- is _Just <$> allocationStarted aId
allocMatching <- runMaybeT $ do
SessionDataAllocationResults allocMap <- MaybeT $ lookupSessionJson SessionAllocationResults
allocMatching <- fmap (view _3) . hoistMaybe $ allocMap !? (tid, ssh, ash)
return $ Map.fromListWith (<>) [ (uid, opoint cid) | (uid, cid) <- Set.toList allocMatching ] :: _ (Map UserId (NonNull (Set CourseId)))
csvName <- getMessageRender <*> pure (MsgAllocationUsersCsvName tid ssh ash) csvName <- getMessageRender <*> pure (MsgAllocationUsersCsvName tid ssh ash)
@ -137,21 +147,23 @@ postAUsersR tid ssh ash = do
(,,,,) (,,,,)
<$> view _1 <*> view _2 <*> view (_3 . _Value) <*> view (_4 . _Value) <*> view (_5 . _Value) <$> view _1 <*> view _2 <*> view (_3 . _Value) <*> view (_4 . _Value) <*> view (_5 . _Value)
dbtColonnade :: Colonnade Sortable _ _ dbtColonnade :: Colonnade Sortable _ _
dbtColonnade = mconcat dbtColonnade = mconcat . catMaybes $
[ colUserDisplayName $ resultUser . _entityVal . $(multifocusL 2) _userDisplayName _userSurname [ pure $ colUserDisplayName (resultUser . _entityVal . $(multifocusL 2) _userDisplayName _userSurname)
, colUserMatriculation $ resultUser . _entityVal . _userMatrikelnummer , pure $ colUserMatriculation (resultUser . _entityVal . _userMatrikelnummer)
, colAllocationRequested $ resultAllocationUser . _entityVal . _allocationUserTotalCourses , pure $ colAllocationRequested (resultAllocationUser . _entityVal . _allocationUserTotalCourses)
, coursesModalApplied $ colAllocationApplied resultAppliedCourses , pure . coursesModalApplied $ colAllocationApplied resultAppliedCourses
, coursesModalVetoed $ colAllocationVetoed resultVetoedCourses , pure . coursesModalVetoed $ colAllocationVetoed resultVetoedCourses
, coursesModalAssigned . assignedHeated $ colAllocationAssigned resultAssignedCourses , guardOn resultsDone . coursesModalAssigned . bool id assignedHeated resultsDone $ colAllocationAssigned resultAssignedCourses
, emptyOpticColonnade' emptyPriorityCell (resultAllocationUser . _entityVal . _allocationUserPriority . _Just) colAllocationPriority , coursesModalNewAssigned . assignedHeated <$> do
allocMatching' <- allocMatching
pure . sortable Nothing (i18nCell MsgAllocationUserNewMatches) .
views (resultUser . _entityKey) $ \uid -> cell . toWidget . toMarkup . maybe 0 olength $ allocMatching' !? uid
, pure $ emptyOpticColonnade' emptyPriorityCell (resultAllocationUser . _entityVal . _allocationUserPriority . _Just) colAllocationPriority
] ]
where where
emptyPriorityCell = addCellClass ("table__td--center" :: Text) . cell $ emptyPriorityCell = addCellClass ("table__td--center" :: Text) . cell $
messageTooltip =<< messageIconI Error IconMissingAllocationPriority MsgAllocationMissingPrioritiesIgnored messageTooltip =<< messageIconI Error IconMissingAllocationPriority MsgAllocationMissingPrioritiesIgnored
assignedHeated assignedHeated = imapColonnade assignedHeated'
| resultsDone = imapColonnade assignedHeated'
| otherwise = id
where where
assignedHeated' res assignedHeated' res
= let maxAssign = min (res ^. resultAllocationUser . _entityVal . _allocationUserTotalCourses . to fromIntegral) = let maxAssign = min (res ^. resultAllocationUser . _entityVal . _allocationUserTotalCourses . to fromIntegral)
@ -179,6 +191,9 @@ postAUsersR tid ssh ash = do
E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val (res ^. resultUser . _entityKey) E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val (res ^. resultUser . _entityKey)
E.orderBy [E.asc $ courseParticipant E.^. CourseParticipantRegistration] E.orderBy [E.asc $ courseParticipant E.^. CourseParticipantRegistration]
return course return course
coursesModalNewAssigned = coursesModal $ \res -> E.from $ \course -> do
E.where_ $ course E.^. CourseId `E.in_` E.valList (maybe [] otoList $ Map.lookup (res ^. resultUser . _entityKey) =<< allocMatching)
return course
coursesModal courseSel = imapColonnade coursesModal' coursesModal courseSel = imapColonnade coursesModal'
where where
coursesModal' res innerCell = review dbCell . (innerCell ^. cellAttrs, ) $ do coursesModal' res innerCell = review dbCell . (innerCell ^. cellAttrs, ) $ do