{-# 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")