227 lines
12 KiB
Haskell
227 lines
12 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
|
|
--
|
|
-- 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
|
|
<p>
|
|
$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
|
|
<p>
|
|
$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")
|