Merge branch '205-klausuren'

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
+ExamOccurrenceEndMustBeAfterStart eoName@ExamOccurrenceName: Beginn des Termins #{eoName} muss vor seinem Ende liegen
-ExamOccurrenceStartMustBeAfterExamStart eoRoom@Text eoRange@Text: Beginn des Termins #{eoRoom} #{eoRange} muss nach Beginn der Klausur liegen
+ExamOccurrenceStartMustBeAfterExamStart eoName@ExamOccurrenceName: Beginn des Termins #{eoName} muss nach Beginn der Klausur liegen
-ExamOccurrenceEndMustBeBeforeExamEnd eoRoom@Text eoRange@Text: Ende des Termins #{eoRoom} #{eoRange} muss vor Ende 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
@@ -1188,3 +1193,5 @@ CsvAddNew: Neue Einträge einfügen
 CsvDeleteMissing: Fehlende Einträge entfernen
 BtnCsvExport: CSV-Datei exportieren
 BtnCsvImport: CSV-Datei importieren
+
+Proportion c@Text of@Text prop@Rational: #{c}/#{of} (#{rationalToFixed2 (100 * prop)}%)

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

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

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

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

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

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
 

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 eofName) $ NTop eofEnd >= NTop (Just eofStart)
-
+    guardValidation (MsgExamOccurrenceStartMustBeAfterExamStart eofName) $ NTop (Just eofStart) >= NTop efStart
-    guardValidation (MsgExamOccurrenceEndMustBeAfterStart eofRoom eofRange') $ NTop eofEnd >= NTop (Just eofStart)
+    guardValidation (MsgExamOccurrenceEndMustBeBeforeExamEnd eofName) $ NTop eofEnd <= NTop efEnd
-    guardValidation (MsgExamOccurrenceStartMustBeAfterExamStart eofRoom eofRange') $ NTop (Just eofStart) >= NTop efStart
-    guardValidation (MsgExamOccurrenceEndMustBeBeforeExamEnd eofRoom eofRange') $ 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
@@ -689,7 +698,7 @@ 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
+  { csvEUserSurname :: Maybe Text
-  , csvUserName :: Text
+  , csvEUserName :: Maybe Text
-  , csvUserMatriculation :: Maybe Text
+  , csvEUserMatriculation :: Maybe Text
-  , csvUserField :: Maybe Text
+  , csvEUserField :: Maybe Text
-  , csvUserDegree :: Maybe Text
+  , csvEUserDegree :: Maybe Text
-  , csvUserSemester :: Maybe Int
+  , csvEUserSemester :: Maybe Int
-  , csvUserRoom :: Maybe Text
+  , 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
+    let
-    examUsersDBTable = DBTable{..}
+      allBoni = (mappend <$> normalSummary <*> bonusSummary) $ fold bonus
-      where
+      showPasses     = numSheetsPasses allBoni /= 0
-        dbtSQLQuery ((examRegistration `E.InnerJoin` user) `E.LeftOuterJoin` occurrence `E.LeftOuterJoin` (courseParticipant `E.LeftOuterJoin` (studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyField))) = do
+      showPoints     = getSum (numSheetsPoints allBoni) - getSum (numSheetsPassPoints allBoni) /= 0
-          E.on $ studyField E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField
+      showPassPoints = numSheetsPassPoints allBoni /= 0
-          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
 
-    examUsersDBTableValidator = def
+    let
-  ((), examUsersTable) <- runDB $ dbTable examUsersDBTableValidator examUsersDBTable
+      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

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

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)

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

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

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

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
 

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
-anchorCell' :: IsDBTable m a
+               , ToWidget UniWorX wgt
-           => (r -> Route UniWorX)
+               , HasRoute UniWorX url
-           -> (r -> Widget)
+               )
+           => (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' :: (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 = cell $ do
+anchorCellM' xM x2route x2widget = linkEitherCellM' xM x2route (x2widget, x2widget)
-  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
 
 -- | 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
+      widget, widgetUnauth :: WidgetT UniWorX IO ()
-      widgetUnauth = x2widgetUnauth x
+      widget       = toWidget $ x2widgetAuth   x
-  authResult <- liftHandlerT $ isAuthorized route False
+      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

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;
+        |]
+    )
   ]
 
 

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 SchoolName         = CI Text
-type SchoolShorthand = CI Text
+type SchoolShorthand    = CI Text
-type CourseName      = CI Text
+type CourseName         = CI Text
-type CourseShorthand = CI Text
+type CourseShorthand    = CI Text
-type SheetName       = CI Text
+type SheetName          = CI Text
-type MaterialName    = CI Text
+type MaterialName       = CI Text
-type UserEmail       = CI Email
+type UserEmail          = CI Email
-type UserIdent       = CI Text
+type UserIdent          = CI Text
-type TutorialName    = CI Text
+type TutorialName       = CI Text
-type ExamName        = CI Text
+type ExamName           = CI Text
-type ExamPartName    = CI Text
+type ExamPartName       = CI Text
+type ExamOccurrenceName = CI Text
 
 type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString
 type InstanceId      = UUID

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
+  , numSheetsPasses :: Count       -- Number of sheets admitting passing FKA: numGradePasses
-  , numSheetsPoints :: Count       -- Number of sheets having points    FKA: sumGradePointsd
+  , 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
+  , numSheetsPasses     = bool  mempty   1 $ has _passingBound gr
-  , numSheetsPoints = bool  mempty   1 $ has _maxPoints    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
+        { numMarked           = numSheets
-        , numMarkedPasses = numSheetsPasses
+        , numMarkedPasses     = numSheetsPasses
-        , numMarkedPoints = numSheetsPoints
+        , numMarkedPoints     = numSheetsPoints
-        , sumMarkedPoints = sumSheetsPoints
+        , 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
         }
 
 

src/Utils.hs

@@ -279,6 +279,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
 textPercent :: Real a => a -> a -> Text
@@ -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

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;
+}

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>

templates/table/cell/link.hamlet

@@ -1,3 +1,3 @@
 $newline never
-<a href=@{route}>
+<a href=#{linkUrl}>
   ^{widget}

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}

templates/widgets/massinput/examRooms/layout.hamlet

@@ -1,6 +1,7 @@
 $newline never
 <table>
   <thead>
+    <th>_{MsgExamRoomName}
     <th>_{MsgExamRoom}
     <th>_{MsgExamRoomCapacity}
     <th>_{MsgExamRoomStart}