-- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Winnie Ros -- -- SPDX-License-Identifier: AGPL-3.0-or-later module Handler.Exam.Show ( getEShowR ) where import Import import Handler.Exam.Register import Handler.Exam.AutoOccurrence (examAutoOccurrenceCalculateWidget) import Handler.ExamOffice.Exam (examCloseWidget, examFinishWidget) import Data.Map ((!?)) import qualified Data.Map as Map import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import qualified Data.CaseInsensitive as CI import Handler.Utils import Handler.Utils.Exam getEShowR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html getEShowR tid ssh csh examn = do cTime <- liftIO getCurrentTime mUid <- maybeAuthId (Entity eId Exam{..}, School{..}, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, bonus, occurrences, (registered, mayRegister), registeredCount, lecturerInfoShown, staffInfoShown, extraSchools, (partsVisible, partsShown)) <- runDB $ do exam@(Entity eId Exam{..}) <- fetchExam tid ssh csh examn school <- getJust examCourse >>= belongsToJust courseSchool lecturerInfoShown <- hasReadAccessTo $ CExamR tid ssh csh examn EEditR let examVisible = NTop (Just cTime) >= NTop examVisibleFrom let gradingVisible = NTop (Just cTime) >= NTop examFinished gradingShown = gradingVisible || lecturerInfoShown let partsVisible = gradingVisible || NTop (Just cTime) >= NTop examPartsFrom partsShown = partsVisible || lecturerInfoShown let occurrenceAssignmentsVisible = NTop (Just cTime) >= NTop examPublishOccurrenceAssignments || examOccurrenceRule == ExamRoomFifo occurrenceAssignmentsShown = occurrenceAssignmentsVisible || lecturerInfoShown sheets <- selectList [ SheetCourse ==. examCourse ] [] let examPartSheets epId = do let sheets' = flip filter sheets $ \(Entity _ Sheet{..}) -> has (_examPart . re _SqlKey . only epId) sheetType flip filterM sheets' $ \(Entity _ Sheet{..}) -> hasReadAccessTo $ CSheetR tid ssh csh sheetName SShowR examParts <- fmap (sortOn . view $ _1 . _entityVal . _examPartNumber) $ selectList [ ExamPartExam ==. eId ] [ Asc ExamPartName ] >>= traverse (\ep@(Entity epId _) -> (ep,,) <$> encrypt @ExamPartId @UUID epId <*> examPartSheets epId) resultsRaw <- for mUid $ \uid -> E.select . E.from $ \examPartResult -> do E.where_ $ examPartResult E.^. ExamPartResultUser E.==. E.val uid E.&&. examPartResult E.^. ExamPartResultExamPart `E.in_` E.valList (map (views _1 entityKey) examParts) return examPartResult let results = maybe Map.empty (\rs -> Map.fromList [ (examPartResultExamPart, res) | res@(Entity _ ExamPartResult{..}) <- rs ]) resultsRaw result <- fmap join . for mUid $ getBy . UniqueExamResult eId bonus <- fmap join . for mUid $ getBy . UniqueExamBonus eId occurrencesRaw <- E.select . E.from $ \examOccurrence -> do E.where_ $ examOccurrence E.^. ExamOccurrenceExam E.==. E.val eId let registered | Just uid <- mUid = E.exists . E.from $ \examRegistration -> E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eId E.&&. examRegistration E.^. ExamRegistrationUser E.==. E.val uid E.&&. examRegistration E.^. ExamRegistrationOccurrence E.==. E.just (examOccurrence E.^. ExamOccurrenceId) | otherwise = E.false registeredCount :: E.SqlExpr (E.Value Int64) registeredCount = E.subSelectCount . E.from $ \examRegistration -> E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eId E.&&. examRegistration E.^. ExamRegistrationOccurrence E.==. E.just (examOccurrence E.^. ExamOccurrenceId) showRoom = maybe E.false (flip showExamOccurrenceRoom examOccurrence . E.val) mUid E.||. E.not_ (examOccurrence E.^. ExamOccurrenceRoomHidden) E.orderBy [E.desc registered, E.asc $ examOccurrence E.^. ExamOccurrenceStart, E.asc $ examOccurrence E.^. ExamOccurrenceRoom] return (examOccurrence, registered, registeredCount, showRoom) registeredCount <- fromIntegral <$> count [ ExamRegistrationExam ==. eId ] registered <- for mUid $ getBy . UniqueExamRegistration eId mayRegister <- if | examOccurrenceRule == ExamRoomFifo -> anyM occurrencesRaw $ \(Entity _ ExamOccurrence{..}, _, _, _) -> hasWriteAccessTo . CExamR tid ssh csh examName $ ERegisterOccR examOccurrenceName | otherwise -> hasWriteAccessTo $ CExamR tid ssh csh examName ERegisterR let occurrences = sortOn sortPred $ map (over _4 E.unValue . over _3 E.unValue . over _2 E.unValue) occurrencesRaw where sortPred (Entity _ ExamOccurrence{..}, registered', _, showRoom) = (Down $ registered' && not mayRegister, examOccurrenceStart, guardOn @Maybe showRoom examOccurrenceRoom) staffInfoShown <- hasReadAccessTo $ CExamR tid ssh csh examn EGradesR extraSchools <- E.select . E.from $ \(school' `E.InnerJoin` examOfficeSchool) -> do E.on $ school' E.^. SchoolId E.==. examOfficeSchool E.^. ExamOfficeSchoolSchool E.where_ $ examOfficeSchool E.^. ExamOfficeSchoolExam E.==. E.val eId return school' return (exam, school, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, bonus, occurrences, (registered, mayRegister), registeredCount, lecturerInfoShown, staffInfoShown, extraSchools, (partsVisible, partsShown)) let occurrenceNamesShown = lecturerInfoShown partNumbersShown = lecturerInfoShown examClosedShown = lecturerInfoShown && isn't _ExamCloseOnFinished' schoolExamCloseMode showCloseWidget = lecturerInfoShown showFinishWidget = lecturerInfoShown && is _Nothing examFinished showAutoOccurrenceCalculateWidget = lecturerInfoShown showRegisteredCount = lecturerInfoShown examFinishedMsg = if lecturerInfoShown then SomeMessage MsgExamFinished else SomeMessage MsgExamFinishedParticipant sumMaxPoints = sum [ fromRational examPartWeight * mPoints | (Entity _ ExamPart{..}, _, _) <- examParts, mPoints <- examPartMaxPoints ^.. _Just ] sumRegisteredCount = sumOf (folded . _3) occurrences noBonus = (Just True ==) $ do guardM $ bonusOnlyPassed <$> examBonusRule return $ Just False /= result ^? _Just . _entityVal . _examResultResult . _examResult . to (either id $ view passingGrade) . _Wrapped . to not sumPoints = fmap getSum . mconcat $ catMaybes [ Just $ foldMap (fmap Sum . examPartResultResult . entityVal) results , guard (not noBonus) *> fmap (pure . Sum . examBonusBonus . entityVal) bonus ] hasRegistration = orOf (folded . _2) occurrences mayRegister' <- fmap ((Map.!) . Map.fromList) . for (Nothing : map Just occurrences) $ \case Nothing -> fmap (Nothing, ) . hasWriteAccessTo $ CExamR tid ssh csh examName ERegisterR Just (Entity occId ExamOccurrence{..}, _, _, _) -> fmap (Just occId, ) . hasWriteAccessTo . CExamR tid ssh csh examName $ ERegisterOccR examOccurrenceName let examTimes = all (\(Entity _ ExamOccurrence{..}, _, _, _) -> Just examOccurrenceStart == examStart && examOccurrenceEnd == examEnd) occurrences examRoom = do (Entity _ primeOcc, _, _, _) <- occurrences ^? _head guard $ all (\(Entity _ occ, _, _, _) -> examOccurrenceRoom occ == examOccurrenceRoom primeOcc) occurrences guard $ andOf (folded . _4) occurrences examOccurrenceRoom primeOcc registerWidget mOcc | isRegistered <- is _Just $ join registered , examOccurrenceRule /= ExamRoomFifo || (isRegistered && not (orOf (folded . _2) occurrences)) , mayRegister' (entityKey <$> mOcc) = Just $ do (examRegisterForm, examRegisterEnctype) <- liftHandler . generateFormPost . buttonForm' $ bool [BtnExamRegister] [BtnExamDeregister] isRegistered [whamlet| $newline never

$if isRegistered _{MsgExamRegistered} $else _{MsgExamNotRegistered} |] wrapForm examRegisterForm def { formAction = Just . SomeRoute $ CExamR tid ssh csh examName ERegisterR , formEncoding = examRegisterEnctype , formSubmit = FormNoSubmit } | examOccurrenceRule == ExamRoomFifo , Just (Entity occId ExamOccurrence{..}) <- mOcc , isRegistered <- (== Just occId) $ examRegistrationOccurrence . entityVal =<< join registered , mayRegister' (Just occId) = Just $ do (examRegisterForm, examRegisterEnctype) <- liftHandler . generateFormPost . buttonForm' $ bool [bool BtnExamRegisterOccurrence BtnExamSwitchOccurrence . is _Just $ join registered] [BtnExamDeregister] isRegistered wrapForm examRegisterForm def { formAction = Just . SomeRoute . CExamR tid ssh csh examName $ ERegisterOccR examOccurrenceName , formEncoding = examRegisterEnctype , formSubmit = FormNoSubmit } | is _Nothing mOcc , is _Nothing registered = Just $ i18n MsgExamLoginToRegister | is _Nothing mOcc , isRegistered <- is _Just $ join registered = Just [whamlet| $newline never

$if isRegistered _{MsgExamRegistered} $else _{MsgExamNotRegistered} $if mayRegister ^{messageTooltip =<< messageI Info MsgExamRegisterForOccurrence} |] | otherwise = Nothing showMaxPoints = gradingShown && any (has $ _1 . _entityVal . _examPartMaxPoints . _Just) examParts showAchievedPoints = gradingShown && not (null results) showPartSheets = any (has $ _3 . folded) examParts showOccurrenceRegisterColumn = occurrenceAssignmentsShown || (mayRegister && examOccurrenceRule == ExamRoomFifo) markUnregisteredOccurrences mOcc = occurrenceAssignmentsShown && hasRegistration && isn't _Just (registerWidget mOcc) showOccurrenceMappingColumn = examOccurrenceRuleAutomatic examOccurrenceRule && occurrenceAssignmentsShown && is _Just examExamOccurrenceMapping closeWgt <- examCloseWidget (SomeRoute $ CExamR tid ssh csh examn EUsersR) eId finishWgt <- examFinishWidget (SomeRoute $ CExamR tid ssh csh examn EUsersR) eId let heading = prependCourseTitle tid ssh csh $ CI.original examName notificationDiscouragedExamMode <- runMaybeT $ do guard $ evalExamModeDNF schoolExamDiscouragedModes examExamMode guardM . lift . hasWriteAccessTo $ CExamR tid ssh csh examn EEditR return $ notification NotificationBroad =<< messageI Warning MsgExamModeSchoolDiscouraged siteLayoutMsg heading $ do setTitleI heading let gradingKeyW :: [Points] -> Widget gradingKeyW bounds = let boundWidgets :: [Widget] boundWidgets = toWidget . (pack :: String -> Text) . showFixed True <$> 0 : bounds grades :: [ExamGrade] grades = universeF in $(widgetFile "widgets/gradingKey") examBonusW :: ExamBonusRule -> Widget examBonusW bonusRule = $(widgetFile "widgets/bonusRule") occurrenceMapping :: ExamOccurrenceName -> Maybe Widget occurrenceMapping occName = examOccurrenceMappingDescriptionWidget <$> fmap examOccurrenceMappingRule examExamOccurrenceMapping <*> (examExamOccurrenceMapping >>= Map.lookup occName . examOccurrenceMappingMapping) notificationPersonalIdentification = notification NotificationBroad =<< messageIconI Info IconPersonalIdentification MsgExamShowIdentificationRequired $(widgetFile "exam-show")