From fed70610f05c7f6f28a66d9912dd345a163a8e88 Mon Sep 17 00:00:00 2001
From: SJost <jost@tcs.ifi.lmu.de>
Date: Wed, 28 Nov 2018 12:01:14 +0100
Subject: [PATCH 01/23] Summary shown for all submission, but mislabelled

---
 src/Handler/Corrections.hs                | 75 +++++++++++++----------
 src/Handler/Sheet.hs                      | 18 +++---
 templates/corrections.hamlet              |  4 +-
 templates/sheetList.hamlet                |  5 +-
 templates/widgets/sheetTypeSummary.hamlet | 21 +++----
 5 files changed, 69 insertions(+), 54 deletions(-)

diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs
index 2589ca409..34322b942 100644
--- a/src/Handler/Corrections.hs
+++ b/src/Handler/Corrections.hs
@@ -56,25 +56,33 @@ import Data.Foldable (foldrM)
 
 
 
-type CorrectionsWhere = forall query expr backend . (E.Esqueleto query expr backend) =>
-            (expr (Entity Course), expr (Entity Sheet), expr (Entity Submission))
-            -> expr (E.Value Bool)
-
-ratedBy :: Key User -> CorrectionsWhere
-ratedBy uid (_course,_sheet,submission) = submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
-
-courseIs :: Key Course -> CorrectionsWhere
-courseIs cid (course,_sheet,_submission) = course E.^. CourseId E.==. E.val cid
-
-sheetIs :: Key Sheet -> CorrectionsWhere
-sheetIs shid (_course,sheet,_submission) = sheet E.^. SheetId E.==. E.val shid
-
-submissionModeIs :: SheetSubmissionMode -> CorrectionsWhere
-submissionModeIs sMode (_course, sheet, _submission) = sheet E.^. SheetSubmissionMode E.==. E.val sMode
-
-
+type CorrectionTableExpr  = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
+type CorrectionTableWhere = CorrectionTableExpr -> E.SqlExpr (E.Value Bool)
 type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (CourseName, CourseShorthand, Key Term, Key School), Maybe (Entity User), Map UserId (User, Maybe Pseudonym))
 
+correctionsTableQuery :: CorrectionTableWhere -> (CorrectionTableExpr -> v) -> CorrectionTableExpr -> E.SqlQuery v
+correctionsTableQuery whereClause returnStatement t@((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) = do
+    E.on $ corrector E.?. UserId   E.==. submission E.^. SubmissionRatingBy
+    E.on $ sheet     E.^. SheetId  E.==. submission E.^. SubmissionSheet
+    E.on $ course    E.^. CourseId E.==. sheet      E.^. SheetCourse
+    E.where_ $ whereClause t
+    return $ returnStatement t
+
+-- Where Clauses
+ratedBy :: UserId -> CorrectionTableWhere
+ratedBy uid   ((_course `E.InnerJoin` _sheet `E.InnerJoin`  submission) `E.LeftOuterJoin` _corrector) = submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
+
+courseIs :: CourseId -> CorrectionTableWhere
+courseIs cid  (( course `E.InnerJoin` _sheet `E.InnerJoin` _submission) `E.LeftOuterJoin` _corrector) = course E.^. CourseId E.==. E.val cid
+
+sheetIs :: Key Sheet -> CorrectionTableWhere
+sheetIs shid  ((_course `E.InnerJoin`  sheet `E.InnerJoin` _submission) `E.LeftOuterJoin` _corrector) = sheet E.^. SheetId E.==. E.val shid
+
+submissionModeIs :: SheetSubmissionMode -> CorrectionTableWhere
+submissionModeIs sMode ((_course `E.InnerJoin` sheet `E.InnerJoin` _submission) `E.LeftOuterJoin` _corrector) = sheet E.^. SheetSubmissionMode E.==. E.val sMode
+
+
+-- Columns
 colTerm :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
 colTerm = sortable (Just "term") (i18nCell MsgTerm)
         $ \DBRow{ dbrOutput=(_, _, course, _, _) } ->
@@ -176,23 +184,19 @@ colCommentField = sortable Nothing (i18nCell MsgRatingComment) $ formCell
   (\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _) } _ -> over (_1.mapped) ((_3 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvInput <$> mopt textareaField "" (Just $ Textarea <$> submissionRatingComment))
 
 
-type CorrectionTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
-
 makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h )
-                     => _ -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> _ -> Handler (DBResult m x)
+                     => CorrectionTableWhere -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> _ -> Handler (DBResult m x)
 makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do
   let dbtSQLQuery :: CorrectionTableExpr -> E.SqlQuery _
-      dbtSQLQuery ((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) = do
-        E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy
-        E.on $ sheet  E.^. SheetId  E.==. submission E.^. SubmissionSheet
-        E.on $ course E.^. CourseId E.==. sheet      E.^. SheetCourse
-        E.where_ $ whereClause (course,sheet,submission)
-        let crse =  ( course E.^. CourseName      :: E.SqlExpr (E.Value CourseName)
-                    , course E.^. CourseShorthand
-                    , course E.^. CourseTerm
-                    , course E.^. CourseSchool    :: E.SqlExpr (E.Value SchoolId)
-                    )
-        return (submission, sheet, crse, corrector)
+      dbtSQLQuery = correctionsTableQuery whereClause
+          (\((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) ->
+            let crse =  ( course E.^. CourseName      :: E.SqlExpr (E.Value CourseName)
+                        , course E.^. CourseShorthand
+                        , course E.^. CourseTerm
+                        , course E.^. CourseSchool    :: E.SqlExpr (E.Value SchoolId)
+                        )
+            in (submission, sheet, crse, corrector)
+          )
       dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CorrectionTableData
       dbtProj = traverse $ \(submission@(Entity sId _), sheet@(Entity shId _), (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector) -> do
         submittors <- lift . E.select . E.from $ \((submissionUser `E.InnerJoin` user) `E.LeftOuterJoin` pseudonym) -> do
@@ -356,9 +360,16 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
             addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsNotAssignedAuto.hamlet") mr)
       redirect currentRoute
 
+  SheetTypeSummary{..} <- runDB $ do
+      let getTypePoints ((_course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` _corrector) = (sheet E.^. SheetType, submission E.^. SubmissionRatingPoints, submission E.^. SubmissionRatingTime)
+      points <- E.select . E.from $ correctionsTableQuery whereClause getTypePoints
+      -- points <- E.select . E.from $ t@((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) -> (correctionsTableQuery whereClause getTypePoints t) <* E.distinctOn []
+      return $ foldMap (\(E.Value stype, E.Value srpoints, E.Value srtime) -> sheetTypeSum stype (srpoints <* srtime)) points
+  let statistics = $(widgetFile "widgets/sheetTypeSummary")
   fmap toTypedContent . defaultLayout $ do
     setTitleI MsgCourseCorrectionsTitle
     $(widgetFile "corrections")
+
   where
     authorizedToAssign :: SubmissionId -> DB Bool
     authorizedToAssign sId = do
@@ -639,7 +650,7 @@ postCorrectionsCreateR = do
     FormFailure errs -> forM_ errs $ addMessage Error . toHtml
     FormSuccess (sid, (pss, invalids)) -> do
       forM_ (Map.toList invalids) $ \((oPseudonyms, iPseudonym), alts) -> $(addMessageFile Warning "templates/messages/ignoredInvalidPseudonym.hamlet")
-      
+
       runDB $ do
         Sheet{..} <- get404 sid
         (sps, unknown) <- fmap partitionEithers' . forM pss . mapM $ \p -> maybe (Left p) Right <$> getBy (UniqueSheetPseudonym sid p)
diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs
index 919dc3f53..0ab687490 100644
--- a/src/Handler/Sheet.hs
+++ b/src/Handler/Sheet.hs
@@ -62,7 +62,7 @@ data SheetForm = SheetForm
       { sfName         :: SheetName
       , sfDescription  :: Maybe Html
       , sfType         :: SheetType
-      , sfGrouping     :: SheetGroup      
+      , sfGrouping     :: SheetGroup
       , sfVisibleFrom  :: Maybe UTCTime
       , sfActiveFrom   :: UTCTime
       , sfActiveTo     :: UTCTime
@@ -98,7 +98,7 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
       <*> aopt htmlField      (fslI MsgSheetDescription)  (sfDescription <$> template)
       <*> sheetTypeAFormReq   (fslI MsgSheetType
             & setTooltip MsgSheetTypeInfo)                  (sfType        <$> template)
-      <*> sheetGroupAFormReq  (fslI MsgSheetGroup)        (sfGrouping    <$> template)      
+      <*> sheetGroupAFormReq  (fslI MsgSheetGroup)        (sfGrouping    <$> template)
       <*> aopt utcTimeField   (fslI MsgSheetVisibleFrom
             & setTooltip MsgSheetVisibleFromTip)
                                                               ((sfVisibleFrom  <$> template) <|> pure (Just ctime))
@@ -118,7 +118,7 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
       <*> aopt (multiFileField $ oldFileIds SheetSolution) (fslI MsgSheetSolution) (sfSolutionF <$> template)
       <*> aopt (multiFileField $ oldFileIds SheetMarking)  (fslI MsgSheetMarking
             & setTooltip MsgSheetMarkingTip)   (sfMarkingF <$> template)
-      <*> aopt htmlField      (fslI MsgSheetMarking)      (sfMarkingText <$> template)            
+      <*> aopt htmlField      (fslI MsgSheetMarking)      (sfMarkingText <$> template)
       <*  submitButton
     return $ case result of
       FormSuccess sheetResult
@@ -137,7 +137,7 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
       ] ]
 
 getSheetListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
-getSheetListR tid ssh csh = do 
+getSheetListR tid ssh csh = do
   muid <- maybeAuthId
   Entity cid _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
   let
@@ -180,7 +180,7 @@ getSheetListR tid ssh csh = do
                       cid' <- mkCid
                       return $ CSubmissionR tid ssh csh sheetName cid' CorrectionR
                 in anchorCellM mkRoute $(widgetFile "widgets/rating")
-      , sortable Nothing -- (Just "percent") 
+      , sortable Nothing -- (Just "percent")
                         (i18nCell MsgRatingPercent)
           $ \(Entity _ Sheet{sheetType=sType}, _, mbSub) -> case mbSub of
               (Just (Entity _ Submission{submissionRatingPoints=Just sPoints})) ->
@@ -188,7 +188,7 @@ getSheetListR tid ssh csh = do
                   Just maxPoints
                     | maxPoints /= 0 ->
                         let percent = sPoints / maxPoints
-                        in textCell $ textPercent $ realToFrac percent    
+                        in textCell $ textPercent $ realToFrac percent
                   _other -> mempty
               _other -> mempty
       ]
@@ -236,9 +236,9 @@ getSheetListR tid ssh csh = do
       E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
       return (sheet E.^. SheetType, submission E.?. SubmissionRatingPoints)
     return $ foldMap (\(E.Value sheetType, E.Value mbPts) -> sheetTypeSum sheetType (join mbPts)) rows
+  let statistics = $(widgetFile "widgets/sheetTypeSummary")
   defaultLayout $ do
     $(widgetFile "sheetList")
-    $(widgetFile "widgets/sheetTypeSummary")
 
 data ButtonGeneratePseudonym = BtnGenerate
   deriving (Enum, Eq, Ord, Bounded, Read, Show)
@@ -398,7 +398,7 @@ getSheetNewR tid ssh csh = do
           { sfName         = stepTextCounterCI sheetName
           , sfDescription  = sheetDescription
           , sfType         = sheetType
-          , sfGrouping     = sheetGrouping          
+          , sfGrouping     = sheetGrouping
           , sfVisibleFrom  = addOneWeek <$> sheetVisibleFrom
           , sfActiveFrom   = addOneWeek     sheetActiveFrom
           , sfActiveTo     = addOneWeek     sheetActiveTo
@@ -431,7 +431,7 @@ getSEditR tid ssh csh shn = do
         { sfName         = sheetName
         , sfDescription  = sheetDescription
         , sfType         = sheetType
-        , sfGrouping     = sheetGrouping        
+        , sfGrouping     = sheetGrouping
         , sfVisibleFrom  = sheetVisibleFrom
         , sfActiveFrom   = sheetActiveFrom
         , sfActiveTo     = sheetActiveTo
diff --git a/templates/corrections.hamlet b/templates/corrections.hamlet
index ae932745a..8dcaa38fb 100644
--- a/templates/corrections.hamlet
+++ b/templates/corrections.hamlet
@@ -1,5 +1,7 @@
-<div .container>
+<section>
   <form method=POST enctype=#{tableEncoding} action=@{currentRoute}>
     ^{table}
     <button type=submit>
       _{MsgBtnSubmit}
+<section>
+  ^{statistics}
\ No newline at end of file
diff --git a/templates/sheetList.hamlet b/templates/sheetList.hamlet
index 697c30b25..1bff2f32a 100644
--- a/templates/sheetList.hamlet
+++ b/templates/sheetList.hamlet
@@ -1 +1,4 @@
-^{table}
+<section>
+  ^{table}
+<section>
+  ^{statistics}
\ No newline at end of file
diff --git a/templates/widgets/sheetTypeSummary.hamlet b/templates/widgets/sheetTypeSummary.hamlet
index b3bb512f7..62572e5e5 100644
--- a/templates/widgets/sheetTypeSummary.hamlet
+++ b/templates/widgets/sheetTypeSummary.hamlet
@@ -1,9 +1,8 @@
-$with realGrades <- normalSummary <> bonusSummary 
+$with realGrades <- normalSummary <> bonusSummary
   $# $with allGrades <- realGrades <> informationalSummary
   <div>
-    <ul>    
-      $maybe realPoints <- positiveSum (sumGradePoints realGrades) 
-        <li>     
+      $maybe realPoints <- positiveSum (sumGradePoints realGrades)
+        <p>
           Gesamtpunktzahl #{display realPoints}
           $maybe nPts <- getSum <$> achievedPoints realGrades
             \ davon #{display nPts} erreicht
@@ -13,21 +12,21 @@ $with realGrades <- normalSummary <> bonusSummary
                 von #{display achievedBonus} erreichbaren #
               Bonuspunkten)
             $if realPoints /= 0
-              \ #{textPercent $ realToFrac $ nPts / realPoints}    
+              \ #{textPercent $ realToFrac $ nPts / realPoints}
             \.
       $maybe fakePoints <- positiveSum (sumGradePoints informationalSummary)
-        <li>
-          <em>Hinweis: 
+        <p>
+          <em>Hinweis:
           \ #{display fakePoints} Punkte gab es für Aufgabenblätter, #
           welche nicht gewertet wurden, sondern nur informativen Charakter besitzen
           $maybe achievedFakes <- getSum <$> achievedPoints informationalSummary
             , davon wurden #{display achievedFakes} erreicht
             $if fakePoints /= 0
-              \ #{textPercent $ realToFrac $ achievedFakes / fakePoints}    
+              \ #{textPercent $ realToFrac $ achievedFakes / fakePoints}
           \.
 
-      $maybe reqPasses <- positiveSum (numGradePasses normalSummary)      
-        <li>
+      $maybe reqPasses <- positiveSum (numGradePasses normalSummary)
+        <p>
           Aufgaben zum Bestehen: #{display reqPasses}
           $maybe passed <- getSum <$> achievedPasses realGrades
             \ davon #{display passed} bestanden
@@ -36,6 +35,6 @@ $with realGrades <- normalSummary <> bonusSummary
             \.
 
       $maybe noGradeSheets <- positiveSum numNotGraded
-        <li>
+        <p>
           #{display noGradeSheets} unbewertete Aufgabenblätter.
 

From 2308771350606af8c37a55dacb34d2b29c68427a Mon Sep 17 00:00:00 2001
From: SJost <jost@tcs.ifi.lmu.de>
Date: Fri, 30 Nov 2018 14:31:05 +0100
Subject: [PATCH 02/23] NO COMPILE. Templates for summaries done, but nestes
 does not (still)  work. Duh.

---
 .vscode/tasks.json                         |  4 +-
 messages/uniworx/de.msg                    |  2 +
 src/Handler/Corrections.hs                 |  9 ++-
 src/Model/Rating.hs                        | 19 +++++-
 src/Model/Types.hs                         | 67 +++++++++++++---------
 src/Utils.hs                               | 11 ++--
 templates/widgets/gradingSummary.hamlet    | 35 +++++++++++
 templates/widgets/gradingSummaryRow.hamlet | 33 +++++++++++
 templates/widgets/sheetTypeSummary.hamlet  |  1 +
 9 files changed, 145 insertions(+), 36 deletions(-)
 create mode 100644 templates/widgets/gradingSummary.hamlet
 create mode 100644 templates/widgets/gradingSummaryRow.hamlet

diff --git a/.vscode/tasks.json b/.vscode/tasks.json
index 9f3625c7e..8b60430d0 100644
--- a/.vscode/tasks.json
+++ b/.vscode/tasks.json
@@ -1,4 +1,4 @@
-{  
+{
   "version": "2.0.0",
   "tasks": [
     {
@@ -11,7 +11,7 @@
       },
       "presentation": {
         "echo": true,
-        "reveal": "silent",
+        "reveal": "always",
         "focus": false,
         "panel": "dedicated",
         "showReuseMessage": false
diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg
index 86c1d0cd5..cbc27001c 100644
--- a/messages/uniworx/de.msg
+++ b/messages/uniworx/de.msg
@@ -379,7 +379,9 @@ SheetGradingPassPoints maxPoints@Points passingPoints@Points: Bestanden ab #{tsh
 SheetGradingPassBinary:  Bestanden/Nicht Bestanden
 SheetGradingInfo: "Bestanden nach Punkten" zählt sowohl zur maximal erreichbaren Gesamtpunktzahl also auch zur Anzahl der zu bestehenden Blätter.
 
+SheetGradingCount': Anzahl
 SheetGradingPoints': Punkte
+SheetGradingPassing': Bestehen
 SheetGradingPassPoints': Bestehen nach Punkten
 SheetGradingPassBinary': Bestanden/Nicht bestanden
 
diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs
index 34322b942..fb124c041 100644
--- a/src/Handler/Corrections.hs
+++ b/src/Handler/Corrections.hs
@@ -360,12 +360,12 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
             addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsNotAssignedAuto.hamlet") mr)
       redirect currentRoute
 
-  SheetTypeSummary{..} <- runDB $ do
+  gradingSummary <- runDB $ do
       let getTypePoints ((_course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` _corrector) = (sheet E.^. SheetType, submission E.^. SubmissionRatingPoints, submission E.^. SubmissionRatingTime)
       points <- E.select . E.from $ correctionsTableQuery whereClause getTypePoints
       -- points <- E.select . E.from $ t@((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) -> (correctionsTableQuery whereClause getTypePoints t) <* E.distinctOn []
       return $ foldMap (\(E.Value stype, E.Value srpoints, E.Value srtime) -> sheetTypeSum stype (srpoints <* srtime)) points
-  let statistics = $(widgetFile "widgets/sheetTypeSummary")
+  let statistics = $(widgetFile "widgets/gradingSummary")
   fmap toTypedContent . defaultLayout $ do
     setTitleI MsgCourseCorrectionsTitle
     $(widgetFile "corrections")
@@ -383,6 +383,11 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
       let route  = CSubmissionR tid ssh csh shn cID SAssignR
       (== Authorized) <$> evalAccessDB route True
 
+gradeSummaryWidget ::  SheetTypeSummary -> Widget UniWorX IO ()
+gradeSummaryWidget sts = undefined
+
+
+
 type ActionCorrections' = (ActionCorrections, AForm (HandlerT UniWorX IO) ActionCorrectionsData)
 
 downloadAction :: ActionCorrections'
diff --git a/src/Model/Rating.hs b/src/Model/Rating.hs
index 6ce7760f5..b4c18b801 100644
--- a/src/Model/Rating.hs
+++ b/src/Model/Rating.hs
@@ -2,7 +2,8 @@ module Model.Rating where
 
 import ClassyPrelude.Yesod
 import Model
-
+import Utils
+import Control.Lens
 -- import Data.Text (Text)
 import Data.Text.Encoding.Error (UnicodeException(..))
 import GHC.Generics (Generic)
@@ -35,3 +36,19 @@ data RatingException = RatingNotUnicode UnicodeException -- ^ Rating failed to p
   deriving (Show, Eq, Generic, Typeable)
 
 instance Exception RatingException
+
+-- TODO: maybe move elsewhere, but Model is a bit overful already
+addBonusToPoints :: SheetTypeSummary -> SheetTypeSummary
+addBonusToPoints sts =
+    sts & _normalSummary . _achievedPoints %~ maxBonusPts  . addBonusPts
+        & _normalSummary . _achievedPasses %~ maxBonusPass . addBonusPass
+  where
+    bonusPoints  = sts ^. _bonusSummary  . _achievedPoints
+    maxPoints    = sts ^. _normalSummary . _sumGradePoints
+    maxBonusPts  = fmap $ min maxPoints
+    addBonusPts  = maybeAdd bonusPoints
+
+    bonusPasses  = sts ^. _bonusSummary  . _achievedPasses
+    maxPasses    = sts ^. _normalSummary . _numGradePasses
+    maxBonusPass = fmap $ min maxPasses
+    addBonusPass = maybeAdd bonusPasses
diff --git a/src/Model/Types.hs b/src/Model/Types.hs
index 186bced96..f92babd87 100644
--- a/src/Model/Types.hs
+++ b/src/Model/Types.hs
@@ -121,10 +121,10 @@ data SheetGrading
   | PassBinary -- non-zero means passed
   deriving (Eq, Read, Show)
 
-deriveJSON defaultOptions 
+deriveJSON defaultOptions
   { constructorTagModifier = intercalate "-" . map toLower . splitCamel
   , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
-  , sumEncoding = TaggedObject "type" "data"  
+  , sumEncoding = TaggedObject "type" "data"
   } ''SheetGrading
 derivePersistFieldJSON ''SheetGrading
 
@@ -133,59 +133,74 @@ gradingPassed (Points {}) _ = Nothing
 gradingPassed (PassPoints {..}) pts = Just $ pts >= passingPoints
 gradingPassed (PassBinary {}) pts = Just $ pts /= 0
 
-data SheetGradeSummary = SheetGradeSummary 
-  { sumGradePoints :: Sum Points
+data SheetGradeSummary = SheetGradeSummary
+  { numSheets      :: Sum Int
   , numGradePasses :: Sum Int
-  , achievedPoints :: Maybe (Sum Points)
+  , sumGradePoints :: Sum Points
   , achievedPasses :: Maybe (Sum Int)
-} deriving (Generic)
+  , achievedPoints :: Maybe (Sum Points)
+} deriving (Generic, Show) -- TODO: Show added for Debugging only
 
 instance Monoid SheetGradeSummary where
   mempty  = memptydefault
   mappend = mappenddefault
 
-instance Semigroup SheetGradeSummary where 
-  (<>) = mappend -- remove for GHC > 8.4.x
+instance Semigroup SheetGradeSummary where
+  (<>) = mappend -- TODO: 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 } 
+makeLenses_ ''SheetGradeSummary
+
+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 }   
-                                                                  
+sheetGradeSum (Points {..})    Nothing = mempty { numSheets      = Sum 1
+                                                , sumGradePoints = Sum maxPoints
+                                                }
+sheetGradeSum (PassPoints{..}) Nothing = mempty { numSheets      = Sum 1
+                                                , numGradePasses = Sum 1
+                                                , sumGradePoints = Sum maxPoints
+                                                }
+sheetGradeSum (PassBinary)     Nothing = mempty { numSheets      = Sum 1
+                                                , numGradePasses = Sum 1
+                                                }
 
-data SheetType 
+data SheetType
   = Normal        { grading :: SheetGrading }
   | Bonus         { grading :: SheetGrading }
   | Informational { grading :: SheetGrading }
   | NotGraded
-  deriving (Eq, Read, Show) 
+  deriving (Eq, Read, Show)
 
 deriveJSON defaultOptions
   { constructorTagModifier = intercalate "-" . map toLower . splitCamel
   , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
-  , sumEncoding = TaggedObject "type" "data"  
+  , sumEncoding = TaggedObject "type" "data"
   } ''SheetType
 derivePersistFieldJSON ''SheetType
 
 data SheetTypeSummary = SheetTypeSummary
-  { normalSummary, bonusSummary, informationalSummary :: SheetGradeSummary
-  , numNotGraded  :: Sum Int
-  } deriving (Generic)
+  { normalSummary
+  , bonusSummary
+  , informationalSummary :: SheetGradeSummary
+  , numNotGraded :: Sum Int
+  } deriving (Generic, Show) -- TODO: Show added for Debugging only
 
 instance Monoid SheetTypeSummary where
   mempty  = memptydefault
   mappend = mappenddefault
 
+instance Semigroup SheetTypeSummary where
+  (<>) = mappend -- TODO: remove for GHC > 8.4.x
+
+makeLenses_ ''SheetTypeSummary
+
 sheetTypeSum :: SheetType -> Maybe Points -> SheetTypeSummary
-sheetTypeSum Bonus{..}         mps = mempty { bonusSummary         = sheetGradeSum grading mps } 
-sheetTypeSum Normal{..}        mps = mempty { normalSummary        = sheetGradeSum grading mps } 
-sheetTypeSum Informational{..} mps = mempty { informationalSummary = sheetGradeSum grading mps } 
-sheetTypeSum NotGraded _           = mempty { numNotGraded = Sum 1 }
+sheetTypeSum Bonus{..}         mps = mempty { bonusSummary         = sheetGradeSum grading mps }
+sheetTypeSum Normal{..}        mps = mempty { normalSummary        = sheetGradeSum grading mps }
+sheetTypeSum Informational{..} mps = mempty { informationalSummary = sheetGradeSum grading mps }
+sheetTypeSum NotGraded _           = mempty { numNotGraded         = Sum 1 }
 
 data SheetGroup
   = Arbitrary { maxParticipants :: Natural }
diff --git a/src/Utils.hs b/src/Utils.hs
index a451eb70b..f9d897630 100644
--- a/src/Utils.hs
+++ b/src/Utils.hs
@@ -185,6 +185,9 @@ textPercent x = lz <> pack (show rx) <> "%"
    rx = fromIntegral (round' $ 1000.0*x) / 10.0
    lz = if rx < 10.0 then "0" else ""
 
+textPercentInt :: Integral a => a -> a -> Text -- slow, maybe use Data.Double.Conversion.Text.toFixed instead?
+textPercentInt part whole = textPercent $ (fromIntegral part) / (fromIntegral whole)
+
 stepTextCounterCI :: CI Text -> CI Text -- find and increment rightmost-number, preserving leading zeroes
 stepTextCounterCI = CI.map stepTextCounter
 
@@ -289,14 +292,13 @@ toNothing = const Nothing
 toNothingS :: String -> Maybe b
 toNothingS = const Nothing
 
-maybeAdd :: Num a => Maybe a -> Maybe a -> Maybe a -- treats Nothing as neutral/zero, unlike fmap
+maybeAdd :: Num a => Maybe a -> Maybe a -> Maybe a -- treats Nothing as neutral/zero, unlike fmap/ap
 maybeAdd (Just x) (Just y) = Just (x + y)
 maybeAdd Nothing y  = y
 maybeAdd x Nothing  = x
 
 maybeEmpty :: Monoid m => Maybe a -> (a -> m) -> m
-maybeEmpty (Just x) f = f x
-maybeEmpty Nothing  _ = mempty
+maybeEmpty = flip foldMap
 
 whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
 whenIsJust (Just x) f = f x
@@ -311,7 +313,7 @@ maybePositive a | a > 0     = Just a
                 | otherwise = Nothing
 
 positiveSum :: (Num a, Ord a) => Sum a -> Maybe a -- like maybePositive
-positiveSum (Sum x) = maybePositive x
+positiveSum = maybePositive . getSum
 
 maybeM :: Monad m => m b -> (a -> m b) -> m (Maybe a) -> m b
 maybeM dft act mb = mb >>= maybe dft act
@@ -341,7 +343,6 @@ instance Ord a => Ord (NTop (Maybe a)) where
   compare (NTop (Just x)) (NTop (Just y)) = compare x y
 
 
-
 ------------
 -- Either --
 ------------
diff --git a/templates/widgets/gradingSummary.hamlet b/templates/widgets/gradingSummary.hamlet
new file mode 100644
index 000000000..7f0bd786f
--- /dev/null
+++ b/templates/widgets/gradingSummary.hamlet
@@ -0,0 +1,35 @@
+$# Displays gradings Summary for various purposes
+$# --
+$with SheetTypeSummary{..} <- addBonusToPoints gradingSummary
+  $with sumSummaries <- mappend normalSummary (mappend bonusSummary informationalSummary)
+    $with hasPassings <- positiveSum $ numGradePasses sumSummaries
+      $with hasPoints  <- positiveSum $ sumGradePoints sumSummaries
+        <div>
+          <table>
+            <tr>
+              <th>
+              $# empty cell for row headers
+              $maybe _ <- hasPassings
+                <th colspan=2>_{MsgSheetGradingPassing'}
+              $maybe _ <- hasPoints
+                <th colspan=2>_{MsgSheetGradingPoints'}
+              <th>_{MsgSheetGradingCount'}
+                $# Number of Sheet/Submissions used for calculating maximum passes/points
+            $with sumHeader <- MsgSheetTypeNormal'
+              $with summary <- normalSummary
+                ^{gradingSummaryRow}
+            $# $for (sumHeader, summary) <- [(MsgSheetTypeNormal',normalSummary),(MsgSheetTypeBonus',bonusSummary),(MsgSheetTypeInformational',informationalSummary)]
+            $# ^{gradingSummaryRow}
+              DEBUG
+            $maybe nrNoGrade <- positiveSum $ numNotGraded
+              <tr>
+                <th>_{MsgSheetTypeNotGraded}
+                $maybe _ <- hasPassings
+                  <td colspan=2>
+                $maybe _ <- hasPoints
+                  <td colspan=2>
+                <td>#{display nrNoGrade}
+          $maybe _ <- positiveSum $ bonusSummary ^. _numSheets
+            <p>_{MsgSheetTypeInfo}
+          $nothing
+            <p>_{MsgSheetTypeInfo}
\ No newline at end of file
diff --git a/templates/widgets/gradingSummaryRow.hamlet b/templates/widgets/gradingSummaryRow.hamlet
new file mode 100644
index 000000000..46e4375bb
--- /dev/null
+++ b/templates/widgets/gradingSummaryRow.hamlet
@@ -0,0 +1,33 @@
+$# Displays one row of the grading summary
+$# Expects several variables:
+$#  hasPassing :: Maybe Int    -- Should Passing be displayed?
+$#  hasPoints  :: Maybe Poibts -- Should Points  be displayed?
+$#  summary    :: SheetGradeSummary -- summary to display
+$#  sumHeader  :: UniWorXMessage    -- row header
+$#
+  $maybe nrSheets <- positiveSum $ summary ^. _numSheets
+    <tr>
+      <th>_{sumHeader}
+      $maybe _ <- hasPassings
+        $with Sum pmax <- sumHeader ^. _numGradePasses
+          $maybe Sum pacv <- summary ^. _achievedPasses
+              <td>
+                $if pmax /= 0
+                  #{textPercentInt pacv pmax}
+              <td>
+                #{display pacv} / #{display pmax}
+          $nothing
+            <td colspan=2>
+              #{display pmax }
+      $maybe _ <- hasPoints
+        $with Sum pmax <- sumHeader ^. _sumGradePoints
+          $maybe Sum pacv <- summary ^. _achievedPoints
+              <td>
+                $if pmax /= 0
+                  #{textPercent $ realToFrac $ pacv / pmax}
+              <td>
+                #{display pacv} / #{display pmax}
+          $nothing
+            <td colspan=2>
+              #{display pmax }
+      <td>#{display nrSheets}
\ No newline at end of file
diff --git a/templates/widgets/sheetTypeSummary.hamlet b/templates/widgets/sheetTypeSummary.hamlet
index 62572e5e5..8609b82b2 100644
--- a/templates/widgets/sheetTypeSummary.hamlet
+++ b/templates/widgets/sheetTypeSummary.hamlet
@@ -1,3 +1,4 @@
+$# DEPRECATED IN FAVOUR OF widgets/gradingSummary.hamlet DO NOT USE !!!
 $with realGrades <- normalSummary <> bonusSummary
   $# $with allGrades <- realGrades <> informationalSummary
   <div>

From 81d8d8c017383c2551eb8bce6b64d2f9c261b184 Mon Sep 17 00:00:00 2001
From: SJost <jost@tcs.ifi.lmu.de>
Date: Fri, 30 Nov 2018 14:44:23 +0100
Subject: [PATCH 03/23] NO COMPILE. Templates for summaries done, but nestes
 does not (still)  work. Duh.

---
 src/Handler/Corrections.hs              | 16 +++++--
 templates/widgets/gradingSummary.hamlet | 58 +++++++++++--------------
 2 files changed, 38 insertions(+), 36 deletions(-)

diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs
index fb124c041..7a97f8b22 100644
--- a/src/Handler/Corrections.hs
+++ b/src/Handler/Corrections.hs
@@ -365,7 +365,7 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
       points <- E.select . E.from $ correctionsTableQuery whereClause getTypePoints
       -- points <- E.select . E.from $ t@((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) -> (correctionsTableQuery whereClause getTypePoints t) <* E.distinctOn []
       return $ foldMap (\(E.Value stype, E.Value srpoints, E.Value srtime) -> sheetTypeSum stype (srpoints <* srtime)) points
-  let statistics = $(widgetFile "widgets/gradingSummary")
+  let statistics = gradeSummaryWidget gradingSummary
   fmap toTypedContent . defaultLayout $ do
     setTitleI MsgCourseCorrectionsTitle
     $(widgetFile "corrections")
@@ -384,8 +384,18 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
       (== Authorized) <$> evalAccessDB route True
 
 gradeSummaryWidget ::  SheetTypeSummary -> Widget UniWorX IO ()
-gradeSummaryWidget sts = undefined
-
+gradeSummaryWidget sts =
+  let SheetTypeSummary{..} = addBonusToPoints sts
+      sumSummaries = (normalSummary <> bonusSummary <> informationalSummary) # _numSheets %~ (<> numNotGraded)
+      hasPassings  = positiveSum $ numGradePasses sumSummaries
+      hasPoints    = positiveSum $ sumGradePoints sumSummaries
+      rowWdgts =  [ $(widgetFile "widgets/gradingSummaryRow")
+                  | (sumHeader,summary) <-
+                    [ (MsgSheetTypeNormal'        ,normalSummary)
+                    , (MsgSheetTypeBonus'         ,bonusSummary)
+                    , (MsgSheetTypeInformational' ,informationalSummary)
+                  ] ]
+  in $(widgetFile "widgets/gradingSummary")
 
 
 type ActionCorrections' = (ActionCorrections, AForm (HandlerT UniWorX IO) ActionCorrectionsData)
diff --git a/templates/widgets/gradingSummary.hamlet b/templates/widgets/gradingSummary.hamlet
index 7f0bd786f..08f04b9e5 100644
--- a/templates/widgets/gradingSummary.hamlet
+++ b/templates/widgets/gradingSummary.hamlet
@@ -1,35 +1,27 @@
 $# Displays gradings Summary for various purposes
 $# --
-$with SheetTypeSummary{..} <- addBonusToPoints gradingSummary
-  $with sumSummaries <- mappend normalSummary (mappend bonusSummary informationalSummary)
-    $with hasPassings <- positiveSum $ numGradePasses sumSummaries
-      $with hasPoints  <- positiveSum $ sumGradePoints sumSummaries
-        <div>
-          <table>
-            <tr>
-              <th>
-              $# empty cell for row headers
-              $maybe _ <- hasPassings
-                <th colspan=2>_{MsgSheetGradingPassing'}
-              $maybe _ <- hasPoints
-                <th colspan=2>_{MsgSheetGradingPoints'}
-              <th>_{MsgSheetGradingCount'}
-                $# Number of Sheet/Submissions used for calculating maximum passes/points
-            $with sumHeader <- MsgSheetTypeNormal'
-              $with summary <- normalSummary
-                ^{gradingSummaryRow}
-            $# $for (sumHeader, summary) <- [(MsgSheetTypeNormal',normalSummary),(MsgSheetTypeBonus',bonusSummary),(MsgSheetTypeInformational',informationalSummary)]
-            $# ^{gradingSummaryRow}
-              DEBUG
-            $maybe nrNoGrade <- positiveSum $ numNotGraded
-              <tr>
-                <th>_{MsgSheetTypeNotGraded}
-                $maybe _ <- hasPassings
-                  <td colspan=2>
-                $maybe _ <- hasPoints
-                  <td colspan=2>
-                <td>#{display nrNoGrade}
-          $maybe _ <- positiveSum $ bonusSummary ^. _numSheets
-            <p>_{MsgSheetTypeInfo}
-          $nothing
-            <p>_{MsgSheetTypeInfo}
\ No newline at end of file
+<div>
+  <table>
+    <tr>
+      <th>
+      $# empty cell for row headers
+      $maybe _ <- hasPassings
+        <th colspan=2>_{MsgSheetGradingPassing'}
+      $maybe _ <- hasPoints
+        <th colspan=2>_{MsgSheetGradingPoints'}
+      <th>_{MsgSheetGradingCount'}
+        $# Number of Sheet/Submissions used for calculating maximum passes/points
+    $forall row <- rowWdgts
+      ^{row}
+    $maybe nrNoGrade <- positiveSum $ numNotGraded
+      <tr>
+        <th>_{MsgSheetTypeNotGraded}
+        $maybe _ <- hasPassings
+          <td colspan=2>
+        $maybe _ <- hasPoints
+          <td colspan=2>
+        <td>#{display nrNoGrade}
+  $maybe _ <- positiveSum $ bonusSummary ^. _numSheets
+    <p>_{MsgSheetTypeInfo}
+  $nothing
+    <p>_{MsgSheetTypeInfo}
\ No newline at end of file

From 42915b3920c9a82c0cecd74d31824860346d8044 Mon Sep 17 00:00:00 2001
From: SJost <jost@tcs.ifi.lmu.de>
Date: Fri, 30 Nov 2018 15:33:27 +0100
Subject: [PATCH 04/23] Proper statistics implemented for submission lists

---
 messages/uniworx/de.msg                    |  3 ++-
 src/Handler/Corrections.hs                 |  8 +++++---
 templates/widgets/gradingSummary.hamlet    | 22 ++++++++++++----------
 templates/widgets/gradingSummaryRow.hamlet | 22 +++++++++++-----------
 4 files changed, 30 insertions(+), 25 deletions(-)

diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg
index cbc27001c..a8521f735 100644
--- a/messages/uniworx/de.msg
+++ b/messages/uniworx/de.msg
@@ -389,7 +389,8 @@ 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.
+SheetTypeInfo: Bonus Blätter zählen normal, 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.
+SheetGradingBonusIncluded: Erzielte Bonuspunkte wurden hier bereits zu den normalen Punkten hinzugezählt.
 
 SheetTypeBonus': Bonus
 SheetTypeNormal': Normal
diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs
index 7a97f8b22..41375eab1 100644
--- a/src/Handler/Corrections.hs
+++ b/src/Handler/Corrections.hs
@@ -383,10 +383,10 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
       let route  = CSubmissionR tid ssh csh shn cID SAssignR
       (== Authorized) <$> evalAccessDB route True
 
-gradeSummaryWidget ::  SheetTypeSummary -> Widget UniWorX IO ()
+gradeSummaryWidget ::  SheetTypeSummary -> Widget
 gradeSummaryWidget sts =
   let SheetTypeSummary{..} = addBonusToPoints sts
-      sumSummaries = (normalSummary <> bonusSummary <> informationalSummary) # _numSheets %~ (<> numNotGraded)
+      sumSummaries = (normalSummary <> bonusSummary <> informationalSummary) --  # _numSheets %~ (<> numNotGraded)
       hasPassings  = positiveSum $ numGradePasses sumSummaries
       hasPoints    = positiveSum $ sumGradePoints sumSummaries
       rowWdgts =  [ $(widgetFile "widgets/gradingSummaryRow")
@@ -395,7 +395,9 @@ gradeSummaryWidget sts =
                     , (MsgSheetTypeBonus'         ,bonusSummary)
                     , (MsgSheetTypeInformational' ,informationalSummary)
                   ] ]
-  in $(widgetFile "widgets/gradingSummary")
+  in if 0 == numSheets sumSummaries
+        then mempty
+        else $(widgetFile "widgets/gradingSummary")
 
 
 type ActionCorrections' = (ActionCorrections, AForm (HandlerT UniWorX IO) ActionCorrectionsData)
diff --git a/templates/widgets/gradingSummary.hamlet b/templates/widgets/gradingSummary.hamlet
index 08f04b9e5..3967a8f37 100644
--- a/templates/widgets/gradingSummary.hamlet
+++ b/templates/widgets/gradingSummary.hamlet
@@ -1,27 +1,29 @@
 $# Displays gradings Summary for various purposes
 $# --
 <div>
-  <table>
-    <tr>
+  <table .table .table--striped>
+    <tr .table__row .table__row--head>
       <th>
       $# empty cell for row headers
       $maybe _ <- hasPassings
-        <th colspan=2>_{MsgSheetGradingPassing'}
+        <th .table__th colspan=2>_{MsgSheetGradingPassing'}
       $maybe _ <- hasPoints
-        <th colspan=2>_{MsgSheetGradingPoints'}
-      <th>_{MsgSheetGradingCount'}
+        <th .table__th colspan=2>_{MsgSheetGradingPoints'}
+      <th .table__th>_{MsgSheetGradingCount'}
         $# Number of Sheet/Submissions used for calculating maximum passes/points
     $forall row <- rowWdgts
       ^{row}
     $maybe nrNoGrade <- positiveSum $ numNotGraded
-      <tr>
-        <th>_{MsgSheetTypeNotGraded}
+      <tr .table__row>
+        <th .table__th>_{MsgSheetTypeNotGraded}
         $maybe _ <- hasPassings
           <td colspan=2>
         $maybe _ <- hasPoints
-          <td colspan=2>
-        <td>#{display nrNoGrade}
+          <td .table__td colspan=2>
+        <td .table__td>#{display nrNoGrade}
   $maybe _ <- positiveSum $ bonusSummary ^. _numSheets
     <p>_{MsgSheetTypeInfo}
+    <p>_{MsgSheetGradingBonusIncluded}
   $nothing
-    <p>_{MsgSheetTypeInfo}
\ No newline at end of file
+    $maybe _ <- positiveSum $ informationalSummary ^. _numSheets
+      <p>_{MsgSheetTypeInfo}
\ No newline at end of file
diff --git a/templates/widgets/gradingSummaryRow.hamlet b/templates/widgets/gradingSummaryRow.hamlet
index 46e4375bb..01e63efeb 100644
--- a/templates/widgets/gradingSummaryRow.hamlet
+++ b/templates/widgets/gradingSummaryRow.hamlet
@@ -6,28 +6,28 @@ $#  summary    :: SheetGradeSummary -- summary to display
 $#  sumHeader  :: UniWorXMessage    -- row header
 $#
   $maybe nrSheets <- positiveSum $ summary ^. _numSheets
-    <tr>
-      <th>_{sumHeader}
+    <tr .table__row >
+      <th .table__th>_{sumHeader}
       $maybe _ <- hasPassings
-        $with Sum pmax <- sumHeader ^. _numGradePasses
+        $with Sum pmax <- summary ^. _numGradePasses
           $maybe Sum pacv <- summary ^. _achievedPasses
-              <td>
+              <td .table__td>
                 $if pmax /= 0
                   #{textPercentInt pacv pmax}
-              <td>
+              <td .table__td>
                 #{display pacv} / #{display pmax}
           $nothing
-            <td colspan=2>
+            <td .table__td colspan=2>
               #{display pmax }
       $maybe _ <- hasPoints
-        $with Sum pmax <- sumHeader ^. _sumGradePoints
+        $with Sum pmax <- summary ^. _sumGradePoints
           $maybe Sum pacv <- summary ^. _achievedPoints
-              <td>
+              <td .table__td>
                 $if pmax /= 0
                   #{textPercent $ realToFrac $ pacv / pmax}
-              <td>
+              <td .table__td>
                 #{display pacv} / #{display pmax}
           $nothing
-            <td colspan=2>
+            <td .table__td colspan=2>
               #{display pmax }
-      <td>#{display nrSheets}
\ No newline at end of file
+      <td .table__td>#{display nrSheets}
\ No newline at end of file

From 16771ae8c5fe6f040e9fdc87e1b9dad2bee388b6 Mon Sep 17 00:00:00 2001
From: SJost <jost@tcs.ifi.lmu.de>
Date: Fri, 30 Nov 2018 16:34:36 +0100
Subject: [PATCH 05/23] Fix build.

---
 src/Handler/Corrections.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs
index 8874e0377..6a95e29dc 100644
--- a/src/Handler/Corrections.hs
+++ b/src/Handler/Corrections.hs
@@ -185,7 +185,7 @@ colCommentField = sortable Nothing (i18nCell MsgRatingComment) $ formCell
 
 
 makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h )
-                     => CorrectionTableWhere -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> _ -> Handler (DBResult m x)
+                     => CorrectionTableWhere -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> _ -> DB (DBResult m x)
 makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do
   let dbtSQLQuery :: CorrectionTableExpr -> E.SqlQuery _
       dbtSQLQuery = correctionsTableQuery whereClause

From 2ef4bbc01412eb9f3d8a53e981e6d407577b8ff3 Mon Sep 17 00:00:00 2001
From: SJost <jost@tcs.ifi.lmu.de>
Date: Fri, 30 Nov 2018 17:45:27 +0100
Subject: [PATCH 06/23] =?UTF-8?q?Neue=20Statistik=20nun=20auch=20f=C3=BCr?=
 =?UTF-8?q?=20Blatt=C3=BCbersicht?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

---
 messages/uniworx/de.msg                 |  3 +-
 src/Handler/Corrections.hs              | 24 ++++---------
 src/Handler/Sheet.hs                    |  8 ++---
 src/Handler/Utils/Rating.hs             | 47 +++++++++++++++++++++----
 src/Handler/Utils/Table/Pagination.hs   | 15 ++++----
 src/Model/Rating.hs                     | 18 ----------
 templates/widgets/gradingSummary.hamlet |  5 ++-
 7 files changed, 66 insertions(+), 54 deletions(-)

diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg
index 08b5f9561..f6d38f8fb 100644
--- a/messages/uniworx/de.msg
+++ b/messages/uniworx/de.msg
@@ -391,7 +391,8 @@ SheetTypeNormal grading@SheetGrading: Normal
 SheetTypeInformational grading@SheetGrading: Keine Wertung
 SheetTypeNotGraded: Unbewertet
 SheetTypeInfo: Bonus Blätter zählen normal, 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.
-SheetGradingBonusIncluded: Erzielte Bonuspunkte wurden hier bereits zu den normalen Punkten hinzugezählt.
+SheetGradingBonusIncluded: Erzielte Bonuspunkte wurden hier bereits zu den erreichten normalen Punkten hinzugezählt.
+SheetGradingSummaryTitle n@Int: Zusammenfassung über alle #{display n} Abgaben/Blätter
 
 SheetTypeBonus': Bonus
 SheetTypeNormal': Normal
diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs
index 6a95e29dc..ab625a903 100644
--- a/src/Handler/Corrections.hs
+++ b/src/Handler/Corrections.hs
@@ -102,6 +102,10 @@ colSheet = sortable (Just "sheet") (i18nCell MsgSheet)
               shn   = sheetName $ entityVal sheet
           in anchorCell (CSheetR tid ssh csh shn SShowR) [whamlet|#{display shn}|]
 
+colSheetType :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
+colSheetType = sortable (toNothing "sheetType") (i18nCell MsgSheetType)
+        $ \DBRow{ dbrOutput=(_, sheet, _, _, _) } -> i18nCell . sheetType $ entityVal sheet
+
 colCorrector :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
 colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector) $ \case
   DBRow{ dbrOutput = (_, _, _, Nothing  , _) } -> cell mempty
@@ -383,23 +387,6 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
       let route  = CSubmissionR tid ssh csh shn cID SAssignR
       (== Authorized) <$> evalAccessDB route True
 
-gradeSummaryWidget ::  SheetTypeSummary -> Widget
-gradeSummaryWidget sts =
-  let SheetTypeSummary{..} = addBonusToPoints sts
-      sumSummaries = (normalSummary <> bonusSummary <> informationalSummary) --  # _numSheets %~ (<> numNotGraded)
-      hasPassings  = positiveSum $ numGradePasses sumSummaries
-      hasPoints    = positiveSum $ sumGradePoints sumSummaries
-      rowWdgts =  [ $(widgetFile "widgets/gradingSummaryRow")
-                  | (sumHeader,summary) <-
-                    [ (MsgSheetTypeNormal'        ,normalSummary)
-                    , (MsgSheetTypeBonus'         ,bonusSummary)
-                    , (MsgSheetTypeInformational' ,informationalSummary)
-                  ] ]
-  in if 0 == numSheets sumSummaries
-        then mempty
-        else $(widgetFile "widgets/gradingSummary")
-
-
 type ActionCorrections' = (ActionCorrections, AForm (HandlerT UniWorX IO) ActionCorrectionsData)
 
 downloadAction :: ActionCorrections'
@@ -448,6 +435,7 @@ postCorrectionsR = do
         , colAssigned
         , colRating
         , colRated
+        , colSheetType
         ] -- Continue here
       psValidator = def
         & restrictFilter (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
@@ -468,6 +456,7 @@ postCCorrectionsR tid ssh csh = do
         , colSMatrikel
         , colSubmittors
         , colSubmissionLink
+        , colSheetType
         , colRating
         , colRated
         , colCorrector
@@ -782,6 +771,7 @@ postCorrectionsGradeR = do
         , colSheet
         , colPseudonyms
         , colSubmissionLink
+        , colSheetType
         , colRated
         , colRatedField
         , colPointsField
diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs
index 371354fe2..bb6e551d5 100644
--- a/src/Handler/Sheet.hs
+++ b/src/Handler/Sheet.hs
@@ -41,7 +41,7 @@ import qualified Data.Map as Map
 
 import Data.Map (Map, (!?))
 
-import Data.Monoid (Sum(..), Any(..))
+import Data.Monoid (Any(..))
 
 -- import Control.Lens
 import Utils.Lens
@@ -152,7 +152,8 @@ getSheetListR tid ssh csh = do
       E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
       return (sheet, lastSheetEdit sheet, submission)
     sheetCol = widgetColonnade . mconcat $
-      [ sortable (Just "name") (i18nCell MsgSheet)
+      [ -- TODO: dbRow add numbers
+        sortable (Just "name") (i18nCell MsgSheet)
           $ \(Entity _ Sheet{..}, _, _) -> anchorCell (CSheetR tid ssh csh sheetName SShowR) (toWidget sheetName)
       , sortable (Just "last-edit") (i18nCell MsgLastEdit)
           $ \(_, E.Value mEditTime, _) -> maybe mempty timeCell mEditTime
@@ -228,7 +229,7 @@ getSheetListR tid ssh csh = do
     , dbtIdent     = "sheets" :: Text
     }
   -- Collect summary over all Sheets, not just the ones shown due to pagination:
-  SheetTypeSummary{..} <- do
+  statistics <- gradeSummaryWidget <$> 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
@@ -236,7 +237,6 @@ getSheetListR tid ssh csh = do
       E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
       return (sheet E.^. SheetType, submission E.?. SubmissionRatingPoints)
     return $ foldMap (\(E.Value sheetType, E.Value mbPts) -> sheetTypeSum sheetType (join mbPts)) rows
-  let statistics = $(widgetFile "widgets/sheetTypeSummary")
   defaultLayout $ do
     $(widgetFile "sheetList")
 
diff --git a/src/Handler/Utils/Rating.hs b/src/Handler/Utils/Rating.hs
index be259344f..6cffb948d 100644
--- a/src/Handler/Utils/Rating.hs
+++ b/src/Handler/Utils/Rating.hs
@@ -12,6 +12,7 @@ module Handler.Utils.Rating
   , parseRating
   , SubmissionContent
   , extractRatings
+  , gradeSummaryWidget
   ) where
 
 import Import
@@ -32,6 +33,8 @@ import qualified Data.CaseInsensitive as CI
 import qualified Data.ByteString.Lazy as Lazy (ByteString)
 import qualified Data.ByteString.Lazy as Lazy.ByteString
 
+import Data.Monoid (Sum(..))
+
 import Text.Read (readEither)
 
 import System.FilePath
@@ -51,7 +54,7 @@ instance Pretty x => Pretty (CI x) where
   pretty = pretty . CI.original
 
 
-instance Pretty SheetGrading where   
+instance Pretty SheetGrading where
   pretty Points{..}     = pretty ( show maxPoints <> " Punkte" :: String)
   pretty PassPoints{..} = pretty ( show maxPoints <> " Punkte, bestanden ab " <> show passingPoints <> " Punkte" :: String )
   pretty PassBinary     = pretty ( "Bestanden (1) /  Nicht bestanden (0)" :: String )
@@ -59,12 +62,12 @@ instance Pretty SheetGrading where
 
 validateRating :: SheetType -> Rating' -> [RatingException]
 validateRating ratingSheetType Rating'{ratingPoints=Just rp, ..}
-  | rp < 0 
-    = [RatingNegative] 
-  | NotGraded <- ratingSheetType 
+  | rp < 0
+    = [RatingNegative]
+  | NotGraded <- ratingSheetType
     = [RatingNotExpected]
   | (Just maxPoints ) <- ratingSheetType ^?  _grading . _maxPoints
-  , rp > maxPoints 
+  , rp > maxPoints
     = [RatingExceedsMax]
   | (Just PassBinary) <- ratingSheetType ^? _grading
   , not (rp == 0 || rp == 1)
@@ -98,7 +101,7 @@ getRating submissionId = runMaybeT $ do
     , E.unValue -> ratingComment
     , E.unValue -> ratingTime
     ) ] <- lift query
-  
+
   return Rating{ ratingValues = Rating'{..}, .. }
 
 formatRating :: CryptoFileNameSubmission -> Rating -> Lazy.ByteString
@@ -199,3 +202,35 @@ isRatingFile' (takeFileName -> fName)
   = Just cID
   | otherwise
   = Nothing
+
+-- TODO: maybe move elsewhere, but Model is a bit overful already
+addBonusToPoints :: SheetTypeSummary -> SheetTypeSummary
+addBonusToPoints sts =
+    sts & _normalSummary . _achievedPoints %~ maxBonusPts  . addBonusPts
+        & _normalSummary . _achievedPasses %~ maxBonusPass . addBonusPass
+  where
+    bonusPoints  = sts ^. _bonusSummary  . _achievedPoints
+    maxPoints    = sts ^. _normalSummary . _sumGradePoints
+    maxBonusPts  = fmap $ min maxPoints
+    addBonusPts  = maybeAdd bonusPoints
+
+    bonusPasses  = sts ^. _bonusSummary  . _achievedPasses
+    maxPasses    = sts ^. _normalSummary . _numGradePasses
+    maxBonusPass = fmap $ min maxPasses
+    addBonusPass = maybeAdd bonusPasses
+
+gradeSummaryWidget ::  SheetTypeSummary -> Widget
+gradeSummaryWidget sts =
+  let SheetTypeSummary{..} = addBonusToPoints sts
+      sumSummaries = normalSummary <> bonusSummary <> informationalSummary & _numSheets %~ (<> numNotGraded)
+      hasPassings  = positiveSum $ numGradePasses sumSummaries
+      hasPoints    = positiveSum $ sumGradePoints sumSummaries
+      rowWdgts =  [ $(widgetFile "widgets/gradingSummaryRow")
+                  | (sumHeader,summary) <-
+                    [ (MsgSheetTypeNormal'        ,normalSummary)
+                    , (MsgSheetTypeBonus'         ,bonusSummary)
+                    , (MsgSheetTypeInformational' ,informationalSummary)
+                  ] ]
+  in if 0 == numSheets sumSummaries
+        then mempty
+        else $(widgetFile "widgets/gradingSummary")
diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs
index 3c5155842..808ad04af 100644
--- a/src/Handler/Utils/Table/Pagination.hs
+++ b/src/Handler/Utils/Table/Pagination.hs
@@ -183,7 +183,7 @@ instance Default (PSValidator m x) where
     Just pi -> swap . (\act -> execRWS act pi def) $ do
       asks piSorting >>= maybe (return ()) (\s -> modify $ \ps -> ps { psSorting = s })
       asks piFilter >>= maybe (return ()) (\f -> modify $ \ps -> ps { psFilter = f })
-      
+
       l <- asks piLimit
       case l of
         Just l'
@@ -258,7 +258,7 @@ class (MonadHandler m, Monoid x, Monoid (DBCell m x)) => IsDBTable (m :: * -> *)
 
   data DBCell m x :: *
   dbCell :: Iso' (DBCell m x) ([(Text, Text)], WriterT x m Widget)
-    
+
   -- dbWidget :: Proxy m -> Proxy x -> Iso' (DBResult m x) (Widget, DBResult' m x)
   -- | Format @DBTable@ when sort-circuiting
   dbWidget   :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> PaginationInput -> DBResult m x -> m' Widget
@@ -284,7 +284,7 @@ instance Monoid x => IsDBTable (HandlerT UniWorX IO) x where
   dbCell = iso
     (\WidgetCell{..} -> (wgtCellAttrs, wgtCellContents))
     (uncurry WidgetCell)
-  
+
   -- dbWidget Proxy Proxy = iso (, ()) $ view _1
   dbWidget _ _ = return . snd
   dbHandler _ _ f = return . over _2 f
@@ -331,7 +331,7 @@ instance Monoid a => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enc
   dbCell = iso
     (\FormCell{..} -> (formCellAttrs, WriterT $ fmap swap formCellContents))
     (\(attrs, mkWidget) -> FormCell attrs . fmap swap $ runWriterT mkWidget)
-  
+
   -- dbWidget Proxy Proxy = iso ((,) <$> view (_1._2) <*> ((,) <$> view (_1._1) <*> view _2))
   --                            ((,) <$> ((,) <$> view (_2._1) <*> view _1) <*> view (_2._2))
   dbWidget dbtable pi = liftHandlerT . fmap (view $ _1 . _2) . runFormPost . addPIHiddenField dbtable pi
@@ -353,10 +353,10 @@ addPIHiddenField DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } pi form fragmen
 instance Monoid a => Monoid (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a)) where
   mempty = FormCell mempty (return mempty)
   (FormCell a c) `mappend` (FormCell a' c') = FormCell (mappend a a') (mappend <$> c <*> c')
-  
+
 instance IsDBTable m a => IsString (DBCell m a) where
   fromString = cell . fromString
-      
+
 
 dbTable :: forall m x. IsDBTable m x => PSValidator m x -> DBTable m x -> DB (DBResult m x)
 dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> dbtIdent), dbtStyle = DBStyle{..}, .. } = do
@@ -378,7 +378,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
       , fieldView = error "multiTextField: should not be rendered"
       , fieldEnctype = UrlEncoded
       }
-    
+
   piResult <- lift . runInputGetResult $ PaginationInput
     <$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting")
     <*> (assertM' (not . Map.null) . Map.mapMaybe (assertM $ not . null) <$> Map.traverseWithKey (\k _ -> iopt multiTextField . wIdent $ CI.foldedCase k) dbtFilter)
@@ -571,6 +571,7 @@ formCell genIndex genForm input = FormCell
 
 -- Predefined colonnades
 
+--Number column?
 dbRow :: forall h r m a. (Headedness h, IsDBTable m a) => Colonnade h (DBRow r) (DBCell m a)
 dbRow = Colonnade.singleton (headednessPure $ i18nCell MsgNrColumn) $ \DBRow{ dbrIndex } -> textCell $ tshow dbrIndex
 
diff --git a/src/Model/Rating.hs b/src/Model/Rating.hs
index b4c18b801..c7b4e910f 100644
--- a/src/Model/Rating.hs
+++ b/src/Model/Rating.hs
@@ -2,8 +2,6 @@ module Model.Rating where
 
 import ClassyPrelude.Yesod
 import Model
-import Utils
-import Control.Lens
 -- import Data.Text (Text)
 import Data.Text.Encoding.Error (UnicodeException(..))
 import GHC.Generics (Generic)
@@ -36,19 +34,3 @@ data RatingException = RatingNotUnicode UnicodeException -- ^ Rating failed to p
   deriving (Show, Eq, Generic, Typeable)
 
 instance Exception RatingException
-
--- TODO: maybe move elsewhere, but Model is a bit overful already
-addBonusToPoints :: SheetTypeSummary -> SheetTypeSummary
-addBonusToPoints sts =
-    sts & _normalSummary . _achievedPoints %~ maxBonusPts  . addBonusPts
-        & _normalSummary . _achievedPasses %~ maxBonusPass . addBonusPass
-  where
-    bonusPoints  = sts ^. _bonusSummary  . _achievedPoints
-    maxPoints    = sts ^. _normalSummary . _sumGradePoints
-    maxBonusPts  = fmap $ min maxPoints
-    addBonusPts  = maybeAdd bonusPoints
-
-    bonusPasses  = sts ^. _bonusSummary  . _achievedPasses
-    maxPasses    = sts ^. _normalSummary . _numGradePasses
-    maxBonusPass = fmap $ min maxPasses
-    addBonusPass = maybeAdd bonusPasses
diff --git a/templates/widgets/gradingSummary.hamlet b/templates/widgets/gradingSummary.hamlet
index 3967a8f37..544651caf 100644
--- a/templates/widgets/gradingSummary.hamlet
+++ b/templates/widgets/gradingSummary.hamlet
@@ -1,6 +1,7 @@
 $# Displays gradings Summary for various purposes
 $# --
 <div>
+  <h3>_{MsgSheetGradingSummaryTitle $ getSum $ numSheets $ sumSummaries}
   <table .table .table--striped>
     <tr .table__row .table__row--head>
       <th>
@@ -23,7 +24,9 @@ $# --
         <td .table__td>#{display nrNoGrade}
   $maybe _ <- positiveSum $ bonusSummary ^. _numSheets
     <p>_{MsgSheetTypeInfo}
-    <p>_{MsgSheetGradingBonusIncluded}
+    $maybe _ <- positiveSum =<< (bonusSummary ^. _achievedPoints)
+      <p>_{MsgSheetGradingBonusIncluded}
   $nothing
+    $#TODO: MsgSheetTypeInfo into part about Bonus and about Informational
     $maybe _ <- positiveSum $ informationalSummary ^. _numSheets
       <p>_{MsgSheetTypeInfo}
\ No newline at end of file

From b05f1ccc75adf07159e110ea70f1b56e32101d62 Mon Sep 17 00:00:00 2001
From: SJost <jost@tcs.ifi.lmu.de>
Date: Fri, 30 Nov 2018 21:51:16 +0100
Subject: [PATCH 07/23] Rating type shown along rating in all corrections.

---
 src/Handler/Corrections.hs      |  4 +---
 src/Handler/Utils/Form.hs       | 36 ++++++++++++++++-----------------
 templates/widgets/rating.hamlet | 17 ++++++++--------
 3 files changed, 28 insertions(+), 29 deletions(-)

diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs
index ab625a903..9a398e017 100644
--- a/src/Handler/Corrections.hs
+++ b/src/Handler/Corrections.hs
@@ -150,6 +150,7 @@ colRating = sortable (Just "rating") (i18nCell MsgRating) $  \DBRow{ dbrOutput=(
       tid = course ^. _3
       ssh = course ^. _4
       -- shn = sheetName
+
       mkRoute = do
         cid <- encrypt subId
         return $ CSubmissionR tid ssh csh sheetName cid CorrectionR
@@ -435,7 +436,6 @@ postCorrectionsR = do
         , colAssigned
         , colRating
         , colRated
-        , colSheetType
         ] -- Continue here
       psValidator = def
         & restrictFilter (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
@@ -456,7 +456,6 @@ postCCorrectionsR tid ssh csh = do
         , colSMatrikel
         , colSubmittors
         , colSubmissionLink
-        , colSheetType
         , colRating
         , colRated
         , colCorrector
@@ -771,7 +770,6 @@ postCorrectionsGradeR = do
         , colSheet
         , colPseudonyms
         , colSubmissionLink
-        , colSheetType
         , colRated
         , colRatedField
         , colPointsField
diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs
index d1c9d3e4b..cc16635d7 100644
--- a/src/Handler/Utils/Form.hs
+++ b/src/Handler/Utils/Form.hs
@@ -263,7 +263,7 @@ multiFileField permittedFiles' = Field{..}
       pVals <- lift permittedFiles'
       let
         decrypt' :: CryptoUUIDFile -> Handler (Maybe FileId)
-        decrypt' = fmap (either (\(_ :: CryptoIDError) -> Nothing) Just) . try . decrypt 
+        decrypt' = fmap (either (\(_ :: CryptoIDError) -> Nothing) Just) . try . decrypt
       yieldMany vals
         .| C.filter (/= unpackZips)
         .| C.map fromPathPiece .| C.catMaybes
@@ -288,7 +288,7 @@ multiFileField permittedFiles' = Field{..}
           let fuiChecked
                 | Right sentVals' <- sentVals = fuiId' `elem` sentVals'
                 | otherwise = True
-          return FileUploadInfo{..}     
+          return FileUploadInfo{..}
       fileInfos <- mapM toFUI <=< handlerToWidget . runDB . E.select . E.from $ \file -> do
           E.where_ $ file E.^. FileId `E.in_` E.valList (setToList pVals)
           E.orderBy [E.asc $ file E.^. FileTitle]
@@ -303,13 +303,13 @@ multiFileField permittedFiles' = Field{..}
 
 
 data SheetGrading' = Points' | PassPoints' | PassBinary'
-  deriving (Eq, Ord, Read, Show, Enum, Bounded)      
+  deriving (Eq, Ord, Read, Show, Enum, Bounded)
 
 instance Universe SheetGrading'
 instance Finite SheetGrading'
 
 nullaryPathPiece ''SheetGrading' (camelToPathPiece . dropSuffix "'")
-embedRenderMessage ''UniWorX ''SheetGrading' ("SheetGrading" <>)  
+embedRenderMessage ''UniWorX ''SheetGrading' ("SheetGrading" <>)
 
 
 data SheetType' = Bonus' | Normal' | Informational' | NotGraded'
@@ -319,7 +319,7 @@ instance Universe SheetType'
 instance Finite SheetType'
 
 nullaryPathPiece ''SheetType' (camelToPathPiece . dropSuffix "'")
-embedRenderMessage ''UniWorX ''SheetType' ("SheetType" <>)  
+embedRenderMessage ''UniWorX ''SheetType' ("SheetType" <>)
 
 
 data SheetGroup' = Arbitrary' | RegisteredGroups' | NoGroups'
@@ -333,31 +333,31 @@ embedRenderMessage ''UniWorX ''SheetGroup' (("SheetGroup" <>) . dropSuffix "'")
 
 sheetGradingAFormReq :: FieldSettings UniWorX -> Maybe SheetGrading -> AForm Handler SheetGrading
 sheetGradingAFormReq fs template = multiActionA fs selOptions (classify' <$> template)
-  where 
-    selOptions = Map.fromList 
-      [ ( Points', Points <$> maxPointsReq )
+  where
+    selOptions = Map.fromList
+      [ ( Points',     Points     <$> maxPointsReq )
       , ( PassPoints', PassPoints <$> maxPointsReq <*> passPointsReq )
       , ( PassBinary', pure PassBinary)
       ]
-    classify' :: SheetGrading -> SheetGrading' 
-    classify' = \case 
-      Points {} -> Points'
+    classify' :: SheetGrading -> SheetGrading'
+    classify' = \case
+      Points     {} -> Points'
       PassPoints {} -> PassPoints'
       PassBinary {} -> PassBinary'
-    
-    maxPointsReq  = apreq pointsField (fslI MsgSheetGradingMaxPoints) (template >>= preview _maxPoints)
+
+    maxPointsReq  = apreq pointsField (fslI MsgSheetGradingMaxPoints)     (template >>= preview _maxPoints)
     passPointsReq = apreq pointsField (fslI MsgSheetGradingPassingPoints) (template >>= preview _passingPoints)
 
 
 sheetTypeAFormReq :: FieldSettings UniWorX -> Maybe SheetType -> AForm Handler SheetType
 sheetTypeAFormReq fs template = multiActionA fs selOptions (classify' <$> template)
-  where 
+  where
     selOptions = Map.fromList
       [ ( Bonus' , Bonus  <$> gradingReq )
       , ( Normal', Normal <$> gradingReq )
       , ( Informational', Informational <$> gradingReq  )
       , ( NotGraded', pure NotGraded )
-      ]    
+      ]
     gradingReq = sheetGradingAFormReq (fslI MsgSheetGrading
         & setTooltip MsgSheetGradingInfo) (template >>= preview _grading)
 
@@ -440,8 +440,8 @@ utcTimeField = Field
     fieldTimeFormat :: String
     --fieldTimeFormat = "%e.%m.%y %k:%M"
     fieldTimeFormat = "%Y-%m-%dT%H:%M"
-    
-    -- `defaultTimeLocale` is okay here, since `fieldTimeFormat` does not contain any 
+
+    -- `defaultTimeLocale` is okay here, since `fieldTimeFormat` does not contain any
     readTime :: Text -> Either UniWorXMessage UTCTime
     readTime t =
       case localTimeToUTC <$> parseTimeM True defaultTimeLocale fieldTimeFormat (T.unpack t) of
@@ -595,7 +595,7 @@ formResultModal res finalDest handler = maybeT_ $ do
     FormMissing -> mzero
     FormFailure errs -> mapM_ (addMessage Error . toHtml) errs >> mzero
     FormSuccess val -> lift . execWriterT $ handler val
-  
+
   isModal <- hasCustomHeader HeaderIsModal
   if
     | isModal   -> sendResponse $ toJSON messages
diff --git a/templates/widgets/rating.hamlet b/templates/widgets/rating.hamlet
index d9241e561..366769452 100644
--- a/templates/widgets/rating.hamlet
+++ b/templates/widgets/rating.hamlet
@@ -3,18 +3,19 @@ $#  submissionRatingPoints :: Maybe points
 
 $maybe points <- submissionRatingPoints
   $maybe grading <- preview _grading sheetType
-    $case grading	
+    $case grading
       $of Points{..}
-        _{MsgAchievedOf points maxPoints}          
-      $of PassPoints{}
-        $if fromMaybe False (gradingPassed grading points)
-          _{MsgPassed}
-        $else
-          _{MsgNotPassed}
-      $of PassBinary 
+        _{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}
   $nothing
     #{tickmarkS}

From aa455d2bdd2b9a7a15650cf6e3cc2d42137b829a Mon Sep 17 00:00:00 2001
From: SJost <jost@tcs.ifi.lmu.de>
Date: Sun, 2 Dec 2018 16:47:56 +0100
Subject: [PATCH 08/23] =?UTF-8?q?Statistik=20Abgaben/Bl=C3=A4tter=20done?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

---
 messages/uniworx/de.msg                 | 3 ++-
 src/Foundation.hs                       | 2 +-
 src/Handler/Corrections.hs              | 2 +-
 src/Handler/Sheet.hs                    | 2 +-
 src/Handler/Utils/Rating.hs             | 4 ++--
 templates/widgets/gradingSummary.hamlet | 2 +-
 6 files changed, 8 insertions(+), 7 deletions(-)

diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg
index f6d38f8fb..315d0e3de 100644
--- a/messages/uniworx/de.msg
+++ b/messages/uniworx/de.msg
@@ -392,7 +392,8 @@ SheetTypeInformational grading@SheetGrading: Keine Wertung
 SheetTypeNotGraded: Unbewertet
 SheetTypeInfo: Bonus Blätter zählen normal, 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.
 SheetGradingBonusIncluded: Erzielte Bonuspunkte wurden hier bereits zu den erreichten normalen Punkten hinzugezählt.
-SheetGradingSummaryTitle n@Int: Zusammenfassung über alle #{display n} Abgaben/Blätter
+SheetGradingSummaryTitle n@Int: Zusammenfassung über alle #{display n} Blätter
+SubmissionGradingSummaryTitle n@Int: Zusammenfassung über alle #{display n} Abgaben
 
 SheetTypeBonus': Bonus
 SheetTypeNormal': Normal
diff --git a/src/Foundation.hs b/src/Foundation.hs
index 8577ae9fd..c443a3c01 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -142,7 +142,7 @@ pattern CSubmissionR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Cr
 pattern CSubmissionR tid ssh csh shn cid ptn
   = CSheetR tid ssh csh shn (SubmissionR cid ptn)
 
--- Messages
+-- Messages creates type UniWorXMessage and RenderMessage UniWorX instance
 mkMessage "UniWorX" "messages/uniworx" "de"
 mkMessageVariant "UniWorX" "Campus" "messages/campus" "de"
 mkMessageVariant "UniWorX" "Dummy" "messages/dummy" "de"
diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs
index 9a398e017..7455f2311 100644
--- a/src/Handler/Corrections.hs
+++ b/src/Handler/Corrections.hs
@@ -370,7 +370,7 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
       points <- E.select . E.from $ correctionsTableQuery whereClause getTypePoints
       -- points <- E.select . E.from $ t@((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) -> (correctionsTableQuery whereClause getTypePoints t) <* E.distinctOn []
       return $ foldMap (\(E.Value stype, E.Value srpoints, E.Value srtime) -> sheetTypeSum stype (srpoints <* srtime)) points
-  let statistics = gradeSummaryWidget gradingSummary
+  let statistics = gradeSummaryWidget MsgSubmissionGradingSummaryTitle gradingSummary
   fmap toTypedContent . defaultLayout $ do
     setTitleI MsgCourseCorrectionsTitle
     $(widgetFile "corrections")
diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs
index bb6e551d5..523a7d297 100644
--- a/src/Handler/Sheet.hs
+++ b/src/Handler/Sheet.hs
@@ -229,7 +229,7 @@ getSheetListR tid ssh csh = do
     , dbtIdent     = "sheets" :: Text
     }
   -- Collect summary over all Sheets, not just the ones shown due to pagination:
-  statistics <- gradeSummaryWidget <$> do
+  statistics <- gradeSummaryWidget MsgSheetGradingSummaryTitle <$> 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
diff --git a/src/Handler/Utils/Rating.hs b/src/Handler/Utils/Rating.hs
index 6cffb948d..d5f6f8006 100644
--- a/src/Handler/Utils/Rating.hs
+++ b/src/Handler/Utils/Rating.hs
@@ -219,8 +219,8 @@ addBonusToPoints sts =
     maxBonusPass = fmap $ min maxPasses
     addBonusPass = maybeAdd bonusPasses
 
-gradeSummaryWidget ::  SheetTypeSummary -> Widget
-gradeSummaryWidget sts =
+gradeSummaryWidget ::  (Int -> UniWorXMessage) -> SheetTypeSummary -> Widget
+gradeSummaryWidget title sts =
   let SheetTypeSummary{..} = addBonusToPoints sts
       sumSummaries = normalSummary <> bonusSummary <> informationalSummary & _numSheets %~ (<> numNotGraded)
       hasPassings  = positiveSum $ numGradePasses sumSummaries
diff --git a/templates/widgets/gradingSummary.hamlet b/templates/widgets/gradingSummary.hamlet
index 544651caf..e728bcfbd 100644
--- a/templates/widgets/gradingSummary.hamlet
+++ b/templates/widgets/gradingSummary.hamlet
@@ -1,7 +1,7 @@
 $# Displays gradings Summary for various purposes
 $# --
 <div>
-  <h3>_{MsgSheetGradingSummaryTitle $ getSum $ numSheets $ sumSummaries}
+  <h3>_{title $ getSum $ numSheets $ sumSummaries}
   <table .table .table--striped>
     <tr .table__row .table__row--head>
       <th>

From 17ea26430f655291239ad492aeb125f7739498d1 Mon Sep 17 00:00:00 2001
From: SJost <jost@tcs.ifi.lmu.de>
Date: Wed, 5 Dec 2018 11:41:25 +0100
Subject: [PATCH 09/23] Sorting Corrections and UniWorXMessages Monoid

---
 src/Foundation.hs                  |  7 +++++++
 src/Handler/Corrections.hs         | 14 ++++++++++++--
 src/Handler/Sheet.hs               | 24 ++++++++++++------------
 src/Handler/Utils/Rating.hs        |  2 +-
 src/Import/NoFoundation.hs         |  2 ++
 templates/standalone/alerts.julius |  2 +-
 6 files changed, 35 insertions(+), 16 deletions(-)

diff --git a/src/Foundation.hs b/src/Foundation.hs
index c443a3c01..2dec96886 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-} -- MonadCrypto
 
 module Foundation where
@@ -222,6 +223,12 @@ instance RenderMessage UniWorX SheetType where
 newtype ErrorResponseTitle = ErrorResponseTitle ErrorResponse
 embedRenderMessageVariant ''UniWorX ''ErrorResponseTitle ("ErrorResponseTitle" <>)
 
+newtype UniWorXMessages = UniWorXMessages [SomeMessage UniWorX]
+  deriving (Generic, Typeable)
+  deriving newtype (Semigroup, Monoid, IsList)
+
+instance RenderMessage UniWorX UniWorXMessages where
+  renderMessage foundation ls (UniWorXMessages msgs) = foldMap (renderMessage foundation ls) msgs
 
 -- Menus and Favourites
 data MenuType = NavbarAside | NavbarRight | NavbarSecondary | PageActionPrime | PageActionSecondary
diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs
index 7455f2311..649bb4078 100644
--- a/src/Handler/Corrections.hs
+++ b/src/Handler/Corrections.hs
@@ -128,7 +128,7 @@ colSelect :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult
 colSelect = dbSelect id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> encrypt subId
 
 colSubmittors :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
-colSubmittors = sortable Nothing (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, _, course, _, users) } -> let
+colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, _, course, _, users) } -> let
   csh = course ^. _2
   tid = course ^. _3
   ssh = course ^. _4
@@ -209,7 +209,7 @@ makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do
            E.&&. pseudonym E.?. SheetPseudonymSheet E.==. E.just (E.val shId)
           E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
           E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val sId
-          E.orderBy [E.asc $ user E.^. UserId]
+          E.orderBy [E.asc $ user E.^. UserDisplayName]
           return (user, pseudonym E.?. SheetPseudonymPseudonym)
         let
           submittorMap = foldr (\(Entity userId user, E.Value pseudo) -> Map.insert userId (user, pseudo)) Map.empty submittors
@@ -240,6 +240,16 @@ makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do
       , ( "assignedtime"
         , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingAssigned
         )
+      , ( "submittors"
+        , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) ->
+            E.sub_select . E.from $ \(submissionUser `E.InnerJoin` user) -> do
+              E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
+              E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
+              E.orderBy [E.asc $ user E.^. UserDisplayName]
+              E.limit 1
+              return (user E.^. UserDisplayName)
+
+        )
       ]
     , dbtFilter    = Map.fromList
       [ ( "term"
diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs
index 523a7d297..c88371762 100644
--- a/src/Handler/Sheet.hs
+++ b/src/Handler/Sheet.hs
@@ -152,19 +152,19 @@ getSheetListR tid ssh csh = do
       E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
       return (sheet, lastSheetEdit sheet, submission)
     sheetCol = widgetColonnade . mconcat $
-      [ -- TODO: dbRow add numbers
-        sortable (Just "name") (i18nCell MsgSheet)
-          $ \(Entity _ Sheet{..}, _, _) -> anchorCell (CSheetR tid ssh csh sheetName SShowR) (toWidget sheetName)
+      [ dbRow
+      , sortable (Just "name") (i18nCell MsgSheet)
+          $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> anchorCell (CSheetR tid ssh csh sheetName SShowR) (toWidget sheetName)
       , sortable (Just "last-edit") (i18nCell MsgLastEdit)
-          $ \(_, E.Value mEditTime, _) -> maybe mempty timeCell mEditTime
+          $ \DBRow{dbrOutput=(_, E.Value mEditTime, _)} -> maybe mempty timeCell mEditTime
       , sortable (Just "submission-since") (i18nCell MsgSheetActiveFrom)
-          $ \(Entity _ Sheet{..}, _, _) -> timeCell sheetActiveFrom
+          $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> timeCell sheetActiveFrom
       , sortable (Just "submission-until") (i18nCell MsgSheetActiveTo)
-          $ \(Entity _ Sheet{..}, _, _) -> timeCell sheetActiveTo
+          $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> timeCell sheetActiveTo
       , sortable Nothing (i18nCell MsgSheetType)
-          $ \(Entity _ Sheet{..}, _, _) -> i18nCell sheetType
+          $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> i18nCell sheetType
       , sortable Nothing (i18nCell MsgSubmission)
-          $ \(Entity _ Sheet{..}, _, mbSub) -> case mbSub of
+          $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, mbSub)} -> case mbSub of
               Nothing -> mempty
               (Just (Entity sid Submission{..})) ->
                 let mkCid = encrypt sid -- TODO: executed twice
@@ -173,7 +173,7 @@ getSheetListR tid ssh csh = do
                       return $ CSubmissionR tid ssh csh sheetName cid' SubShowR
                 in anchorCellM mkRoute (mkCid >>= \cid2 -> [whamlet|#{display cid2}|])
       , sortable (Just "rating") (i18nCell MsgRating)
-          $ \(Entity _ Sheet{..}, _, mbSub) -> case mbSub of
+          $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, mbSub)} -> case mbSub of
               Nothing -> mempty
               (Just (Entity sid Submission{..})) ->
                 let mkCid = encrypt sid
@@ -183,7 +183,7 @@ getSheetListR tid ssh csh = do
                 in anchorCellM mkRoute $(widgetFile "widgets/rating")
       , sortable Nothing -- (Just "percent")
                         (i18nCell MsgRatingPercent)
-          $ \(Entity _ Sheet{sheetType=sType}, _, mbSub) -> case mbSub of
+          $ \DBRow{dbrOutput=(Entity _ Sheet{sheetType=sType}, _, mbSub)} -> case mbSub of
               (Just (Entity _ Submission{submissionRatingPoints=Just sPoints})) ->
                 case preview (_grading . _maxPoints) sType of
                   Just maxPoints
@@ -198,8 +198,8 @@ getSheetListR tid ssh csh = do
   table <- runDB $ dbTableWidget' psValidator DBTable
     { dbtSQLQuery  = sheetData
     , dbtColonnade = sheetCol
-    , dbtProj = \DBRow{ dbrOutput = dbrOutput@(Entity _ Sheet{..}, _, _) }
-                   -> dbrOutput <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh sheetName SShowR) False)
+    , dbtProj = \dbr@DBRow{ dbrOutput=(Entity _ Sheet{..}, _, _) }
+                   -> dbr <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh sheetName SShowR) False)
     , dbtSorting   = Map.fromList
       [ ( "name"
         , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetName
diff --git a/src/Handler/Utils/Rating.hs b/src/Handler/Utils/Rating.hs
index d5f6f8006..11cb411e8 100644
--- a/src/Handler/Utils/Rating.hs
+++ b/src/Handler/Utils/Rating.hs
@@ -219,7 +219,7 @@ addBonusToPoints sts =
     maxBonusPass = fmap $ min maxPasses
     addBonusPass = maybeAdd bonusPasses
 
-gradeSummaryWidget ::  (Int -> UniWorXMessage) -> SheetTypeSummary -> Widget
+gradeSummaryWidget ::  RenderMessage UniWorX msg => (Int -> msg) -> SheetTypeSummary -> Widget
 gradeSummaryWidget title sts =
   let SheetTypeSummary{..} = addBonusToPoints sts
       sumSummaries = normalSummary <> bonusSummary <> informationalSummary & _numSheets %~ (<> numNotGraded)
diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs
index 94c8ffbd2..568cabfd2 100644
--- a/src/Import/NoFoundation.hs
+++ b/src/Import/NoFoundation.hs
@@ -35,10 +35,12 @@ import Mail                   as Import
 import Data.Data              as Import (Data)
 import Data.Typeable          as Import (Typeable)
 import GHC.Generics           as Import (Generic)
+import GHC.Exts               as Import (IsList)
 
 import Data.Hashable          as Import
 import Data.List.NonEmpty     as Import (NonEmpty(..))
 import Data.Text.Encoding.Error    as Import(UnicodeException(..))
+import Data.Semigroup         as Import (Semigroup)
 
 import Control.Monad.Morph    as Import (MFunctor(..))
 
diff --git a/templates/standalone/alerts.julius b/templates/standalone/alerts.julius
index f993cdfbc..632661eb5 100644
--- a/templates/standalone/alerts.julius
+++ b/templates/standalone/alerts.julius
@@ -29,7 +29,7 @@
       var iconEl = document.createElement('DIV');
       var closeEl = document.createElement('DIV');
       var dataDecay = alertEl.dataset.decay;
-      var autoDecay = 30;
+      var autoDecay = 10;
       if (dataDecay) {
         autoDecay = parseInt(dataDecay, 10);
       }

From 63de63f16c1ed60d620ad01f4369f56019d57578 Mon Sep 17 00:00:00 2001
From: SJost <jost@tcs.ifi.lmu.de>
Date: Wed, 5 Dec 2018 11:57:28 +0100
Subject: [PATCH 10/23] UniworxMessages allows combining messages

---
 messages/uniworx/de.msg                 |  3 +-
 src/Foundation.hs                       |  6 +++-
 src/Handler/Corrections.hs              |  1 +
 src/Handler/Sheet.hs                    |  4 ++-
 src/Handler/Utils/Rating.hs             | 35 ----------------------
 src/Handler/Utils/SheetType.hs          | 39 +++++++++++++++++++++++++
 templates/widgets/gradingSummary.hamlet |  7 +++--
 7 files changed, 55 insertions(+), 40 deletions(-)
 create mode 100644 src/Handler/Utils/SheetType.hs

diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg
index 315d0e3de..8b15af8b0 100644
--- a/messages/uniworx/de.msg
+++ b/messages/uniworx/de.msg
@@ -390,7 +390,8 @@ SheetTypeBonus grading@SheetGrading: Bonus
 SheetTypeNormal grading@SheetGrading: Normal
 SheetTypeInformational grading@SheetGrading: Keine Wertung
 SheetTypeNotGraded: Unbewertet
-SheetTypeInfo: Bonus Blätter zählen normal, 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.
+SheetTypeInfoBonus: Bonus Blätter zählen normal, erhöhen aber nicht die maximal erreichbare Punktzahl bzw. Anzahl zu bestehender Blätter.
+SheetTypeInfoNotGraded: Blätter ohne Wertung werden nirgends angerechnet, die Bewertung durch den Korrektor dient lediglich zur Information an die Teilnehmer.
 SheetGradingBonusIncluded: Erzielte Bonuspunkte wurden hier bereits zu den erreichten normalen Punkten hinzugezählt.
 SheetGradingSummaryTitle n@Int: Zusammenfassung über alle #{display n} Blätter
 SubmissionGradingSummaryTitle n@Int: Zusammenfassung über alle #{display n} Abgaben
diff --git a/src/Foundation.hs b/src/Foundation.hs
index 2dec96886..b80b2630c 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -228,7 +228,11 @@ newtype UniWorXMessages = UniWorXMessages [SomeMessage UniWorX]
   deriving newtype (Semigroup, Monoid, IsList)
 
 instance RenderMessage UniWorX UniWorXMessages where
-  renderMessage foundation ls (UniWorXMessages msgs) = foldMap (renderMessage foundation ls) msgs
+  renderMessage foundation ls (UniWorXMessages msgs) =
+    intercalate " " $ map (renderMessage foundation ls) msgs
+
+uniworxMessages :: [UniWorXMessage] -> UniWorXMessages
+uniworxMessages = UniWorXMessages . map SomeMessage
 
 -- Menus and Favourites
 data MenuType = NavbarAside | NavbarRight | NavbarSecondary | PageActionPrime | PageActionSecondary
diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs
index 649bb4078..0ebeef68e 100644
--- a/src/Handler/Corrections.hs
+++ b/src/Handler/Corrections.hs
@@ -7,6 +7,7 @@ import Jobs
 import Handler.Utils
 import Handler.Utils.Submission
 import Handler.Utils.Table.Cells
+import Handler.Utils.SheetType
 -- import Handler.Utils.Zip
 
 import Utils.Lens
diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs
index c88371762..6728e11a2 100644
--- a/src/Handler/Sheet.hs
+++ b/src/Handler/Sheet.hs
@@ -6,6 +6,7 @@ import System.FilePath (takeFileName)
 import Handler.Utils
 -- import Handler.Utils.Zip
 import Handler.Utils.Table.Cells
+import Handler.Utils.SheetType
 
 -- import Data.Time
 -- import qualified Data.Text as T
@@ -97,7 +98,8 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
       <$> areq ciField        (fslI MsgSheetName)         (sfName        <$> template)
       <*> aopt htmlField      (fslI MsgSheetDescription)  (sfDescription <$> template)
       <*> sheetTypeAFormReq   (fslI MsgSheetType
-            & setTooltip MsgSheetTypeInfo)                  (sfType        <$> template)
+            & setTooltip (uniworxMessages [MsgSheetTypeInfoBonus,MsgSheetTypeInfoNotGraded]))
+                                                          (sfType        <$> template)
       <*> sheetGroupAFormReq  (fslI MsgSheetGroup)        (sfGrouping    <$> template)
       <*> aopt utcTimeField   (fslI MsgSheetVisibleFrom
             & setTooltip MsgSheetVisibleFromTip)
diff --git a/src/Handler/Utils/Rating.hs b/src/Handler/Utils/Rating.hs
index 11cb411e8..8c8b4f273 100644
--- a/src/Handler/Utils/Rating.hs
+++ b/src/Handler/Utils/Rating.hs
@@ -12,7 +12,6 @@ module Handler.Utils.Rating
   , parseRating
   , SubmissionContent
   , extractRatings
-  , gradeSummaryWidget
   ) where
 
 import Import
@@ -33,8 +32,6 @@ import qualified Data.CaseInsensitive as CI
 import qualified Data.ByteString.Lazy as Lazy (ByteString)
 import qualified Data.ByteString.Lazy as Lazy.ByteString
 
-import Data.Monoid (Sum(..))
-
 import Text.Read (readEither)
 
 import System.FilePath
@@ -202,35 +199,3 @@ isRatingFile' (takeFileName -> fName)
   = Just cID
   | otherwise
   = Nothing
-
--- TODO: maybe move elsewhere, but Model is a bit overful already
-addBonusToPoints :: SheetTypeSummary -> SheetTypeSummary
-addBonusToPoints sts =
-    sts & _normalSummary . _achievedPoints %~ maxBonusPts  . addBonusPts
-        & _normalSummary . _achievedPasses %~ maxBonusPass . addBonusPass
-  where
-    bonusPoints  = sts ^. _bonusSummary  . _achievedPoints
-    maxPoints    = sts ^. _normalSummary . _sumGradePoints
-    maxBonusPts  = fmap $ min maxPoints
-    addBonusPts  = maybeAdd bonusPoints
-
-    bonusPasses  = sts ^. _bonusSummary  . _achievedPasses
-    maxPasses    = sts ^. _normalSummary . _numGradePasses
-    maxBonusPass = fmap $ min maxPasses
-    addBonusPass = maybeAdd bonusPasses
-
-gradeSummaryWidget ::  RenderMessage UniWorX msg => (Int -> msg) -> SheetTypeSummary -> Widget
-gradeSummaryWidget title sts =
-  let SheetTypeSummary{..} = addBonusToPoints sts
-      sumSummaries = normalSummary <> bonusSummary <> informationalSummary & _numSheets %~ (<> numNotGraded)
-      hasPassings  = positiveSum $ numGradePasses sumSummaries
-      hasPoints    = positiveSum $ sumGradePoints sumSummaries
-      rowWdgts =  [ $(widgetFile "widgets/gradingSummaryRow")
-                  | (sumHeader,summary) <-
-                    [ (MsgSheetTypeNormal'        ,normalSummary)
-                    , (MsgSheetTypeBonus'         ,bonusSummary)
-                    , (MsgSheetTypeInformational' ,informationalSummary)
-                  ] ]
-  in if 0 == numSheets sumSummaries
-        then mempty
-        else $(widgetFile "widgets/gradingSummary")
diff --git a/src/Handler/Utils/SheetType.hs b/src/Handler/Utils/SheetType.hs
new file mode 100644
index 000000000..69885e759
--- /dev/null
+++ b/src/Handler/Utils/SheetType.hs
@@ -0,0 +1,39 @@
+module Handler.Utils.SheetType
+  (
+    gradeSummaryWidget
+  ) where
+
+import Import
+import Data.Monoid (Sum(..))
+import Utils.Lens hiding ((<.>))
+
+addBonusToPoints :: SheetTypeSummary -> SheetTypeSummary
+addBonusToPoints sts =
+    sts & _normalSummary . _achievedPoints %~ maxBonusPts  . addBonusPts
+        & _normalSummary . _achievedPasses %~ maxBonusPass . addBonusPass
+  where
+    bonusPoints  = sts ^. _bonusSummary  . _achievedPoints
+    maxPoints    = sts ^. _normalSummary . _sumGradePoints
+    maxBonusPts  = fmap $ min maxPoints
+    addBonusPts  = maybeAdd bonusPoints
+
+    bonusPasses  = sts ^. _bonusSummary  . _achievedPasses
+    maxPasses    = sts ^. _normalSummary . _numGradePasses
+    maxBonusPass = fmap $ min maxPasses
+    addBonusPass = maybeAdd bonusPasses
+
+gradeSummaryWidget ::  RenderMessage UniWorX msg => (Int -> msg) -> SheetTypeSummary -> Widget
+gradeSummaryWidget title sts =
+  let SheetTypeSummary{..} = addBonusToPoints sts
+      sumSummaries = normalSummary <> bonusSummary <> informationalSummary & _numSheets %~ (<> numNotGraded)
+      hasPassings  = positiveSum $ numGradePasses sumSummaries
+      hasPoints    = positiveSum $ sumGradePoints sumSummaries
+      rowWdgts =  [ $(widgetFile "widgets/gradingSummaryRow")
+                  | (sumHeader,summary) <-
+                    [ (MsgSheetTypeNormal'        ,normalSummary)
+                    , (MsgSheetTypeBonus'         ,bonusSummary)
+                    , (MsgSheetTypeInformational' ,informationalSummary)
+                  ] ]
+  in if 0 == numSheets sumSummaries
+        then mempty
+        else $(widgetFile "widgets/gradingSummary")
diff --git a/templates/widgets/gradingSummary.hamlet b/templates/widgets/gradingSummary.hamlet
index e728bcfbd..f72c1edd9 100644
--- a/templates/widgets/gradingSummary.hamlet
+++ b/templates/widgets/gradingSummary.hamlet
@@ -22,11 +22,14 @@ $# --
         $maybe _ <- hasPoints
           <td .table__td colspan=2>
         <td .table__td>#{display nrNoGrade}
+  $# TODO: for Steffen: show messages conditional upon table content
   $maybe _ <- positiveSum $ bonusSummary ^. _numSheets
-    <p>_{MsgSheetTypeInfo}
+    <p>_{MsgSheetTypeInfoBonus}
+    <p>_{MsgSheetTypeInfoNotGraded}
     $maybe _ <- positiveSum =<< (bonusSummary ^. _achievedPoints)
       <p>_{MsgSheetGradingBonusIncluded}
   $nothing
     $#TODO: MsgSheetTypeInfo into part about Bonus and about Informational
     $maybe _ <- positiveSum $ informationalSummary ^. _numSheets
-      <p>_{MsgSheetTypeInfo}
\ No newline at end of file
+      <p>_{MsgSheetTypeInfoBonus}
+      <p>_{MsgSheetTypeInfoNotGraded}
\ No newline at end of file

From 48080639b110485dd9e4ed41f6e4c25e5e106960 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Wed, 5 Dec 2018 13:50:46 +0100
Subject: [PATCH 11/23] Memcached integration for widgets

---
 config/settings.yml              |  12 +++++-
 package.yaml                     |   1 +
 routes                           |   2 +-
 src/Application.hs               |  18 +++++++--
 src/Foundation.hs                |  67 ++++++++++++++-----------------
 src/Handler/Common.hs            |   6 +--
 src/Import/NoFoundation.hs       |   2 +-
 src/Settings.hs                  |  44 +++++++++++++++++++-
 src/Settings/StaticFiles.hs      |  24 +++++++----
 stack.yaml                       |   4 ++
 {embedded => static}/favicon.ico | Bin
 {embedded => static}/robots.txt  |   0
 12 files changed, 125 insertions(+), 55 deletions(-)
 rename {embedded => static}/favicon.ico (100%)
 rename {embedded => static}/robots.txt (100%)

diff --git a/config/settings.yml b/config/settings.yml
index f3243a773..2ff396932 100644
--- a/config/settings.yml
+++ b/config/settings.yml
@@ -34,7 +34,6 @@ log-settings:
   minimum-level: "_env:LOGLEVEL:warn"
   destination:   "_env:LOGDEST:stderr"
 
-
 # Debugging
 auth-dummy-login:  "_env:DUMMY_LOGIN:false"
 allow-deprecated:  "_env:ALLOW_DEPRECATED:false"
@@ -80,7 +79,16 @@ smtp:
   pool:
     stripes: "_env:SMTPSTRIPES:1"
     timeout: "_env:SMTPTIMEOUT:20"
-    limit: "_env:SMTPLIMIT:10"
+    limit:   "_env:SMTPLIMIT:10"
+
+widget-memcached:
+  host:       "_env:MEMCACHEDHOST:"
+  port:       "_env:MEMCACHEDPORT:11211"
+  auth:       []
+  limit:      "_env:MEMCACHEDLIMIT:10"
+  timeout:    "_env:MEMCACHEDTIMEOUT:20"
+  base-url:   "_env:MEMCACHEDROOT:"
+  expiration: "_env:MEMCACHEDEXPIRATION:3600"
 
 user-defaults:
   max-favourites:   12
diff --git a/package.yaml b/package.yaml
index 0aa2b1269..4bc841965 100644
--- a/package.yaml
+++ b/package.yaml
@@ -111,6 +111,7 @@ dependencies:
   - xss-sanitize
   - text-metrics
   - pkcs7
+  - memcached-binary
 
 other-extensions:
   - GeneralizedNewtypeDeriving
diff --git a/routes b/routes
index a84d2842e..4508cb781 100644
--- a/routes
+++ b/routes
@@ -26,7 +26,7 @@
 --    !deprecated  -- like free, but logs and gives a warning; entirely disabled in production
 --    !development -- like free, but only for development builds
 
-/static StaticR Static appStatic                              !free
+/static StaticR EmbeddedStatic appStatic                      !free
 /auth   AuthR   Auth   getAuth                                !free
 
 /favicon.ico FaviconR GET                                     !free
diff --git a/src/Application.hs b/src/Application.hs
index 90792b4f5..cdf4d9ecc 100644
--- a/src/Application.hs
+++ b/src/Application.hs
@@ -69,6 +69,8 @@ import Data.Proxy
 import qualified Data.Aeson as Aeson
 
 import System.Exit (exitFailure)
+
+import qualified Database.Memcached.Binary.IO as Memcached
   
 -- Import all relevant handler modules here.
 -- (HPack takes care to add new modules to our cabal file nowadays.)
@@ -125,7 +127,7 @@ makeFoundation appSettings@AppSettings{..} = do
         (tVar, ) <$> fork (updateLogger initialSettings)
     appLogger <- over _2 fst <$> allocate mkLogger' (\(tVar, tId) -> killThread tId >> (readTVarIO tVar >>= rmLoggerSet . loggerSet))
 
-    appStatic <- liftIO $ bool static staticDevel appMutableStatic appStaticDir
+    let appStatic = embeddedStatic
 
     appInstanceID <- liftIO $ maybe UUID.nextRandom (either readInstanceIDFile return) appInitialInstanceID
 
@@ -137,7 +139,7 @@ makeFoundation appSettings@AppSettings{..} = do
     -- logging function. To get out of this loop, we initially create a
     -- temporary foundation without a real connection pool, get a log function
     -- from there, and then create the real foundation.
-    let mkFoundation appConnPool appSmtpPool appCryptoIDKey appSessionKey appSecretBoxKey = UniWorX {..}
+    let mkFoundation appConnPool appSmtpPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached = UniWorX {..}
         -- The UniWorX {..} syntax is an example of record wild cards. For more
         -- information, see:
         -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html
@@ -147,6 +149,7 @@ makeFoundation appSettings@AppSettings{..} = do
           (error "cryptoIDKey forced in tempFoundation")
           (error "sessionKey forced in tempFoundation")
           (error "secretBoxKey forced in tempFoundation")
+          (error "widgetMemcached forced in tempFoundation")
         logFunc loc src lvl str = do
           f <- messageLoggerSource tempFoundation <$> readTVarIO (snd appLogger)
           f loc src lvl str
@@ -157,6 +160,8 @@ makeFoundation appSettings@AppSettings{..} = do
 
       smtpPool <- traverse createSmtpPool appSmtpConf
 
+      appWidgetMemcached <- traverse createWidgetMemcached appWidgetMemcachedConf
+
       -- Create the database connection pool
       sqlPool <- createPostgresqlPool
         (pgConnStr  appDatabaseConf)
@@ -168,7 +173,7 @@ makeFoundation appSettings@AppSettings{..} = do
       appSessionKey <- clusterSetting (Proxy :: Proxy 'ClusterClientSessionKey) `runSqlPool` sqlPool
       appSecretBoxKey <- clusterSetting (Proxy :: Proxy 'ClusterSecretBoxKey) `runSqlPool` sqlPool
 
-      let foundation = mkFoundation sqlPool smtpPool appCryptoIDKey appSessionKey appSecretBoxKey
+      let foundation = mkFoundation sqlPool smtpPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached
 
       handleJobs foundation
 
@@ -234,6 +239,9 @@ createSmtpPool SmtpConf{ smtpPool = ResourcePoolConf{..}, .. } = do
       return conn
   liftIO $ createPool (mkConnection >>= maybe return applyAuth smtpAuth) reapConnection poolStripes poolTimeout poolLimit
 
+createWidgetMemcached :: (MonadLogger m, MonadResource m) => WidgetMemcachedConf -> m Memcached.Connection
+createWidgetMemcached WidgetMemcachedConf{widgetMemcachedConnectInfo} = snd <$> allocate (Memcached.connect widgetMemcachedConnectInfo) Memcached.close
+
 -- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
 -- applying some additional middlewares.
 makeApplication :: MonadIO m => UniWorX -> m Application
@@ -348,6 +356,10 @@ getApplicationRepl = do
 shutdownApp :: MonadIO m => UniWorX -> m ()
 shutdownApp app = do
   stopJobCtl app
+  liftIO $ do
+    for_ (appWidgetMemcached app) Memcached.close
+    for_ (appSmtpPool app) destroyAllResources
+    destroyAllResources $ appConnPool app
   release . fst $ appLogger app
 
 
diff --git a/src/Foundation.hs b/src/Foundation.hs
index 8577ae9fd..0dc658312 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -6,7 +6,6 @@ module Foundation where
 import Import.NoFoundation
 import Database.Persist.Sql (ConnectionPool, runSqlPool)
 import Text.Hamlet          (hamletFile)
-import Text.Jasmine         (minifym)
 
 import qualified Web.ClientSession as ClientSession
 
@@ -18,7 +17,6 @@ import Jobs.Types
 
 import qualified Network.Wai as W (pathInfo)
 
-import Yesod.Default.Util   (addStaticContentExternal)
 import Yesod.Core.Types     (Logger)
 import qualified Yesod.Core.Unsafe as Unsafe
 import Data.CaseInsensitive (CI)
@@ -75,6 +73,9 @@ import qualified Data.Conduit.List as C
 
 import qualified Crypto.Saltine.Core.SecretBox as SecretBox
 
+import qualified Database.Memcached.Binary.IO as Memcached
+import Data.Bits (Bits(zeroBits))
+
 
 instance DisplayAble b => DisplayAble (E.CryptoID a b) where
   display = display . ciphertext
@@ -96,19 +97,20 @@ instance DisplayAble SchoolId where
 -- starts running, such as database connections. Every handler will have
 -- access to the data present here.
 data UniWorX = UniWorX
-    { appSettings     :: AppSettings
-    , appStatic       :: Static -- ^ Settings for static file serving.
-    , appConnPool     :: ConnectionPool -- ^ Database connection pool.
-    , appSmtpPool     :: Maybe SMTPPool
-    , appHttpManager  :: Manager
-    , appLogger       :: (ReleaseKey, TVar Logger)
-    , appLogSettings  :: TVar LogSettings
-    , appCryptoIDKey  :: CryptoIDKey
-    , appInstanceID   :: InstanceId
-    , appJobCtl       :: TVar (Map ThreadId (TMChan JobCtl))
-    , appCronThread   :: TMVar (ReleaseKey, ThreadId)
-    , appSessionKey   :: ClientSession.Key
-    , appSecretBoxKey :: SecretBox.Key
+    { appSettings        :: AppSettings
+    , appStatic          :: EmbeddedStatic -- ^ Settings for static file serving.
+    , appConnPool        :: ConnectionPool -- ^ Database connection pool.
+    , appSmtpPool        :: Maybe SMTPPool
+    , appWidgetMemcached :: Maybe Memcached.Connection
+    , appHttpManager     :: Manager
+    , appLogger          :: (ReleaseKey, TVar Logger)
+    , appLogSettings     :: TVar LogSettings
+    , appCryptoIDKey     :: CryptoIDKey
+    , appInstanceID      :: InstanceId
+    , appJobCtl          :: TVar (Map ThreadId (TMChan JobCtl))
+    , appCronThread      :: TMVar (ReleaseKey, ThreadId)
+    , appSessionKey      :: ClientSession.Key
+    , appSecretBoxKey    :: SecretBox.Key
     }
 
 type SMTPPool = Pool SMTPConnection
@@ -704,21 +706,15 @@ instance Yesod UniWorX where
 
     isAuthorized = evalAccess
 
-    -- This function creates static content files in the static folder
-    -- and names them based on a hash of their content. This allows
-    -- expiration dates to be set far in the future without worry of
-    -- users receiving stale content.
-    addStaticContent ext mime content = do
-        master <- getYesod
-        let staticDir = appStaticDir $ appSettings master
-        addStaticContentExternal
-            minifym
-            genFileName
-            staticDir
-            (StaticR . flip StaticRoute [])
-            ext
-            mime
-            content
+    addStaticContent ext _mime content = do
+      UniWorX{appWidgetMemcached, appSettings} <- getYesod
+      for ((,) <$> appWidgetMemcached <*> appWidgetMemcachedConf appSettings) $ \(mConn, WidgetMemcachedConf{ widgetMemcachedConnectInfo = _, .. }) -> do
+        let expiry = (maybe 0 ceiling widgetMemcachedExpiry)
+            touch = liftIO $ Memcached.touch expiry fileName mConn
+            add = liftIO $ Memcached.add zeroBits expiry fileName content mConn
+        C.catchIf Memcached.isKeyNotFound touch $ \_ ->
+          C.handleIf Memcached.isKeyExists (\_ -> return ()) add
+        return . Left $ widgetMemcachedBaseUrl <> "/" <> decodeUtf8 fileName
       where
         -- Generate a unique filename based on the content itself, this is used
         -- for deduplication so a collision resistant hash function is required
@@ -727,12 +723,11 @@ instance Yesod UniWorX where
         --
         -- Length of hash is 144 bits instead of MD5's 128, so as to avoid
         -- padding after base64-conversion
-        genFileName lbs = Text.unpack
-                        . Text.decodeUtf8
-                        . Base64.encode
-                        . (convert :: Digest (SHAKE256 144) -> ByteString)
-                        . runIdentity
-                        $ sourceList (Lazy.ByteString.toChunks lbs) $$ sinkHash
+        fileName = (<> ("." <> encodeUtf8 ext))
+                 . Base64.encode
+                 . (convert :: Digest (SHAKE256 144) -> ByteString)
+                 . runIdentity
+                 $ sourceList (Lazy.ByteString.toChunks content) $$ sinkHash
 
     -- What messages should be logged. The following includes all messages when
     -- in development, and warnings and errors in production.
diff --git a/src/Handler/Common.hs b/src/Handler/Common.hs
index 390b041e1..54eddd1c3 100644
--- a/src/Handler/Common.hs
+++ b/src/Handler/Common.hs
@@ -2,7 +2,7 @@
 module Handler.Common where
 
 import Data.FileEmbed (embedFile)
-import Import
+import Import hiding (embedFile)
 
 -- These handlers embed files in the executable at compile time to avoid a
 -- runtime dependency, and for efficiency.
@@ -10,8 +10,8 @@ import Import
 getFaviconR :: Handler TypedContent
 getFaviconR = do cacheSeconds $ 60 * 60 * 24 * 30 -- cache for a month
                  return $ TypedContent "image/x-icon"
-                        $ toContent $(embedFile "embedded/favicon.ico")
+                        $ toContent $(embedFile "static/favicon.ico")
 
 getRobotsR :: Handler TypedContent
 getRobotsR = return $ TypedContent typePlain
-                    $ toContent $(embedFile "embedded/robots.txt")
+                    $ toContent $(embedFile "static/robots.txt")
diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs
index 94c8ffbd2..9b0c591f8 100644
--- a/src/Import/NoFoundation.hs
+++ b/src/Import/NoFoundation.hs
@@ -3,7 +3,7 @@ module Import.NoFoundation
     , MForm
     ) where
 
-import ClassyPrelude.Yesod    as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy, foldlM)
+import ClassyPrelude.Yesod    as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy, foldlM, static)
 import Model                  as Import
 import Model.Types.JSON       as Import
 import Model.Migration        as Import
diff --git a/src/Settings.hs b/src/Settings.hs
index 9b4e48541..c042b9e39 100644
--- a/src/Settings.hs
+++ b/src/Settings.hs
@@ -29,7 +29,7 @@ import           Yesod.Default.Util          (WidgetFileSettings,
                                               widgetFileReload)
 import qualified Yesod.Auth.Util.PasswordStore as PWStore
 
-import Data.Time (NominalDiffTime)
+import Data.Time (NominalDiffTime, nominalDay)
 
 import Data.Scientific (toBoundedInteger)
 import Data.Word (Word16)
@@ -47,12 +47,15 @@ import qualified Data.Char as Char
 
 import qualified Network.HaskellNet.Auth as HaskellNet (UserName, Password, AuthType(..))
 import qualified Network.Socket as HaskellNet (PortNumber(..), HostName)
+import qualified Network as Network
 
 import Network.Mail.Mime (Address)
 import Network.Mail.Mime.Instances ()
 
 import Mail (VerpMode)
 
+import qualified Database.Memcached.Binary.Types as Memcached
+
 import Model
 import Settings.Cluster
 
@@ -68,6 +71,8 @@ data AppSettings = AppSettings
     -- ^ Configuration settings for accessing the LDAP-directory
     , appSmtpConf               :: Maybe SmtpConf
     -- ^ Configuration settings for accessing a SMTP Mailserver
+    , appWidgetMemcachedConf    :: Maybe WidgetMemcachedConf
+    -- ^ Configuration settings for accessing a Memcached instance for use with `addStaticContent`
     , appRoot                   :: Maybe Text
     -- ^ Base for all generated URLs. If @Nothing@, determined
     -- from the request headers.
@@ -167,6 +172,34 @@ data SmtpConf = SmtpConf
   , smtpPool :: ResourcePoolConf
   } deriving (Show)
 
+data WidgetMemcachedConf = WidgetMemcachedConf
+  { widgetMemcachedConnectInfo :: Memcached.ConnectInfo
+  , widgetMemcachedBaseUrl     :: Text
+  , widgetMemcachedExpiry      :: Maybe NominalDiffTime
+  } deriving (Show)
+
+instance FromJSON Memcached.Auth where
+  parseJSON = Aeson.withText "Auth" $ \(Text.breakOn "@" -> (encodeUtf8 -> user, encodeUtf8 -> pw)) -> return $ Memcached.Plain user pw
+
+instance FromJSON Network.PortID where
+  parseJSON v = Network.UnixSocket <$> pSocket v <|> Network.PortNumber <$> pNumber v <|> Network.Service <$> pService v
+    where
+      pSocket = Aeson.withText "UnixSocket" $ fmap unpack . assertM' ("/" `Text.isPrefixOf`)
+      pNumber = Aeson.withScientific "PortNumber" $ maybe (fail "PortNumber ") (return . (fromIntegral :: Word16 -> Network.PortNumber)) . toBoundedInteger
+      pService = Aeson.withText "Service" $ return . unpack
+
+instance FromJSON WidgetMemcachedConf where
+  parseJSON = withObject "WidgetMemcachedConf" $ \o -> do
+    connectHost <- o .: "host"
+    connectPort <- o .: "port"
+    connectAuth <- o .: "auth"
+    numConnection <- o .: "limit"
+    connectionIdleTime <- o .: "timeout"
+    widgetMemcachedBaseUrl <- o .: "base-url"
+    widgetMemcachedExpiry <- assertM (maybe True $ \t -> 0 < t && t <= 30 * nominalDay) $ o .:? "expiration"
+    
+    return WidgetMemcachedConf{ widgetMemcachedConnectInfo = Memcached.ConnectInfo{..}, .. }
+
 data ResourcePoolConf = ResourcePoolConf
   { poolStripes :: Int
   , poolTimeout :: NominalDiffTime
@@ -284,6 +317,15 @@ instance FromJSON AppSettings where
               Ldap.Plain host -> not $ null host
         appLdapConf               <- assertM nonEmptyHost <$> o .:? "ldap"
         appSmtpConf               <- assertM (not . null . smtpHost) <$> o .:? "smtp"
+        let validWidgetMemcachedConf WidgetMemcachedConf{ widgetMemcachedConnectInfo = Memcached.ConnectInfo{..}, ..} = and
+              [ not (null connectHost) || isUnixSocket connectPort
+              , not $ null widgetMemcachedBaseUrl
+              , numConnection > 0
+              , connectionIdleTime >= 0
+              ]
+            isUnixSocket (Network.UnixSocket _) = True
+            isUnixSocket _ = False
+        appWidgetMemcachedConf    <- assertM validWidgetMemcachedConf <$> o .:? "widget-memcached"
         appRoot                   <- o .:? "approot"
         appHost                   <- fromString <$> o .: "host"
         appPort                   <- o .: "port"
diff --git a/src/Settings/StaticFiles.hs b/src/Settings/StaticFiles.hs
index c8021d3a5..c7bd88255 100644
--- a/src/Settings/StaticFiles.hs
+++ b/src/Settings/StaticFiles.hs
@@ -1,18 +1,26 @@
-module Settings.StaticFiles where
+module Settings.StaticFiles
+  ( module Settings.StaticFiles
+  , module Yesod.EmbeddedStatic
+  ) where
+
+import ClassyPrelude
 
 import Settings     (appStaticDir, compileTimeAppSettings)
-import Yesod.Static (staticFiles)
+import Yesod.EmbeddedStatic
 
 -- This generates easy references to files in the static directory at compile time,
 -- giving you compile-time verification that referenced files exist.
 -- Warning: any files added to your static directory during run-time can't be
--- accessed this way. You'll have to use their FilePath or URL to access them.
+-- accessed this way.
 --
 -- For example, to refer to @static/js/script.js@ via an identifier, you'd use:
 --
 --     js_script_js
---
--- If the identifier is not available, you may use:
---
---     StaticFile ["js", "script.js"] []
-staticFiles (appStaticDir compileTimeAppSettings)
+
+#ifdef DEVELOPMENT
+#define DEV_BOOL True
+#else
+#define DEV_BOOL False
+#endif
+
+mkEmbeddedStatic DEV_BOOL "embeddedStatic" [embedDir $ appStaticDir compileTimeAppSettings]
diff --git a/stack.yaml b/stack.yaml
index bd108cdef..6ae2e45d6 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -45,4 +45,8 @@ extra-deps:
   - quickcheck-classes-0.4.14
   - semirings-0.2.1.1
 
+  - memcached-binary-0.2.0
+
+allow-newer: true
+
 resolver: lts-10.5
diff --git a/embedded/favicon.ico b/static/favicon.ico
similarity index 100%
rename from embedded/favicon.ico
rename to static/favicon.ico
diff --git a/embedded/robots.txt b/static/robots.txt
similarity index 100%
rename from embedded/robots.txt
rename to static/robots.txt

From ae04da3338eb256b4184ab7f4af3c249e9d2f443 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Wed, 5 Dec 2018 14:06:48 +0100
Subject: [PATCH 12/23] minor cleanup

---
 src/Settings.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/Settings.hs b/src/Settings.hs
index c042b9e39..8abbc1fe1 100644
--- a/src/Settings.hs
+++ b/src/Settings.hs
@@ -47,7 +47,7 @@ import qualified Data.Char as Char
 
 import qualified Network.HaskellNet.Auth as HaskellNet (UserName, Password, AuthType(..))
 import qualified Network.Socket as HaskellNet (PortNumber(..), HostName)
-import qualified Network as Network
+import qualified Network
 
 import Network.Mail.Mime (Address)
 import Network.Mail.Mime.Instances ()

From 1314bde6ff38e736729801fbebad74e798045f50 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Wed, 5 Dec 2018 14:08:35 +0100
Subject: [PATCH 13/23] Fix memcached deployment

---
 config/keter_testworx.yml | 6 ++++++
 config/keter_uni2work.yml | 6 ++++++
 2 files changed, 12 insertions(+)

diff --git a/config/keter_testworx.yml b/config/keter_testworx.yml
index b67de9dc6..be7037613 100644
--- a/config/keter_testworx.yml
+++ b/config/keter_testworx.yml
@@ -47,6 +47,12 @@ stanzas:
       - SMTPTIMEOUT
       - SMTPLIMIT
       - INSTANCE_ID
+      - MEMCACHEDHOST
+      - MEMCACHEDPORT
+      - MEMCACHEDLIMIT
+      - MEMCACHEDTIMEOUT
+      - MEMCACHEDROOT
+      - MEMCACHEDEXPIRATION
 
 # Use the following to automatically copy your bundle upon creation via `yesod
 # keter`. Uses `scp` internally, so you can set it to a remote destination
diff --git a/config/keter_uni2work.yml b/config/keter_uni2work.yml
index 04c0a506b..873124070 100644
--- a/config/keter_uni2work.yml
+++ b/config/keter_uni2work.yml
@@ -46,6 +46,12 @@ stanzas:
       - SMTPTIMEOUT
       - SMTPLIMIT
       - INSTANCE_ID
+      - MEMCACHEDHOST
+      - MEMCACHEDPORT
+      - MEMCACHEDLIMIT
+      - MEMCACHEDTIMEOUT
+      - MEMCACHEDROOT
+      - MEMCACHEDEXPIRATION
 
 
 # Use the following to automatically copy your bundle upon creation via `yesod

From 3080cac2f3c0f1afe49ce5d4d59e975c3c6bd7e1 Mon Sep 17 00:00:00 2001
From: SJost <jost@tcs.ifi.lmu.de>
Date: Wed, 5 Dec 2018 14:51:14 +0100
Subject: [PATCH 14/23] fix build

---
 src/Model/Types.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/Model/Types.hs b/src/Model/Types.hs
index bb0fdebd8..222b84a22 100644
--- a/src/Model/Types.hs
+++ b/src/Model/Types.hs
@@ -139,8 +139,8 @@ data SheetGradeSummary = SheetGradeSummary
   , numGradePasses :: Sum Int
   , sumGradePoints :: Sum Points
   , achievedPasses :: Maybe (Sum Int)
+  , achievedPoints :: Maybe (Sum Points)
   } deriving (Generic, Read, Show, Eq)
-} deriving (Generic, Show) -- TODO: Show added for Debugging only
 
 instance Monoid SheetGradeSummary where
   mempty  = memptydefault

From 5de9eb791a078a98ceb6284de7a2a2fe9216e97b Mon Sep 17 00:00:00 2001
From: SJost <jost@tcs.ifi.lmu.de>
Date: Wed, 5 Dec 2018 14:56:36 +0100
Subject: [PATCH 15/23] Fix gradingSummart.hamlet

---
 templates/widgets/gradingSummary.hamlet | 11 +++--------
 1 file changed, 3 insertions(+), 8 deletions(-)

diff --git a/templates/widgets/gradingSummary.hamlet b/templates/widgets/gradingSummary.hamlet
index f72c1edd9..a1c62237c 100644
--- a/templates/widgets/gradingSummary.hamlet
+++ b/templates/widgets/gradingSummary.hamlet
@@ -22,14 +22,9 @@ $# --
         $maybe _ <- hasPoints
           <td .table__td colspan=2>
         <td .table__td>#{display nrNoGrade}
-  $# TODO: for Steffen: show messages conditional upon table content
   $maybe _ <- positiveSum $ bonusSummary ^. _numSheets
     <p>_{MsgSheetTypeInfoBonus}
+      $maybe _ <- positiveSum =<< (bonusSummary ^. _achievedPoints)
+        _{MsgSheetGradingBonusIncluded}
+  $maybe _ <- positiveSum $ informationalSummary ^. _numSheets
     <p>_{MsgSheetTypeInfoNotGraded}
-    $maybe _ <- positiveSum =<< (bonusSummary ^. _achievedPoints)
-      <p>_{MsgSheetGradingBonusIncluded}
-  $nothing
-    $#TODO: MsgSheetTypeInfo into part about Bonus and about Informational
-    $maybe _ <- positiveSum $ informationalSummary ^. _numSheets
-      <p>_{MsgSheetTypeInfoBonus}
-      <p>_{MsgSheetTypeInfoNotGraded}
\ No newline at end of file

From c757bf9a005e1f343c46052025350c5de1aa42e4 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Wed, 5 Dec 2018 15:07:24 +0100
Subject: [PATCH 16/23] Include preload hints about static content

---
 src/Foundation.hs           | 18 ++++++++++++++----
 src/Handler/Utils/Rating.hs |  2 +-
 src/Utils/Lens.hs           |  2 +-
 3 files changed, 16 insertions(+), 6 deletions(-)

diff --git a/src/Foundation.hs b/src/Foundation.hs
index 0dc658312..80f979ff3 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -710,11 +710,19 @@ instance Yesod UniWorX where
       UniWorX{appWidgetMemcached, appSettings} <- getYesod
       for ((,) <$> appWidgetMemcached <*> appWidgetMemcachedConf appSettings) $ \(mConn, WidgetMemcachedConf{ widgetMemcachedConnectInfo = _, .. }) -> do
         let expiry = (maybe 0 ceiling widgetMemcachedExpiry)
-            touch = liftIO $ Memcached.touch expiry fileName mConn
-            add = liftIO $ Memcached.add zeroBits expiry fileName content mConn
+            touch = liftIO $ Memcached.touch expiry (encodeUtf8 $ pack fileName) mConn
+            add = liftIO $ Memcached.add zeroBits expiry (encodeUtf8 $ pack fileName) content mConn
+            link = pack $ unpack widgetMemcachedBaseUrl </> fileName
+            linkAs :: Maybe Text
+            linkAs
+              | ext == "js"  = Just "script"
+              | ext == "css" = Just "style"
+              | otherwise    = Nothing
         C.catchIf Memcached.isKeyNotFound touch $ \_ ->
           C.handleIf Memcached.isKeyExists (\_ -> return ()) add
-        return . Left $ widgetMemcachedBaseUrl <> "/" <> decodeUtf8 fileName
+        whenIsJust linkAs $ \linkAs' -> 
+          addHeader "Link" [st|<#{link}>; as=#{linkAs'}; rel=preload|]
+        return $ Left link
       where
         -- Generate a unique filename based on the content itself, this is used
         -- for deduplication so a collision resistant hash function is required
@@ -723,7 +731,9 @@ instance Yesod UniWorX where
         --
         -- Length of hash is 144 bits instead of MD5's 128, so as to avoid
         -- padding after base64-conversion
-        fileName = (<> ("." <> encodeUtf8 ext))
+        fileName = (<.> unpack ext)
+                 . unpack
+                 . decodeUtf8
                  . Base64.encode
                  . (convert :: Digest (SHAKE256 144) -> ByteString)
                  . runIdentity
diff --git a/src/Handler/Utils/Rating.hs b/src/Handler/Utils/Rating.hs
index be259344f..624b6cea4 100644
--- a/src/Handler/Utils/Rating.hs
+++ b/src/Handler/Utils/Rating.hs
@@ -41,7 +41,7 @@ import qualified Database.Esqueleto as E
 
 import qualified Data.Conduit.List as Conduit
 
-import Utils.Lens hiding ((<.>))
+import Utils.Lens
 
 
 instance HasResolution prec => Pretty (Fixed prec) where
diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs
index 7d7df4350..7d71d63ef 100644
--- a/src/Utils/Lens.hs
+++ b/src/Utils/Lens.hs
@@ -1,7 +1,7 @@
 module Utils.Lens ( module Utils.Lens ) where
 
 import Import.NoFoundation
-import Control.Lens as Utils.Lens
+import Control.Lens as Utils.Lens hiding ((<.>))
 import Control.Lens.Extras as Utils.Lens (is)
 import Utils.Lens.TH as Utils.Lens (makeLenses_)
 

From e94173acb10a3f7bfba91e78e53ddb246a2f8ff5 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Wed, 5 Dec 2018 15:13:12 +0100
Subject: [PATCH 17/23] Fix build

---
 src/Handler/Utils/SheetType.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/Handler/Utils/SheetType.hs b/src/Handler/Utils/SheetType.hs
index 69885e759..150b7cd63 100644
--- a/src/Handler/Utils/SheetType.hs
+++ b/src/Handler/Utils/SheetType.hs
@@ -5,7 +5,7 @@ module Handler.Utils.SheetType
 
 import Import
 import Data.Monoid (Sum(..))
-import Utils.Lens hiding ((<.>))
+import Utils.Lens
 
 addBonusToPoints :: SheetTypeSummary -> SheetTypeSummary
 addBonusToPoints sts =

From 3f60f6391c8a3625a3baa19c89cfa3e885f75bb5 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Wed, 5 Dec 2018 15:30:51 +0100
Subject: [PATCH 18/23] Revert "Include preload hints about static content"

This reverts commit c757bf9a005e1f343c46052025350c5de1aa42e4.
---
 src/Foundation.hs           | 18 ++++--------------
 src/Handler/Utils/Rating.hs |  2 +-
 src/Utils/Lens.hs           |  2 +-
 3 files changed, 6 insertions(+), 16 deletions(-)

diff --git a/src/Foundation.hs b/src/Foundation.hs
index 86216a4ed..a3a63fb55 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -721,19 +721,11 @@ instance Yesod UniWorX where
       UniWorX{appWidgetMemcached, appSettings} <- getYesod
       for ((,) <$> appWidgetMemcached <*> appWidgetMemcachedConf appSettings) $ \(mConn, WidgetMemcachedConf{ widgetMemcachedConnectInfo = _, .. }) -> do
         let expiry = (maybe 0 ceiling widgetMemcachedExpiry)
-            touch = liftIO $ Memcached.touch expiry (encodeUtf8 $ pack fileName) mConn
-            add = liftIO $ Memcached.add zeroBits expiry (encodeUtf8 $ pack fileName) content mConn
-            link = pack $ unpack widgetMemcachedBaseUrl </> fileName
-            linkAs :: Maybe Text
-            linkAs
-              | ext == "js"  = Just "script"
-              | ext == "css" = Just "style"
-              | otherwise    = Nothing
+            touch = liftIO $ Memcached.touch expiry fileName mConn
+            add = liftIO $ Memcached.add zeroBits expiry fileName content mConn
         C.catchIf Memcached.isKeyNotFound touch $ \_ ->
           C.handleIf Memcached.isKeyExists (\_ -> return ()) add
-        whenIsJust linkAs $ \linkAs' -> 
-          addHeader "Link" [st|<#{link}>; as=#{linkAs'}; rel=preload|]
-        return $ Left link
+        return . Left $ widgetMemcachedBaseUrl <> "/" <> decodeUtf8 fileName
       where
         -- Generate a unique filename based on the content itself, this is used
         -- for deduplication so a collision resistant hash function is required
@@ -742,9 +734,7 @@ instance Yesod UniWorX where
         --
         -- Length of hash is 144 bits instead of MD5's 128, so as to avoid
         -- padding after base64-conversion
-        fileName = (<.> unpack ext)
-                 . unpack
-                 . decodeUtf8
+        fileName = (<> ("." <> encodeUtf8 ext))
                  . Base64.encode
                  . (convert :: Digest (SHAKE256 144) -> ByteString)
                  . runIdentity
diff --git a/src/Handler/Utils/Rating.hs b/src/Handler/Utils/Rating.hs
index fc4e88574..8c8b4f273 100644
--- a/src/Handler/Utils/Rating.hs
+++ b/src/Handler/Utils/Rating.hs
@@ -41,7 +41,7 @@ import qualified Database.Esqueleto as E
 
 import qualified Data.Conduit.List as Conduit
 
-import Utils.Lens
+import Utils.Lens hiding ((<.>))
 
 
 instance HasResolution prec => Pretty (Fixed prec) where
diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs
index 7d71d63ef..7d7df4350 100644
--- a/src/Utils/Lens.hs
+++ b/src/Utils/Lens.hs
@@ -1,7 +1,7 @@
 module Utils.Lens ( module Utils.Lens ) where
 
 import Import.NoFoundation
-import Control.Lens as Utils.Lens hiding ((<.>))
+import Control.Lens as Utils.Lens
 import Control.Lens.Extras as Utils.Lens (is)
 import Utils.Lens.TH as Utils.Lens (makeLenses_)
 

From 7fc705730d5d70e4c1ae03826503618e2bb82eda Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Wed, 5 Dec 2018 17:57:13 +0100
Subject: [PATCH 19/23] Minor cleanup

---
 src/Foundation.hs           | 11 +++++++----
 src/Handler/Utils/Rating.hs |  2 +-
 src/Utils/Lens.hs           |  2 +-
 3 files changed, 9 insertions(+), 6 deletions(-)

diff --git a/src/Foundation.hs b/src/Foundation.hs
index a3a63fb55..ab9552bdf 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -721,11 +721,12 @@ instance Yesod UniWorX where
       UniWorX{appWidgetMemcached, appSettings} <- getYesod
       for ((,) <$> appWidgetMemcached <*> appWidgetMemcachedConf appSettings) $ \(mConn, WidgetMemcachedConf{ widgetMemcachedConnectInfo = _, .. }) -> do
         let expiry = (maybe 0 ceiling widgetMemcachedExpiry)
-            touch = liftIO $ Memcached.touch expiry fileName mConn
-            add = liftIO $ Memcached.add zeroBits expiry fileName content mConn
+            touch = liftIO $ Memcached.touch expiry (encodeUtf8 $ pack fileName) mConn
+            add = liftIO $ Memcached.add zeroBits expiry (encodeUtf8 $ pack fileName) content mConn
+            absoluteLink = unpack widgetMemcachedBaseUrl </> fileName
         C.catchIf Memcached.isKeyNotFound touch $ \_ ->
           C.handleIf Memcached.isKeyExists (\_ -> return ()) add
-        return . Left $ widgetMemcachedBaseUrl <> "/" <> decodeUtf8 fileName
+        return . Left $ pack absoluteLink
       where
         -- Generate a unique filename based on the content itself, this is used
         -- for deduplication so a collision resistant hash function is required
@@ -734,7 +735,9 @@ instance Yesod UniWorX where
         --
         -- Length of hash is 144 bits instead of MD5's 128, so as to avoid
         -- padding after base64-conversion
-        fileName = (<> ("." <> encodeUtf8 ext))
+        fileName = (<.> unpack ext)
+                 . unpack
+                 . decodeUtf8
                  . Base64.encode
                  . (convert :: Digest (SHAKE256 144) -> ByteString)
                  . runIdentity
diff --git a/src/Handler/Utils/Rating.hs b/src/Handler/Utils/Rating.hs
index 8c8b4f273..fc4e88574 100644
--- a/src/Handler/Utils/Rating.hs
+++ b/src/Handler/Utils/Rating.hs
@@ -41,7 +41,7 @@ import qualified Database.Esqueleto as E
 
 import qualified Data.Conduit.List as Conduit
 
-import Utils.Lens hiding ((<.>))
+import Utils.Lens
 
 
 instance HasResolution prec => Pretty (Fixed prec) where
diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs
index 7d7df4350..7d71d63ef 100644
--- a/src/Utils/Lens.hs
+++ b/src/Utils/Lens.hs
@@ -1,7 +1,7 @@
 module Utils.Lens ( module Utils.Lens ) where
 
 import Import.NoFoundation
-import Control.Lens as Utils.Lens
+import Control.Lens as Utils.Lens hiding ((<.>))
 import Control.Lens.Extras as Utils.Lens (is)
 import Utils.Lens.TH as Utils.Lens (makeLenses_)
 

From 5c8f837b88431727e6805d54f675b341276362c1 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Wed, 5 Dec 2018 19:47:18 +0100
Subject: [PATCH 20/23] Minor cleanup

---
 messages/uniworx/de.msg |  2 +-
 src/Foundation.hs       | 20 ++++++++++----------
 src/Utils.hs            | 19 ++++++++++---------
 3 files changed, 21 insertions(+), 20 deletions(-)

diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg
index 8b15af8b0..1595dc8d9 100644
--- a/messages/uniworx/de.msg
+++ b/messages/uniworx/de.msg
@@ -171,7 +171,7 @@ MaterialFree: Kursmaterialien ohne Anmeldung zugänglich
 UnauthorizedWrite: Sie haben hierfür keine Schreibberechtigung
 UnauthorizedSystemMessageTime: Diese Systemnachricht ist noch nicht oder nicht mehr einsehbar.
 UnauthorizedSystemMessageAuth: Diese Systemnachricht ist nur für angemeldete Benutzer einsehbar.
-UnsupportedAuthPredicate tag@String shownRoute@String: "#{tag}" wurde auf eine Route angewandt, die dies nicht unterstützt: #{shownRoute}
+UnsupportedAuthPredicate authTagT@Text shownRoute@String: "#{authTagT}" wurde auf eine Route angewandt, die dies nicht unterstützt: #{shownRoute}
 UnauthorizedDisabledTag authTag@AuthTag: Authorisierungsprädikat "#{toPathPiece authTag}" ist für Ihre Sitzung nicht aktiv
 UnknownAuthPredicate tag@String: Authorisierungsprädikat "#{tag}" ist dem System nicht bekannt
 
diff --git a/src/Foundation.hs b/src/Foundation.hs
index ab9552bdf..601db3527 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -454,7 +454,7 @@ tagAccessPredicate AuthTime = APDB $ \route _ -> case route of
          && NTop systemMessageTo   >= cTime
     return Authorized
 
-  r -> $unsupportedAuthPredicate "time" r
+  r -> $unsupportedAuthPredicate AuthTime r
 tagAccessPredicate AuthRegistered = APDB $ \route _ -> case route of
   CourseR tid ssh csh _ -> exceptT return return $ do
     authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
@@ -467,14 +467,14 @@ tagAccessPredicate AuthRegistered = APDB $ \route _ -> case route of
       return (E.countRows :: E.SqlExpr (E.Value Int64))
     guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedParticipant)
     return Authorized
-  r -> $unsupportedAuthPredicate "registered" r
+  r -> $unsupportedAuthPredicate AuthRegistered r
 tagAccessPredicate AuthCapacity = APDB $ \route _ -> case route of
   CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do
     Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
     registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ]
     guard $ NTop courseCapacity > NTop (Just registered)
     return Authorized
-  r -> $unsupportedAuthPredicate "capacity" r
+  r -> $unsupportedAuthPredicate AuthCapacity r
 tagAccessPredicate AuthEmpty = APDB $ \route _ -> case route of
   CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNotEmpty) $ do
     -- Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
@@ -482,41 +482,41 @@ tagAccessPredicate AuthEmpty = APDB $ \route _ -> case route of
     registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ]
     guard $ registered <= 0
     return Authorized
-  r -> $unsupportedAuthPredicate "empty" r
+  r -> $unsupportedAuthPredicate AuthEmpty r
 tagAccessPredicate AuthMaterials = APDB $ \route _ -> case route of
   CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do
     Entity _ Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
     guard courseMaterialFree
     return Authorized
-  r -> $unsupportedAuthPredicate "materials" r
+  r -> $unsupportedAuthPredicate AuthMaterials r
 tagAccessPredicate AuthOwner = APDB $ \route _ -> case route of
   CSubmissionR _ _ _ _ cID _ -> exceptT return return $ do
     sid <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSubmissionOwner) (const True :: CryptoIDError -> Bool) $ decrypt cID
     authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
     void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid
     return Authorized
-  r -> $unsupportedAuthPredicate "owner" r
+  r -> $unsupportedAuthPredicate AuthOwner r
 tagAccessPredicate AuthRated = APDB $ \route _ -> case route of
   CSubmissionR _ _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionRated) $ do
     sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
     sub <- MaybeT $ get sid
     guard $ submissionRatingDone sub
     return Authorized
-  r -> $unsupportedAuthPredicate "rated" r
+  r -> $unsupportedAuthPredicate AuthRated r
 tagAccessPredicate AuthUserSubmissions = APDB $ \route _ -> case route of
   CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedUserSubmission) $ do
     Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
     Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn
     guard $ sheetSubmissionMode == UserSubmissions
     return Authorized
-  r -> $unsupportedAuthPredicate "user-submissions" r
+  r -> $unsupportedAuthPredicate AuthUserSubmissions r
 tagAccessPredicate AuthCorrectorSubmissions = APDB $ \route _ -> case route of
   CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedCorrectorSubmission) $ do
     Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
     Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn
     guard $ sheetSubmissionMode == CorrectorSubmissions
     return Authorized
-  r -> $unsupportedAuthPredicate "corrector-submissions" r
+  r -> $unsupportedAuthPredicate AuthCorrectorSubmissions r
 tagAccessPredicate AuthAuthentication = APDB $ \route _ -> case route of
   MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do
     smId <- decrypt cID
@@ -524,7 +524,7 @@ tagAccessPredicate AuthAuthentication = APDB $ \route _ -> case route of
     isAuthenticated <- isJust <$> liftHandlerT maybeAuthId
     guard $ not systemMessageAuthenticatedOnly || isAuthenticated
     return Authorized
-  r -> $unsupportedAuthPredicate "authentication" r
+  r -> $unsupportedAuthPredicate AuthAuthentication r
 tagAccessPredicate AuthRead = APHandler . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite)
 tagAccessPredicate AuthWrite = APHandler . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized)
 
diff --git a/src/Utils.hs b/src/Utils.hs
index 0bd5a400d..fed726e6f 100644
--- a/src/Utils.hs
+++ b/src/Utils.hs
@@ -63,6 +63,9 @@ import qualified Crypto.Saltine.Core.SecretBox as SecretBox
 import qualified Crypto.Saltine.Class as Saltine
 import qualified Crypto.Data.PKCS7 as PKCS7
 
+import Data.Fixed (Centi)
+import Data.Ratio ((%))
+
 
 
 -----------
@@ -87,7 +90,7 @@ guardAuthResult AuthenticationRequired = notAuthenticated
 guardAuthResult (Unauthorized t) = permissionDenied t
 guardAuthResult Authorized = return ()
 
-data UnsupportedAuthPredicate route = UnsupportedAuthPredicate String route
+data UnsupportedAuthPredicate route = UnsupportedAuthPredicate Text route
   deriving (Eq, Ord, Typeable, Show)
 instance (Show route, Typeable route) => Exception (UnsupportedAuthPredicate route)
 
@@ -95,8 +98,8 @@ unsupportedAuthPredicate :: ExpQ
 unsupportedAuthPredicate = do
   logFunc <- logErrorS
   [e| \tag route -> do
-        $(return logFunc) "AccessControl" [st|"!#{tag}" used on route that doesn't support it: #{tshow route}|]
-        unauthorizedI (UnsupportedAuthPredicate tag route)
+        $(return logFunc) "AccessControl" [st|"!#{toPathPiece tag}" used on route that doesn't support it: #{tshow route}|]
+        unauthorizedI (UnsupportedAuthPredicate (toPathPiece tag) route)
     |]
 
 
@@ -204,17 +207,15 @@ instance {-# OVERLAPPABLE #-} Show a => DisplayAble a where -- The easy way out
   display = pack . show
 -}
 
-textPercent :: Double -> Text -- slow, maybe use Data.Double.Conversion.Text.toFixed instead?
+textPercent :: Real a => a -> Text -- slow, maybe use Data.Double.Conversion.Text.toFixed instead?
 textPercent x = lz <> pack (show rx) <> "%"
  where
-   round' :: Double -> Int -- avoids annoying warning
-   round' = round
-   rx :: Double
-   rx = fromIntegral (round' $ 1000.0*x) / 10.0
+   rx :: Centi
+   rx = realToFrac (x * 100)
    lz = if rx < 10.0 then "0" else ""
 
 textPercentInt :: Integral a => a -> a -> Text -- slow, maybe use Data.Double.Conversion.Text.toFixed instead?
-textPercentInt part whole = textPercent $ (fromIntegral part) / (fromIntegral whole)
+textPercentInt part whole = textPercent $ fromIntegral part % fromIntegral whole
 
 stepTextCounterCI :: CI Text -> CI Text -- find and increment rightmost-number, preserving leading zeroes
 stepTextCounterCI = CI.map stepTextCounter

From 32e6306cd512a97f3852152cb9557c6e276532a4 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Wed, 5 Dec 2018 20:57:04 +0100
Subject: [PATCH 21/23] Fix typo breaking modals without memcached

---
 templates/standalone/modal.julius | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/templates/standalone/modal.julius b/templates/standalone/modal.julius
index 607e9a7fe..5c2eb991c 100644
--- a/templates/standalone/modal.julius
+++ b/templates/standalone/modal.julius
@@ -76,7 +76,7 @@
 
                 var scriptClone = document.createElement('script');
                 if (scriptTag.text)
-                  scriptClone.text = striptTag.text;
+                  scriptClone.text = scriptTag.text;
                 if (scriptTag.hasAttributes()) {
                   var attrs = scriptTag.attributes;
                   for (var i = attrs.length - 1; i >= 0; i--) {

From 19413380753684aa0d378e31f7e489279d0c5b0b Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Wed, 5 Dec 2018 21:52:37 +0100
Subject: [PATCH 22/23] Cleanup pseudonym handling

Fixes #247
---
 src/Handler/Corrections.hs | 167 ++++++++++++++++++++-----------------
 test/Database.hs           |  10 ++-
 2 files changed, 101 insertions(+), 76 deletions(-)

diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs
index 31465c5f8..803ef4bae 100644
--- a/src/Handler/Corrections.hs
+++ b/src/Handler/Corrections.hs
@@ -14,12 +14,13 @@ import Utils.Lens
 
 import Data.Set (Set)
 import qualified Data.Set as Set
-import Data.Map (Map)
+import Data.Map (Map, (!))
 import qualified Data.Map as Map
 
 import qualified Data.Text as Text
 
 import Data.Semigroup (Sum(..))
+import Data.Monoid (All(..))
 
 -- import Data.Time
 -- import qualified Data.Text as T
@@ -46,7 +47,8 @@ import Database.Persist.Sql (updateWhereCount)
 
 import Data.List (genericLength)
 
-import Control.Monad.Trans.Writer (WriterT(..), runWriter)
+import Control.Monad.Trans.Writer (WriterT(..), runWriter, execWriterT)
+import Control.Monad.Trans.Reader (mapReaderT)
 
 import Control.Monad.Trans.RWS (RWST)
 
@@ -668,81 +670,96 @@ postCorrectionsCreateR = do
     FormMissing -> return ()
     FormFailure errs -> forM_ errs $ addMessage Error . toHtml
     FormSuccess (sid, (pss, invalids)) -> do
-      forM_ (Map.toList invalids) $ \((oPseudonyms, iPseudonym), alts) -> $(addMessageFile Warning "templates/messages/ignoredInvalidPseudonym.hamlet")
+      allDone <- fmap getAll . execWriterT $ do 
+        forM_ (Map.toList invalids) $ \((oPseudonyms, iPseudonym), alts) -> $(addMessageFile Error "templates/messages/ignoredInvalidPseudonym.hamlet")
+        tell . All $ null invalids
 
-      runDB $ do
-        Sheet{..} <- get404 sid
-        (sps, unknown) <- fmap partitionEithers' . forM pss . mapM $ \p -> maybe (Left p) Right <$> getBy (UniqueSheetPseudonym sid p)
-        forM_ unknown $ addMessageI Error . MsgUnknownPseudonym . review _PseudonymText
-        now <- liftIO getCurrentTime
-        let
-          sps' :: [[SheetPseudonym]]
-          duplicate :: Set Pseudonym
-          ( sps'
-            , Map.keysSet . Map.filter (\(getSum -> n) -> n > 1) -> duplicate
-            ) = flip runState Map.empty . forM sps . flip (foldrM :: (Entity SheetPseudonym -> [SheetPseudonym] -> State (Map Pseudonym (Sum Integer)) [SheetPseudonym]) -> [SheetPseudonym] -> [Entity SheetPseudonym] -> State (Map Pseudonym (Sum Integer)) [SheetPseudonym]) [] $ \(Entity _ p@SheetPseudonym{sheetPseudonymPseudonym}) ps -> do
-                  known <- State.gets $ Map.member sheetPseudonymPseudonym
-                  State.modify $ Map.insertWith (<>) sheetPseudonymPseudonym (Sum 1)
-                  return $ bool (p :) id known ps
-          submissionPrototype = Submission
-            { submissionSheet = sid
-            , submissionRatingPoints = Nothing
-            , submissionRatingComment = Nothing
-            , submissionRatingBy = Just uid
-            , submissionRatingAssigned = Just now
-            , submissionRatingTime = Nothing
-            }
-        unless (null duplicate)
-          $(addMessageFile Warning "templates/messages/submissionCreateDuplicates.hamlet")
-        existingSubUsers <- E.select . E.from $ \(submissionUser `E.InnerJoin` submission) -> do
-          E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission
-          E.where_ $ submissionUser E.^. SubmissionUserUser `E.in_` E.valList (sheetPseudonymUser <$> concat sps')
-               E.&&. submission E.^. SubmissionSheet E.==. E.val sid
-          return submissionUser
-        unless (null existingSubUsers) $ do
-          (Map.toList -> subs) <- foldrM (\(Entity _ SubmissionUser{..}) mp -> Map.insertWith (<>) <$> (encrypt submissionUserSubmission :: DB CryptoFileNameSubmission) <*> pure (Set.fromList . map sheetPseudonymPseudonym . filter (\SheetPseudonym{..} -> sheetPseudonymUser == submissionUserUser) $ concat sps') <*> pure mp) Map.empty existingSubUsers
-          $(addMessageFile Warning "templates/messages/submissionCreateExisting.hamlet")
-        let sps'' = filter (not . null) $ filter (\spGroup -> not . flip any spGroup $ \SheetPseudonym{sheetPseudonymUser} -> sheetPseudonymUser `elem` map (submissionUserUser . entityVal) existingSubUsers) sps'
-        forM_ sps'' $ \spGroup
-          -> let
-               sheetGroupDesc = Text.intercalate ", " $ map (review _PseudonymText . sheetPseudonymPseudonym) spGroup
-              in case sheetGrouping of
-          Arbitrary maxSize -> do
-            subId <- insert submissionPrototype
-            void . insert $ SubmissionEdit uid now subId
-            insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
-              { submissionUserUser = sheetPseudonymUser
-              , submissionUserSubmission = subId
+        WriterT . runDB . mapReaderT runWriterT $ do
+          Sheet{..} <- get404 sid
+          (sps, unknown) <- fmap partitionEithers' . forM pss . mapM $ \p -> maybe (Left p) Right <$> getBy (UniqueSheetPseudonym sid p)
+          forM_ unknown $ addMessageI Error . MsgUnknownPseudonym . review _PseudonymText
+          tell . All $ null unknown
+          now <- liftIO getCurrentTime
+          let
+            sps' :: [[SheetPseudonym]]
+            duplicate :: Set Pseudonym
+            ( sps'
+              , Map.keysSet . Map.filter (\(getSum -> n) -> n > 1) -> duplicate
+              ) = flip runState Map.empty . forM sps . flip (foldrM :: (Entity SheetPseudonym -> [SheetPseudonym] -> State (Map Pseudonym (Sum Integer)) [SheetPseudonym]) -> [SheetPseudonym] -> [Entity SheetPseudonym] -> State (Map Pseudonym (Sum Integer)) [SheetPseudonym]) [] $ \(Entity _ p@SheetPseudonym{sheetPseudonymPseudonym}) ps -> do
+                    known <- State.gets $ Map.member sheetPseudonymPseudonym
+                    State.modify $ Map.insertWith (<>) sheetPseudonymPseudonym (Sum 1)
+                    return $ bool (p :) id known ps
+            submissionPrototype = Submission
+              { submissionSheet = sid
+              , submissionRatingPoints = Nothing
+              , submissionRatingComment = Nothing
+              , submissionRatingBy = Just uid
+              , submissionRatingAssigned = Just now
+              , submissionRatingTime = Nothing
               }
-            when (genericLength spGroup > maxSize) $
-              addMessageI Warning $ MsgSheetGroupTooLarge sheetGroupDesc
-          RegisteredGroups -> do
-            groups <- E.select . E.from $ \submissionGroup -> do
-              E.where_ . E.exists . E.from $ \submissionGroupUser ->
-                E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser `E.in_` E.valList (map sheetPseudonymUser spGroup)
-              return $ submissionGroup E.^. SubmissionGroupId
-            if
-              | length (groups :: [E.Value SubmissionGroupId]) < 2
-                -> do
-                  subId <- insert submissionPrototype
-                  void . insert $ SubmissionEdit uid now subId
-                  insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
-                    { submissionUserUser = sheetPseudonymUser
-                    , submissionUserSubmission = subId
-                    }
-                  when (null groups) $
-                    addMessageI Warning $ MsgSheetNoRegisteredGroup sheetGroupDesc
-              | otherwise -> addMessageI Error $ MsgSheetAmbiguousRegisteredGroup sheetGroupDesc
-          NoGroups -> do
-            subId <- insert submissionPrototype
-            void . insert $ SubmissionEdit uid now subId
-            insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
-              { submissionUserUser = sheetPseudonymUser
-              , submissionUserSubmission = subId
-              }
-            when (length spGroup > 1) $
-              addMessageI Warning $ MsgSheetNoGroupSubmission sheetGroupDesc
-      redirect CorrectionsGradeR
+          unless (null duplicate)
+            $(addMessageFile Warning "templates/messages/submissionCreateDuplicates.hamlet")
+          existingSubUsers <- E.select . E.from $ \(submissionUser `E.InnerJoin` submission) -> do
+            E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission
+            E.where_ $ submissionUser E.^. SubmissionUserUser `E.in_` E.valList (sheetPseudonymUser <$> concat sps')
+                 E.&&. submission E.^. SubmissionSheet E.==. E.val sid
+            return submissionUser
+          unless (null existingSubUsers) . mapReaderT lift $ do
+            (Map.toList -> subs) <- foldrM (\(Entity _ SubmissionUser{..}) mp -> Map.insertWith (<>) <$> (encrypt submissionUserSubmission :: DB CryptoFileNameSubmission) <*> pure (Set.fromList . map sheetPseudonymPseudonym . filter (\SheetPseudonym{..} -> sheetPseudonymUser == submissionUserUser) $ concat sps') <*> pure mp) Map.empty existingSubUsers
+            $(addMessageFile Warning "templates/messages/submissionCreateExisting.hamlet")
+          let sps'' = filter (not . null) $ filter (\spGroup -> not . flip any spGroup $ \SheetPseudonym{sheetPseudonymUser} -> sheetPseudonymUser `elem` map (submissionUserUser . entityVal) existingSubUsers) sps'
+          forM_ sps'' $ \spGroup
+            -> let
+                 sheetGroupDesc = Text.intercalate ", " $ map (review _PseudonymText . sheetPseudonymPseudonym) spGroup
+                in case sheetGrouping of
+            Arbitrary maxSize -> do
+              subId <- insert submissionPrototype
+              void . insert $ SubmissionEdit uid now subId
+              insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
+                { submissionUserUser = sheetPseudonymUser
+                , submissionUserSubmission = subId
+                }
+              when (genericLength spGroup > maxSize) $
+                addMessageI Warning $ MsgSheetGroupTooLarge sheetGroupDesc
+            RegisteredGroups -> do
+              let spGroup' = Map.fromList $ map (sheetPseudonymUser &&& id) spGroup
+              groups <- E.select . E.from $ \submissionGroup -> do
+                E.where_ . E.exists . E.from $ \submissionGroupUser ->
+                  E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser `E.in_` E.valList (map sheetPseudonymUser spGroup)
+                return $ submissionGroup E.^. SubmissionGroupId
+              groupUsers <- fmap (Set.fromList . map E.unValue) . E.select . E.from $ \submissionGroupUser -> do
+                E.where_ $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup `E.in_` E.valList (map E.unValue groups)
+                return $ submissionGroupUser E.^. SubmissionGroupUserUser
+              if
+                | [_] <- groups
+                , Map.keysSet spGroup' `Set.isSubsetOf` groupUsers
+                  -> do
+                    subId <- insert submissionPrototype
+                    void . insert $ SubmissionEdit uid now subId
+                    insertMany_ . flip map (Set.toList groupUsers) $ \sheetUser -> SubmissionUser
+                      { submissionUserUser = sheetUser
+                      , submissionUserSubmission = subId
+                      }
+                    when (null groups) $
+                      addMessageI Warning $ MsgSheetNoRegisteredGroup sheetGroupDesc
+                | length groups < 2
+                  -> do
+                    forM_ (Set.toList (Map.keysSet spGroup' `Set.difference` groupUsers)) $ \((spGroup' !) -> SheetPseudonym{sheetPseudonymPseudonym}) -> do
+                      addMessageI Error $ MsgSheetNoRegisteredGroup (review _PseudonymText sheetPseudonymPseudonym)
+                      tell $ All False
+                | otherwise ->
+                    addMessageI Error $ MsgSheetAmbiguousRegisteredGroup sheetGroupDesc
+            NoGroups -> do
+              subId <- insert submissionPrototype
+              void . insert $ SubmissionEdit uid now subId
+              insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
+                { submissionUserUser = sheetPseudonymUser
+                , submissionUserSubmission = subId
+                }
+              when (length spGroup > 1) $
+                addMessageI Warning $ MsgSheetNoGroupSubmission sheetGroupDesc
+      when allDone $
+        redirect CorrectionsGradeR
 
 
   defaultLayout $
diff --git a/test/Database.hs b/test/Database.hs
index 0308a3dfa..1e42ecaf6 100755
--- a/test/Database.hs
+++ b/test/Database.hs
@@ -24,6 +24,9 @@ import qualified Data.ByteString as BS
 
 import Data.Time
 
+import Utils.Lens (review)
+import Control.Monad.Random.Class (MonadRandom(..))
+
 
 data DBAction = DBClear
               | DBTruncate
@@ -151,7 +154,7 @@ fillDb = do
     , userMailLanguages = MailLanguages ["de"]
     , userNotificationSettings = def
     }
-  void . insert $ User
+  tinaTester <- insert $ User
     { userIdent  = "tester@campus.lmu.de"
     , userAuthentication = AuthLDAP
     , userMatrikelnummer = Just "999"
@@ -312,6 +315,7 @@ fillDb = do
   insert_ $ CourseEdit jost now pmo
   void . insert $ DegreeCourse pmo sdBsc sdInf
   void . insert $ Lecturer jost pmo
+  void . insertMany $ map (\u -> CourseParticipant pmo u now) [fhamann, maxMuster, tinaTester]
   sh1 <- insert Sheet
     { sheetCourse = pmo
     , sheetName = "Blatt 1"
@@ -328,6 +332,10 @@ fillDb = do
     , sheetSolutionFrom = Nothing
     }
   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"

From aea7837c49643a02346ae916337f96cb9a977be3 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Wed, 5 Dec 2018 22:03:10 +0100
Subject: [PATCH 23/23] Debounce notifications much more aggressively

Fixes #251
---
 src/Jobs.hs | 14 ++++++++++----
 1 file changed, 10 insertions(+), 4 deletions(-)

diff --git a/src/Jobs.hs b/src/Jobs.hs
index 45a5f74f6..9385eeff4 100644
--- a/src/Jobs.hs
+++ b/src/Jobs.hs
@@ -134,6 +134,7 @@ execCrontab = evalStateT go HashMap.empty
         runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ merge
 
       refT <- liftIO getCurrentTime
+      settings <- getsYesod appSettings
       currentState <- mapStateT (mapReaderT $ liftIO . atomically) $ do
         crontab' <- liftBase . tryReadTMVar =<< asks jobCrontab
         case crontab' of
@@ -141,7 +142,7 @@ execCrontab = evalStateT go HashMap.empty
           Just crontab -> Just <$> do
             State.modify . HashMap.filterWithKey $ \k _ -> HashMap.member k crontab
             prevExec <- State.get
-            case earliestJob prevExec crontab refT of
+            case earliestJob settings prevExec crontab refT of
               Nothing -> liftBase retry
               Just (_, MatchNone) -> liftBase retry
               Just x -> return (crontab, x)
@@ -189,6 +190,11 @@ execCrontab = evalStateT go HashMap.empty
         acc :: NominalDiffTime
         acc = 1e-3
 
+        debouncingAcc :: AppSettings -> JobCtl -> NominalDiffTime
+        debouncingAcc AppSettings{appNotificationRateLimit} = \case
+          JobCtlQueue (JobQueueNotification _) -> appNotificationRateLimit
+          _ -> acc
+
         applyJitter :: (MonadHandler m, HandlerSite m ~ UniWorX, Hashable seed) => seed -> UTCTime -> m UTCTime
         applyJitter seed t = do
           appInstance <- getsYesod appInstanceID
@@ -197,8 +203,8 @@ execCrontab = evalStateT go HashMap.empty
             diff = evalRand ( (* acc) . fromInteger <$> getRandomR (- halfRange, halfRange)) $ mkStdGen (hash appInstance `hashWithSalt` seed)
           return $ addUTCTime diff t
 
-        earliestJob :: HashMap JobCtl (Max UTCTime) -> Crontab JobCtl -> UTCTime -> Maybe (JobCtl, CronNextMatch UTCTime)
-        earliestJob lastTimes crontab now = foldr go' Nothing $ HashMap.toList crontab
+        earliestJob :: AppSettings -> HashMap JobCtl (Max UTCTime) -> Crontab JobCtl -> UTCTime -> Maybe (JobCtl, CronNextMatch UTCTime)
+        earliestJob settings lastTimes crontab now = foldr go' Nothing $ HashMap.toList crontab
           where
             go' (jobCtl, cron) mbPrev
               | Just (_, t') <- mbPrev
@@ -207,7 +213,7 @@ execCrontab = evalStateT go HashMap.empty
               | otherwise
               = Just (jobCtl, t)
               where
-                t = nextCronMatch appTZ (getMax <$> HashMap.lookup jobCtl lastTimes) acc now cron
+                t = nextCronMatch appTZ (getMax <$> HashMap.lookup jobCtl lastTimes) (debouncingAcc settings jobCtl) now cron
 
         waitUntil :: (Eq a, MonadResourceBase m, MonadLogger m) => TMVar a -> a -> UTCTime -> m Bool
         waitUntil crontabTV crontab nextTime = runResourceT $ do