Merge branch '205-klausuren'

2019-07-16 11:58:13 +02:00 · 2019-07-16 11:58:13 +02:00 · 4d242799d1
commit 4d242799d1
parent 9dbef1fe0f 2218103cbd
24 changed files with 345 additions and 156 deletions
--- a/messages/uniworx/de.msg
+++ b/messages/uniworx/de.msg
@ -437,7 +437,9 @@ HasCorrector: Korrektor zugeteilt
 AssignedTime: Zuteilung
 AchievedBonusPoints: Erreichte Bonuspunkte
 AchievedNormalPoints: Erreichte Punkte
-AchievedPassPoints: Erreichte Punkte
+AchievedPoints: Erreichte Punkte
+AchievedPassPoints: Erreichte Punkte zum Bestehen
+AchievedPasses: Bestandene Blätter
 AchievedOf achieved@Points possible@Points: #{achieved} von #{possible}
 PassAchievedOf points@Points passingPoints@Points maxPoints@Points: #{points} von #{maxPoints} (Bestanden ab #{passingPoints})
 PassedResult: Ergebnis
@ -1113,8 +1115,10 @@ ExamRoomSurname': Nach Nachname
 ExamRoomMatriculation': Nach Matrikelnummer
 ExamRoomRandom': Zufällig pro Teilnehmer

+ExamOccurrence: Termin/Raum
 ExamOccurrences: Prüfungen
 ExamRoomAlreadyExists: Prüfung ist bereits eingetragen
+ExamRoomName: Interne Bezeichnung
 ExamRoom: Raum
 ExamRoomCapacity: Kapazität
 ExamRoomCapacityNegative: Kapazität darf nicht negativ sein
@ -1172,10 +1176,11 @@ ExamClosedMustBeAfterFinished: "Noten stehen fest ab" muss nach "Bewertung abges
 ExamClosedMustBeAfterStart: "Noten stehen fest ab" muss nach Start liegen
 ExamClosedMustBeAfterEnd: "Noten stehen fest ab" muss nach Ende liegen

-ExamOccurrenceEndMustBeAfterStart eoRoom@Text eoRange@Text: Beginn des Termins #{eoRoom} #{eoRange} muss vor seinem Ende liegen
-ExamOccurrenceStartMustBeAfterExamStart eoRoom@Text eoRange@Text: Beginn des Termins #{eoRoom} #{eoRange} muss nach Beginn der Klausur liegen
-ExamOccurrenceEndMustBeBeforeExamEnd eoRoom@Text eoRange@Text: Ende des Termins #{eoRoom} #{eoRange} muss vor Ende der Klausur liegen
+ExamOccurrenceEndMustBeAfterStart eoName@ExamOccurrenceName: Beginn des Termins #{eoName} muss vor seinem Ende liegen
+ExamOccurrenceStartMustBeAfterExamStart eoName@ExamOccurrenceName: Beginn des Termins #{eoName} muss nach Beginn der Klausur liegen
+ExamOccurrenceEndMustBeBeforeExamEnd eoName@ExamOccurrenceName: Ende des Termins #{eoName} muss vor Ende der Klausur liegen
 ExamOccurrenceDuplicate eoRoom@Text eoRange@Text: Raum #{eoRoom}, Termin #{eoRange} kommt mehrfach mit der selben Beschreibung vor
+ExamOccurrenceDuplicateName eoName@ExamOccurrenceName: Interne Terminbezeichnung #{eoName} kommt mehrfach vor

 VersionHistory: Versionsgeschichte
 KnownBugs: Bekannte Bugs
@ -1187,4 +1192,6 @@ CsvModifyExisting: Existierende Einträge angleichen
 CsvAddNew: Neue Einträge einfügen
 CsvDeleteMissing: Fehlende Einträge entfernen
 BtnCsvExport: CSV-Datei exportieren
-BtnCsvImport: CSV-Datei importieren
+BtnCsvImport: CSV-Datei importieren
+
+Proportion c@Text of@Text prop@Rational: #{c}/#{of} (#{rationalToFixed2 (100 * prop)}%)
--- a/models/exams
+++ b/models/exams
@ -25,11 +25,13 @@ ExamPart
  UniqueExamPart exam name
 ExamOccurrence
  exam ExamId
+  name ExamOccurrenceName
  room Text
  capacity Natural
  start UTCTime
  end UTCTime Maybe
  description Html Maybe
+  UniqueExamOccurrence exam name
 ExamRegistration
  exam ExamId
  user UserId
--- a/src/Data/CaseInsensitive/Instances.hs
+++ b/src/Data/CaseInsensitive/Instances.hs
@ -29,6 +29,8 @@ import Web.HttpApiData
 import Data.Binary (Binary)
 import qualified Data.Binary as Binary

+import qualified Data.Csv as Csv
+

 instance PersistField (CI Text) where
  toPersistValue ciText = PersistDbSpecific . Text.encodeUtf8 $ CI.original ciText
@ -86,11 +88,11 @@ instance (CI.FoldCase s, PathPiece s) => PathPiece (CI s) where
  fromPathPiece = fmap CI.mk . fromPathPiece
  toPathPiece = toPathPiece . CI.original

-instance ToHttpApiData (CI Text) where
+instance ToHttpApiData s => ToHttpApiData (CI s) where
  toUrlPiece = toUrlPiece . CI.original
  toEncodedUrlPiece = toEncodedUrlPiece . CI.original

-instance FromHttpApiData (CI Text) where
+instance (CI.FoldCase s, FromHttpApiData s) => FromHttpApiData (CI s) where
  parseUrlPiece = fmap CI.mk . parseUrlPiece

 instance (CI.FoldCase s, PathMultiPiece s) => PathMultiPiece (CI s) where
@ -101,3 +103,9 @@ instance (CI.FoldCase s, Binary s) => Binary (CI s) where
  get = CI.mk <$> Binary.get
  put = Binary.put . CI.original
  putList = Binary.putList . map CI.original
+
+instance Csv.ToField s => Csv.ToField (CI s) where
+  toField = Csv.toField . CI.original
+
+instance (CI.FoldCase s, Csv.FromField s) => Csv.FromField (CI s) where
+  parseField = fmap CI.original . Csv.parseField
--- a/src/Data/Fixed/Instances.hs
+++ b/src/Data/Fixed/Instances.hs
@ -9,5 +9,18 @@ import Data.Fixed

 import Text.Blaze (ToMarkup(..))

+import qualified Data.Csv as Csv
+
+import Data.Proxy (Proxy(..))
+
+import Data.Scientific
+  
+
 instance HasResolution a => ToMarkup (Fixed a) where
-  toMarkup = toMarkup . showFixed True
+  toMarkup = toMarkup . showFixed True
+
+
+instance HasResolution a => Csv.ToField (Fixed a) where
+  toField = Csv.toField . (realToFrac :: Fixed a -> Scientific)
+instance HasResolution a => Csv.FromField (Fixed a) where
+  parseField = fmap (MkFixed . (round :: Scientific -> Integer) . (* fromInteger (resolution $ Proxy @a))) . Csv.parseField
--- a/src/Data/UUID/Instances.hs
+++ b/src/Data/UUID/Instances.hs
@ -3,12 +3,13 @@
 module Data.UUID.Instances
  () where

-import ClassyPrelude
+import ClassyPrelude.Yesod
 import Data.UUID (UUID)
 import qualified Data.UUID as UUID

 import Database.Persist.Sql
-import Web.PathPieces
+
+import Text.Blaze (ToMarkup(..))
  

 instance PathPiece UUID where
@ -25,3 +26,13 @@ instance PersistField UUID where

 instance PersistFieldSql UUID where
  sqlType _ = SqlOther "uuid"
+
+instance ToMarkup UUID where
+  toMarkup uuid = [shamlet|
+                    $newline never
+                    <span .uuid>
+                      #{UUID.toText uuid}
+                  |]
+
+instance ToWidget site UUID where
+  toWidget = toWidget . toMarkup
--- a/src/Handler/Corrections.hs
+++ b/src/Handler/Corrections.hs
@ -168,7 +168,7 @@ colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DB

 colSMatrikel :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
 colSMatrikel = sortable Nothing (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput=(_, _, _, _, _, users) } -> let
-  protoCell = listCell (Map.toList users) $ \(userId, (User{..}, _)) -> anchorCellM (AdminUserR <$> encrypt userId) (maybe mempty toWidget userMatrikelnummer)
+  protoCell = listCell (Map.toList users) $ \(userId, (User{..}, _)) -> anchorCellM (AdminUserR <$> encrypt userId) (fromMaybe mempty userMatrikelnummer)
  in protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]

 colRating :: forall m a. IsDBTable m (a, SheetTypeSummary) => Colonnade Sortable CorrectionTableData (DBCell m (a, SheetTypeSummary))
--- a/src/Handler/Course.hs
+++ b/src/Handler/Course.hs
@ -437,7 +437,7 @@ getCShowR tid ssh csh = do
          guardM . hasReadAccessTo $ CExamR tid ssh csh examName EShowR
          return r
        dbtColonnade = dbColonnade $ mconcat
-          [ sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> indicatorCell <> anchorCell (CExamR tid ssh csh examName EShowR) (toWidget examName)
+          [ sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> indicatorCell <> anchorCell (CExamR tid ssh csh examName EShowR) examName
          , sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom
          , sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo
          , sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> maybe mempty (cell . flip (formatTimeRangeW SelFormatDateTime) examEnd) examStart
@ -1085,7 +1085,7 @@ colUserComment tid ssh csh =
    sortable (Just "note") (i18nCell MsgCourseUserNote)
      $ \DBRow{ dbrOutput=(Entity uid _, _, mbNoteKey,_) } ->
        maybeEmpty mbNoteKey $ const $
-          anchorCellM (courseLink <$> encrypt uid) (toWidget $ hasComment True)
+          anchorCellM (courseLink <$> encrypt uid) (hasComment True)
  where
    courseLink = CourseR tid ssh csh . CUserR

--- a/src/Handler/Exam.hs
+++ b/src/Handler/Exam.hs
@ -34,6 +34,8 @@ import qualified Data.Csv as Csv

 import qualified Data.Conduit.List as C

+import Numeric.Lens (integral)
+


 -- Dedicated ExamRegistrationButton
@ -69,7 +71,7 @@ getCExamListR tid ssh csh = do
          guardM . hasReadAccessTo $ CExamR tid ssh csh examName EShowR
          return x
        dbtColonnade = dbColonnade . mconcat $ catMaybes
-          [ Just . sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> anchorCell (CExamR tid ssh csh examName EShowR) $ toWidget examName
+          [ Just . sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> anchorCell (CExamR tid ssh csh examName EShowR) examName
          , (<$ guard mayCreate) . sortable (Just "visible") (i18nCell MsgExamVisibleFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty (dateTimeCellVisible now) examVisibleFrom
          , Just . sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom
          , Just . sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo
@ -184,6 +186,7 @@ data ExamForm = ExamForm

 data ExamOccurrenceForm = ExamOccurrenceForm
  { eofId :: Maybe CryptoUUIDExamOccurrence
+  , eofName :: ExamOccurrenceName
  , eofRoom :: Text
  , eofCapacity :: Natural
  , eofStart :: UTCTime
@ -296,7 +299,8 @@ examOccurrenceForm prev = wFormToAForm $ do
  where
    examOccurrenceForm' nudge mPrev csrf = do
      (eofIdRes, eofIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ eofId =<< mPrev)
-      (eofRoomRes, eofRoomView) <- mpreq textField ("" & addName (nudge "name")) (eofRoom <$> mPrev)
+      (eofNameRes, eofNameView) <- mpreq ciField ("" & addName (nudge "name")) (eofName <$> mPrev)
+      (eofRoomRes, eofRoomView) <- mpreq textField ("" & addName (nudge "room")) (eofRoom <$> mPrev)
      (eofCapacityRes, eofCapacityView) <- mpreq (natFieldI MsgExamRoomCapacityNegative) ("" & addName (nudge "capacity")) (eofCapacity <$> mPrev)
      (eofStartRes, eofStartView) <- mpreq utcTimeField ("" & addName (nudge "start")) (eofStart <$> mPrev)
      (eofEndRes, eofEndView) <- mopt utcTimeField ("" & addName (nudge "end")) (eofEnd <$> mPrev)
@ -304,6 +308,7 @@ examOccurrenceForm prev = wFormToAForm $ do

      return ( ExamOccurrenceForm
                 <$> eofIdRes
+                 <*> eofNameRes
                 <*> eofRoomRes
                 <*> eofCapacityRes
                 <*> eofStartRes
@ -392,6 +397,7 @@ examFormTemplate (Entity eId Exam{..}) = do
        (Just -> eofId, ExamOccurrence{..}) <- occurrences'
        return ExamOccurrenceForm
          { eofId
+          , eofName        = examOccurrenceName
          , eofRoom        = examOccurrenceRoom
          , eofCapacity    = examOccurrenceCapacity
          , eofStart       = examOccurrenceStart
@ -476,11 +482,9 @@ validateExam = do
  guardValidation MsgExamClosedMustBeAfterEnd                              . fromMaybe True $ (>=) <$> efClosed <*> efEnd

  forM_ efOccurrences $ \ExamOccurrenceForm{..} -> do
-    eofRange' <- formatTimeRange SelFormatDateTime eofStart eofEnd
-
-    guardValidation (MsgExamOccurrenceEndMustBeAfterStart eofRoom eofRange') $ NTop eofEnd >= NTop (Just eofStart)
-    guardValidation (MsgExamOccurrenceStartMustBeAfterExamStart eofRoom eofRange') $ NTop (Just eofStart) >= NTop efStart
-    guardValidation (MsgExamOccurrenceEndMustBeBeforeExamEnd eofRoom eofRange') $ NTop eofEnd <= NTop efEnd
+    guardValidation (MsgExamOccurrenceEndMustBeAfterStart eofName) $ NTop eofEnd >= NTop (Just eofStart)
+    guardValidation (MsgExamOccurrenceStartMustBeAfterExamStart eofName) $ NTop (Just eofStart) >= NTop efStart
+    guardValidation (MsgExamOccurrenceEndMustBeBeforeExamEnd eofName) $ NTop eofEnd <= NTop efEnd

  forM_ [ (a, b) | a <- Set.toAscList efOccurrences, b <- Set.toAscList efOccurrences, b > a ] $ \(a, b) -> do
    eofRange' <- formatTimeRange SelFormatDateTime (eofStart a) (eofEnd a)
@ -492,6 +496,8 @@ validateExam = do
      , (/=) `on` fmap renderHtml . eofDescription
      ]

+    guardValidation (MsgExamOccurrenceDuplicateName $ eofName a) $ ((/=) `on` eofName) a b
+

 getCExamNewR, postCExamNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 getCExamNewR = postCExamNewR
@ -538,6 +544,7 @@ postCExamNewR tid ssh csh = do
          [ ExamOccurrence{..}
          | ExamOccurrenceForm{..} <- Set.toList efOccurrences
          , let examOccurrenceExam        = examid
+                examOccurrenceName        = eofName
                examOccurrenceRoom        = eofRoom
                examOccurrenceCapacity    = eofCapacity
                examOccurrenceStart       = eofStart
@ -611,6 +618,7 @@ postEEditR tid ssh csh examn = do
          ExamOccurrenceForm{ eofId = Nothing, .. } -> insert_
            ExamOccurrence
              { examOccurrenceExam = eId
+              , examOccurrenceName = eofName
              , examOccurrenceRoom = eofRoom
              , examOccurrenceCapacity = eofCapacity
              , examOccurrenceStart = eofStart
@ -624,6 +632,7 @@ postEEditR tid ssh csh examn = do
            guard $ examOccurrenceExam oldOcc == eId
            lift $ replace eofId' ExamOccurrence
              { examOccurrenceExam = eId
+              , examOccurrenceName = eofName
              , examOccurrenceRoom = eofRoom
              , examOccurrenceCapacity = eofCapacity
              , examOccurrenceStart = eofStart
@ -688,8 +697,8 @@ getEShowR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
 getEShowR tid ssh csh examn = do
  cTime <- liftIO getCurrentTime
  mUid <- maybeAuthId
-
-  (Entity _ Exam{..}, parts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister)) <- runDB $ do
+  
+  (Entity _ Exam{..}, parts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister), occurrenceNamesShown) <- runDB $ do
    exam@(Entity eId Exam{..}) <- fetchExam tid ssh csh examn

    let examVisible = NTop (Just cTime) >= NTop examVisibleFrom
@ -729,7 +738,9 @@ getEShowR tid ssh csh examn = do
    registered <- for mUid $ existsBy . UniqueExamRegistration eId
    mayRegister <- (== Authorized) <$> evalAccessDB (CExamR tid ssh csh examName ERegisterR) True

-    return (exam, parts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister))
+    occurrenceNamesShown <- hasReadAccessTo $ CExamR tid ssh csh examn EEditR
+
+    return (exam, parts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister), occurrenceNamesShown)

  let examTimes = all (\(Entity _ ExamOccurrence{..}, _) -> Just examOccurrenceStart == examStart && examOccurrenceEnd == examEnd) occurrences
      registerWidget
@ -789,6 +800,9 @@ queryStudyFeatures = $(sqlIJproj 3 1) . $(sqlLOJproj 2 2) . $(sqlLOJproj 3 3)
 queryExamRegistration :: ExamUserTableExpr -> E.SqlExpr (Entity ExamRegistration)
 queryExamRegistration = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)

+queryExamOccurrence :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamOccurrence))
+queryExamOccurrence = $(sqlLOJproj 3 2)
+
 queryStudyDegree :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyDegree))
 queryStudyDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 2 2) . $(sqlLOJproj 3 3)

@ -811,18 +825,22 @@ resultExamOccurrence :: Traversal' ExamUserTableData (Entity ExamOccurrence)
 resultExamOccurrence = _dbrOutput . _3 . _Just

 data ExamUserTableCsv = ExamUserTableCsv
-  { csvUserSurname :: Text
-  , csvUserName :: Text
-  , csvUserMatriculation :: Maybe Text
-  , csvUserField :: Maybe Text
-  , csvUserDegree :: Maybe Text
-  , csvUserSemester :: Maybe Int
-  , csvUserRoom :: Maybe Text
+  { csvEUserSurname :: Maybe Text
+  , csvEUserName :: Maybe Text
+  , csvEUserMatriculation :: Maybe Text
+  , csvEUserField :: Maybe Text
+  , csvEUserDegree :: Maybe Text
+  , csvEUserSemester :: Maybe Int
+  , csvEUserOccurrence :: Maybe (CI Text)
+  , csvEUserExercisePoints, csvEUserExercisePassPoints :: Maybe Points
+  , csvEUserExercisePasses :: Maybe Int
+  , csvEUserExercisePointsMax, csvEUserExercisePassPointsMax :: Maybe Points
+  , csvEUserExercisePassesMax :: Maybe Int
  }
  deriving (Generic)

 examUserTableCsvOptions :: Csv.Options
-examUserTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 1 }
+examUserTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 3 }

 instance ToNamedRecord ExamUserTableCsv where
  toNamedRecord = Csv.genericToNamedRecord examUserTableCsvOptions
@ -836,72 +854,101 @@ instance DefaultOrdered ExamUserTableCsv where
 getEUsersR, postEUsersR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
 getEUsersR = postEUsersR
 postEUsersR tid ssh csh examn = do
-  Entity eid Exam{..} <- runDB $ fetchExam tid ssh csh examn
+  ((), examUsersTable) <- runDB $ do
+    exam@(Entity eid Exam{..}) <- fetchExam tid ssh csh examn
+    bonus <- examBonus exam

-  let
-    examUsersDBTable = DBTable{..}
-      where
-        dbtSQLQuery ((examRegistration `E.InnerJoin` user) `E.LeftOuterJoin` occurrence `E.LeftOuterJoin` (courseParticipant `E.LeftOuterJoin` (studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyField))) = do
-          E.on $ studyField E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField
-          E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree
-          E.on $ studyFeatures E.?. StudyFeaturesId E.==. E.joinV (courseParticipant E.?. CourseParticipantField)
-          E.on $ courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val examCourse)
-           E.&&. courseParticipant E.?. CourseParticipantUser E.==. E.just (user E.^. UserId)
-          E.on $ occurrence E.?. ExamOccurrenceExam E.==. E.just (E.val eid)
-           E.&&. occurrence E.?. ExamOccurrenceId   E.==. examRegistration E.^. ExamRegistrationOccurrence
-          E.on $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId
-          E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eid
-          return (examRegistration, user, occurrence, studyFeatures, studyDegree, studyField)
-        dbtRowKey = queryExamRegistration >>> (E.^. ExamRegistrationId)
-        dbtProj = return
-        dbtColonnade = dbColonnade $ mconcat
-          [ colUserNameLink (CourseR tid ssh csh . CUserR)
-          , colUserMatriclenr
-          , colField            resultStudyField
-          , colDegreeShort      resultStudyDegree
-          , colFeaturesSemester resultStudyFeatures
-          , sortable (Just "room") (i18nCell MsgExamRoom) (maybe mempty (cell . toWgt . examOccurrenceRoom . entityVal) . view _userTableOccurrence)
-          ]
-        dbtSorting = Map.fromList
-          [ sortUserNameLink     queryUser
-          , sortUserSurname      queryUser
-          , sortUserDisplayName  queryUser
-          , sortUserMatriclenr   queryUser
-          , sortField            queryStudyField
-          , sortDegreeShort      queryStudyDegree
-          , sortFeaturesSemester queryStudyFeatures
-          ]
-        dbtFilter = Map.fromList
-          [ fltrUserNameEmail    queryUser
-          , fltrUserMatriclenr   queryUser
-          , fltrField            queryStudyField
-          , fltrDegree           queryStudyDegree
-          , fltrFeaturesSemester queryStudyFeatures
-          ]
-        dbtFilterUI mPrev = mconcat
-          [ fltrUserNameEmailUI    mPrev
-          , fltrUserMatriclenrUI   mPrev
-          , fltrFieldUI            mPrev
-          , fltrDegreeUI           mPrev
-          , fltrFeaturesSemesterUI mPrev
-          ]
-        dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
-        dbtParams = def
-        dbtIdent :: Text
-        dbtIdent = "exam-users"
-        dbtCsvEncode :: DBTCsvEncode ExamUserTableData ExamUserTableCsv
-        dbtCsvEncode = DictJust . C.map $ ExamUserTableCsv
-          <$> view (resultUser . _entityVal . _userSurname)
-          <*> view (resultUser . _entityVal . _userDisplayName)
-          <*> view (resultUser . _entityVal . _userMatrikelnummer)
-          <*> preview (resultStudyField . _entityVal . to (\StudyTerms{..} -> studyTermsName <|> studyTermsShorthand <|> Just (tshow studyTermsKey)) . _Just)
-          <*> preview (resultStudyDegree . _entityVal . to (\StudyDegree{..} -> studyDegreeName <|> studyDegreeShorthand <|> Just (tshow studyDegreeKey)) . _Just)
-          <*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester)
-          <*> preview (resultExamOccurrence . _entityVal . _examOccurrenceRoom)
-        dbtCsvDecode = Nothing
+    let
+      allBoni = (mappend <$> normalSummary <*> bonusSummary) $ fold bonus
+      showPasses     = numSheetsPasses allBoni /= 0
+      showPoints     = getSum (numSheetsPoints allBoni) - getSum (numSheetsPassPoints allBoni) /= 0
+      showPassPoints = numSheetsPassPoints allBoni /= 0

-    examUsersDBTableValidator = def
-  ((), examUsersTable) <- runDB $ dbTable examUsersDBTableValidator examUsersDBTable
+    let
+      examUsersDBTable = DBTable{..}
+        where
+          dbtSQLQuery ((examRegistration `E.InnerJoin` user) `E.LeftOuterJoin` occurrence `E.LeftOuterJoin` (courseParticipant `E.LeftOuterJoin` (studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyField))) = do
+            E.on $ studyField E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField
+            E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree
+            E.on $ studyFeatures E.?. StudyFeaturesId E.==. E.joinV (courseParticipant E.?. CourseParticipantField)
+            E.on $ courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val examCourse)
+             E.&&. courseParticipant E.?. CourseParticipantUser E.==. E.just (user E.^. UserId)
+            E.on $ occurrence E.?. ExamOccurrenceExam E.==. E.just (E.val eid)
+             E.&&. occurrence E.?. ExamOccurrenceId   E.==. examRegistration E.^. ExamRegistrationOccurrence
+            E.on $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId
+            E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eid
+            return (examRegistration, user, occurrence, studyFeatures, studyDegree, studyField)
+          dbtRowKey = queryExamRegistration >>> (E.^. ExamRegistrationId)
+          dbtProj = return
+          dbtColonnade = dbColonnade . mconcat $ catMaybes
+            [ pure $ colUserNameLink (CourseR tid ssh csh . CUserR)
+            , pure   colUserMatriclenr
+            , pure $ colField            resultStudyField
+            , pure $ colDegreeShort      resultStudyDegree
+            , pure $ colFeaturesSemester resultStudyFeatures
+            , pure $ sortable (Just "occurrence") (i18nCell MsgExamOccurrence) $ maybe mempty (anchorCell' (\n -> CExamR tid ssh csh examn EShowR :#: [st|exam-occurrence__#{n}|]) id . examOccurrenceName . entityVal) . view _userTableOccurrence
+            , guardOn showPasses $ sortable Nothing (i18nCell MsgAchievedPasses) $ \(view $ resultUser . _entityKey -> uid) -> fromMaybe mempty $ do
+                SheetGradeSummary{achievedPasses} <- examBonusAchieved uid bonus
+                SheetGradeSummary{numSheetsPasses} <- examBonusPossible uid bonus
+                return $ propCell (getSum achievedPasses) (getSum numSheetsPasses)
+            , guardOn showPassPoints $ sortable Nothing (i18nCell MsgAchievedPassPoints) $ \(view $ resultUser . _entityKey -> uid) -> fromMaybe mempty $ do
+                SheetGradeSummary{achievedPassPoints} <- examBonusAchieved uid bonus
+                SheetGradeSummary{sumSheetsPassPoints} <- examBonusPossible uid bonus
+                return $ propCell (getSum achievedPassPoints) (getSum sumSheetsPassPoints)
+            , guardOn showPoints $ sortable Nothing (i18nCell MsgAchievedPoints) $ \(view $ resultUser . _entityKey -> uid) -> fromMaybe mempty $ do
+                SheetGradeSummary{achievedPoints, achievedPassPoints} <- examBonusAchieved uid bonus
+                SheetGradeSummary{sumSheetsPoints, sumSheetsPassPoints} <- examBonusPossible uid bonus
+                return $ propCell (getSum achievedPoints - getSum achievedPassPoints) (getSum sumSheetsPoints - getSum sumSheetsPassPoints)
+            ] 
+          dbtSorting = Map.fromList
+            [ sortUserNameLink     queryUser
+            , sortUserSurname      queryUser
+            , sortUserDisplayName  queryUser
+            , sortUserMatriclenr   queryUser
+            , sortField            queryStudyField
+            , sortDegreeShort      queryStudyDegree
+            , sortFeaturesSemester queryStudyFeatures
+            , ("occurrence", SortColumn $ queryExamOccurrence >>> (E.?. ExamOccurrenceName))
+            ]
+          dbtFilter = Map.fromList
+            [ fltrUserNameEmail    queryUser
+            , fltrUserMatriclenr   queryUser
+            , fltrField            queryStudyField
+            , fltrDegree           queryStudyDegree
+            , fltrFeaturesSemester queryStudyFeatures
+            , ("occurrence", FilterColumn . E.mkContainsFilterWith Just $ queryExamOccurrence >>> (E.?. ExamOccurrenceName))
+            ]
+          dbtFilterUI mPrev = mconcat
+            [ fltrUserNameEmailUI    mPrev
+            , fltrUserMatriclenrUI   mPrev
+            , fltrFieldUI            mPrev
+            , fltrDegreeUI           mPrev
+            , fltrFeaturesSemesterUI mPrev
+            , prismAForm (singletonFilter "occurrence") mPrev $ aopt textField (fslI MsgExamOccurrence)
+            ]
+          dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
+          dbtParams = def
+          dbtIdent :: Text
+          dbtIdent = "exam-users"
+          dbtCsvEncode :: DBTCsvEncode ExamUserTableData ExamUserTableCsv
+          dbtCsvEncode = DictJust . C.map $ ExamUserTableCsv
+            <$> view (resultUser . _entityVal . _userSurname . to Just)
+            <*> view (resultUser . _entityVal . _userDisplayName . to Just)
+            <*> view (resultUser . _entityVal . _userMatrikelnummer)
+            <*> preview (resultStudyField . _entityVal . to (\StudyTerms{..} -> studyTermsName <|> studyTermsShorthand <|> Just (tshow studyTermsKey)) . _Just)
+            <*> preview (resultStudyDegree . _entityVal . to (\StudyDegree{..} -> studyDegreeName <|> studyDegreeShorthand <|> Just (tshow studyDegreeKey)) . _Just)
+            <*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester)
+            <*> preview (resultExamOccurrence . _entityVal . _examOccurrenceName)
+            <*> preview (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPoints . _Wrapped)
+            <*> preview (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPassPoints . _Wrapped)
+            <*> preview (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPasses . _Wrapped . integral)
+            <*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _sumSheetsPoints . _Wrapped)
+            <*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _sumSheetsPassPoints . _Wrapped)
+            <*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _numSheetsPasses . _Wrapped . integral)
+          dbtCsvDecode = Nothing
+
+      examUsersDBTableValidator = def
+    dbTable examUsersDBTableValidator examUsersDBTable

  siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamUsersHeading) $ do
    setTitleI $ prependCourseTitle tid ssh csh MsgExamUsersHeading
--- a/src/Handler/Home.hs
+++ b/src/Handler/Home.hs
@ -47,7 +47,7 @@ homeOpenCourses = do
            let tid = courseTerm      course
                ssh = courseSchool    course
                csh = courseShorthand course
-            anchorCell (CourseR tid ssh csh CShowR) (toWidget csh)
+            anchorCell (CourseR tid ssh csh CShowR) csh
        , sortable (Just "deadline") (i18nCell MsgRegisterTo) $ \DBRow{ dbrOutput=Entity{entityVal = course} } ->
            cell $ traverse (formatTime SelFormatDateTime) (courseRegisterTo course) >>= maybe mempty toWidget
        ]
@ -130,9 +130,9 @@ homeUpcomingSheets uid = do
        , sortable (Just "school") (i18nCell MsgCourseSchool) $ \DBRow{ dbrOutput=(_,E.Value ssh,_,_,_,_) } ->
            textCell $ toMessage ssh
        , sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, _, _, _) } ->
-            anchorCell (CourseR tid ssh csh CShowR) (toWidget csh)
+            anchorCell (CourseR tid ssh csh CShowR) csh
        , sortable (Just "sheet")  (i18nCell MsgSheet)  $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) } ->
-            anchorCell (CSheetR tid ssh csh shn SShowR) (toWidget shn)
+            anchorCell (CSheetR tid ssh csh shn SShowR) shn
        , sortable (Just "deadline") (i18nCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, _, E.Value deadline, _) } ->
            cell $ formatTime SelFormatDateTime deadline >>= toWidget
        , sortable (Just "done")   (i18nCell MsgDone)   $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, E.Value mbsid) } ->
@ -142,7 +142,7 @@ homeUpcomingSheets uid = do
                whenM (hasWriteAccessTo submitRoute) $
                  modal [whamlet|_{MsgMenuSubmissionNew}|] . Left $ SomeRoute submitRoute
              (Just sid) -> anchorCellM (CSubmissionR tid ssh csh shn <$> encrypt sid <*> pure SubShowR)
-                                        (toWidget $ hasTickmark True)
+                                        (hasTickmark True)
        ]
  let validator = def & defaultSorting [SortDescBy "done", SortAscBy "deadline"]
  sheetTable <- liftHandlerT . runDB $ dbTableWidget' validator DBTable
@ -228,7 +228,7 @@ homeUpcomingExams uid = do
          , sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput } -> do
              let Entity _ Exam{..}   = view lensExam   dbrOutput
                  Entity _ Course{..} = view lensCourse dbrOutput
-              indicatorCell <> anchorCell (CExamR courseTerm courseSchool courseShorthand examName EShowR) (toWidget examName)
+              indicatorCell <> anchorCell (CExamR courseTerm courseSchool courseShorthand examName EShowR) examName
          , sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom
          , sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo
          , sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty (cell . flip (formatTimeRangeW SelFormatDateTime) examEnd) examStart
--- a/src/Handler/Sheet.hs
+++ b/src/Handler/Sheet.hs
@ -207,7 +207,7 @@ getSheetListR tid ssh csh = do
    sheetCol = widgetColonnade . mconcat $
      [ -- dbRow ,
        sortable (Just "name") (i18nCell MsgSheet)
-          $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> anchorCell (CSheetR tid ssh csh sheetName SShowR) (toWidget sheetName)
+          $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> anchorCell (CSheetR tid ssh csh sheetName SShowR) sheetName
      , sortable (Just "last-edit") (i18nCell MsgLastEdit)
          $ \DBRow{dbrOutput=(_, E.Value mEditTime, _, _)} -> foldMap dateTimeCell mEditTime
      , sortable (Just "visible-from") (i18nCell MsgAccessibleSince)
--- a/src/Handler/SystemMessage.hs
+++ b/src/Handler/SystemMessage.hs
@ -165,7 +165,7 @@ postMessageListR = do
    dbtColonnade = mconcat
      [ dbSelect (applying _2) id $ \DBRow{ dbrOutput = (Entity smId _, _) } -> encrypt smId
      , dbRow
-      , sortable Nothing (i18nCell MsgSystemMessageId) $ \DBRow{ dbrOutput = (Entity smId _, _) } -> anchorCellM' (encrypt smId) MessageR (toWidget . tshow . ciphertext)
+      , sortable Nothing (i18nCell MsgSystemMessageId) $ \DBRow{ dbrOutput = (Entity smId _, _) } -> anchorCellM' (encrypt smId) MessageR ciphertext
      , sortable (Just "from") (i18nCell MsgSystemMessageFrom) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ maybe mempty (formatTimeW SelFormatDateTime) systemMessageFrom
      , sortable (Just "to") (i18nCell MsgSystemMessageTo) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ maybe mempty (formatTimeW SelFormatDateTime) systemMessageTo
      , sortable (Just "authenticated") (i18nCell MsgSystemMessageAuthenticatedOnly) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> tickmarkCell systemMessageAuthenticatedOnly
--- a/src/Handler/Tutorial.hs
+++ b/src/Handler/Tutorial.hs
@ -61,7 +61,7 @@ getCTutorialListR tid ssh csh = do
                           <li>
                             ^{nameEmailWidget' tutor}
                     |]
-          , sortable (Just "participants") (i18nCell MsgTutorialParticipants) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, n) } -> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) . toWidget $ tshow n
+          , sortable (Just "participants") (i18nCell MsgTutorialParticipants) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, n) } -> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) $ tshow n
          , sortable (Just "capacity") (i18nCell MsgTutorialCapacity) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybe mempty (textCell . tshow) tutorialCapacity
          , sortable (Just "room") (i18nCell MsgTutorialRoom) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> textCell tutorialRoom
          , sortable Nothing (i18nCell MsgTutorialTime) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> occurrencesCell tutorialTime
--- a/src/Handler/Utils/Exam.hs
+++ b/src/Handler/Utils/Exam.hs
@ -1,6 +1,7 @@
 module Handler.Utils.Exam
  ( fetchExamAux
  , fetchExam, fetchExamId, fetchCourseIdExamId, fetchCourseIdExam
+  , examBonus, examBonusPossible, examBonusAchieved
  ) where

 import Import.NoFoundation
@ -12,6 +13,10 @@ import Database.Esqueleto.Utils.TH

 import Utils.Lens

+import qualified Data.Conduit.List as C
+
+import qualified Data.Map as Map
+

 fetchExamAux :: ( SqlBackendCanRead backend
                , E.SqlSelect b a
@ -45,3 +50,34 @@ fetchCourseIdExamId tid ssh cid examn = $(unValueN 2) <$> fetchExamAux (\tutoria

 fetchCourseIdExam  :: MonadHandler m => TermId -> SchoolId -> CourseShorthand -> ExamName -> ReaderT SqlBackend m (Key Course, Entity Exam)
 fetchCourseIdExam tid ssh cid examn = over _1 E.unValue <$> fetchExamAux (\tutorial course -> (course E.^. CourseId, tutorial)) tid ssh cid examn
+
+
+examBonus :: MonadHandler m => Entity Exam -> ReaderT SqlBackend m (Map UserId SheetTypeSummary)
+examBonus (Entity eId Exam{..}) = runConduit $
+  let
+    rawData = E.selectSource . E.from $ \((examRegistration `E.LeftOuterJoin` examOccurrence) `E.InnerJoin` (sheet `E.InnerJoin` submission)) -> E.distinctOnOrderBy [ E.asc $ examRegistration E.^. ExamRegistrationUser, E.asc $ sheet E.^. SheetId ] $ do
+      E.on $ submission E.?. SubmissionSheet E.==. E.just (sheet E.^. SheetId)
+      E.on $ E.exists (E.from $ \submissionUser -> E.where_ $ submissionUser E.^. SubmissionUserUser E.==. examRegistration E.^. ExamRegistrationUser
+                                                        E.&&. E.just (submissionUser E.^. SubmissionUserSubmission) E.==. submission E.?. SubmissionId
+                      )
+      E.on $ examRegistration E.^. ExamRegistrationOccurrence E.==. examOccurrence E.?. ExamOccurrenceId
+      E.where_ $ sheet E.^. SheetCourse E.==. E.val examCourse
+           E.&&. examRegistration E.^. ExamRegistrationExam E.==. E.val eId
+      E.where_ $ E.case_ 
+        [ E.when_
+            ( E.not_ . E.isNothing $ examRegistration E.^. ExamRegistrationOccurrence )
+          E.then_
+            (       E.just (sheet E.^. SheetActiveTo) E.<=. examOccurrence E.?. ExamOccurrenceStart
+              E.&&. sheet E.^. SheetVisibleFrom E.<=. examOccurrence E.?. ExamOccurrenceStart
+            )
+        ]
+        ( E.else_ . E.not_ . E.isNothing $ sheet E.^. SheetVisibleFrom
+        )
+      return (examRegistration E.^. ExamRegistrationUser, sheet E.^. SheetType, submission)
+    accum = C.fold ?? Map.empty $ \acc (E.Value uid, E.Value sheetType, fmap entityVal -> sub) ->
+      Map.unionWith mappend acc . Map.singleton uid . sheetTypeSum sheetType . (>>= submissionRatingPoints) $ assertM submissionRatingDone sub
+   in rawData .| accum
+
+examBonusPossible, examBonusAchieved :: UserId -> Map UserId SheetTypeSummary -> Maybe SheetGradeSummary
+examBonusPossible uid bonusMap = normalSummary <$> Map.lookup uid bonusMap
+examBonusAchieved uid bonusMap = (mappend <$> normalSummary <*> bonusSummary) <$> Map.lookup uid bonusMap
--- a/src/Handler/Utils/Table/Cells.hs
+++ b/src/Handler/Utils/Table/Cells.hs
@ -91,7 +91,7 @@ ifCell decision cTrue cFalse x
  | otherwise  = cFalse x

 linkEmptyCell :: IsDBTable m a => Route UniWorX -> Widget -> DBCell m a
-linkEmptyCell link wgt = linkEitherCell link (wgt,mempty)
+linkEmptyCell = anchorCell

 msgCell :: (ToMessage t, IsDBTable m a) => t -> DBCell m a
 msgCell = textCell . toMessage
@ -123,7 +123,7 @@ isNewCell = cell . toWidget . isNew
 commentCell :: IsDBTable m a => Maybe (Route UniWorX) -> DBCell m a
 commentCell Nothing     = mempty
 commentCell (Just link) = anchorCell link icon
-  where icon = toWidget $ hasComment True
+  where icon = hasComment True

 -- | whether something is visible or hidden
 isVisibleCell :: (IsDBTable m a) => Bool -> DBCell m a
@ -134,11 +134,11 @@ isVisibleCell False = (cell . toWidget $ isVisible False) & addUrgencyClass

 -- | for simple file downloads
 fileCell :: IsDBTable m a => Route UniWorX -> DBCell m a
-fileCell route = anchorCell route $ toWidget fileDownload
+fileCell route = anchorCell route fileDownload

 -- | for zip-archive downloads
 zipCell :: IsDBTable m a => Route UniWorX -> DBCell m a
-zipCell route = anchorCell route $ toWidget zipDownload
+zipCell route = anchorCell route zipDownload

 -- | Display an icon that opens a modal upon clicking
 modalCell :: (IsDBTable m a, ToWidget UniWorX w) => w -> DBCell m a
@ -214,6 +214,9 @@ maybeDateTimeCell = maybe mempty dateTimeCell
 numCell :: (IsDBTable m a, Num b, ToMessage b) => b -> DBCell m a
 numCell = textCell . toMessage

+propCell :: (IsDBTable m a, Real b, ToMessage b) => b -> b -> DBCell m a
+propCell curr max' = i18nCell $ MsgProportion (toMessage curr) (toMessage max') (toRational curr / toRational max')
+
 int64Cell :: (IsDBTable m a) => Int64-> DBCell m a
 int64Cell = numCell

--- a/src/Handler/Utils/Table/Pagination.hs
+++ b/src/Handler/Utils/Table/Pagination.hs
@ -971,43 +971,47 @@ cellTooltip msg = cellContents.mapped %~ (<> tipWdgt)

 -- | Always display widget; maybe a link if user is Authorized.
 --   Also see variant `linkEmptyCell`
-anchorCell :: IsDBTable m a => Route UniWorX -> Widget -> DBCell m a
+anchorCell :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a) => url -> wgt -> DBCell m a
 anchorCell = anchorCellM . return

-{-# DEPRECATED anchorCell' "For compatibility with Colonnade; better use anchorCell instead." #-}
-anchorCell' :: IsDBTable m a
-           => (r -> Route UniWorX)
-           -> (r -> Widget)
+anchorCell' :: ( IsDBTable m a
+               , ToWidget UniWorX wgt
+               , HasRoute UniWorX url
+               )
+           => (r -> url)
+           -> (r -> wgt)
           -> (r -> DBCell m a)
 anchorCell' mkRoute mkWidget val = anchorCell (mkRoute val) (mkWidget val)

-anchorCellM :: IsDBTable m a => WidgetT UniWorX IO (Route UniWorX) -> Widget -> DBCell m a
+anchorCellM :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a, HandlerSite m ~ UniWorX) => WidgetT UniWorX IO url -> wgt -> DBCell m a
 anchorCellM routeM widget = anchorCellM' routeM id (const widget)

-anchorCellM' :: IsDBTable m a => WidgetT UniWorX IO x -> (x -> Route UniWorX) -> (x -> Widget) -> DBCell m a
-anchorCellM' xM x2route x2widget = cell $ do
-  x <- xM
-  let route  = x2route  x
-      widget = x2widget x
-  authResult <- liftHandlerT $ isAuthorized route False
-  case authResult of
-    Authorized -> $(widgetFile "table/cell/link") -- show allowed link
-    _otherwise -> widget                          -- don't show prohibited link
+anchorCellM' :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a, HandlerSite m ~ UniWorX) => WidgetT UniWorX IO x -> (x -> url) -> (x -> wgt) -> DBCell m a
+anchorCellM' xM x2route x2widget = linkEitherCellM' xM x2route (x2widget, x2widget)

 -- | Variant of `anchorCell` that displays different widgets depending whether the route is authorized for current user
-linkEitherCell :: IsDBTable m a => Route UniWorX -> (Widget, Widget) -> DBCell m a
+linkEitherCell :: (HasRoute UniWorX url, ToWidget UniWorX wgt, ToWidget UniWorX wgt', IsDBTable m a, HandlerSite m ~ UniWorX) => url -> (wgt, wgt') -> DBCell m a
 linkEitherCell = linkEitherCellM . return

-linkEitherCellM :: IsDBTable m a => WidgetT UniWorX IO (Route UniWorX) -> (Widget, Widget) -> DBCell m a
+linkEitherCellM :: (HasRoute UniWorX url, ToWidget UniWorX wgt, ToWidget UniWorX wgt', IsDBTable m a, HandlerSite m ~ UniWorX) => WidgetT UniWorX IO url -> (wgt, wgt') -> DBCell m a
 linkEitherCellM routeM (widgetAuth,widgetUnauth) = linkEitherCellM' routeM id (const widgetAuth, const widgetUnauth)

-linkEitherCellM' :: IsDBTable m a => WidgetT UniWorX IO x -> (x -> Route UniWorX) -> (x -> Widget, x -> Widget) -> DBCell m a
+linkEitherCellM' :: forall m url wgt wgt' a x.
+                    ( HasRoute UniWorX url
+                    , ToWidget UniWorX wgt
+                    , ToWidget UniWorX wgt'
+                    , IsDBTable m a
+                    , HandlerSite m ~ UniWorX
+                    )
+                 => WidgetT UniWorX IO x -> (x -> url) -> (x -> wgt, x -> wgt') -> DBCell m a
 linkEitherCellM' xM x2route (x2widgetAuth,x2widgetUnauth) = cell $ do
  x <- xM
  let route        = x2route        x
-      widget       = x2widgetAuth   x
-      widgetUnauth = x2widgetUnauth x
-  authResult <- liftHandlerT $ isAuthorized route False
+      widget, widgetUnauth :: WidgetT UniWorX IO ()
+      widget       = toWidget $ x2widgetAuth   x
+      widgetUnauth = toWidget $ x2widgetUnauth x
+  authResult <- liftHandlerT $ isAuthorized (urlRoute route) False
+  linkUrl <- toTextUrl route
  case authResult of
    Authorized -> $(widgetFile "table/cell/link") -- show allowed link
    _otherwise -> widgetUnauth                    -- show alternative widget
--- a/src/Model/Migration.hs
+++ b/src/Model/Migration.hs
@ -28,6 +28,8 @@ import Control.Monad.Trans.Reader (mapReaderT)
 import Control.Monad.Except (MonadError(..))
 import Utils (exceptT)

+import Numeric.Natural
+
 -- Database versions must follow https://pvp.haskell.org:
 --   - Breaking changes are instances where manual migration is necessary (via customMigrations; i.e. changing a columns format)
 --   - Non-breaking changes are instances where the automatic migration done by persistent is sufficient (i.e. adding a column or table)
@ -57,7 +59,11 @@ share [mkPersist sqlSettings, mkMigrate "migrateDBVersioning"]
      deriving Show Eq Ord
  |]

-migrateAll :: (MonadLogger m, MonadBaseControl IO m, MonadIO m) => ReaderT SqlBackend m ()
+migrateAll :: ( MonadLogger m
+              , MonadBaseControl IO m
+              , MonadIO m
+              )
+           => ReaderT SqlBackend m ()
 migrateAll = do
  $logDebugS "Migration" "Initial migration"
  mapM_ ($logInfoS "Migration") =<< runMigrationSilent initialMigration
@ -77,14 +83,19 @@ migrateAll = do
  $logDebugS "Migration" "Persistent automatic migration"
  mapM_ ($logInfoS "Migration") =<< runMigrationSilent migrateAll'

-requiresMigration :: forall m. (MonadLogger m, MonadBaseControl IO m, MonadIO m) => ReaderT SqlBackend m Bool
+requiresMigration :: forall m.
+                     ( MonadLogger m
+                     , MonadBaseControl IO m
+                     , MonadIO m
+                     )
+                  => ReaderT SqlBackend m Bool
 requiresMigration = mapReaderT (exceptT return return) $ do
  initial <- either id (map snd) <$> parseMigration initialMigration
  when (not $ null initial) $ do
    $logInfoS "Migration" $ intercalate "; " initial
    throwError True

-  customs <- getMissingMigrations @_ @m
+  customs <- mapReaderT lift $ getMissingMigrations @_ @m
  when (not $ Map.null customs) $ do
    $logInfoS "Migration" . intercalate ", " . map tshow $ Map.keys customs
    throwError True
@ -123,7 +134,8 @@ getMissingMigrations = do
 -}


-customMigrations :: MonadIO m => Map (Key AppliedMigration) (ReaderT SqlBackend m ())
+customMigrations :: ( MonadIO m
+                    ) => Map (Key AppliedMigration) (ReaderT SqlBackend m ())
 customMigrations = Map.fromListWith (>>)
  [ ( AppliedMigrationKey [migrationVersion|initial|] [version|0.0.0|]
    , whenM (columnExists "user" "theme") $ do -- New theme format
@ -292,6 +304,20 @@ customMigrations = Map.fromListWith (>>)
    , whenM (tableExists "exam") $ -- Exams were an unused stub before
        tableDropEmpty "exam"
    )
+  , ( AppliedMigrationKey [migrationVersion|13.0.0|] [version|14.0.0|]
+    , whenM ((&&) <$> tableExists "exam_occurrence" <*> (not <$> columnExists "exam_occurrence" "name")) $ do
+        examOccurrences <- [sqlQQ| SELECT "id" FROM "exam_occurrence" ORDER BY "exam"; |]
+        [executeQQ|
+          ALTER TABLE "exam_occurrence" ADD COLUMN "name" citext DEFAULT null;
+        |]
+        forM_ (zip [0..] examOccurrences) $ \(n :: Natural, Single eoId :: Single ExamOccurrenceId) -> do
+          let name = [st|occ-#{tshow n}|]
+          [executeQQ| UPDATE "exam_occurrence" SET "name" = #{name} WHERE "id" = #{eoId} |]
+        [executeQQ|
+          ALTER TABLE "exam_occurrence" ALTER COLUMN "name" DROP DEFAULT;
+          ALTER TABLE "exam_occurrence" ALTER COLUMN "name" SET NOT NULL;
+        |]
+    )
  ]


--- a/src/Model/Types/Common.hs
+++ b/src/Model/Types/Common.hs
@ -16,19 +16,20 @@ import qualified Yesod.Auth.Util.PasswordStore as PWStore
 type Count  = Sum Integer
 type Points = Centi

-type Email           = Text
+type Email              = Text

-type SchoolName      = CI Text
-type SchoolShorthand = CI Text
-type CourseName      = CI Text
-type CourseShorthand = CI Text
-type SheetName       = CI Text
-type MaterialName    = CI Text
-type UserEmail       = CI Email
-type UserIdent       = CI Text
-type TutorialName    = CI Text
-type ExamName        = CI Text
-type ExamPartName    = CI Text
+type SchoolName         = CI Text
+type SchoolShorthand    = CI Text
+type CourseName         = CI Text
+type CourseShorthand    = CI Text
+type SheetName          = CI Text
+type MaterialName       = CI Text
+type UserEmail          = CI Email
+type UserIdent          = CI Text
+type TutorialName       = CI Text
+type ExamName           = CI Text
+type ExamPartName       = CI Text
+type ExamOccurrenceName = CI Text

 type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString
 type InstanceId      = UUID
--- a/src/Model/Types/Sheet.hs
+++ b/src/Model/Types/Sheet.hs
@ -12,6 +12,7 @@ import Model.Types.Common
 import Utils.Lens.TH

 import Control.Lens
+import Control.Lens.Extras (is)
 import Generics.Deriving.Monoid (memptydefault, mappenddefault)

 import Data.Set (Set)
@ -40,6 +41,7 @@ deriveJSON defaultOptions
 derivePersistFieldJSON ''SheetGrading

 makeLenses_ ''SheetGrading
+makePrisms ''SheetGrading

 _passingBound :: Fold SheetGrading (Either () Points)
 _passingBound = folding passPts
@ -57,17 +59,22 @@ gradingPassed gr pts = either pBinary pPoints <$> gr ^? _passingBound

 data SheetGradeSummary = SheetGradeSummary
  { numSheets       :: Count       -- Total number of sheets, includes all
-  , numSheetsPasses :: Count       -- Number of sheets required to pass FKA: numGradePasses
-  , numSheetsPoints :: Count       -- Number of sheets having points    FKA: sumGradePointsd
+  , numSheetsPasses :: Count       -- Number of sheets admitting passing FKA: numGradePasses
+  , numSheetsPoints :: Count       -- Number of sheets having points     FKA: sumGradePointsd
+  , numSheetsPassPoints :: Count   -- Number of sheets where passing is by points
  , sumSheetsPoints :: Sum Points  -- Total of all points in all sheets
+  , sumSheetsPassPoints :: Sum Points -- Achieved points within marked sheets where passing is by points
  -- Marking dependend
  , numMarked       :: Count       -- Number of already marked sheets
  , numMarkedPasses :: Count       -- Number of already marked sheets with passes
  , numMarkedPoints :: Count       -- Number of already marked sheets with points
+  , numMarkedPassPoints :: Count   -- Number of already marked sheets where passing is by points
  , sumMarkedPoints :: Sum Points  -- Achieveable points within marked sheets
+  , sumMarkedPassPoints :: Sum Points -- Achieved points within marked sheets where passing is by points
  --
  , achievedPasses :: Count        -- Achieved passes (within marked sheets)
  , achievedPoints :: Sum Points   -- Achieved points (within marked sheets)
+  , achievedPassPoints :: Sum Points -- Achieved points within marked sheets where passing is by points
  } deriving (Generic, Read, Show, Eq)

 instance Monoid SheetGradeSummary where
@ -82,19 +89,24 @@ makeLenses_ ''SheetGradeSummary
 sheetGradeSum :: SheetGrading -> Maybe Points -> SheetGradeSummary
 sheetGradeSum gr Nothing  = mempty
  { numSheets = 1
-  , numSheetsPasses = bool  mempty   1 $ has _passingBound gr
-  , numSheetsPoints = bool  mempty   1 $ has _maxPoints    gr
+  , numSheetsPasses     = bool  mempty   1 $ has _passingBound gr
+  , numSheetsPoints     = bool  mempty   1 $ has _maxPoints    gr
+  , numSheetsPassPoints = bool  mempty   1 $ is  _PassPoints   gr
  , sumSheetsPoints = maybe mempty Sum $ gr ^? _maxPoints
+  , sumSheetsPassPoints = maybe mempty Sum . (<* guard (is _PassPoints gr)) $ gr ^? _maxPoints
  }
 sheetGradeSum gr (Just p) =
  let unmarked@SheetGradeSummary{..} = sheetGradeSum gr Nothing
  in  unmarked
-        { numMarked       = numSheets
-        , numMarkedPasses = numSheetsPasses
-        , numMarkedPoints = numSheetsPoints
-        , sumMarkedPoints = sumSheetsPoints
+        { numMarked           = numSheets
+        , numMarkedPasses     = numSheetsPasses
+        , numMarkedPoints     = numSheetsPoints
+        , numMarkedPassPoints = numSheetsPassPoints
+        , sumMarkedPoints     = sumSheetsPoints
+        , sumMarkedPassPoints = sumSheetsPassPoints
        , achievedPasses  = maybe mempty (bool 0 1) (gradingPassed gr p)
        , achievedPoints  = bool mempty (Sum p) $ has _maxPoints gr
+        , achievedPassPoints = bool mempty (Sum p) $ is _PassPoints gr
        }


--- a/src/Utils.hs
+++ b/src/Utils.hs
@ -278,6 +278,9 @@ rationalToFixed = MkFixed . round . (* (fromIntegral $ resolution (Proxy :: HasR

 rationalToFixed3 :: Rational -> Fixed E3
 rationalToFixed3 = rationalToFixed
+  
+rationalToFixed2 :: Rational -> Fixed E2
+rationalToFixed2 = rationalToFixed

 -- | Convert `part` and `whole` into percentage including symbol
 --   showing trailing zeroes and to decimal digits
@ -709,6 +712,9 @@ assertM_ f x = guard . f =<< x
 assertM' :: Alternative m => (a -> Bool) -> a -> m a
 assertM' f x = x <$ guard (f x)

+guardOn :: Alternative m => Bool -> a -> m a
+guardOn b x = x <$ guard b
+
 -- Some Utility Functions from Agda.Utils.Monad
 -- | Monadic if-then-else.
 ifM :: Monad m => m Bool -> m a -> m a -> m a
--- a/templates/default-layout.lucius
+++ b/templates/default-layout.lucius
@ -637,3 +637,8 @@ section {
  font-weight: var(--weight, 600);
  background-color: rgba(var(--red), var(--green), 0, var(--opacity));
 }
+
+
+.uuid {
+  font-family: monospace;
+}
--- a/templates/exam-show.hamlet
+++ b/templates/exam-show.hamlet
@ -93,6 +93,10 @@ $if not (null occurrences)
    <table .table .table--striped .table--hover>
      <thead>
        <tr .table__row .table__row--head>
+          $if occurrenceNamesShown
+            <th .table__th>
+              _{MsgExamRoomName}
+              ^{isVisible False}
          <th .table__th>_{MsgExamRoom}
          $if not examTimes
            <th .table__th>_{MsgExamRoomTime}
@ -103,8 +107,10 @@ $if not (null occurrences)
              $if not occurrenceAssignmentsVisible
                \ ^{isVisible False}
      <tbody>
-        $forall (Entity _occId ExamOccurrence{examOccurrenceRoom, examOccurrenceStart, examOccurrenceEnd, examOccurrenceDescription}, registered) <- occurrences
+        $forall (Entity _occId ExamOccurrence{examOccurrenceName, examOccurrenceRoom, examOccurrenceStart, examOccurrenceEnd, examOccurrenceDescription}, registered) <- occurrences
          <tr .table__row :occurrenceAssignmentsShown && not registered:.occurrence--not-registered>
+            $if occurrenceNamesShown
+              <td .table__td #exam-occurrence__#{examOccurrenceName}>#{examOccurrenceName}
            <td .table__td>#{examOccurrenceRoom}
            $if not examTimes
              <td .table__td>
--- a/templates/table/cell/link.hamlet
+++ b/templates/table/cell/link.hamlet
@ -1,3 +1,3 @@
 $newline never
-<a href=@{route}>
-  ^{widget}
+<a href=#{linkUrl}>
+  ^{widget}
--- a/templates/widgets/massinput/examRooms/form.hamlet
+++ b/templates/widgets/massinput/examRooms/form.hamlet
@ -1,5 +1,6 @@
 $newline never
-<td>#{csrf}^{fvInput eofIdView}^{fvInput eofRoomView}
+<td>#{csrf}^{fvInput eofIdView}^{fvInput eofNameView}
+<td>^{fvInput eofRoomView}
 <td>^{fvInput eofCapacityView}
 <td>^{fvInput eofStartView}
 <td>^{fvInput eofEndView}
--- a/templates/widgets/massinput/examRooms/layout.hamlet
+++ b/templates/widgets/massinput/examRooms/layout.hamlet
@ -1,6 +1,7 @@
 $newline never
 <table>
  <thead>
+    <th>_{MsgExamRoomName}
    <th>_{MsgExamRoom}
    <th>_{MsgExamRoomCapacity}
    <th>_{MsgExamRoomStart}