fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'master' of gitlab.cip.ifi.lmu.de:jost/UniWorX

Browse Source
This commit is contained in:
Steffen Jost 2019-06-26 12:12:30 +02:00
commit a4a3c14f9d
5 changed files with 44 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
messages/uniworx/de.msg
View File

@ -474,6 +474,7 @@ RatingNegative: Bewertungspunkte dürfen nicht negativ sein
RatingExceedsMax: Bewertung übersteigt die erlaubte Maximalpunktzahl
RatingNotExpected: Keine Bewertungen erlaubt
RatingBinaryExpected: Bewertung muss 0 (=durchgefallen) oder 1 (=bestanden) sein
RatingPointsRequired: Bewertung erfordert für dieses Blatt eine Punktzahl
SubmissionSinkExceptionDuplicateFileTitle file@FilePath: Dateiname #{show file} kommt mehrfach im Zip-Archiv vor
SubmissionSinkExceptionDuplicateRating: Mehr als eine Bewertung gefunden.

66
src/Handler/Corrections.hs
View File

@ -710,12 +710,12 @@ postCorrectionR tid ssh csh shn cid = do
results <- runDB $ correctionData tid ssh csh shn sub
case results of
[(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector)] -> do
[(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ subm@Submission{..}, corrector)] -> do
let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c))
pointsForm = case sheetType of
NotGraded -> pure Nothing
_otherwise -> aopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType)
(fslpI MsgRatingPoints "Punktezahl")
(fslpI MsgRatingPoints "Punktezahl" & setTooltip sheetType)
(Just submissionRatingPoints)
((corrResult, corrForm'), corrEncoding) <- runFormPost . identifyForm FIDcorrection . renderAForm FormStandard $ (,,)
@ -734,22 +734,20 @@ postCorrectionR tid ssh csh shn cid = do
, formEncoding = uploadEncoding
}
case corrResult of
FormMissing -> return ()
FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
FormSuccess (rated, ratingPoints', ratingComment') -> do
uid <- liftHandlerT requireAuthId
now <- liftIO getCurrentTime
formResult corrResult $ \(rated, ratingPoints', ratingComment') -> do
uid <- liftHandlerT requireAuthId
now <- liftIO getCurrentTime
if
| errs <- validateRating sheetType Rating'
{ ratingPoints = ratingPoints'
, ratingComment = ratingComment'
, ratingTime = (now <$ guard rated)
}
, not $ null errs
-> mapM_ (addMessageI Error) errs
| otherwise -> runDBJobs $ do
if
| errs <- validateRating sheetType Rating'
{ ratingPoints = ratingPoints'
, ratingComment = ratingComment'
, ratingTime = (now <$ guard rated)
}
, not $ null errs
-> mapM_ (addMessageI Error) errs
| otherwise -> do
runDBJobs $ do
update sub [ SubmissionRatingBy =. Just uid
, SubmissionRatingTime =. (now <$ guard rated)
, SubmissionRatingPoints =. ratingPoints'
@ -761,25 +759,29 @@ postCorrectionR tid ssh csh shn cid = do
when (rated && isNothing submissionRatingTime) $ do
$logDebugS "CorrectionR" [st|Rated #{tshow sub}|]
queueDBJob . JobQueueNotification $ NotificationSubmissionRated sub
redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
case uploadResult of
FormMissing -> return ()
FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
FormSuccess fileUploads -> do
uid <- requireAuthId
res <- msgSubmissionErrors . runDBJobs . runConduit $ transPipe (lift . lift) fileUploads .| extractRatingsMsg .| sinkSubmission uid (Right sub) True
case res of
Nothing -> return () -- ErrorMessages are already added by msgSubmissionErrors
(Just _) -> do
addMessageI Success MsgRatingFilesUpdated
redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
formResult uploadResult $ \fileUploads -> do
uid <- requireAuthId
res <- msgSubmissionErrors . runDBJobs . runConduit $ transPipe (lift . lift) fileUploads .| extractRatingsMsg .| sinkSubmission uid (Right sub) True
case res of
Nothing -> return () -- ErrorMessages are already added by msgSubmissionErrors
(Just _) -> do
addMessageI Success MsgRatingFilesUpdated
redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
mr <- getMessageRender
let sheetTypeDesc = mr sheetType
defaultLayout $ do
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

7
src/Handler/Utils/Rating.hs
View File

@ -56,7 +56,7 @@ instance Pretty SheetGrading where
validateRating :: SheetType -> Rating' -> [RatingException]
validateRating ratingSheetType Rating'{ratingPoints=Just rp, ..}
validateRating ratingSheetType Rating'{ ratingPoints=Just rp, .. }
| rp < 0
= [RatingNegative]
| NotGraded <- ratingSheetType
@ -67,6 +67,11 @@ validateRating ratingSheetType Rating'{ratingPoints=Just rp, ..}
| (Just PassBinary) <- ratingSheetType ^? _grading
, not (rp == 0 || rp == 1)
= [RatingBinaryExpected]
validateRating ratingSheetType Rating'{ .. }
| has _grading ratingSheetType
, is _Nothing ratingPoints
, isn't _Nothing ratingTime
= [RatingPointsRequired]
validateRating _ _ = []
getRating :: SubmissionId -> YesodDB UniWorX (Maybe Rating)

1
src/Model/Rating.hs
View File

@ -31,6 +31,7 @@ data RatingException = RatingNotUnicode UnicodeException -- ^ Rating failed to p
| RatingExceedsMax -- ^ Rating point must not exceed maximum points
| RatingNotExpected -- ^ Rating not expected
| RatingBinaryExpected -- ^ Rating must be 0 or 1
| RatingPointsRequired -- ^ Rating without points for sheet that requires there to be points
deriving (Show, Eq, Generic, Typeable)
instance Exception RatingException

4
templates/default-layout.lucius
View File

@ -502,7 +502,7 @@ ul.list--inline {
@media (min-width: 768px) {
.deflist {
grid-template-columns: max-content minmax(auto, max-content);
grid-template-columns: max-content minmax(0, max-content);
.deflist {
margin-top: -10px;
@ -580,7 +580,7 @@ section {
justify-content: center;
}
}
.form-group__input > .notification {
margin: 0;
}