ee2e504ffa
BREAKING CHANGE: influence of grades on allocation priority now relative when priorities are ordinal
236 lines
12 KiB
Haskell
236 lines
12 KiB
Haskell
{-# 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 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
|
|
, csvAUserPriority :: Maybe AllocationPriority
|
|
} 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
|
|
, singletonMap 'csvAUserPriority MsgCsvColumnAllocationUserPriority
|
|
]
|
|
|
|
|
|
getAUsersR, postAUsersR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html
|
|
getAUsersR = postAUsersR
|
|
postAUsersR tid ssh ash = do
|
|
(usersTable, missingPriorities) <- runDB $ do
|
|
Entity aId _ <- getBy404 $ TermSchoolAllocationShort tid ssh ash
|
|
now <- liftIO getCurrentTime
|
|
resultsDone <- (<= NTop (Just now)) . NTop <$> allocationDone aId
|
|
|
|
missingPriorities <- E.selectExists . E.from $ \allocationUser ->
|
|
E.where_ $ allocationUser E.^. AllocationUserAllocation E.==. E.val aId
|
|
E.&&. E.isNothing (allocationUser E.^. AllocationUserPriority)
|
|
|
|
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
|
|
, coursesModalApplied $ colAllocationApplied resultAppliedCourses
|
|
, coursesModalVetoed $ colAllocationVetoed resultVetoedCourses
|
|
, coursesModalAssigned . assignedHeated $ colAllocationAssigned resultAssignedCourses
|
|
, emptyOpticColonnade (resultAllocationUser . _entityVal . _allocationUserPriority . _Just) colAllocationPriority
|
|
]
|
|
where
|
|
assignedHeated
|
|
| resultsDone = imapColonnade assignedHeated'
|
|
| otherwise = id
|
|
where
|
|
assignedHeated' res
|
|
= let maxAssign = min (res ^. resultAllocationUser . _entityVal . _allocationUserTotalCourses . to fromIntegral)
|
|
(res ^. resultAppliedCourses)
|
|
assigned = maxAssign - res ^. resultAssignedCourses
|
|
in cellAttrs <>~ [ ("class", "heated")
|
|
, ("style", [st|--hotness: #{tshow (heat maxAssign assigned)}|])
|
|
]
|
|
coursesModalApplied = coursesModal $ \res -> E.from $ \(course `E.InnerJoin` courseApplication) -> do
|
|
E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse
|
|
E.where_ $ courseApplication E.^. CourseApplicationAllocation E.==. E.val (Just aId)
|
|
E.&&. courseApplication E.^. CourseApplicationUser E.==. E.val (res ^. resultUser . _entityKey)
|
|
E.orderBy [E.desc $ courseApplication E.^. CourseApplicationAllocationPriority]
|
|
return course
|
|
coursesModalVetoed = coursesModal $ \res -> E.from $ \(course `E.InnerJoin` courseApplication) -> do
|
|
E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse
|
|
E.where_ $ courseApplication E.^. CourseApplicationAllocation E.==. E.val (Just aId)
|
|
E.&&. courseApplication E.^. CourseApplicationUser E.==. E.val (res ^. resultUser . _entityKey)
|
|
E.where_ $ courseApplication E.^. CourseApplicationRatingVeto
|
|
E.||. courseApplication E.^. CourseApplicationRatingPoints `E.in_` E.valList (map Just $ filter (view $ passingGrade . _Wrapped . to not) universeF)
|
|
return course
|
|
coursesModalAssigned = coursesModal $ \res -> E.from $ \(course `E.InnerJoin` courseParticipant) -> do
|
|
E.on $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
|
|
E.&&. courseParticipant E.^. CourseParticipantAllocated E.==. E.val (Just aId)
|
|
E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val (res ^. resultUser . _entityKey)
|
|
E.orderBy [E.asc $ courseParticipant E.^. CourseParticipantRegistration]
|
|
return course
|
|
coursesModal courseSel = imapColonnade coursesModal'
|
|
where
|
|
coursesModal' res innerCell = review dbCell . (innerCell ^. cellAttrs, ) $ do
|
|
courses <- lift . E.select $ courseSel res
|
|
contents <- innerCell ^. cellContents
|
|
return $ if
|
|
| null courses -> contents
|
|
| otherwise -> $(widgetFile "table/cell/allocation-courses")
|
|
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
|
|
, sortAllocationPriority $ queryAllocationUser . (to (E.^. AllocationUserPriority))
|
|
]
|
|
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)
|
|
<*> view (resultAllocationUser . _entityVal . _allocationUserPriority)
|
|
dbtCsvDecode = Nothing
|
|
allocationUsersDBTableValidator = def
|
|
& defaultSorting [SortAscBy "priority", SortAscBy "user-matriculation"]
|
|
& defaultPagesize PagesizeAll
|
|
|
|
usersTable <- dbTableDB' allocationUsersDBTableValidator allocationUsersDBTable
|
|
return (usersTable, missingPriorities)
|
|
|
|
siteLayoutMsg MsgMenuAllocationUsers $ do
|
|
setTitleI $ MsgAllocationUsersTitle tid ssh ash
|
|
|
|
when missingPriorities $
|
|
notification NotificationBroad =<< messageIconI Warning IconMissingAllocationPriority MsgAllocationMissingPrioritiesIgnored
|
|
usersTable
|