164 lines
8.2 KiB
Haskell
164 lines
8.2 KiB
Haskell
module Handler.Submission.Correction
|
|
( getCorrectionR, postCorrectionR
|
|
, getCorrectionUserR
|
|
) where
|
|
|
|
import Import hiding (link)
|
|
-- import System.FilePath (takeFileName)
|
|
|
|
import Jobs
|
|
import Handler.Utils hiding (colSchool)
|
|
import Handler.Utils.Submission
|
|
|
|
import qualified Data.Text as Text
|
|
|
|
import qualified Control.Monad.State.Class as State
|
|
|
|
import qualified Database.Esqueleto as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
|
|
correctionData :: TermId -> SchoolId -> CourseShorthand -> SheetName -> _ -- CryptoFileNameSubmission -> _
|
|
correctionData tid ssh csh shn sub = E.select . E.from $ \((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) -> do
|
|
E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy
|
|
E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
|
|
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
|
|
E.where_ $ course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
E.&&. sheet E.^. SheetName E.==. E.val shn
|
|
E.&&. submission E.^. SubmissionId E.==. E.val sub
|
|
let filesCorrected = E.exists . E.from $ \(sFile1 `E.LeftOuterJoin` sFile2) -> do
|
|
E.on $ E.just (sFile1 E.^. SubmissionFileTitle) E.==. sFile2 E.?. SubmissionFileTitle
|
|
E.&&. E.just (sFile1 E.^. SubmissionFileSubmission) E.==. sFile2 E.?. SubmissionFileSubmission
|
|
E.&&. sFile1 E.^. SubmissionFileContent E.!=. E.joinV (sFile2 E.?. SubmissionFileContent)
|
|
E.&&. sFile1 E.^. SubmissionFileIsUpdate E.&&. E.maybe E.false E.not_ (sFile2 E.?. SubmissionFileIsUpdate)
|
|
E.where_ $ sFile1 E.^. SubmissionFileSubmission E.==. submission E.^. SubmissionId
|
|
E.&&. sFile2 E.?. SubmissionFileSubmission E.==. E.just (submission E.^. SubmissionId)
|
|
return (course, sheet, submission, corrector, filesCorrected)
|
|
|
|
getCorrectionR, getCorrectionUserR, postCorrectionR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
|
|
getCorrectionR tid ssh csh shn cid = do
|
|
mayPost <- isAuthorized (CSubmissionR tid ssh csh shn cid CorrectionR) True
|
|
bool getCorrectionUserR postCorrectionR (mayPost == Authorized) tid ssh csh shn cid
|
|
postCorrectionR tid ssh csh shn cid = do
|
|
sub <- decrypt cid
|
|
|
|
(results, isLecturer) <- runDB $ (,)
|
|
<$> correctionData tid ssh csh shn sub
|
|
<*> hasWriteAccessTo (CSheetR tid ssh csh shn SSubsR)
|
|
|
|
MsgRenderer mr <- getMsgRenderer
|
|
case results of
|
|
[(Entity cId Course{..}, Entity shId Sheet{..}, Entity _ subm@Submission{..}, corrector, E.Value filesCorrected)] -> do
|
|
let ratingComment = submissionRatingComment >>= (\c -> c <$ guard (not $ null c)) . Text.strip
|
|
pointsForm = case sheetType of
|
|
NotGraded
|
|
-> pure Nothing
|
|
(preview _grading -> Just PassBinary)
|
|
-> Just <$> apopt (convertField (bool 0 1) (/= 0) checkBoxField) (fslI MsgPassed) submissionRatingPoints
|
|
(preview _grading -> Just PassAlways)
|
|
-> Just <$> aforced (convertField (bool 0 1) (/= 0) checkBoxField) (fslI MsgPassed) 1
|
|
_otherwise
|
|
-> aopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType)
|
|
(fslpI MsgRatingPoints (mr MsgPointsPlaceholder) & setTooltip sheetType)
|
|
(Just submissionRatingPoints)
|
|
correctorForm
|
|
| not isLecturer = wFormToAForm $ pure . Just <$> requireAuthId
|
|
| otherwise = wFormToAForm $ do
|
|
let correctors = E.from $ \user -> do
|
|
let isCorrector = E.exists . E.from $ \sheetCorrector ->
|
|
E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. user E.^. UserId
|
|
E.&&. sheetCorrector E.^. SheetCorrectorSheet E.==. E.val shId
|
|
isLecturer' = E.exists . E.from $ \lecturer ->
|
|
E.where_ $ lecturer E.^. LecturerUser E.==. user E.^. UserId
|
|
E.&&. lecturer E.^. LecturerCourse E.==. E.val cId
|
|
E.where_ $ isCorrector E.||. isLecturer'
|
|
return user
|
|
wopt (selectField' (Just $ SomeMessage MsgSubmissionNoCorrector) $ userOptionsE correctors) (fslI MsgSubmissionCorrector & setTooltip MsgSubmissionCorrectorTip) (Just submissionRatingBy)
|
|
validateCorr = do
|
|
(now, ratingBy', rated, ratingPoints', ratingComment') <- State.get
|
|
mapM_ tellValidationError $ validateRating sheetType Rating'
|
|
{ ratingPoints = ratingPoints'
|
|
, ratingComment = ratingComment'
|
|
, ratingTime = guardOn rated now
|
|
, ratingDone = rated
|
|
}
|
|
guardValidation MsgSubmissionCannotBeRatedWithoutCorrector $ isn't _Nothing ratingBy' || not rated
|
|
|
|
((corrResult, corrForm'), corrEncoding) <- runFormPost . validateForm validateCorr . identifyForm FIDcorrection . renderAForm FormStandard $ (,,,,)
|
|
<$> wFormToAForm (pure <$> liftIO getCurrentTime)
|
|
<*> correctorForm
|
|
<*> apopt checkBoxField (fslI MsgRatingDone & setTooltip MsgRatingDoneTip) (Just $ submissionRatingDone Submission{..})
|
|
<*> pointsForm
|
|
<*> aopt (textareaField & isoField _Wrapped & cfStrip) (fslI MsgRatingComment) (Just submissionRatingComment)
|
|
let corrForm = wrapForm' BtnSave corrForm' def
|
|
{ formAction = Just . SomeRoute $ CSubmissionR tid ssh csh shn cid CorrectionR
|
|
, formEncoding = corrEncoding
|
|
}
|
|
|
|
((uploadResult, uploadForm'), uploadEncoding) <- runFormPost . identifyForm FIDcorrectionUpload . renderAForm FormStandard $
|
|
apopt (zipFileField True Nothing) (fslI MsgRatingFiles & setTooltip MsgRatingFilesTip) Nothing
|
|
let uploadForm = wrapForm uploadForm' def
|
|
{ formAction = Just . SomeRoute $ CSubmissionR tid ssh csh shn cid CorrectionR
|
|
, formEncoding = uploadEncoding
|
|
}
|
|
|
|
formResult corrResult $ \(now, ratingBy', rated, ratingPoints', ratingComment') -> do
|
|
runDBJobs $ do
|
|
update sub [ SubmissionRatingBy =. ratingBy'
|
|
, SubmissionRatingTime =. (now <$ guard rated)
|
|
, SubmissionRatingPoints =. ratingPoints'
|
|
, SubmissionRatingComment =. ratingComment'
|
|
]
|
|
|
|
when (rated && is _Nothing submissionRatingTime) $ do
|
|
$logDebugS "CorrectionR" [st|Rated #{tshow sub}|]
|
|
queueDBJob . JobQueueNotification $ NotificationSubmissionRated sub
|
|
|
|
addMessageI Success $ if
|
|
| rated -> MsgRatingUpdated
|
|
| is _Nothing ratingComment'
|
|
, is _Nothing ratingPoints'
|
|
, is _Nothing ratingBy' -> MsgRatingDeleted
|
|
| is _Nothing ratingComment'
|
|
, is _Nothing ratingPoints' -> MsgCorrectorUpdated
|
|
| otherwise -> MsgRatingDraftUpdated
|
|
redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
|
|
|
|
formResult uploadResult $ \fileUploads -> do
|
|
uid <- maybeAuthId
|
|
|
|
res <- msgSubmissionErrors . runDBJobs . runConduit $ transPipe (lift . lift) fileUploads .| extractRatingsMsg .| sinkSubmission uid (Right sub) True
|
|
|
|
when (is _Just res) $ do
|
|
addMessageI Success MsgRatingFilesUpdated
|
|
redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
|
|
|
|
let heading = MsgCorrectionHead tid ssh csh shn cid
|
|
headingWgt = [whamlet|
|
|
$newline never
|
|
_{heading}
|
|
$if not (submissionRatingDone subm)
|
|
\ ^{isVisibleWidget False}
|
|
|]
|
|
siteLayout headingWgt $ do
|
|
setTitleI heading
|
|
let userCorrection = $(widgetFile "correction-user")
|
|
$(widgetFile "correction")
|
|
_ -> notFound
|
|
|
|
|
|
getCorrectionUserR tid ssh csh shn cid = do
|
|
|
|
|
|
sub <- decrypt cid
|
|
|
|
results <- runDB $ correctionData tid ssh csh shn sub
|
|
|
|
case results of
|
|
[(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector@(Just _), E.Value filesCorrected)] ->
|
|
let ratingComment = assertM (not . null) $ Text.strip <$> submissionRatingComment
|
|
in defaultLayout $(widgetFile "correction-user")
|
|
_ -> notFound
|