128 lines
5.1 KiB
Haskell
128 lines
5.1 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
module Handler.Exam.New
|
|
( getCExamNewR, postCExamNewR
|
|
) where
|
|
|
|
import Import
|
|
import Handler.Exam.Form
|
|
import Handler.Exam.CorrectorInvite
|
|
|
|
import qualified Data.Set as Set
|
|
|
|
import Handler.Utils
|
|
import Handler.Utils.Invitations
|
|
|
|
import Jobs.Queue
|
|
|
|
import qualified Data.Conduit.Combinators as C
|
|
|
|
|
|
getCExamNewR, postCExamNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
|
getCExamNewR = postCExamNewR
|
|
postCExamNewR tid ssh csh = do
|
|
(newExamAct, (newExamWidget, newExamEnctype)) <- runDBJobs $ do
|
|
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
|
course <- getEntity404 cid
|
|
template <- examTemplate cid
|
|
|
|
((newExamResult, newExamWidget), newExamEnctype) <- runFormPost . validateForm (validateExam cid Nothing) $ examForm course template
|
|
|
|
newExamAct <- formResultMaybe newExamResult $ \ExamForm{..} -> do
|
|
now <- liftIO getCurrentTime
|
|
|
|
examAuthorshipStatement <- traverse insertAuthorshipStatement efAuthorshipStatement
|
|
|
|
insertRes <- insertUnique Exam
|
|
{ examName = efName
|
|
, examCourse = cid
|
|
, examGradingRule = efGradingRule
|
|
, examBonusRule = efBonusRule
|
|
, examOccurrenceRule = efOccurrenceRule
|
|
, examExamOccurrenceMapping = Nothing
|
|
, examVisibleFrom = efVisibleFrom
|
|
, examRegisterFrom = efRegisterFrom
|
|
, examRegisterTo = efRegisterTo
|
|
, examDeregisterUntil = efDeregisterUntil
|
|
, examPublishOccurrenceAssignments = efPublishOccurrenceAssignments
|
|
, examStart = efStart
|
|
, examEnd = efEnd
|
|
, examFinished = efFinished
|
|
, examClosed = Nothing
|
|
, examGradingMode = efGradingMode
|
|
, examPublicStatistics = efPublicStatistics
|
|
, examDescription = efDescription
|
|
, examExamMode = efExamMode
|
|
, examStaff = efStaff
|
|
, examPartsFrom = efPartsFrom
|
|
, examAuthorshipStatement
|
|
}
|
|
whenIsJust insertRes $ \examid -> do
|
|
insertMany_
|
|
[ ExamPart{..}
|
|
| ExamPartForm{..} <- Set.toList efExamParts
|
|
, let examPartExam = examid
|
|
examPartNumber = epfNumber
|
|
examPartName = epfName
|
|
examPartMaxPoints = epfMaxPoints
|
|
examPartWeight = epfWeight
|
|
]
|
|
|
|
insertMany_
|
|
[ ExamOccurrence{..}
|
|
| ExamOccurrenceForm{..} <- Set.toList efOccurrences
|
|
, let examOccurrenceExam = examid
|
|
examOccurrenceName = eofName
|
|
examOccurrenceRoom = eofRoom
|
|
examOccurrenceRoomHidden = eofRoomHidden
|
|
examOccurrenceCapacity = eofCapacity
|
|
examOccurrenceStart = eofStart
|
|
examOccurrenceEnd = eofEnd
|
|
examOccurrenceDescription = eofDescription
|
|
]
|
|
|
|
insertMany_ [ ExamOfficeSchool ssh' examid | ssh' <- Set.toList efOfficeSchools ]
|
|
|
|
let (invites, adds) = partitionEithers $ Set.toList efCorrectors
|
|
insertMany_ [ ExamCorrector{..}
|
|
| let examCorrectorExam = examid
|
|
, examCorrectorUser <- adds
|
|
]
|
|
sinkInvitationsF examCorrectorInvitationConfig $ map (, examid, (InvDBDataExamCorrector, InvTokenDataExamCorrector)) invites
|
|
memcachedByInvalidate AuthCacheExamCorrectorList $ Proxy @(Set UserId)
|
|
|
|
let recordNoShow (Entity _ CourseParticipant{..}) = do
|
|
didRecord <- is _Just <$> insertUnique ExamResult
|
|
{ examResultExam = examid
|
|
, examResultUser = courseParticipantUser
|
|
, examResultResult = ExamNoShow
|
|
, examResultLastChanged = now
|
|
}
|
|
when didRecord $
|
|
audit $ TransactionExamResultEdit examid courseParticipantUser
|
|
runConduit $ selectSource [ CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantInactive True ] [] .| C.mapM_ recordNoShow
|
|
|
|
return . Just $ case insertRes of
|
|
Nothing -> addMessageI Error $ MsgExamEditExamNameTaken efName
|
|
Just _ -> do
|
|
addMessageI Success $ MsgExamCreated efName
|
|
redirect $ CourseR tid ssh csh CExamListR
|
|
|
|
return (newExamAct, (newExamWidget, newExamEnctype))
|
|
|
|
sequence_ newExamAct
|
|
|
|
let heading = prependCourseTitle tid ssh csh MsgExamNew
|
|
|
|
siteLayoutMsg heading $ do
|
|
setTitleI heading
|
|
let
|
|
newExamForm = wrapForm newExamWidget def
|
|
{ formMethod = POST
|
|
, formAction = Just . SomeRoute $ CourseR tid ssh csh CExamNewR
|
|
, formEncoding = newExamEnctype
|
|
}
|
|
$(widgetFile "exam-new")
|