341 lines
18 KiB
Haskell
341 lines
18 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
|
|
|
|
module Handler.Allocation.Users
|
|
( getAUsersR, postAUsersR
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Handler.Allocation.Accept
|
|
|
|
import Handler.Utils
|
|
import Handler.Utils.Allocation
|
|
import Handler.Utils.StudyFeatures
|
|
|
|
import qualified Database.Esqueleto as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
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)
|
|
|
|
import qualified Data.Conduit.Combinators as C
|
|
|
|
|
|
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.InnerJoin` allocationCourse) -> do
|
|
E.on $ allocationCourse E.^. AllocationCourseCourse E.==. courseApplication E.^. CourseApplicationCourse
|
|
E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.just (allocationCourse E.^. AllocationCourseAllocation)
|
|
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)
|
|
E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
|
|
|
|
queryVetoedCourses :: Getter UserTableExpr (E.SqlExpr (E.Value Int))
|
|
queryVetoedCourses = queryAllocationUser . to queryVetoedCourses'
|
|
where queryVetoedCourses' allocationUser = E.subSelectCount . E.from $ \(courseApplication `E.InnerJoin` allocationCourse) -> do
|
|
E.on $ allocationCourse E.^. AllocationCourseCourse E.==. courseApplication E.^. CourseApplicationCourse
|
|
E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.just (allocationCourse E.^. AllocationCourseAllocation)
|
|
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
|
|
, UserTableStudyFeatures
|
|
, Entity AllocationUser
|
|
, Int -- ^ Applied
|
|
, Int -- ^ Assigned
|
|
, Int -- ^ Vetoed
|
|
)
|
|
|
|
resultUser :: Lens' UserTableData (Entity User)
|
|
resultUser = _dbrOutput . _1
|
|
|
|
resultStudyFeatures :: Lens' UserTableData UserTableStudyFeatures
|
|
resultStudyFeatures = _dbrOutput . _2
|
|
|
|
resultAllocationUser :: Lens' UserTableData (Entity AllocationUser)
|
|
resultAllocationUser = _dbrOutput . _3
|
|
|
|
resultAppliedCourses, resultAssignedCourses, resultVetoedCourses :: Lens' UserTableData Int
|
|
resultAppliedCourses = _dbrOutput . _4
|
|
resultAssignedCourses = _dbrOutput . _5
|
|
resultVetoedCourses = _dbrOutput . _6
|
|
|
|
|
|
data AllocationUserTableCsv = AllocationUserTableCsv
|
|
{ csvAUserSurname :: Text
|
|
, csvAUserFirstName :: Text
|
|
, csvAUserName :: Text
|
|
, csvAUserMatriculation :: Maybe Text
|
|
, csvAUserStudyFeatures :: UserTableStudyFeatures
|
|
, csvAUserRequested
|
|
, csvAUserApplied
|
|
, csvAUserVetos
|
|
, csvAUserAssigned :: Natural
|
|
, csvAUserNewAssigned :: Maybe Natural
|
|
, csvAUserPriority :: Maybe AllocationPriority
|
|
} deriving (Generic)
|
|
makeLenses_ ''AllocationUserTableCsv
|
|
|
|
allocationUserTableCsvOptions :: Csv.Options
|
|
allocationUserTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 3}
|
|
|
|
instance Csv.ToNamedRecord AllocationUserTableCsv where
|
|
toNamedRecord AllocationUserTableCsv{..} = Csv.namedRecord $
|
|
[ "surname" Csv..= csvAUserSurname
|
|
, "first-name" Csv..= csvAUserFirstName
|
|
, "name" Csv..= csvAUserName
|
|
, "matriculation" Csv..= csvAUserMatriculation
|
|
, "study-features" Csv..= csvAUserStudyFeatures
|
|
, "requested" Csv..= csvAUserRequested
|
|
, "applied" Csv..= csvAUserApplied
|
|
, "vetos" Csv..= csvAUserVetos
|
|
, "assigned" Csv..= csvAUserAssigned
|
|
] ++
|
|
[ "new-assigned" Csv..= newAssigned
|
|
| newAssigned <- hoistMaybe csvAUserNewAssigned
|
|
] ++
|
|
[ "priority" Csv..= csvAUserPriority
|
|
]
|
|
|
|
instance CsvColumnsExplained AllocationUserTableCsv where
|
|
csvColumnsExplanations = genericCsvColumnsExplanations allocationUserTableCsvOptions $ mconcat
|
|
[ singletonMap 'csvAUserSurname MsgCsvColumnAllocationUserSurname
|
|
, singletonMap 'csvAUserFirstName MsgCsvColumnAllocationUserFirstName
|
|
, singletonMap 'csvAUserName MsgCsvColumnAllocationUserName
|
|
, singletonMap 'csvAUserMatriculation MsgCsvColumnAllocationUserMatriculation
|
|
, singletonMap 'csvAUserStudyFeatures MsgCsvColumnAllocationUserStudyFeatures
|
|
, singletonMap 'csvAUserRequested MsgCsvColumnAllocationUserRequested
|
|
, singletonMap 'csvAUserApplied MsgCsvColumnAllocationUserApplied
|
|
, singletonMap 'csvAUserVetos MsgCsvColumnAllocationUserVetos
|
|
, singletonMap 'csvAUserAssigned MsgCsvColumnAllocationUserAssigned
|
|
, singletonMap 'csvAUserNewAssigned MsgCsvColumnAllocationUserNewAssigned
|
|
, singletonMap 'csvAUserPriority MsgCsvColumnAllocationUserPriority
|
|
]
|
|
|
|
userTableCsvHeader :: Bool -> Csv.Header
|
|
userTableCsvHeader hasNewAssigned = Csv.header $
|
|
[ "surname"
|
|
, "first-name"
|
|
, "name"
|
|
, "matriculation"
|
|
, "study-features"
|
|
, "requested"
|
|
, "applied"
|
|
, "vetos"
|
|
, "assigned"
|
|
] ++
|
|
[ "new-assigned"
|
|
| hasNewAssigned
|
|
] ++
|
|
[ "priority"
|
|
]
|
|
|
|
|
|
getAUsersR, postAUsersR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html
|
|
getAUsersR = postAUsersR
|
|
postAUsersR tid ssh ash = do
|
|
(usersTable, acceptForm) <- runDB $ do
|
|
Entity aId _ <- getBy404 $ TermSchoolAllocationShort tid ssh ash
|
|
resultsDone <- is _Just <$> allocationStarted aId
|
|
allocMatching <- runMaybeT $ do
|
|
SessionDataAllocationResults allocMap <- MaybeT $ lookupSessionJson SessionAllocationResults
|
|
allocMatching <- fmap (view _4) . 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)
|
|
|
|
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 $ do
|
|
feats <- lift . allocationUserStudyFeatures aId =<< views _1 entityKey
|
|
(,,,,,)
|
|
<$> view _1 <*> pure feats <*> view _2 <*> view (_3 . _Value) <*> view (_4 . _Value) <*> view (_5 . _Value)
|
|
dbtColonnade :: Colonnade Sortable _ _
|
|
dbtColonnade = mconcat . catMaybes $
|
|
[ pure $ colUserDisplayName (resultUser . _entityVal . $(multifocusL 2) _userDisplayName _userSurname)
|
|
, pure $ colUserMatriculation (resultUser . _entityVal . _userMatrikelnummer)
|
|
, pure $ colStudyFeatures resultStudyFeatures
|
|
, pure $ colAllocationRequested (resultAllocationUser . _entityVal . _allocationUserTotalCourses)
|
|
, pure . coursesModalApplied $ colAllocationApplied resultAppliedCourses
|
|
, pure . coursesModalVetoed $ colAllocationVetoed resultVetoedCourses
|
|
, guardOn resultsDone . coursesModalAssigned . bool id (assignedHeated $ view resultAssignedCourses) resultsDone $ colAllocationAssigned resultAssignedCourses
|
|
, coursesModalNewAssigned <$> do
|
|
allocMatching' <- allocMatching
|
|
let newAssigned uid = maybe 0 olength $ allocMatching' !? uid
|
|
pure . assignedHeated (views (resultUser . _entityKey) newAssigned) . sortable (Just "new-assigned") (i18nCell MsgAllocationUserNewMatches) .
|
|
views (resultUser . _entityKey) $ cell . toWidget . toMarkup . newAssigned
|
|
, pure $ emptyOpticColonnade' emptyPriorityCell (resultAllocationUser . _entityVal . _allocationUserPriority . _Just) colAllocationPriority
|
|
]
|
|
where
|
|
emptyPriorityCell = addCellClass ("table__td--center" :: Text) . cell $
|
|
messageTooltip =<< messageIconI Error IconMissingAllocationPriority MsgAllocationMissingPrioritiesIgnored
|
|
assignedHeated fAssigned = imapColonnade assignedHeated'
|
|
where
|
|
assignedHeated' res
|
|
= let maxAssign = min (res ^. resultAllocationUser . _entityVal . _allocationUserTotalCourses . to fromIntegral)
|
|
(res ^. resultAppliedCourses)
|
|
assigned = fAssigned res
|
|
in cellAttrs <>~ [ ("class", "heated")
|
|
, ("style", [st|--hotness: #{tshow (coHeat 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
|
|
, courseApplication E.^. CourseApplicationRatingPoints
|
|
, E.just $ courseApplication E.^. CourseApplicationRatingVeto
|
|
, E.exists . E.from $ \allocationCourse ->
|
|
E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
|
|
E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId
|
|
)
|
|
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
|
|
, E.nothing
|
|
, E.nothing
|
|
, E.exists . E.from $ \allocationCourse ->
|
|
E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
|
|
E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId
|
|
)
|
|
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
|
|
, E.nothing
|
|
, E.nothing
|
|
, courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
|
|
)
|
|
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
|
|
, E.nothing
|
|
, E.nothing
|
|
, E.true
|
|
)
|
|
coursesModal :: (_ -> E.SqlQuery (E.SqlExpr (Entity Course), E.SqlExpr (E.Value (Maybe ExamGrade)), E.SqlExpr (E.Value (Maybe Bool)), E.SqlExpr (E.Value Bool))) -> _ -> _
|
|
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 -> let tooltipContent = $(widgetFile "table/cell/allocation-courses")
|
|
in $(widgetFile "widgets/tooltip_no-handle")
|
|
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)
|
|
, singletonMap "new-assigned" $
|
|
SortProjected . comparing $ (\uid -> maybe 0 olength $ Map.lookup uid =<< allocMatching) . view (resultUser . _entityKey)
|
|
]
|
|
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 = return DBTCsvEncode
|
|
{ dbtCsvExportForm = pure ()
|
|
, dbtCsvDoEncode = \() -> C.mapM $ \(_, row) -> flip runReaderT row $
|
|
AllocationUserTableCsv
|
|
<$> view (resultUser . _entityVal . _userSurname)
|
|
<*> view (resultUser . _entityVal . _userFirstName)
|
|
<*> view (resultUser . _entityVal . _userDisplayName)
|
|
<*> view (resultUser . _entityVal . _userMatrikelnummer)
|
|
<*> view resultStudyFeatures
|
|
<*> view (resultAllocationUser . _entityVal . _allocationUserTotalCourses)
|
|
<*> view (resultAppliedCourses . to fromIntegral)
|
|
<*> view (resultVetoedCourses . to fromIntegral)
|
|
<*> view (resultAssignedCourses . to fromIntegral)
|
|
<*> views (resultUser . _entityKey) (\uid -> maybe 0 (fromIntegral . olength) . Map.lookup uid <$> allocMatching)
|
|
<*> view (resultAllocationUser . _entityVal . _allocationUserPriority)
|
|
, dbtCsvName = unpack csvName
|
|
, dbtCsvNoExportData = Just id
|
|
, dbtCsvHeader = \_ -> return . userTableCsvHeader $ is _Just allocMatching
|
|
, dbtCsvExampleData = Nothing
|
|
}
|
|
dbtCsvDecode = Nothing
|
|
allocationUsersDBTableValidator = def
|
|
& defaultSorting [SortAscBy "priority", SortAscBy "user-matriculation"]
|
|
& defaultPagesize (PagesizeLimit 500)
|
|
|
|
usersTable <- dbTableDB' allocationUsersDBTableValidator allocationUsersDBTable
|
|
|
|
acceptForm <- allocationAcceptForm aId
|
|
|
|
return (usersTable, acceptForm)
|
|
|
|
acceptView <- for acceptForm $ \acceptForm' -> do
|
|
(acceptWgt, acceptEnctype) <- generateFormPost acceptForm'
|
|
return $ wrapForm' BtnAllocationAccept acceptWgt def
|
|
{ formAction = Just . SomeRoute $ AllocationR tid ssh ash AAcceptR
|
|
, formEncoding = acceptEnctype
|
|
}
|
|
|
|
siteLayoutMsg MsgMenuAllocationUsers $ do
|
|
setTitleI $ MsgAllocationUsersTitle tid ssh ash
|
|
|
|
$(widgetFile "allocation/users")
|