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

feat(sheets): pass-always

Browse Source
This commit is contained in:
Gregor Kleen 2020-05-23 11:50:54 +02:00
parent 8bb3bc50a2
commit b2ebce4836
9 changed files with 152 additions and 122 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
messages/uniworx/de-de-formal.msg
View File

@ -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

14
src/Handler/Corrections.hs
View File

@ -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{..})

4
src/Handler/Utils/Form.hs
View File

@ -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)

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

@ -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

3
src/Model/Types/Sheet.hs
View File

@ -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

1
templates/correction-user.hamlet
View File

@ -38,6 +38,7 @@
_{MsgPassed}
$else
_{MsgNotPassed}
$of PassAlways
$maybe comment <- ratingComment
<tr .table__row>

2
templates/mail/submissionRated.hamlet
View File

@ -56,6 +56,8 @@ $newline never
_{MsgPassed}
$else
_{MsgNotPassed}
$of PassAlways
<dd>
$maybe comment <- submissionRatingComment
<dt>

6
templates/widgets/rating/rating.hamlet
View File

@ -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}

215
test/Database/Fill.hs
View File

@ -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