121 lines
5.3 KiB
Haskell
121 lines
5.3 KiB
Haskell
module Handler.Exam.Show
|
|
( getEShowR
|
|
) where
|
|
|
|
import Import
|
|
import Handler.Exam.Register
|
|
|
|
import Data.Map ((!?))
|
|
import qualified Data.Map as Map
|
|
|
|
import qualified Database.Esqueleto 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 _ Exam{..}, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, bonus, occurrences, (registered, mayRegister), lecturerInfoShown) <- runDB $ do
|
|
exam@(Entity eId Exam{..}) <- fetchExam tid ssh csh examn
|
|
|
|
let examVisible = NTop (Just cTime) >= NTop examVisibleFrom
|
|
|
|
let gradingVisible = NTop (Just cTime) >= NTop examFinished
|
|
gradingShown <- or2M (return gradingVisible) . hasReadAccessTo $ CExamR tid ssh csh examn EEditR
|
|
|
|
let occurrenceAssignmentsVisible = NTop (Just cTime) >= NTop examPublishOccurrenceAssignments
|
|
occurrenceAssignmentsShown <- or2M (return occurrenceAssignmentsVisible) . hasReadAccessTo $ CExamR tid ssh csh examn EEditR
|
|
|
|
examParts <- sortOn (view $ _entityVal . _examPartNumber) <$> selectList [ ExamPartExam ==. eId ] [ Asc ExamPartName ]
|
|
|
|
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 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
|
|
E.orderBy [E.desc registered, E.asc $ examOccurrence E.^. ExamOccurrenceStart, E.asc $ examOccurrence E.^. ExamOccurrenceRoom]
|
|
return (examOccurrence, registered)
|
|
|
|
let occurrences = map (over _2 E.unValue) occurrencesRaw
|
|
|
|
registered <- for mUid $ existsBy . UniqueExamRegistration eId
|
|
mayRegister <- (== Authorized) <$> evalAccessDB (CExamR tid ssh csh examName ERegisterR) True
|
|
|
|
lecturerInfoShown <- hasReadAccessTo $ CExamR tid ssh csh examn EEditR
|
|
|
|
return (exam, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, bonus, occurrences, (registered, mayRegister), lecturerInfoShown)
|
|
|
|
let occurrenceNamesShown = lecturerInfoShown
|
|
partNumbersShown = lecturerInfoShown
|
|
examClosedShown = lecturerInfoShown
|
|
|
|
sumMaxPoints = sum [ fromRational examPartWeight * mPoints | Entity _ ExamPart{..} <- examParts, let Just mPoints = examPartMaxPoints ]
|
|
sumPoints = getSum <$> foldMap (fmap Sum . examPartResultResult . entityVal) results
|
|
|
|
noBonus = fromMaybe False $ do
|
|
guardM $ bonusOnlyPassed <$> examBonusRule
|
|
return . fromMaybe True $ result ^? _Just . _entityVal . _examResultResult . _examResult . passingGrade . _Wrapped . to not
|
|
|
|
|
|
let examTimes = all (\(Entity _ ExamOccurrence{..}, _) -> Just examOccurrenceStart == examStart && examOccurrenceEnd == examEnd) occurrences
|
|
registerWidget
|
|
| Just isRegistered <- registered
|
|
, mayRegister = Just $ do
|
|
(examRegisterForm, examRegisterEnctype) <- liftHandler . generateFormPost . buttonForm' $ bool [BtnExamRegister] [BtnExamDeregister] isRegistered
|
|
[whamlet|
|
|
<p>
|
|
$if isRegistered
|
|
_{MsgExamRegistered}
|
|
$else
|
|
_{MsgExamNotRegistered}
|
|
|]
|
|
wrapForm examRegisterForm def
|
|
{ formAction = Just . SomeRoute $ CExamR tid ssh csh examName ERegisterR
|
|
, formEncoding = examRegisterEnctype
|
|
, formSubmit = FormNoSubmit
|
|
}
|
|
| fromMaybe False registered = Just [whamlet|_{MsgExamRegistered}|]
|
|
| otherwise = Nothing
|
|
|
|
showMaxPoints = any (has $ _entityVal . _examPartMaxPoints . _Just) examParts
|
|
showAchievedPoints = not $ null results
|
|
|
|
let heading = prependCourseTitle tid ssh csh $ CI.original examName
|
|
|
|
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")
|
|
$(widgetFile "exam-show")
|