feat(sheets): pass-always

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

src/Handler/Corrections.hs

@@ -798,8 +798,14 @@ 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
+            NotGraded
-            _otherwise -> aopt  (pointsFieldMax $ preview (_grading . _maxPoints) sheetType)
+              -> 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)
 

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)

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
+  doc = renderPretty 1 45 . foldr (<$$>) mempty $ catMaybes
-    [ "= Bitte nur Bewertung und Kommentare ändern ="
+    [ pure "= Bitte nur Bewertung und Kommentare ändern ="
-    , "============================================="
+    , pure "============================================="
-    , "========== Uni2work Bewertungsdatei ========="
+    , pure "========== Uni2work Bewertungsdatei ========="
-    , "======= diese Datei ist UTF8 encodiert ======"
+    , pure "======= diese Datei ist UTF8 encodiert ======"
-    , "Informationen zum Übungsblatt:"
+    , pure "Informationen zum Übungsblatt:"
-    , indent 2 . foldr (<$$>) mempty . catMaybes $
+    , 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)
+    , pure $ "Abgabe-Id:" <+> pretty (Text.unpack $ toPathPiece cID)
-    , "============================================="
+    , guardOn (hasn't (_grading . _PassAlways) ratingSheetType)   "============================================="
-    , "Bewertung:" <+> pretty ratingPoints
+    , guardOn (hasn't (_grading . _PassAlways) ratingSheetType) $ "Bewertung:" <+> pretty ratingPoints
-    , "=========== Beginn der Kommentare ==========="
+    , pure $ "=========== Beginn der Kommentare ==========="
-    , pretty ratingComment
+    , 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

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

templates/correction-user.hamlet

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

templates/mail/submissionRated.hamlet

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

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}

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
+  let shTypes = NotGraded : [ shType g | g <- shGradings, shType <- [ Normal, Bonus, Informational ] ]
-    , sheetName = "Papierabgabe"
+        where shGradings = [ Points 6, PassPoints 3 6, PassBinary, PassAlways ]
-    , sheetDescription = Nothing
+      shGroupings = [ Arbitrary 3, RegisteredGroups, NoGroups ]
-    , sheetType = Normal $ Points 6
+      shSubModes = do
-    , sheetGrouping = Arbitrary 3
+        corrector <- universeF
-    , sheetMarkingText = Nothing
+        [   SubmissionMode corrector Nothing
-    , sheetVisibleFrom = Just $ termTime True Summer 0 False Monday toMidnight
+          , SubmissionMode corrector $ Just NoUpload
-    , sheetActiveFrom = Just $ termTime True Summer 1 False Monday toMidnight
+          , SubmissionMode corrector $ Just UploadSpecific
-    , 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
               ]
             }
-    , sheetHintFrom = Nothing
+          ] ++ [ SubmissionMode corrector $ Just UploadAny{..}
-    , sheetSolutionFrom = Nothing
+               | unpackZips <- universeF
-    , sheetAutoDistribute = True
+               , extensionRestriction <- [ Nothing, Just . impureNonNull $ Set.fromList ["pdf", "txt", "jpeg", "hs"] ]
-    , sheetAnonymousCorrection = False
+               ]
-    }
+
-  void . insert $ SheetEdit jost now sh2
+      sheetCombinations = ((,,) <$> shTypes <*> shGroupings <*> shSubModes)
-  sh3 <- insert Sheet
+
+  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 = "Dateiendung-eingeschränkte Abgabe"
+      , sheetName = CI.mk $ tshow shNr <> ": " <> Text.intercalate ", " [sheetTypeDescr, sheetGroupingDescr, sheetSubmissionModeDescr]
       , sheetDescription = Nothing
-    , sheetType = Normal $ Points 6
+      , sheetType, sheetGrouping, sheetSubmissionMode
-    , sheetGrouping = Arbitrary 3
       , sheetMarkingText = Nothing
-    , sheetVisibleFrom = Just $ termTime True Summer 2 False Monday toMidnight
+      , sheetVisibleFrom = Just $ termTime True Summer prog False Monday toMidnight
-    , sheetActiveFrom = Just $ termTime True Summer 3 False Monday toMidnight
+      , sheetActiveFrom = Just $ termTime True Summer (prog + 1) False Monday toMidnight
-    , sheetActiveTo = Just $ termTime True Summer 4 False Sunday beforeMidnight
+      , sheetActiveTo = Just $ termTime True Summer (prog + 2) False Sunday beforeMidnight
-    , sheetSubmissionMode = SubmissionMode False . Just $ UploadAny True defaultExtensionRestriction
       , sheetHintFrom = Nothing
       , sheetSolutionFrom = Nothing
       , sheetAutoDistribute = True
       , sheetAnonymousCorrection = True
       }
-  void . insert $ SheetEdit jost now sh3
+    void . insert $ SheetEdit jost now shId
-  sh4 <- insert Sheet
+    when (submissionModeCorrector sheetSubmissionMode) $
-    { sheetCourse = pmo
+      forM_ [fhamann, maxMuster, tinaTester] $ \uid -> do
-    , sheetName = "Uneingeschränkte Abgabe, einzelne Datei"
+        p <- liftIO getRandom
-    , sheetDescription = Nothing
+        void . insert $ SheetPseudonym shId p uid
-    , sheetType = Normal $ Points 6
+    void . insert $ SheetCorrector jost shId (Load (Just True) 0) CorrectorNormal
-    , sheetGrouping = Arbitrary 3
+    void . insert $ SheetCorrector gkleen shId (Load (Just True) 1) CorrectorNormal
-    , sheetMarkingText = Nothing
+    void . insert $ SheetCorrector svaupel shId (Load (Just True) 1) CorrectorNormal
-    , sheetVisibleFrom = Just $ termTime True Summer 3 False Monday toMidnight
+    h102 <- insertFile "H10-2.hs"
-    , sheetActiveFrom = Just $ termTime True Summer 4 False Monday toMidnight
+    h103 <- insertFile "H10-3.hs"
-    , sheetActiveTo = Just $ termTime True Summer 5 False Sunday beforeMidnight
+    pdf10 <- insertFile "ProMo_Uebung10.pdf"
-    , sheetSubmissionMode = SubmissionMode False . Just $ UploadAny False Nothing
+    void . insert $ SheetFile shId h102 SheetHint
-    , sheetHintFrom = Nothing
+    void . insert $ SheetFile shId h103 SheetSolution
-    , sheetSolutionFrom = Nothing
+    void . insert $ SheetFile shId pdf10 SheetExercise
-    , sheetAutoDistribute = True
+
-    , sheetAnonymousCorrection = True
+    forM_ [fhamann, maxMuster, tinaTester] $ \uid -> do
+        subId <- insert $ Submission
+          { submissionSheet = shId
+          , submissionRatingPoints = Nothing
+          , submissionRatingComment = Nothing
+          , submissionRatingBy = Nothing
+          , submissionRatingAssigned = Nothing
+          , submissionRatingTime = Nothing
           }
-  void . insert $ SheetEdit jost now sh4
+        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