176 lines
6.9 KiB
Haskell
176 lines
6.9 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
|
|
|
|
import qualified Database.Esqueleto.Legacy as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
|
|
data ExamEditException
|
|
= ExamEditExamNameTaken ExamName
|
|
| ExamEditWouldBreakSheetTypeReference
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
deriving anyclass (Exception)
|
|
|
|
embedRenderMessage ''UniWorX ''ExamEditException id
|
|
|
|
|
|
getEEditR, postEEditR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
|
|
getEEditR = postEEditR
|
|
postEEditR tid ssh csh examn = do
|
|
(template, (editExamAct, (editExamWidget, editExamEnctype))) <- runDBJobs $ do
|
|
(cid, exam@(Entity eId oldExam)) <- fetchCourseIdExam tid ssh csh examn
|
|
course <- getEntity404 cid
|
|
|
|
template <- examFormTemplate exam
|
|
|
|
((editExamResult, editExamWidget), editExamEnctype) <- runFormPost . validateForm (validateExam cid $ Just exam) . examForm course $ Just template
|
|
|
|
editExamAct <- formResultMaybe editExamResult $ \ExamForm{..} -> do
|
|
res <- trySql @ExamEditException $ do
|
|
examAuthorshipStatement <- traverse insertAuthorshipStatement efAuthorshipStatement
|
|
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
|
|
, examGradingMode = efGradingMode
|
|
, examDescription = efDescription
|
|
, examExamMode = efExamMode
|
|
, examStaff = efStaff
|
|
, examPartsFrom = efPartsFrom
|
|
, examAuthorshipStatement
|
|
}
|
|
|
|
when (is _Just insertRes) $
|
|
throwM $ ExamEditExamNameTaken efName
|
|
|
|
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
|
|
, examOccurrenceRoomHidden = eofRoomHidden
|
|
, 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
|
|
, examOccurrenceRoomHidden = eofRoomHidden
|
|
, examOccurrenceCapacity = eofCapacity
|
|
, examOccurrenceStart = eofStart
|
|
, examOccurrenceEnd = eofEnd
|
|
, examOccurrenceDescription = eofDescription
|
|
}
|
|
|
|
pIds <- fmap catMaybes . forM (Set.toList efExamParts) $ traverse decrypt . epfId
|
|
|
|
brokenRefs <- E.selectExists . E.from $ \examPart -> do
|
|
E.where_ $ examPart E.^. ExamPartExam E.==. E.val eId
|
|
E.&&. examPart E.^. ExamPartId `E.notIn` E.valList pIds
|
|
E.where_ . E.exists . E.from $ \sheet -> do
|
|
let
|
|
sheetTypeExamPart :: E.SqlExpr (E.Value (Maybe Value))
|
|
sheetTypeExamPart = sheet E.^. SheetType E.->. "exam-part"
|
|
examPartId' :: E.SqlExpr (E.Value Value)
|
|
examPartId' = E.explicitUnsafeCoerceSqlExprValue @Value "jsonb" . E.explicitUnsafeCoerceSqlExprValue @Text "text" $ examPart E.^. ExamPartId
|
|
E.where_ $ E.maybe E.false (E.==. examPartId') sheetTypeExamPart
|
|
|
|
when brokenRefs $
|
|
throwM ExamEditWouldBreakSheetTypeReference
|
|
|
|
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
|
|
}
|
|
|
|
deleteWhere [ ExamOfficeSchoolExam ==. eId ]
|
|
insertMany_ [ ExamOfficeSchool ssh' eId | ssh' <- Set.toList efOfficeSchools ]
|
|
|
|
let (invites, adds) = partitionEithers $ Set.toList efCorrectors
|
|
|
|
deleteWhere [ ExamCorrectorExam ==. eId ]
|
|
insertMany_ $ map (ExamCorrector eId) adds
|
|
memcachedByInvalidate AuthCacheExamCorrectorList $ Proxy @(Set UserId)
|
|
|
|
deleteWhere [ InvitationFor ==. invRef @ExamCorrector eId, InvitationEmail /<-. invites ]
|
|
sinkInvitationsF examCorrectorInvitationConfig $ map (, eId, (InvDBDataExamCorrector, InvTokenDataExamCorrector)) invites
|
|
|
|
return insertRes
|
|
|
|
return . Just $ case res of
|
|
Left exc -> addMessageI Error exc
|
|
Right _ -> do
|
|
addMessageI Success $ MsgExamEdited efName
|
|
redirect $ CExamR tid ssh csh efName EShowR
|
|
|
|
return (template, (editExamAct, (editExamWidget, editExamEnctype)))
|
|
|
|
sequence_ editExamAct
|
|
|
|
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")
|