diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index de26df378..16d99da8e 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -990,12 +990,14 @@ SheetGradingPoints maxPoints@Points: #{maxPoints} #{pluralDE maxPoints "Punkt" " SheetGradingPassPoints maxPoints@Points passingPoints@Points: Bestanden ab #{passingPoints} von #{maxPoints} #{pluralDE maxPoints "Punkt" "Punkten"} SheetGradingPassBinary: Bestanden/Nicht Bestanden SheetGradingInfo: "Bestanden nach Punkten" zählt sowohl zur maximal erreichbaren Gesamtpunktzahl also auch zur Anzahl der zu bestehenden Blätter. +SheetGradingPassAlways: Automatisch bestanden, sobald korrigiert SheetGradingCount': Anzahl SheetGradingPoints': Punkte SheetGradingPassing': Bestehen SheetGradingPassPoints': Bestehen nach Punkten SheetGradingPassBinary': Bestanden/Nicht bestanden +SheetGradingPassAlways': Automatisch bestanden, sobald korrigiert SheetTypeBonus grading@SheetGrading: Bonus SheetTypeNormal grading@SheetGrading: Normal diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 24703e72e..2ed001ffa 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -798,10 +798,16 @@ postCorrectionR tid ssh csh shn cid = 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 (mr MsgPointsPlaceholder) & setTooltip sheetType) - (Just submissionRatingPoints) + 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) ((corrResult, corrForm'), corrEncoding) <- runFormPost . identifyForm FIDcorrection . renderAForm FormStandard $ (,,) <$> areq checkBoxField (fslI MsgRatingDone) (Just $ submissionRatingDone Submission{..}) diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 0c950205e..560dc072f 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -1121,7 +1121,7 @@ multiFileField mkPermitted = genericFileField $ mkField <$> mkPermitted , fieldAdditionalFiles = Map.fromSet (const $ FileFieldUserOption False True) permitted } -data SheetGrading' = Points' | PassPoints' | PassBinary' +data SheetGrading' = Points' | PassPoints' | PassBinary' | PassAlways' deriving (Eq, Ord, Read, Show, Enum, Bounded) instance Universe SheetGrading' @@ -1157,12 +1157,14 @@ sheetGradingAFormReq fs template = multiActionA selOptions fs (classify' <$> tem [ ( Points', Points <$> maxPointsReq ) , ( PassPoints', PassPoints <$> maxPointsReq <*> passPointsReq ) , ( PassBinary', pure PassBinary) + , ( PassAlways', pure PassAlways) ] classify' :: SheetGrading -> SheetGrading' classify' = \case Points {} -> Points' PassPoints {} -> PassPoints' PassBinary {} -> PassBinary' + PassAlways {} -> PassAlways' maxPointsReq = apreq pointsField (fslI MsgSheetGradingMaxPoints) (template >>= preview _maxPoints) passPointsReq = apreq pointsField (fslI MsgSheetGradingPassingPoints) (template >>= preview _passingPoints) diff --git a/src/Handler/Utils/Rating.hs b/src/Handler/Utils/Rating.hs index 94bb2aaca..a11682c92 100644 --- a/src/Handler/Utils/Rating.hs +++ b/src/Handler/Utils/Rating.hs @@ -48,6 +48,7 @@ instance Pretty SheetGrading where pretty Points{..} = pretty ( "Maximal " <> show maxPoints <> " Punkt(e)" :: String) pretty PassPoints{..} = pretty ( "Maximal " <> show maxPoints <> " Punkt(e), bestanden ab " <> show passingPoints <> " Punkt(en)" :: String ) pretty PassBinary = pretty ( "Bestanden (1) / Nicht bestanden (0)" :: String ) + pretty PassAlways = pretty ( "Automatisch bestanden, sobald korrigiert" :: String ) validateRating :: SheetType -> Rating' -> [RatingException] @@ -66,6 +67,7 @@ validateRating ratingSheetType Rating'{ .. } | has _grading ratingSheetType , is _Nothing ratingPoints , isn't _Nothing ratingTime + , hasn't (_grading . _PassAlways) ratingSheetType = [RatingPointsRequired] validateRating _ _ = [] @@ -101,23 +103,23 @@ getRating submissionId = runMaybeT $ do formatRating :: CryptoFileNameSubmission -> Rating -> Lazy.ByteString formatRating cID Rating{ ratingValues = Rating'{..}, ..} = let - doc = renderPretty 1 45 $ foldr (<$$>) mempty - [ "= Bitte nur Bewertung und Kommentare ändern =" - , "=============================================" - , "========== Uni2work Bewertungsdatei =========" - , "======= diese Datei ist UTF8 encodiert ======" - , "Informationen zum Übungsblatt:" - , indent 2 . foldr (<$$>) mempty . catMaybes $ + doc = renderPretty 1 45 . foldr (<$$>) mempty $ catMaybes + [ pure "= Bitte nur Bewertung und Kommentare ändern =" + , pure "=============================================" + , pure "========== Uni2work Bewertungsdatei =========" + , pure "======= diese Datei ist UTF8 encodiert ======" + , pure "Informationen zum Übungsblatt:" + , pure . indent 2 . foldr (<$$>) mempty . catMaybes $ [ Just $ "Veranstaltung:" <+> pretty ratingCourseName , Just $ "Blatt:" <+> pretty ratingSheetName , ("Korrektor:" <+>) . pretty <$> ratingCorrectorName , ("Bewertungsschema:" <+>) . pretty <$> (ratingSheetType ^? _grading) ] - , "Abgabe-Id:" <+> pretty (Text.unpack $ toPathPiece cID) - , "=============================================" - , "Bewertung:" <+> pretty ratingPoints - , "=========== Beginn der Kommentare ===========" - , pretty ratingComment + , pure $ "Abgabe-Id:" <+> pretty (Text.unpack $ toPathPiece cID) + , guardOn (hasn't (_grading . _PassAlways) ratingSheetType) "=============================================" + , guardOn (hasn't (_grading . _PassAlways) ratingSheetType) $ "Bewertung:" <+> pretty ratingPoints + , pure $ "=========== Beginn der Kommentare ===========" + , pure $ pretty ratingComment ] in Lazy.Text.encodeUtf8 . (<> "\n") $ displayT doc @@ -149,6 +151,7 @@ parseRating File{ fileContent = Just input, .. } = do | Text.null comment' = Nothing | otherwise = Just comment' ratingLine' <- case ratingLines' of + [] -> return Text.empty [l] -> return l _ -> throwM RatingMultiple let diff --git a/src/Model/Types/Sheet.hs b/src/Model/Types/Sheet.hs index 0ef6f6ae8..08067c9ab 100644 --- a/src/Model/Types/Sheet.hs +++ b/src/Model/Types/Sheet.hs @@ -25,6 +25,7 @@ data SheetGrading = Points { maxPoints :: Points } | PassPoints { maxPoints, passingPoints :: Points } | PassBinary -- non-zero means passed + | PassAlways deriving (Eq, Read, Show, Generic) deriveJSON defaultOptions @@ -44,8 +45,10 @@ _passingBound = folding passPts passPts Points{} = Nothing passPts PassPoints{passingPoints} = Just $ Right passingPoints passPts PassBinary = Just $ Left () + passPts PassAlways = Just $ Left () gradingPassed :: SheetGrading -> Points -> Maybe Bool +gradingPassed PassAlways _ = Just True gradingPassed gr pts = either pBinary pPoints <$> gr ^? _passingBound where pBinary _ = pts /= 0 pPoints b = pts >= b diff --git a/templates/correction-user.hamlet b/templates/correction-user.hamlet index 88f443a8b..ae8780f29 100644 --- a/templates/correction-user.hamlet +++ b/templates/correction-user.hamlet @@ -38,6 +38,7 @@ _{MsgPassed} $else _{MsgNotPassed} + $of PassAlways $maybe comment <- ratingComment diff --git a/templates/mail/submissionRated.hamlet b/templates/mail/submissionRated.hamlet index e21c3f5b1..24a9a1aec 100644 --- a/templates/mail/submissionRated.hamlet +++ b/templates/mail/submissionRated.hamlet @@ -56,6 +56,8 @@ $newline never _{MsgPassed} $else _{MsgNotPassed} + $of PassAlways +
$maybe comment <- submissionRatingComment
diff --git a/templates/widgets/rating/rating.hamlet b/templates/widgets/rating/rating.hamlet index a2fb74fe0..210ea6e48 100644 --- a/templates/widgets/rating/rating.hamlet +++ b/templates/widgets/rating/rating.hamlet @@ -8,16 +8,20 @@ $if submissionRatingDone sub $case grading $of Points{..} _{MsgAchievedOf points maxPoints} + , # $of PassPoints{maxPoints} $if fromMaybe False (gradingPassed grading points) _{MsgPassed}, _{MsgAchievedOf points maxPoints} $else _{MsgNotPassed}, _{MsgAchievedOf points maxPoints} + , # $of PassBinary $if fromMaybe False (gradingPassed grading points) _{MsgPassed} $else _{MsgNotPassed} - , _{SheetTypeHeader sheetType} + , # + $of PassAlways + _{SheetTypeHeader sheetType} $nothing #{hasTickmark True} diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index cfd1ab532..d70a39306 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -3,9 +3,12 @@ module Database.Fill ) where import "uniworx" Import hiding (Option(..), currentYear) +import Handler.Utils.Form (SheetGrading'(..), SheetType'(..), SheetGroup'(..)) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS +import qualified Data.Text as Text +-- import Data.Text.IO (hPutStrLn) import qualified Data.Set as Set import qualified Data.Map as Map @@ -25,6 +28,7 @@ import qualified Data.CaseInsensitive as CI import qualified Data.Csv as Csv import Crypto.Random (getRandomBytes) +import Data.List (genericLength) testdataDir :: FilePath @@ -68,7 +72,7 @@ fillDb = do termTime :: Bool -- ^ Next term? -> Season - -> Integer + -> Rational -> Bool -- ^ Relative to end of semester? -> WeekDay -> (Day -> UTCTime) @@ -76,7 +80,7 @@ fillDb = do termTime next gSeason weekOffset fromEnd day = ($ utctDay) where utctDay = fromWeekDate wYear wWeek $ fromEnum day - (wYear, wWeek, _) = toWeekDate . addDays (7 * weekOffset) $ fromGregorian gYear rMonth rDay + (wYear, wWeek, _) = toWeekDate . addDays (round $ 7 * weekOffset) $ fromGregorian gYear rMonth rDay gYear = year $ seasonTerm next gSeason (rMonth, rDay) | Winter <- gSeason @@ -743,108 +747,111 @@ fillDb = do ,(maxMuster , Just sfMMp) ,(tinaTester, Just sfTTb) ] - sh1 <- insert Sheet - { sheetCourse = pmo - , sheetName = "Papierabgabe" - , sheetDescription = Nothing - , sheetType = Normal $ Points 6 - , sheetGrouping = Arbitrary 3 - , sheetMarkingText = Nothing - , sheetVisibleFrom = Just $ termTime True Summer 0 False Monday toMidnight - , sheetActiveFrom = Just $ termTime True Summer 1 False Monday toMidnight - , sheetActiveTo = Just $ termTime True Summer 2 False Sunday beforeMidnight - , sheetSubmissionMode = SubmissionMode True Nothing - , sheetHintFrom = Nothing - , sheetSolutionFrom = Nothing - , sheetAutoDistribute = True - , sheetAnonymousCorrection = False - } - void . insert $ SheetEdit jost now sh1 - forM_ [fhamann, maxMuster, tinaTester] $ \u -> do - p <- liftIO getRandom - $logDebug (review _PseudonymText p) - void . insert $ SheetPseudonym sh1 p u - void . insert $ SheetCorrector jost sh1 (Load (Just True) 0) CorrectorNormal - void . insert $ SheetCorrector gkleen sh1 (Load (Just True) 1) CorrectorNormal - h102 <- insertFile "H10-2.hs" - h103 <- insertFile "H10-3.hs" - pdf10 <- insertFile "ProMo_Uebung10.pdf" - void . insert $ SheetFile sh1 h102 SheetHint - void . insert $ SheetFile sh1 h103 SheetSolution - void . insert $ SheetFile sh1 pdf10 SheetExercise - -- - sub1 <- insert $ Submission - { submissionSheet = sh1 - , submissionRatingPoints = Nothing - , submissionRatingComment = Nothing - , submissionRatingBy = Just gkleen - , submissionRatingAssigned = Just now - , submissionRatingTime = Nothing - } - void . insert $ SubmissionEdit (Just maxMuster) now sub1 - void . insert $ SubmissionUser maxMuster sub1 - sub1fid1 <- insertFile "AbgabeH10-1.hs" - void . insert $ SubmissionFile sub1 sub1fid1 False False - sub2 <- insert $ Submission sh1 Nothing Nothing Nothing Nothing Nothing - void . insert $ SubmissionEdit (Just fhamann) now sub2 - void . insert $ SubmissionUser fhamann sub2 - sh2 <- insert Sheet - { sheetCourse = pmo - , sheetName = "Spezifische Abgabe" - , sheetDescription = Nothing - , sheetType = Normal $ Points 6 - , sheetGrouping = Arbitrary 3 - , sheetMarkingText = Nothing - , sheetVisibleFrom = Just $ termTime True Summer 1 False Monday toMidnight - , sheetActiveFrom = Just $ termTime True Summer 2 False Monday toMidnight - , sheetActiveTo = Just $ termTime True Summer 3 False Sunday beforeMidnight - , sheetSubmissionMode = SubmissionMode False $ Just UploadSpecific - { specificFiles = impureNonNull $ Set.fromList - [ UploadSpecificFile "Aufgabe 1" "exercise_2.1.hs" False - , UploadSpecificFile "Aufgabe 2" "exercise_2.2.hs" False - , UploadSpecificFile "Erklärung der Eigenständigkeit" "erklärung.txt" True - ] + + let shTypes = NotGraded : [ shType g | g <- shGradings, shType <- [ Normal, Bonus, Informational ] ] + where shGradings = [ Points 6, PassPoints 3 6, PassBinary, PassAlways ] + shGroupings = [ Arbitrary 3, RegisteredGroups, NoGroups ] + shSubModes = do + corrector <- universeF + [ SubmissionMode corrector Nothing + , SubmissionMode corrector $ Just NoUpload + , SubmissionMode corrector $ Just UploadSpecific + { specificFiles = impureNonNull $ Set.fromList + [ UploadSpecificFile "Aufgabe 1" "exercise_2.1.hs" False + , UploadSpecificFile "Aufgabe 2" "exercise_2.2.hs" False + , UploadSpecificFile "Erklärung der Eigenständigkeit" "erklärung.txt" True + ] + } + ] ++ [ SubmissionMode corrector $ Just UploadAny{..} + | unpackZips <- universeF + , extensionRestriction <- [ Nothing, Just . impureNonNull $ Set.fromList ["pdf", "txt", "jpeg", "hs"] ] + ] + + sheetCombinations = ((,,) <$> shTypes <*> shGroupings <*> shSubModes) + + forM_ (zip [0..] sheetCombinations) $ \(shNr, (sheetType, sheetGrouping, sheetSubmissionMode)) -> do + MsgRenderer mr <- getMsgRenderer + + let sheetSubmissionModeDescr + | Just userMode <- sheetSubmissionMode ^? _submissionModeUser . _Just + = let + extra = catMaybes + [ guardOn (fromMaybe False $ userMode ^? _unpackZips) $ mr MsgAutoUnzip + , guardOn (maybe False (is _Just) $ userMode ^? _extensionRestriction) $ mr MsgUploadModeExtensionRestriction + ] + in mr (classifySubmissionMode sheetSubmissionMode) <> " (" <> Text.intercalate ", " (mr (classifyUploadMode userMode) : extra) <> ")" + | Just userMode <- sheetSubmissionMode ^? _submissionModeUser . _Just + = mr (classifySubmissionMode sheetSubmissionMode) <> " (" <> mr (classifyUploadMode userMode) <> ")" + | otherwise + = mr (classifySubmissionMode sheetSubmissionMode) + sheetGroupingDescr = case sheetGrouping of + Arbitrary{} -> mr Arbitrary' + RegisteredGroups -> mr RegisteredGroups' + NoGroups -> mr NoGroups' + sheetTypeDescr + | Just g <- sheetType ^? _grading + = let sheetGrading' = case g of + Points{} -> Points' + PassPoints{} -> PassPoints' + PassBinary{} -> PassBinary' + PassAlways{} -> PassAlways' + in mr sheetType' <> " (" <> mr sheetGrading' <> ")" + | otherwise + = mr sheetType' + where + sheetType' = case sheetType of + NotGraded -> NotGraded' + Normal{} -> Normal' + Bonus{} -> Bonus' + Informational{} -> Informational' + + prog = 14 * (shNr % genericLength sheetCombinations) + + -- liftIO . hPutStrLn stderr $ Text.intercalate ", " [sheetTypeDescr, sheetGroupingDescr, sheetSubmissionModeDescr] + -- liftIO . hPutStrLn stderr $ tshow (sheetType, sheetGrouping, sheetSubmissionMode) + + shId <- insert Sheet + { sheetCourse = pmo + , sheetName = CI.mk $ tshow shNr <> ": " <> Text.intercalate ", " [sheetTypeDescr, sheetGroupingDescr, sheetSubmissionModeDescr] + , sheetDescription = Nothing + , sheetType, sheetGrouping, sheetSubmissionMode + , sheetMarkingText = Nothing + , sheetVisibleFrom = Just $ termTime True Summer prog False Monday toMidnight + , sheetActiveFrom = Just $ termTime True Summer (prog + 1) False Monday toMidnight + , sheetActiveTo = Just $ termTime True Summer (prog + 2) False Sunday beforeMidnight + , sheetHintFrom = Nothing + , sheetSolutionFrom = Nothing + , sheetAutoDistribute = True + , sheetAnonymousCorrection = True } - , sheetHintFrom = Nothing - , sheetSolutionFrom = Nothing - , sheetAutoDistribute = True - , sheetAnonymousCorrection = False - } - void . insert $ SheetEdit jost now sh2 - sh3 <- insert Sheet - { sheetCourse = pmo - , sheetName = "Dateiendung-eingeschränkte Abgabe" - , sheetDescription = Nothing - , sheetType = Normal $ Points 6 - , sheetGrouping = Arbitrary 3 - , sheetMarkingText = Nothing - , sheetVisibleFrom = Just $ termTime True Summer 2 False Monday toMidnight - , sheetActiveFrom = Just $ termTime True Summer 3 False Monday toMidnight - , sheetActiveTo = Just $ termTime True Summer 4 False Sunday beforeMidnight - , sheetSubmissionMode = SubmissionMode False . Just $ UploadAny True defaultExtensionRestriction - , sheetHintFrom = Nothing - , sheetSolutionFrom = Nothing - , sheetAutoDistribute = True - , sheetAnonymousCorrection = True - } - void . insert $ SheetEdit jost now sh3 - sh4 <- insert Sheet - { sheetCourse = pmo - , sheetName = "Uneingeschränkte Abgabe, einzelne Datei" - , sheetDescription = Nothing - , sheetType = Normal $ Points 6 - , sheetGrouping = Arbitrary 3 - , sheetMarkingText = Nothing - , sheetVisibleFrom = Just $ termTime True Summer 3 False Monday toMidnight - , sheetActiveFrom = Just $ termTime True Summer 4 False Monday toMidnight - , sheetActiveTo = Just $ termTime True Summer 5 False Sunday beforeMidnight - , sheetSubmissionMode = SubmissionMode False . Just $ UploadAny False Nothing - , sheetHintFrom = Nothing - , sheetSolutionFrom = Nothing - , sheetAutoDistribute = True - , sheetAnonymousCorrection = True - } - void . insert $ SheetEdit jost now sh4 + void . insert $ SheetEdit jost now shId + when (submissionModeCorrector sheetSubmissionMode) $ + forM_ [fhamann, maxMuster, tinaTester] $ \uid -> do + p <- liftIO getRandom + void . insert $ SheetPseudonym shId p uid + void . insert $ SheetCorrector jost shId (Load (Just True) 0) CorrectorNormal + void . insert $ SheetCorrector gkleen shId (Load (Just True) 1) CorrectorNormal + void . insert $ SheetCorrector svaupel shId (Load (Just True) 1) CorrectorNormal + h102 <- insertFile "H10-2.hs" + h103 <- insertFile "H10-3.hs" + pdf10 <- insertFile "ProMo_Uebung10.pdf" + void . insert $ SheetFile shId h102 SheetHint + void . insert $ SheetFile shId h103 SheetSolution + void . insert $ SheetFile shId pdf10 SheetExercise + + forM_ [fhamann, maxMuster, tinaTester] $ \uid -> do + subId <- insert $ Submission + { submissionSheet = shId + , submissionRatingPoints = Nothing + , submissionRatingComment = Nothing + , submissionRatingBy = Nothing + , submissionRatingAssigned = Nothing + , submissionRatingTime = Nothing + } + void . insert $ SubmissionEdit (Just uid) now subId + void . insert $ SubmissionUser uid subId + fId <- insertFile "AbgabeH10-1.hs" + void . insert $ SubmissionFile subId fId False False tut1 <- insert Tutorial { tutorialName = "Di08" , tutorialCourse = pmo @@ -1103,7 +1110,7 @@ fillDb = do participants <- getRandomR (0, 50) manyUsers' <- shuffleM $ take 1024 manyUsers forM_ (take participants manyUsers') $ \uid -> - void . insert $ CourseParticipant cid uid now Nothing Nothing CourseParticipantActive + void . insertUnique $ CourseParticipant cid uid now Nothing Nothing CourseParticipantActive aSeedBig <- liftIO $ getRandomBytes 40 bigAlloc <- insert' Allocation