135 lines
5.0 KiB
Haskell
135 lines
5.0 KiB
Haskell
module Handler.Exam.Edit
|
|
( getEEditR, postEEditR
|
|
) where
|
|
|
|
import Import
|
|
import Handler.Exam.Form
|
|
import Handler.Exam.CorrectorInvite
|
|
|
|
import qualified Data.Set as Set
|
|
|
|
import Handler.Utils
|
|
import Handler.Utils.Exam
|
|
import Handler.Utils.Invitations
|
|
|
|
import Jobs.Queue
|
|
|
|
|
|
getEEditR, postEEditR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
|
|
getEEditR = postEEditR
|
|
postEEditR tid ssh csh examn = do
|
|
(cid, Entity eId oldExam, template) <- runDB $ do
|
|
(cid, exam) <- fetchCourseIdExam tid ssh csh examn
|
|
|
|
template <- examFormTemplate exam
|
|
|
|
return (cid, exam, template)
|
|
|
|
((editExamResult, editExamWidget), editExamEnctype) <- runFormPost . validateForm validateExam . examForm $ Just template
|
|
|
|
formResult editExamResult $ \ExamForm{..} -> do
|
|
insertRes <- runDBJobs $ do
|
|
insertRes <- myReplaceUnique eId Exam
|
|
{ examCourse = cid
|
|
, examName = efName
|
|
, examGradingRule = efGradingRule
|
|
, examBonusRule = efBonusRule
|
|
, examOccurrenceRule = efOccurrenceRule
|
|
, examExamOccurrenceMapping = examExamOccurrenceMapping oldExam
|
|
, examVisibleFrom = efVisibleFrom
|
|
, examRegisterFrom = efRegisterFrom
|
|
, examRegisterTo = efRegisterTo
|
|
, examDeregisterUntil = efDeregisterUntil
|
|
, examPublishOccurrenceAssignments = efPublishOccurrenceAssignments
|
|
, examStart = efStart
|
|
, examEnd = efEnd
|
|
, examFinished = efFinished
|
|
, examClosed = examClosed oldExam
|
|
, examPublicStatistics = efPublicStatistics
|
|
, examShowGrades = efShowGrades
|
|
, examDescription = efDescription
|
|
}
|
|
|
|
when (is _Nothing insertRes) $ do
|
|
occIds <- fmap catMaybes . forM (Set.toList efOccurrences) $ traverse decrypt . eofId
|
|
deleteWhere [ ExamOccurrenceExam ==. eId, ExamOccurrenceId /<-. occIds ]
|
|
forM_ (Set.toList efOccurrences) $ \case
|
|
ExamOccurrenceForm{ eofId = Nothing, .. } -> insert_
|
|
ExamOccurrence
|
|
{ examOccurrenceExam = eId
|
|
, examOccurrenceName = eofName
|
|
, examOccurrenceRoom = eofRoom
|
|
, examOccurrenceCapacity = eofCapacity
|
|
, examOccurrenceStart = eofStart
|
|
, examOccurrenceEnd = eofEnd
|
|
, examOccurrenceDescription = eofDescription
|
|
}
|
|
ExamOccurrenceForm{ .. } -> void . runMaybeT $ do
|
|
cID <- hoistMaybe eofId
|
|
eofId' <- decrypt cID
|
|
oldOcc <- MaybeT $ get eofId'
|
|
guard $ examOccurrenceExam oldOcc == eId
|
|
lift $ replace eofId' ExamOccurrence
|
|
{ examOccurrenceExam = eId
|
|
, examOccurrenceName = eofName
|
|
, examOccurrenceRoom = eofRoom
|
|
, examOccurrenceCapacity = eofCapacity
|
|
, examOccurrenceStart = eofStart
|
|
, examOccurrenceEnd = eofEnd
|
|
, examOccurrenceDescription = eofDescription
|
|
}
|
|
|
|
|
|
pIds <- fmap catMaybes . forM (Set.toList efExamParts) $ traverse decrypt . epfId
|
|
deleteWhere [ ExamPartExam ==. eId, ExamPartId /<-. pIds ]
|
|
forM_ (Set.toList efExamParts) $ \case
|
|
ExamPartForm{ epfId = Nothing, .. } -> insert_
|
|
ExamPart
|
|
{ examPartExam = eId
|
|
, examPartNumber = epfNumber
|
|
, examPartName = epfName
|
|
, examPartMaxPoints = epfMaxPoints
|
|
, examPartWeight = epfWeight
|
|
}
|
|
ExamPartForm{ .. } -> void . runMaybeT $ do
|
|
cID <- hoistMaybe epfId
|
|
epfId' <- decrypt cID
|
|
oldPart <- MaybeT $ get epfId'
|
|
guard $ examPartExam oldPart == eId
|
|
lift $ replace epfId' ExamPart
|
|
{ examPartExam = eId
|
|
, examPartNumber = epfNumber
|
|
, examPartName = epfName
|
|
, examPartMaxPoints = epfMaxPoints
|
|
, examPartWeight = epfWeight
|
|
}
|
|
|
|
|
|
let (invites, adds) = partitionEithers $ Set.toList efCorrectors
|
|
|
|
deleteWhere [ ExamCorrectorExam ==. eId ]
|
|
insertMany_ $ map (ExamCorrector eId) adds
|
|
|
|
deleteWhere [ InvitationFor ==. invRef @ExamCorrector eId, InvitationEmail /<-. invites ]
|
|
sinkInvitationsF examCorrectorInvitationConfig $ map (, eId, (InvDBDataExamCorrector, InvTokenDataExamCorrector)) invites
|
|
|
|
return insertRes
|
|
|
|
case insertRes of
|
|
Just _ -> addMessageI Error $ MsgExamNameTaken efName
|
|
Nothing -> do
|
|
addMessageI Success $ MsgExamEdited efName
|
|
redirect $ CExamR tid ssh csh efName EShowR
|
|
|
|
let heading = prependCourseTitle tid ssh csh . MsgExamEditHeading $ efName template
|
|
|
|
siteLayoutMsg heading $ do
|
|
setTitleI heading
|
|
let
|
|
editExamForm = wrapForm editExamWidget def
|
|
{ formMethod = POST
|
|
, formAction = Just . SomeRoute $ CExamR tid ssh csh examn EEditR
|
|
, formEncoding = editExamEnctype
|
|
}
|
|
$(widgetFile "exam-edit")
|