Merge branch 'master' into tests

messages/uniworx/de.msg

@@ -258,6 +258,7 @@ RatingDone: Bewertung fertiggestellt
 RatingPercent: Erreicht
 RatingFiles: Korrigierte Dateien
 PointsNotPositive: Punktzahl darf nicht negativ sein
+PointsTooHigh maxPoints@Points: Punktzahl darf nicht höher als #{tshow maxPoints} sein 
 RatingPointsDone: Abgabe zählt als korrigiert, gdw. Punktezahl gesetzt ist
 ColumnRatingPointsDone: Punktzahl/Abgeschlossen
 Pseudonyms: Pseudonyme
@@ -355,6 +356,7 @@ SheetGrading: Bewertung
 SheetGradingPoints maxPoints@Points: #{tshow maxPoints} Punkte
 SheetGradingPassPoints maxPoints@Points passingPoints@Points: Bestanden ab #{tshow passingPoints} von #{tshow maxPoints} 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. 
 
 SheetGradingPoints': Punkte
 SheetGradingPassPoints': Bestehen nach Punkten
@@ -364,6 +366,7 @@ SheetTypeBonus grading@SheetGrading: Bonus
 SheetTypeNormal grading@SheetGrading: Normal
 SheetTypeInformational grading@SheetGrading: Keine Wertung
 SheetTypeNotGraded: Unbewertet
+SheetTypeInfo: Bonus Blätter zählen, erhöhen aber nicht die maximal erreichbare Punktzahl bzw. Anzahl zu bestehender Blätter. Blätter ohne Wertung werden nirgends angerechnet, die Bewertung durch den Korrektor dient lediglich zur Information an die Teilnehmer.
 
 SheetTypeBonus': Bonus
 SheetTypeNormal': Normal

src/Foundation.hs

@@ -221,6 +221,15 @@ embedRenderMessage ''UniWorX ''CorrectorState id
 embedRenderMessage ''UniWorX ''SheetGrading ("SheetGrading" <>)
 embedRenderMessage ''UniWorX ''SheetType ("SheetType" <>)
 
+newtype SheetTypeComplete = SheetTypeComplete SheetType 
+instance RenderMessage UniWorX (SheetTypeComplete) where
+  renderMessage foundation ls (SheetTypeComplete st) = case st of
+      NotGraded -> mr NotGraded
+      other -> mr (grading other) <> ", " <> mr other
+    where 
+      mr :: RenderMessage UniWorX msg => msg -> Text
+      mr = renderMessage foundation ls
+
 newtype ErrorResponseTitle = ErrorResponseTitle ErrorResponse
 embedRenderMessageVariant ''UniWorX ''ErrorResponseTitle ("ErrorResponseTitle" <>)
 

src/Handler/Corrections.hs

@@ -232,6 +232,9 @@ makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do
       , ( "ratingtime"
         , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingTime
         )
+      , ( "assignedtime"
+        , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingAssigned
+        )	
       ]
     , dbtFilter    = Map.fromList
       [ ( "term"
@@ -480,7 +483,9 @@ postCorrectionR tid ssh csh shn cid = do
       let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c))
           pointsForm = case sheetType of
             NotGraded  -> pure Nothing
-            _otherwise -> aopt pointsField (fslpI MsgRatingPoints "Punktezahl") (Just $ submissionRatingPoints)
+            _otherwise -> aopt  (pointsFieldMax $ preview (_grading . _maxPoints) sheetType) 
+                                (fslpI MsgRatingPoints "Punktezahl") 
+                                (Just $ submissionRatingPoints)
 
       ((corrResult, corrForm), corrEncoding) <- runFormPost . identForm FIDcorrection . renderAForm FormStandard $ (,,)
         <$> areq checkBoxField (fslI MsgRatingDone) (Just $ submissionRatingDone Submission{..})

src/Handler/Sheet.hs

@@ -97,7 +97,8 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
     (result, widget) <- flip (renderAForm FormStandard) html $ SheetForm
       <$> areq ciField        (fslI MsgSheetName)         (sfName        <$> template)
       <*> aopt htmlField      (fslI MsgSheetDescription)  (sfDescription <$> template)
-      <*> sheetTypeAFormReq   (fslI MsgSheetType)         (sfType        <$> template)
+      <*> sheetTypeAFormReq   (fslI MsgSheetType
+            & setTooltip MsgSheetTypeInfo)                  (sfType        <$> template)
       <*> sheetGroupAFormReq  (fslI MsgSheetGroup)        (sfGrouping    <$> template)      
       <*> aopt utcTimeField   (fslI MsgSheetVisibleFrom
             & setTooltip MsgSheetVisibleFromTip)
@@ -161,7 +162,7 @@ getSheetListR tid ssh csh = do
       , sortable (Just "submission-until") (i18nCell MsgSheetActiveTo)
           $ \(Entity _ Sheet{..}, _, _) -> timeCell sheetActiveTo
       , sortable Nothing (i18nCell MsgSheetType)
-          $ \(Entity _ Sheet{..}, _, _) -> i18nCell sheetType
+          $ \(Entity _ Sheet{..}, _, _) -> i18nCell $ SheetTypeComplete sheetType
       , sortable Nothing (i18nCell MsgSubmission)
           $ \(Entity _ Sheet{..}, _, mbSub) -> case mbSub of
               Nothing -> mempty
@@ -180,8 +181,8 @@ getSheetListR tid ssh csh = do
                       cid' <- mkCid
                       return $ CSubmissionR tid ssh csh sheetName cid' CorrectionR
                     protoCell = anchorCellM mkRoute $(widgetFile "widgets/rating")
-                in protoCell & cellContents %~ (<* tell (sheetTypeSum (sheetType, submissionRatingPoints)))
+                in protoCell & cellContents %~ (<* tell (sheetTypeSum sheetType submissionRatingPoints))
-      , sortable Nothing -- (Just "percent")
+      , sortable Nothing -- (Just "percent") 
                         (i18nCell MsgRatingPercent)
           $ \(Entity _ Sheet{sheetType=sType}, _, mbSub) -> case mbSub of
               (Just (Entity _ Submission{submissionRatingPoints=Just sPoints})) ->
@@ -194,7 +195,23 @@ getSheetListR tid ssh csh = do
       ]
     psValidator = def
       & defaultSorting [("submission-since", SortAsc)]
-  (SheetTypeSummary{..}, table) <- dbTable psValidator $ DBTable
+  ------------------------------------------------------
+  -- ISSUE #223
+  -- The following line does not work; something is wrong with the tell in line 189 above.
+  -- (SheetTypeSummary{..}, table) <- dbTable psValidator $ DBTable
+  --
+  -- If fixed, remove the following workaround code:
+  SheetTypeSummary{..} <- do
+    rows <- runDB $ E.select $ E.from $ \(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) -> do
+      E.on $ submission E.?. SubmissionId E.==. submissionUser E.?. SubmissionUserSubmission
+      E.on $  (E.just $ sheet E.^. SheetId) E.==. submission E.?. SubmissionSheet
+        E.&&. submissionUser E.?. SubmissionUserUser E.==. E.val muid
+      E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
+      return (sheet E.^. SheetType, submission E.?. SubmissionRatingPoints)
+    return $ foldMap (\(E.Value st, E.Value mbPts) -> sheetTypeSum st (join mbPts)) rows
+  (_, table) <- dbTable psValidator $ DBTable
+  -- END ISSUE #223
+  -----------------------------------------------------
     { dbtSQLQuery  = sheetData
     , dbtColonnade = sheetCol
     , dbtProj = \DBRow{ dbrOutput = dbrOutput@(Entity _ Sheet{..}, _, _) }

src/Handler/Utils/Form.hs

@@ -187,6 +187,9 @@ pointsField = checkBool (>= 0) MsgPointsNotPositive Field{..}
       sci <- maybe (Left $ MsgInvalidNumber t) Right (readMaybe $ unpack t :: Maybe Scientific)
       return . fromRational $ round (sci * 100) % 100
 
+pointsFieldMax :: (Monad m, HandlerSite m ~ UniWorX) => Maybe Points -> Field m Points --TODO allow fractions
+pointsFieldMax Nothing = pointsField
+pointsFieldMax (Just maxp) = checkBool (<= maxp) (MsgPointsTooHigh maxp) pointsField
 
 termsActiveField :: Field Handler TermId
 termsActiveField = selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName
@@ -382,7 +385,8 @@ sheetTypeAFormReq fs template = multiActionA fs selOptions (classify' <$> templa
       , ( Informational', Informational <$> gradingReq  )
       , ( NotGraded', pure NotGraded )
       ]    
-    gradingReq = sheetGradingAFormReq (fslI MsgSheetGrading) (template >>= preview _grading)
+    gradingReq = sheetGradingAFormReq (fslI MsgSheetGrading
+        & setTooltip MsgSheetGradingInfo) (template >>= preview _grading)
 
     classify' :: SheetType -> SheetType'
     classify' = \case

src/Handler/Utils/Table/Cells.hs

@@ -83,6 +83,9 @@ sheetCell crse shn =
       link= CSheetR tid ssh csh shn SShowR
   in anchorCell link $ display2widget shn
 
+sheetTypeCell :: IsDBTable m a => SheetType -> DBCell m a
+sheetTypeCell st = i18nCell $ SheetTypeComplete st
+
 submissionCell :: IsDBTable m a => CourseLink -> SheetName -> SubmissionId -> DBCell m a
 submissionCell crse shn sid =
   let tid = crse ^. _1

src/Model/Types.hs

@@ -132,10 +132,34 @@ gradingPassed (Points {}) _ = Nothing
 gradingPassed (PassPoints {..}) pts = Just $ pts >= passingPoints
 gradingPassed (PassBinary {}) pts = Just $ pts /= 0
 
+data SheetGradeSummary = SheetGradeSummary 
+  { sumGradePoints :: Sum Points
+  , numGradePasses :: Sum Int
+  , achievedPoints :: Maybe (Sum Points)
+  , achievedPasses :: Maybe (Sum Int)
+} deriving (Generic)
+
+instance Monoid SheetGradeSummary where
+  mempty  = memptydefault
+  mappend = mappenddefault
+
+instance Semigroup SheetGradeSummary where 
+  (<>) = mappend -- remove for GHC > 8.4.x
+
+sheetGradeSum :: SheetGrading -> Maybe Points -> SheetGradeSummary                                              
+sheetGradeSum gr (Just p) = 
+  let baseSum = (sheetGradeSum gr Nothing) { achievedPasses = Sum . bool 0 1 <$> gradingPassed gr p } 
+  in case gr of PassBinary -> baseSum
+                _other     -> baseSum { achievedPoints = Just $ Sum $ p }
+sheetGradeSum (Points {..})    Nothing = mempty { sumGradePoints = Sum maxPoints }
+sheetGradeSum (PassPoints{..}) Nothing = mempty { sumGradePoints = Sum maxPoints 
+                                                , numGradePasses = Sum 1 }   
+sheetGradeSum (PassBinary)     Nothing = mempty { numGradePasses = Sum 1 }   
+                                                                  
 
 data SheetType 
-  = Bonus         { grading :: SheetGrading }
+  = Normal        { grading :: SheetGrading }
-  | Normal        { grading :: SheetGrading }
+  | Bonus         { grading :: SheetGrading }
   | Informational { grading :: SheetGrading }
   | NotGraded
   deriving (Eq, Read, Show) 
@@ -147,30 +171,20 @@ deriveJSON defaultOptions
   } ''SheetType
 derivePersistFieldJSON ''SheetType
 
-
 data SheetTypeSummary = SheetTypeSummary
-  { sumBonusPoints  :: Sum Points
+  { normalSummary, bonusSummary, informationalSummary :: SheetGradeSummary
-  , sumNormalPoints :: Sum Points
+  , numNotGraded  :: Sum Int
-  , numPassSheets   :: Sum Int
-  , numNotGraded    :: Sum Int
-  , achievedBonus   :: Maybe (Sum Points)
-  , achievedNormal  :: Maybe (Sum Points)
-  , achievedPasses  :: Maybe (Sum Int)
   } deriving (Generic)
 
 instance Monoid SheetTypeSummary where
-  mempty = memptydefault
+  mempty  = memptydefault
   mappend = mappenddefault
 
-
+sheetTypeSum :: SheetType -> Maybe Points -> SheetTypeSummary
-sheetTypeSum :: (SheetType, Maybe Points) -> SheetTypeSummary
+sheetTypeSum Bonus{..}         mps = mempty { bonusSummary         = sheetGradeSum grading mps } 
-sheetTypeSum = error "TODO sheetTypeSum"
+sheetTypeSum Normal{..}        mps = mempty { normalSummary        = sheetGradeSum grading mps } 
-{-
+sheetTypeSum Informational{..} mps = mempty { informationalSummary = sheetGradeSum grading mps } 
-sheetTypeSum (Bonus{..},  achieved) = mempty { sumBonusPoints = Sum maxPoints, achievedBonus = Sum <$> achieved }
+sheetTypeSum NotGraded _           = mempty { numNotGraded = Sum 1 }
-sheetTypeSum (Normal{..}, achieved) = mempty { sumNormalPoints = Sum maxPoints, achievedNormal = Sum <$> achieved }
-sheetTypeSum (Pass{..},   achieved) = mempty { numPassSheets = Sum 1, achievedPasses = Sum . bool 0 1 . (passingPoints <=) <$> achieved}
-sheetTypeSum (NotGraded,  _       ) = mempty { numNotGraded = Sum 1 }
--}
 
 data SheetGroup
   = Arbitrary { maxParticipants :: Natural }

src/Utils.hs

@@ -8,6 +8,7 @@ import ClassyPrelude.Yesod
 
 -- import Data.Double.Conversion.Text -- faster implementation for textPercent?
 import Data.Foldable as Fold hiding (length)
+import Data.Monoid (Sum(..))
 
 import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
@@ -303,6 +304,13 @@ ifMaybeM :: Monad m => Maybe a -> b -> (a -> m b) -> m b -- more convenient argu
 ifMaybeM Nothing dft _  = return dft
 ifMaybeM (Just x) _ act = act x
 
+maybePositive :: (Num a, Ord a) => a -> Maybe a -- convenient for Shakespear: one $maybe instead of $with & $if
+maybePositive a | a > 0     = Just a
+                | otherwise = Nothing 
+
+positiveSum :: (Num a, Ord a) => Sum a -> Maybe a -- like maybePositive                
+positiveSum (Sum x) = maybePositive x
+
 maybeM :: Monad m => m b -> (a -> m b) -> m (Maybe a) -> m b
 maybeM dft act mb = mb >>= maybe dft act
 

templates/correction.hamlet

@@ -2,9 +2,9 @@
   ^{userCorrection}
 
 <section> 
-  <form method=post enctype=#{corrEncoding}>
+  <form method=post enctype=#{corrEncoding} action=@{CSubmissionR tid ssh csh shn cid CorrectionR}>
     ^{corrForm}
 
 <section>
-  <form method=post enctype=#{uploadEncoding}>
+  <form method=post enctype=#{uploadEncoding} action=@{CSubmissionR tid ssh csh shn cid CorrectionR}>
     ^{uploadForm}

templates/corrections-upload.hamlet

@@ -1,2 +1,2 @@
-<form method=POST enctype=#{uploadEncoding}>
+<form method=POST enctype=#{uploadEncoding} action=@{CorrectionsUploadR}>
   ^{upload}

templates/corrections.hamlet

@@ -1,5 +1,5 @@
 <div .container>
-  <form method=POST enctype=#{tableEncoding}>
+  <form method=POST enctype=#{tableEncoding} action=@{currentRoute}>
     ^{table}
     <button type=submit>
       _{MsgBtnSubmit}

templates/sheetShow.hamlet

@@ -18,7 +18,7 @@ $maybe descr <- sheetDescription sheet
       <dt .deflist__dt>_{MsgSheetSolutionFrom}
       <dd .deflist__dd>#{solution}
     <dt .deflist__dt>_{MsgSheetType}
-    <dd .deflist__dd>_{sheetType sheet}
+    <dd .deflist__dd>_{SheetTypeComplete (sheetType sheet)}
     $if CorrectorSubmissions == sheetSubmissionMode sheet
       <dt .deflist__dt>_{MsgSheetPseudonym}
       <dd .deflist__dd #pseudonym>

templates/widgets/sheetTypeSummary.hamlet

@@ -1,23 +1,38 @@
-<div>
+$with realGrades <- normalSummary <> bonusSummary 
-  $if 0 < getSum sumNormalPoints
+  $with allGrades <- realGrades <> informationalSummary
-    Gesamtpunktzahl #{display (getSum sumNormalPoints)}
+    <div>
-    $maybe nPts <- (maybeAdd (getSum <$> achievedNormal) (getSum <$> achievedBonus))
+      <ul>    
-      \ davon #{display nPts} erreicht
+        $maybe realPoints <- positiveSum (sumGradePoints realGrades) 
-      $maybe bPts <- getSum <$> achievedBonus
+          <li>     
-        \ (inklusive #{display bPts} #
+            Gesamtpunktzahl #{display realPoints}
-        $if 0 < getSum sumBonusPoints
+            $maybe nPts <- getSum <$> achievedPoints realGrades
-          von #{display $ getSum sumBonusPoints} erreichbaren #
+              \ davon #{display nPts} erreicht
-        Bonuspunkten)
+              $maybe bPts <- getSum <$> achievedPoints bonusSummary
-      \ #{textPercent $ realToFrac $ nPts / (getSum sumNormalPoints)}
+                \ (inklusive #{display bPts} #
-
+                $maybe achievedBonus <- positiveSum (sumGradePoints bonusSummary)
-
+                  von #{display achievedBonus} erreichbaren #
-<div>
+                Bonuspunkten)
-  $if 0 < getSum numPassSheets
+              \ #{textPercent $ realToFrac $ nPts / realPoints}    
-    Blätter zum Bestehen: #{display (getSum numPassSheets)}
+        $maybe fakePoints <- positiveSum (sumGradePoints informationalSummary)
-    $maybe passed <- getSum <$> achievedPasses
+          <li>
-      \ davon #{display passed} bestanden.
+            <em>Hinweis: 
-
+            \ #{display fakePoints} Punkte gab es für Aufgabenblätter, #
-<div>
+            welche nicht gewertet wurden, sondern nur informativen Charakter besitzen
-  $if 0 < getSum numNotGraded
+            $maybe achievedFakes <- getSum <$> achievedPoints informationalSummary
-    Unbewertet: #{display (getSum numNotGraded)} Blätter
+              , davon wurden #{display achievedFakes} erreicht
-
+              \ #{textPercent $ realToFrac $ achievedFakes / fakePoints}    
+            .
+      
+        $maybe reqPasses <- positiveSum (numGradePasses normalSummary)      
+          <li>
+            Aufgaben zum Bestehen: #{display reqPasses}
+            $maybe passed <- getSum <$> achievedPasses realGrades
+              \ davon #{display passed} bestanden
+              $maybe bonusPassed <- getSum <$> achievedPasses bonusSummary
+                \ (inklusive #{display bonusPassed} Bonusaufgaben)
+              .
+      
+        $maybe noGradeSheets <- positiveSum numNotGraded
+          <li>
+            #{display noGradeSheets} unbewertete Aufgabenblätter.
+