feat(exams): csv-import of ExamPartResults

BREAKING CHANGE: Introduces ExamPartNumbers

frontend/src/utils/inputs/inputs.scss

@@ -33,11 +33,14 @@
   margin: 7px 0;
 }
 
-.form-section-title__hint {
+.form-group__hint, .form-section-title__hint {
-  margin-top: 7px;
   color: var(--color-fontsec);
   font-size: 0.9rem;
   font-weight: 600;
+}
+
+.form-section-title__hint {
+  margin-top: 7px;
 
   + .form-group {
     margin-top: 11px;
@@ -58,6 +61,7 @@
 .form-group--required .form-group-label__caption::after, .form-group__required-marker::before {
   content: ' *';
   color: var(--color-error);
+  font-weight: 600;
 }
 
 .form-group--optional {

messages/uniworx/de.msg

@@ -1387,9 +1387,13 @@ ExamCorrectorAlreadyAdded: Ein Korrektor mit dieser E-Mail ist bereits für dies
 ExamParts: Teilaufgaben
 ExamPartWeightNegative: Gewicht aller Teilaufgaben muss größer oder gleich Null sein
 ExamPartAlreadyExists: Teilaufgabe mit diesem Namen existiert bereits
+ExamPartNumber: Nummer
+ExamPartNumberTip: Wird als interne Bezeichnung z.B. bei CSV-Export verwendet
 ExamPartName: Name
+ExamPartNameTip: Wird den Studierenden angezeigt
 ExamPartMaxPoints: Maximalpunktzahl
 ExamPartWeight: Gewichtung
+ExamPartWeightTip: Wird vor Anzeige oder Notenberechnung mit der erreichten Punktzahl und der Maximalpunktzahl multipliziert; Änderungen hier passen auch bestehende Korrekturergebnisse an
 ExamPartResultPoints: Erreichte Punkte
 
 ExamNameTaken exam@ExamName: Es existiert bereits eine Prüfung mit Namen #{exam}
@@ -1518,7 +1522,9 @@ ExamUserCsvRegister: Kursteilnehmer zur Prüfung anmelden
 ExamUserCsvAssignOccurrence: Teilnehmern einen anderen Termin/Raum zuweisen
 ExamUserCsvDeregister: Teilnehmer von der Prüfung abmelden
 ExamUserCsvSetCourseField: Kurs-assoziiertes Studienfach ändern
+ExamUserCsvOverrideResult: Ergebnis entgegen automatischer Notenberechnung überschreiben
 ExamUserCsvSetResult: Ergebnis eintragen
+ExamUserCsvSetPartResult: Ergebnis einer Teilaufgabe eintragen
 ExamUserCsvSetCourseNote: Teilnehmer-Notizen anpassen
 
 ExamUserCsvCourseNoteDeleted: Notiz wird gelöscht

models/exams

@@ -19,10 +19,12 @@ Exam
   UniqueExam course name
 ExamPart
   exam ExamId
-  name (CI Text)
+  number ExamPartNumber
+  name ExamPartName
   maxPoints Points Maybe
   weight Rational
-  UniqueExamPart exam name
+  UniqueExamPartNumber exam number
+  UniqueExamPartName exam name
 ExamOccurrence
   exam ExamId
   name ExamOccurrenceName
@@ -42,6 +44,7 @@ ExamPartResult
   examPart ExamPartId
   user UserId
   result ExamResultPoints
+  lastChanged UTCTime default=now()
   UniqueExamPartResult examPart user
 ExamResult
   exam ExamId

src/Audit/Types.hs

@@ -23,6 +23,15 @@ data Transaction
     { transactionExam   :: ExamId
     , transactionUser   :: UserId
     }
+  
+  | TransactionExamPartResultEdit
+    { transactionExamPart :: ExamPartId
+    , transactionUser     :: UserId
+    }
+  | TransactionExamPartResultDeleted
+    { transactionExamPart :: ExamPartId
+    , transactionUser     :: UserId
+    }
 
   | TransactionExamResultEdit
     { transactionExam   :: ExamId

src/Database/Persist/Class/Instances.hs

@@ -8,11 +8,14 @@ module Database.Persist.Class.Instances
 import ClassyPrelude
 
 import Database.Persist.Class
+import Database.Persist.Types (HaskellName, DBName, PersistValue)
 import Database.Persist.Types.Instances ()
 
 import Data.Binary (Binary)
 import qualified Data.Binary as Binary
 
+import qualified Data.Map as Map
+
 
 instance PersistEntity record => Hashable (Key record) where
   hashWithSalt s = hashWithSalt s . toPersistValue
@@ -24,3 +27,13 @@ instance PersistEntity record => Binary (Key record) where
 
 instance PersistEntity record => NFData (Key record) where
   rnf = rnf . keyToValues
+
+
+uniqueToMap :: PersistEntity record => Unique record -> Map (HaskellName, DBName) PersistValue
+uniqueToMap = fmap Map.fromList $ zip <$> persistUniqueToFieldNames <*> persistUniqueToValues
+
+instance PersistEntity record => Eq (Unique record) where
+  (==) = (==) `on` uniqueToMap
+  
+instance PersistEntity record => Show (Unique record) where
+  showsPrec p = showsPrec p . uniqueToMap

src/Handler/Exam/Edit.hs

@@ -85,6 +85,7 @@ postEEditR tid ssh csh examn = do
           ExamPartForm{ epfId = Nothing, .. } -> insert_
             ExamPart
               { examPartExam = eId
+              , examPartNumber = epfNumber
               , examPartName = epfName
               , examPartMaxPoints = epfMaxPoints
               , examPartWeight = epfWeight
@@ -96,6 +97,7 @@ postEEditR tid ssh csh examn = do
             guard $ examPartExam oldPart == eId
             lift $ replace epfId' ExamPart
               { examPartExam = eId
+              , examPartNumber = epfNumber
               , examPartName = epfName
               , examPartMaxPoints = epfMaxPoints
               , examPartWeight = epfWeight

src/Handler/Exam/Form.hs

@@ -56,6 +56,7 @@ data ExamOccurrenceForm = ExamOccurrenceForm
 
 data ExamPartForm = ExamPartForm
   { epfId :: Maybe CryptoUUIDExamPart
+  , epfNumber :: ExamPartNumber
   , epfName :: ExamPartName
   , epfMaxPoints :: Maybe Points
   , epfWeight :: Rational
@@ -200,12 +201,14 @@ examPartsForm prev = wFormToAForm $ do
   where
     examPartForm' nudge mPrev csrf = do
       (epfIdRes, epfIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ epfId =<< mPrev)
+      (epfNumberRes, epfNumberView) <- mpreq (isoField (from _ExamPartNumber) $ textField & cfStrip & cfCI) ("" & addName (nudge "number") & addPlaceholder "1, 6a, 3.1.4, ...") (epfNumber <$> mPrev)
       (epfNameRes, epfNameView) <- mpreq (textField & cfStrip & cfCI) ("" & addName (nudge "name")) (epfName <$> mPrev)
       (epfMaxPointsRes, epfMaxPointsView) <- mopt pointsField ("" & addName (nudge "max-points")) (epfMaxPoints <$> mPrev)
       (epfWeightRes, epfWeightView) <- mpreq (checkBool (>= 0) MsgExamPartWeightNegative rationalField) ("" & addName (nudge "weight")) (epfWeight <$> mPrev <|> Just 1)
 
       return ( ExamPartForm
                  <$> epfIdRes
+                 <*> epfNumberRes
                  <*> epfNameRes
                  <*> epfMaxPointsRes
                  <*> epfWeightRes
@@ -266,6 +269,7 @@ examFormTemplate (Entity eId Exam{..}) = do
         (Just -> epfId, ExamPart{..}) <- examParts'
         return ExamPartForm
           { epfId
+          , epfNumber    = examPartNumber
           , epfName      = examPartName
           , epfMaxPoints = examPartMaxPoints
           , epfWeight    = examPartWeight

src/Handler/Exam/New.hs

@@ -50,6 +50,7 @@ postCExamNewR tid ssh csh = do
           [ ExamPart{..}
           | ExamPartForm{..} <- Set.toList efExamParts
           , let examPartExam      = examid
+                examPartNumber    = epfNumber
                 examPartName      = epfName
                 examPartMaxPoints = epfMaxPoints
                 examPartWeight    = epfWeight

src/Handler/Exam/Show.hs

@@ -33,7 +33,7 @@ getEShowR tid ssh csh examn = do
     let occurrenceAssignmentsVisible = NTop (Just cTime) >= NTop examPublishOccurrenceAssignments
     occurrenceAssignmentsShown <- or2M (return occurrenceAssignmentsVisible) . hasReadAccessTo $ CExamR tid ssh csh examn EEditR
 
-    examParts <- selectList [ ExamPartExam ==. eId ] [ Asc ExamPartName ]
+    examParts <- sortOn (view $ _entityVal . _examPartNumber) <$> selectList [ ExamPartExam ==. eId ] [ Asc ExamPartName ]
 
     resultsRaw <- for mUid $ \uid ->
       E.select . E.from $ \examPartResult -> do
@@ -86,6 +86,9 @@ getEShowR tid ssh csh examn = do
         | fromMaybe False registered = Just [whamlet|_{MsgExamRegistered}|]
         | otherwise = Nothing
 
+      showMaxPoints = any (has $ _entityVal . _examPartMaxPoints . _Just) examParts
+      showAchievedPoints = not $ null results
+
   let heading = prependCourseTitle tid ssh csh $ CI.original examName
 
   siteLayoutMsg heading $ do

src/Handler/Exam/Users.hs

@@ -4,7 +4,7 @@ module Handler.Exam.Users
   ( getEUsersR, postEUsersR
   ) where
 
-import Import
+import Import hiding ((<.), (.>))
 
 import Handler.Utils
 import Handler.Utils.Exam
@@ -18,11 +18,13 @@ import Database.Esqueleto.Utils.TH
 
 import qualified Data.Csv as Csv
 
-import Data.Map ((!))
+import Data.Map ((!), (!?))
 import qualified Data.Map as Map
 import qualified Data.Set as Set
+import qualified Data.HashMap.Lazy as HashMap
 
 import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Text
 import qualified Data.Text.Lens as Text
 
 import qualified Data.Conduit.List as C
@@ -33,9 +35,31 @@ import Numeric.Lens (integral)
 
 import Database.Persist.Sql (deleteWhereCount, updateWhereCount)
 
+import Control.Lens.Indexed ((<.), (.>))
 
-type ExamUserTableExpr = (E.SqlExpr (Entity ExamRegistration) `E.InnerJoin` E.SqlExpr (Entity User)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamOccurrence)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity CourseParticipant)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity StudyFeatures)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms)))) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamResult)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseUserNote))
+
-type ExamUserTableData = DBRow (Entity ExamRegistration, Entity User, Maybe (Entity ExamOccurrence), Maybe (Entity StudyFeatures), Maybe (Entity StudyDegree), Maybe (Entity StudyTerms), Maybe (Entity ExamResult), Maybe (Entity CourseUserNote))
+type ExamUserTableExpr = (              E.SqlExpr (Entity ExamRegistration)
+                          `E.InnerJoin` E.SqlExpr (Entity User)
+                         )
+       `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamOccurrence))
+       `E.LeftOuterJoin` (                  E.SqlExpr (Maybe (Entity CourseParticipant))
+                          `E.LeftOuterJoin` (              E.SqlExpr (Maybe (Entity StudyFeatures))
+                                             `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree))
+                                             `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms))
+                                            )
+                         )
+       `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamResult))
+       `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseUserNote))
+type ExamUserTableData = DBRow ( Entity ExamRegistration
+                               , Entity User
+                               , Maybe (Entity ExamOccurrence)
+                               , Maybe (Entity StudyFeatures)
+                               , Maybe (Entity StudyDegree)
+                               , Maybe (Entity StudyTerms)
+                               , Maybe (Entity ExamResult)
+                               , Map ExamPartId (ExamPart, Maybe (Entity ExamPartResult))
+                               , Maybe (Entity CourseUserNote)
+                               )
 
 instance HasEntity ExamUserTableData User where
   hasEntity = _dbrOutput . _2
@@ -91,8 +115,32 @@ resultExamOccurrence = _dbrOutput . _3 . _Just
 resultExamResult :: Traversal' ExamUserTableData (Entity ExamResult)
 resultExamResult = _dbrOutput . _7 . _Just
 
+resultExamParts :: IndexedTraversal' ExamPartId ExamUserTableData (ExamPart, Maybe (Entity ExamPartResult))
+resultExamParts = _dbrOutput . _8 . itraversed
+
+-- resultExamParts' :: Traversal' ExamUserTableData (Entity ExamPart)
+-- resultExamParts' = (resultExamParts <. _1) . withIndex . from _Entity
+
+-- resultExamPartResult :: ExamPartId -> Lens' ExamUserTableData (Maybe (Entity ExamPartResult))
+-- resultExamPartResult epId = _dbrOutput . _8 . unsafeSingular (ix epId) . _2
+
+-- resultExamPartResults :: IndexedTraversal' ExamPartId ExamUserTableData (Maybe (Entity ExamPartResult))
+-- resultExamPartResults = resultExamParts <. _2
+
 resultCourseNote :: Traversal' ExamUserTableData (Entity CourseUserNote)
-resultCourseNote = _dbrOutput . _8 . _Just
+resultCourseNote = _dbrOutput . _9 . _Just
+
+
+csvExamPartHeader :: Prism' Csv.Name ExamPartNumber
+csvExamPartHeader = prism' toHeader fromHeader
+  where
+    toHeader pName = encodeUtf8 $ partPrefix <> CI.foldedCase (pName ^. _ExamPartNumber)
+    fromHeader hdr = do
+      tHdr <- either (const Nothing) Just $ Text.decodeUtf8' hdr
+      review _ExamPartNumber . CI.mk <$> stripPrefix partPrefix tHdr
+
+    partPrefix = "part-"
+  
 
 data ExamUserTableCsv = ExamUserTableCsv
   { csvEUserSurname :: Maybe Text
@@ -107,20 +155,38 @@ data ExamUserTableCsv = ExamUserTableCsv
   , csvEUserExerciseNumPasses :: Maybe Int
   , csvEUserExercisePointsMax :: Maybe Points
   , csvEUserExerciseNumPassesMax :: Maybe Int
+  , csvEUserExamPartResults :: Map ExamPartNumber (Maybe ExamResultPoints)
   , csvEUserExamResult :: Maybe ExamResultPassedGrade
   , csvEUserCourseNote :: Maybe Html
   }
   deriving (Generic)
 makeLenses_ ''ExamUserTableCsv
 
-examUserTableCsvOptions :: Csv.Options
-examUserTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 3 }
-
 instance ToNamedRecord ExamUserTableCsv where
-  toNamedRecord = Csv.genericToNamedRecord examUserTableCsvOptions
+  toNamedRecord ExamUserTableCsv{..} = Csv.namedRecord $
+    [ "surname" Csv..= csvEUserSurname
+    , "first-name" Csv..= csvEUserFirstName
+    , "name" Csv..= csvEUserName
+    , "matriculation" Csv..= csvEUserMatriculation
+    , "field" Csv..= csvEUserField
+    , "degree" Csv..= csvEUserDegree
+    , "semester" Csv..= csvEUserSemester
+    , "occurrence" Csv..= csvEUserOccurrence
+    , "exercise-points" Csv..= csvEUserExercisePoints
+    , "exercise-num-passes" Csv..= csvEUserExerciseNumPasses
+    , "exercise-points-max" Csv..= csvEUserExercisePointsMax
+    , "exercise-num-passes-max" Csv..= csvEUserExerciseNumPassesMax
+    ] ++ examPartResults ++
+    [ "exam-result" Csv..= csvEUserExamResult
+    , "course-note" Csv..= csvEUserCourseNote
+    ]
+    where
+      examPartResults
+        = flip ifoldMap csvEUserExamPartResults $
+            \pNumber pResult -> pure $ (csvExamPartHeader # pNumber) Csv..= pResult
 
 instance FromNamedRecord ExamUserTableCsv where
-  parseNamedRecord csv -- Manually defined awaiting issue #427
+  parseNamedRecord csv
     = ExamUserTableCsv
       <$> csv .:?? "surname"
       <*> csv .:?? "first-name"
@@ -134,29 +200,49 @@ instance FromNamedRecord ExamUserTableCsv where
       <*> csv .:?? "exercise-num-passes"
       <*> csv .:?? "exercise-points-max"
       <*> csv .:?? "exercise-num-passes-max"
+      <*> examPartResults
       <*> csv .:?? "exam-result"
       <*> csv .:?? "course-note"
-
+    where
-instance DefaultOrdered ExamUserTableCsv where
+      examPartResults = fmap fold . sequence . flip HashMap.mapMaybeWithKey csv $ \pNumber' _ -> do
-  headerOrder = Csv.genericHeaderOrder examUserTableCsvOptions
+        pNumber <- pNumber' ^? csvExamPartHeader
+        return . fmap (singletonMap pNumber ) $ csv .:?? pNumber'
 
 instance CsvColumnsExplained ExamUserTableCsv where
-  csvColumnsExplanations = genericCsvColumnsExplanations examUserTableCsvOptions $ Map.fromList
+  csvColumnsExplanations _ = mconcat
-    [ ('csvEUserSurname             , MsgCsvColumnExamUserSurname           )
+    [ single "surname"                 MsgCsvColumnExamUserSurname
-    , ('csvEUserFirstName           , MsgCsvColumnExamUserFirstName         )
+    , single "first-name"              MsgCsvColumnExamUserFirstName
-    , ('csvEUserName                , MsgCsvColumnExamUserName              )
+    , single "name"                    MsgCsvColumnExamUserName
-    , ('csvEUserMatriculation       , MsgCsvColumnExamUserMatriculation     )
+    , single "matriculation"           MsgCsvColumnExamUserMatriculation
-    , ('csvEUserField               , MsgCsvColumnExamUserField             )
+    , single "field"                   MsgCsvColumnExamUserField
-    , ('csvEUserDegree              , MsgCsvColumnExamUserDegree            )
+    , single "degree"                  MsgCsvColumnExamUserDegree
-    , ('csvEUserSemester            , MsgCsvColumnExamUserSemester          )
+    , single "semester"                MsgCsvColumnExamUserSemester
-    , ('csvEUserOccurrence          , MsgCsvColumnExamUserOccurrence        )
+    , single "occurrence"              MsgCsvColumnExamUserOccurrence
-    , ('csvEUserExercisePoints      , MsgCsvColumnExamUserExercisePoints    )
+    , single "exercise-points"         MsgCsvColumnExamUserExercisePoints
-    , ('csvEUserExerciseNumPasses   , MsgCsvColumnExamUserExercisePasses    )
+    , single "exercise-num-passes"     MsgCsvColumnExamUserExercisePasses
-    , ('csvEUserExercisePointsMax   , MsgCsvColumnExamUserExercisePointsMax )
+    , single "exercise-points-max"     MsgCsvColumnExamUserExercisePointsMax
-    , ('csvEUserExerciseNumPassesMax, MsgCsvColumnExamUserExercisePassesMax )
+    , single "exercise-num-passes-max" MsgCsvColumnExamUserExercisePassesMax
-    , ('csvEUserExamResult          , MsgCsvColumnExamUserResult            )
+    , single "exam-result"             MsgCsvColumnExamUserResult
-    , ('csvEUserCourseNote          , MsgCsvColumnExamUserCourseNote        )
+    , single "course-note"             MsgCsvColumnExamUserCourseNote
     ]
+    where
+      single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
+      single k v = singletonMap k [whamlet|_{v}|]
+
+examUserTableCsvHeader :: ( MonoFoldable mono
+                          , Element mono ~ ExamPartNumber
+                          )
+                       => mono -> Csv.Header
+examUserTableCsvHeader pNames = Csv.header $
+  [ "surname", "first-name", "name"
+  , "matriculation"
+  , "field", "degree", "semester"
+  , "course-note"
+  , "occurrence"
+  , "exercise-points", "exercise-num-passes", "exercise-points-max", "exercise-num-passes-max"
+  ] ++ map (review csvExamPartHeader) (sort $ otoList pNames) ++
+  [ "exam-result"
+  ]
 
 data ExamUserAction = ExamUserDeregister
                     | ExamUserAssignOccurrence
@@ -175,7 +261,9 @@ data ExamUserCsvActionClass
   | ExamUserCsvRegister
   | ExamUserCsvAssignOccurrence
   | ExamUserCsvSetCourseField
+  | ExamUserCsvSetPartResult
   | ExamUserCsvSetResult
+  | ExamUserCsvOverrideResult
   | ExamUserCsvSetCourseNote
   | ExamUserCsvDeregister
   deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
@@ -202,8 +290,14 @@ data ExamUserCsvAction
   | ExamUserCsvDeregisterData
     { examUserCsvActRegistration :: ExamRegistrationId
     }
-  | ExamUserCsvSetResultData
+  | ExamUserCsvSetPartResultData
     { examUserCsvActUser :: UserId
+    , examUserCsvActExamPart :: ExamPartNumber
+    , examUserCsvActExamPartResult :: Maybe ExamResultPoints
+    }
+  | ExamUserCsvSetResultData
+    { examUserCsvIsResultOverride :: Bool
+    , examUserCsvActUser :: UserId
     , examUserCsvActExamResult :: Maybe ExamResultPassedGrade
     }
   | ExamUserCsvSetCourseNoteData
@@ -232,6 +326,7 @@ getEUsersR = postEUsersR
 postEUsersR tid ssh csh examn = do
   ((registrationResult, examUsersTable), Entity eId _) <- runDB $ do
     exam@(Entity eid Exam{..}) <- fetchExam tid ssh csh examn
+    examParts <- selectList [ExamPartExam ==. eid] [Asc ExamPartName]
     bonus <- examBonus exam
 
     let
@@ -242,6 +337,8 @@ postEUsersR tid ssh csh examn = do
       resultView :: ExamResultGrade -> ExamResultPassedGrade
       resultView = fmap $ bool (Left . view passingGrade) Right examShowGrades
 
+      examPartNumbers = examParts ^.. folded . _entityVal . _examPartNumber
+
     csvName <- getMessageRender <*> pure (MsgExamUserCsvName tid ssh csh examn)
 
     let
@@ -263,7 +360,25 @@ postEUsersR tid ssh csh examn = do
             E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eid
             return (examRegistration, user, occurrence, studyFeatures, studyDegree, studyField, examResult, courseUserNote)
           dbtRowKey = queryExamRegistration >>> (E.^. ExamRegistrationId)
-          dbtProj = return
+          dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $
+            (,,,,,,,,)
+              <$> view _1 <*> view _2 <*> view _3 <*> view _4 <*> view _5 <*> view _6 <*> view _7
+              <*> getExamParts
+              <*> view _8
+            where
+              getExamParts :: ReaderT _ (MaybeT (YesodDB UniWorX)) (Map ExamPartId (ExamPart, Maybe (Entity ExamPartResult)))
+              getExamParts = do
+                uid <- view $ _2 . _entityKey
+                rawResults <- lift . lift . E.select . E.from $ \(examPart `E.LeftOuterJoin` examPartResult) -> do
+                  E.on $ examPartResult E.?. ExamPartResultExamPart E.==. E.just (examPart E.^. ExamPartId)
+                   E.&&. examPartResult E.?. ExamPartResultUser     E.==. E.just (E.val uid)
+                  E.where_ $ examPart E.^. ExamPartExam E.==. E.val eid
+                  return (examPart, examPartResult)
+                return $ Map.fromList
+                  [ (epId, (examPart, mbRes))
+                  | (Entity epId examPart, mbRes) <- rawResults
+                  ]
+            
           dbtColonnade = mconcat $ catMaybes
             [ pure $ dbSelect (applying _2) id $ return . view (resultExamRegistration . _entityKey)
             , pure $ colUserNameLink (CourseR tid ssh csh . CUserR)
@@ -359,21 +474,30 @@ postEUsersR tid ssh csh examn = do
             }
           dbtIdent :: Text
           dbtIdent = "exam-users"
-          dbtCsvEncode = simpleCsvEncode csvName $ ExamUserTableCsv
+          dbtCsvEncode = Just DBTCsvEncode
-            <$> view (resultUser . _entityVal . _userSurname . to Just)
+            { dbtCsvExportForm   = pure ()
-            <*> view (resultUser . _entityVal . _userFirstName . to Just)
+            , dbtCsvDoEncode     = \() -> C.map (doEncode' . view _2)
-            <*> view (resultUser . _entityVal . _userDisplayName . to Just)
+            , dbtCsvName         = unpack csvName
-            <*> view (resultUser . _entityVal . _userMatrikelnummer)
+            , dbtCsvNoExportData = Just id
-            <*> preview (resultStudyField . _entityVal . to (\StudyTerms{..} -> studyTermsName <|> studyTermsShorthand <|> Just (tshow studyTermsKey)) . _Just)
+            , dbtCsvHeader       = const . return . examUserTableCsvHeader $ examParts ^.. folded . _entityVal . _examPartNumber
-            <*> preview (resultStudyDegree . _entityVal . to (\StudyDegree{..} -> studyDegreeName <|> studyDegreeShorthand <|> Just (tshow studyDegreeKey)) . _Just)
+            }
-            <*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester)
+            where
-            <*> preview (resultExamOccurrence . _entityVal . _examOccurrenceName)
+              doEncode' = ExamUserTableCsv
-            <*> preview (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPoints . _Wrapped)
+                <$> view (resultUser . _entityVal . _userSurname . to Just)
-            <*> preview (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPasses . _Wrapped . integral)
+                <*> view (resultUser . _entityVal . _userFirstName . to Just)
-            <*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _sumSheetsPoints . _Wrapped)
+                <*> view (resultUser . _entityVal . _userDisplayName . to Just)
-            <*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _numSheetsPasses . _Wrapped . integral)
+                <*> view (resultUser . _entityVal . _userMatrikelnummer)
-            <*> preview (resultExamResult . _entityVal . _examResultResult . to resultView)
+                <*> preview (resultStudyField . _entityVal . to (\StudyTerms{..} -> studyTermsName <|> studyTermsShorthand <|> Just (tshow studyTermsKey)) . _Just)
-            <*> preview (resultCourseNote . _entityVal . _courseUserNoteNote)
+                <*> 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 . _achievedPasses . _Wrapped . integral)
+                <*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _sumSheetsPoints . _Wrapped)
+                <*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _numSheetsPasses . _Wrapped . integral)
+                <*> (Map.fromList . map (over _1 examPartNumber . over (_2 . _Just) (examPartResultResult . entityVal)) <$> asks (toListOf resultExamParts))
+                <*> preview (resultExamResult . _entityVal . _examResultResult . to resultView)
+                <*> preview (resultCourseNote . _entityVal . _courseUserNoteNote)
           dbtCsvDecode = Just DBTCsvDecode
             { dbtCsvRowKey = \csv -> do
                 uid <- lift $ view _2 <$> guessUser csv
@@ -394,8 +518,13 @@ postEUsersR tid ssh csh examn = do
                           yield $ ExamUserCsvSetCourseFieldData cpId newFeatures
                     | otherwise ->
                         yieldM $ ExamUserCsvCourseRegisterData uid <$> lookupStudyFeatures dbCsvNew <*> lookupOccurrence dbCsvNew
+
+                  iforMOf_ (ifolded <. _Just) (csvEUserExamPartResults dbCsvNew) $ \epNumber epRes ->
+                    when (epNumber `elem` examPartNumbers) $
+                      yield $ ExamUserCsvSetPartResultData uid epNumber (Just epRes)
+            
                   when (is _Just $ csvEUserExamResult dbCsvNew) $
-                    yield . ExamUserCsvSetResultData uid $ csvEUserExamResult dbCsvNew
+                    yield . ExamUserCsvSetResultData False uid $ csvEUserExamResult dbCsvNew
 
                   note <- lift . getBy $ UniqueCourseUserNote uid examCourse
                   when (csvEUserCourseNote dbCsvNew /= note ^? _Just . _entityVal . _courseUserNoteNote) $
@@ -410,8 +539,38 @@ postEUsersR tid ssh csh examn = do
                     Just (Entity cpId _) <- lift . getBy . flip UniqueParticipant examCourse $ dbCsvOld ^. resultUser . _entityKey
                     yield $ ExamUserCsvSetCourseFieldData cpId newFeatures
 
-                  when (csvEUserExamResult dbCsvNew /= dbCsvOld ^? resultExamResult . _entityVal . _examResultResult . to resultView) $
+                  let uid = dbCsvOld ^. resultUser . _entityKey
-                    yield . ExamUserCsvSetResultData (dbCsvOld ^. resultUser . _entityKey) $ csvEUserExamResult dbCsvNew
+
+                  forM_ examPartNumbers $ \epNumber ->
+                    let oldPartResult = dbCsvOld ^? resultExamParts . filtered (views (_1 . _examPartNumber) (== epNumber)) . _2 . _Just . _entityVal . _examPartResultResult
+                     in whenIsJust (csvEUserExamPartResults dbCsvNew !? epNumber) $ \epRes ->
+                          when (epRes /= oldPartResult) $
+                            yield $ ExamUserCsvSetPartResultData uid epNumber epRes
+
+                  let newResults :: Map ExamPartNumber (Maybe ExamResultPoints)
+                      newResults = csvEUserExamPartResults dbCsvNew
+                       `Map.union` toMapOf (resultExamParts .> ito (over _1 $ examPartNumber) <. to (fmap $ examPartResultResult . entityVal)) dbCsvOld
+
+                      newGrade :: Maybe ExamResultPassedGrade
+                      newGrade = do
+                        possible <- examBonusPossible uid bonus
+                        achieved <- examBonusAchieved uid bonus
+                        resultView <$> examGrade exam possible achieved (newResults ^.. folded . _Just)
+
+                      oldResult = dbCsvOld ^? resultExamResult . _entityVal . _examResultResult . to resultView
+                  
+                  case newGrade of
+                    _ | csvEUserExamResult dbCsvNew == oldResult
+                        -> return ()
+                    Nothing
+                      -> yield . ExamUserCsvSetResultData False uid $ csvEUserExamResult dbCsvNew
+                    Just _
+                      | csvEUserExamResult dbCsvNew /= newGrade
+                        -> yield . ExamUserCsvSetResultData True uid $ csvEUserExamResult dbCsvNew
+                      | oldResult /= newGrade
+                        -> yield . ExamUserCsvSetResultData False uid $ csvEUserExamResult dbCsvNew
+                      | otherwise
+                        -> return ()
 
                   when (csvEUserCourseNote dbCsvNew /= dbCsvOld ^? resultCourseNote . _entityVal . _courseUserNoteNote) $
                     yield . ExamUserCsvSetCourseNoteData (dbCsvOld ^. resultUser . _entityKey) $ csvEUserCourseNote dbCsvNew
@@ -421,7 +580,10 @@ postEUsersR tid ssh csh examn = do
                 ExamUserCsvDeregisterData{}       -> ExamUserCsvDeregister
                 ExamUserCsvAssignOccurrenceData{} -> ExamUserCsvAssignOccurrence
                 ExamUserCsvSetCourseFieldData{}   -> ExamUserCsvSetCourseField
-                ExamUserCsvSetResultData{}        -> ExamUserCsvSetResult
+                ExamUserCsvSetPartResultData{}    -> ExamUserCsvSetPartResult
+                ExamUserCsvSetResultData{..}
+                  | examUserCsvIsResultOverride   -> ExamUserCsvOverrideResult
+                  | otherwise                     -> ExamUserCsvSetResult
                 ExamUserCsvSetCourseNoteData{}    -> ExamUserCsvSetCourseNote
             , dbtCsvCoarsenActionClass = \case
                 ExamUserCsvCourseRegister -> DBCsvActionNew
@@ -462,6 +624,21 @@ postEUsersR tid ssh csh examn = do
                     update examUserCsvActCourseParticipant [ CourseParticipantField =. examUserCsvActCourseField ]
                     CourseParticipant{..} <- getJust examUserCsvActCourseParticipant
                     audit $ TransactionCourseParticipantEdit examCourse courseParticipantUser
+                  ExamUserCsvSetPartResultData{..} -> do
+                    epid <- getKeyJustBy $ UniqueExamPartNumber eid examUserCsvActExamPart
+                    case examUserCsvActExamPartResult of
+                      Nothing  -> do
+                        deleteBy $ UniqueExamPartResult epid examUserCsvActUser
+                        audit $ TransactionExamPartResultDeleted epid examUserCsvActUser
+                      Just res -> do
+                        now <- liftIO getCurrentTime
+                        void $ upsertBy
+                          (UniqueExamPartResult epid examUserCsvActUser)
+                          (ExamPartResult epid examUserCsvActUser res now)
+                          [ ExamPartResultResult =. res
+                          , ExamPartResultLastChanged =. now
+                          ]
+                        audit $ TransactionExamPartResultEdit epid examUserCsvActUser
                   ExamUserCsvSetResultData{..} -> case examUserCsvActExamResult of
                     Nothing  -> do
                       deleteBy $ UniqueExamResult eid examUserCsvActUser
@@ -540,6 +717,19 @@ postEUsersR tid ssh csh examn = do
                     $nothing
                       , _{MsgCourseStudyFeatureNone}
                   |]
+                ExamUserCsvSetPartResultData{..} -> do
+                  (User{..}, Entity _ ExamPart{..}) <- liftHandlerT . runDB $
+                    (,) <$> getJust examUserCsvActUser
+                        <*> getJustBy (UniqueExamPartNumber eid examUserCsvActExamPart)
+                  [whamlet|
+                    $newline never
+                    ^{nameWidget userDisplayName userSurname}
+                    , „#{examPartName}“
+                    $maybe newResult <- examUserCsvActExamPartResult
+                      , _{newResult}
+                    $nothing
+                      , _{MsgExamResultNone}
+                  |]
                 ExamUserCsvSetResultData{..} -> do
                   User{..} <- liftHandlerT . runDB $ getJust examUserCsvActUser
                   [whamlet|

src/Handler/ExamOffice/Exam.hs

@@ -408,6 +408,7 @@ postEGradesR tid ssh csh examn = do
                   (row ^. resultExamResult . _entityVal . _examResultResult . to (fmap $ bool (Left . view passingGrade) Right examShowGrades))
             , dbtCsvName = unpack csvName
             , dbtCsvNoExportData = Nothing
+            , dbtCsvHeader = const . return $ Csv.headerOrder (error "headerOrder" :: ExamUserTableCsv)
             }
           dbtCsvDecode = Nothing
 

src/Handler/Utils/Csv.hs

@@ -4,7 +4,9 @@ module Handler.Utils.Csv
   ( typeCsv, extensionCsv
   , decodeCsv
   , encodeCsv
+  , encodeDefaultOrderedCsv
   , respondCsv, respondCsvDB
+  , respondDefaultOrderedCsv, respondDefaultOrderedCsvDB
   , fileSourceCsv
   , CsvParseError(..)
   , ToNamedRecord(..), FromNamedRecord(..)
@@ -12,6 +14,7 @@ module Handler.Utils.Csv
   , ToField(..), FromField(..)
   , CsvRendered(..)
   , toCsvRendered
+  , toDefaultOrderedCsvRendered
   ) where
 
 import Import hiding (Header, mapM_)
@@ -111,30 +114,54 @@ decodeCsv = transPipe throwExceptT $ do
       
 
 encodeCsv :: ( ToNamedRecord csv
-             , DefaultOrdered csv
              , Monad m
              )
-          => Conduit csv m ByteString
+          => Header
+          -> Conduit csv m ByteString
 -- ^ Encode a stream of records
 --
 -- Currently not streaming
-encodeCsv = fmap encodeDefaultOrderedByName (C.foldMap pure) >>= C.sourceLazy
+encodeCsv hdr = fmap (encodeByName hdr) (C.foldMap pure) >>= C.sourceLazy
+
+encodeDefaultOrderedCsv :: forall csv m.
+                           ( ToNamedRecord csv
+                           , DefaultOrdered csv
+                           , Monad m
+                           )
+                        => Conduit csv m ByteString
+encodeDefaultOrderedCsv = encodeCsv $ headerOrder (error "headerOrder" :: csv)
 
   
-respondCsv :: ( ToNamedRecord csv
+respondCsv :: ToNamedRecord csv
-              , DefaultOrdered csv
+           => Header
-              )
+           -> Source (HandlerT site IO) csv
-           => Source (HandlerT site IO) csv
            -> HandlerT site IO TypedContent
-respondCsv src = respondSource typeCsv' $ src .| encodeCsv .| awaitForever sendChunk
+respondCsv hdr src = respondSource typeCsv' $ src .| encodeCsv hdr .| awaitForever sendChunk
+
+respondDefaultOrderedCsv :: forall csv site.
+                            ( ToNamedRecord csv
+                            , DefaultOrdered csv
+                            )
+                         => Source (HandlerT site IO) csv
+                         -> HandlerT site IO TypedContent
+respondDefaultOrderedCsv = respondCsv $ headerOrder (error "headerOrder" :: csv)
 
 respondCsvDB :: ( ToNamedRecord csv
-                , DefaultOrdered csv
                 , YesodPersistRunner site
                 )
-             => Source (YesodDB site) csv
+             => Header
+             -> Source (YesodDB site) csv
              -> HandlerT site IO TypedContent
-respondCsvDB src = respondSourceDB typeCsv' $ src .| encodeCsv .| awaitForever sendChunk
+respondCsvDB hdr src = respondSourceDB typeCsv' $ src .| encodeCsv hdr .| awaitForever sendChunk
+
+respondDefaultOrderedCsvDB :: forall csv site.
+                              ( ToNamedRecord csv
+                              , DefaultOrdered csv
+                              , YesodPersistRunner site
+                              )
+                           => Source (YesodDB site) csv
+                           -> HandlerT site IO TypedContent
+respondDefaultOrderedCsvDB = respondCsvDB $ headerOrder (error "headerOrder" :: csv)
 
 fileSourceCsv :: ( FromNamedRecord csv
                  , MonadResource m
@@ -166,8 +193,16 @@ toCsvRendered :: forall mono.
                  , DefaultOrdered (Element mono)
                  , MonoFoldable mono
                  )
-              => mono -> CsvRendered
+              => Header
-toCsvRendered (otoList -> csvs) = CsvRendered{..}
+              -> mono -> CsvRendered
+toCsvRendered csvRenderedHeader (otoList -> csvs) = CsvRendered{..}
   where
-    csvRenderedHeader = headerOrder (error "not forced" :: Element mono)
     csvRenderedData   = map toNamedRecord csvs
+  
+toDefaultOrderedCsvRendered :: forall mono.
+                               ( ToNamedRecord (Element mono)
+                               , DefaultOrdered (Element mono)
+                               , MonoFoldable mono
+                               )
+                            => mono -> CsvRendered
+toDefaultOrderedCsvRendered = toCsvRendered $ headerOrder (error "headerOrder" :: Element mono)

src/Handler/Utils/Exam.hs

@@ -2,6 +2,7 @@ module Handler.Utils.Exam
   ( fetchExamAux
   , fetchExam, fetchExamId, fetchCourseIdExamId, fetchCourseIdExam
   , examBonus, examBonusPossible, examBonusAchieved
+  , examGrade
   ) where
 
 import Import.NoFoundation
@@ -81,3 +82,58 @@ examBonus (Entity eId Exam{..}) = runConduit $
 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
+
+
+examGrade :: ( MonoFoldable mono
+             , Element mono ~ ExamResultPoints
+             )
+          => Entity Exam
+          -> SheetGradeSummary -- ^ `examBonusPossible`
+          -> SheetGradeSummary -- ^ `examBonusAchieved`
+          -> mono -- ^ `ExamPartResult`s
+          -> Maybe ExamResultGrade
+examGrade (Entity _ Exam{..}) bonusPossible bonusAchieved (otoList -> results)
+  | null results
+  = Nothing
+  | otherwise
+  = traverse pointsToGrade achievedPoints'
+  where
+    achievedPoints' :: ExamResultPoints
+    achievedPoints' = withBonus . getSum <$> foldMap (fmap Sum) results
+
+    withBonus :: Points -> Points
+    withBonus ps
+      | ExamBonusPoints{..} <- examBonusRule
+      = if
+          |    not bonusOnlyPassed
+            || fmap (view passingGrade) (pointsToGrade ps) == Just (_Wrapped # True)
+            -> ps + roundToPoints (toRational bonusMaxPoints * bonusProp)
+          | otherwise
+            -> ps
+      | otherwise
+      = ps
+      where
+        bonusProp :: Rational
+        bonusProp = clamp 0 1 $ toRational (getSum (achievedPoints bonusAchieved) + scalePasses (getSum $ achievedPasses bonusAchieved))
+                              / toRational (getSum (sumSheetsPoints bonusPossible) + scalePasses (getSum $ numSheetsPasses bonusPossible))
+          where
+            scalePasses :: Integer -> Points
+            -- ^ Rescale passes so count of all sheets with pass is worth as many points as sum of all sheets with points
+            scalePasses passes = fromInteger passes / (fromInteger . getSum $ numSheetsPasses bonusPossible) * (getSum $ sumSheetsPoints bonusPossible)
+
+        roundToPoints :: forall a. HasResolution a => Rational -> Fixed a
+        roundToPoints = MkFixed . round . ((*) . toRational $ resolution (Proxy @a))
+    
+    pointsToGrade :: Points -> Maybe ExamGrade
+    pointsToGrade ps
+      | ExamGradingKey{..} <- examGradingRule
+      = Just $ gradeFromKey examGradingKey
+      | otherwise
+      = Nothing
+      where
+        gradeFromKey :: [Points] -> ExamGrade
+        gradeFromKey examGradingKey' = maximum $ impureNonNull [ g | (g, b) <- lowerBounds, b <= clampMin 0 ps ]
+          where
+            lowerBounds :: [(ExamGrade, Points)]
+            lowerBounds = zip [Grade50, Grade40 ..] $ 0 : examGradingKey'
+        

src/Handler/Utils/Table/Pagination.hs

@@ -111,6 +111,8 @@ import qualified Control.Monad.Catch as Catch
 
 import Data.Dynamic
 
+import qualified Data.Csv as Csv
+
 
 #if MIN_VERSION_base(4,11,0)
 type Monoid' = Monoid
@@ -513,17 +515,18 @@ singletonFilter key = prism' fromInner (fmap Just . fromOuter)
 
 
 data DBTCsvEncode r' k' csv = forall exportData.
-  ( ToNamedRecord csv, DefaultOrdered csv, CsvColumnsExplained csv
+  ( ToNamedRecord csv, CsvColumnsExplained csv
   , DBTableKey k'
   , Typeable exportData
   ) => DBTCsvEncode
   { dbtCsvExportForm   :: AForm (YesodDB UniWorX) exportData
+  , dbtCsvHeader       :: Maybe exportData -> YesodDB UniWorX Csv.Header -- ^ @exportData@ is @Nothing@, if we're reporting an error
   , dbtCsvDoEncode     :: exportData -> Conduit (k', r') (YesodDB UniWorX) csv
   , dbtCsvName         :: FilePath
   , dbtCsvNoExportData :: Maybe (AnIso' exportData ())
   }
 data DBTCsvDecode r' k' csv = forall route csvAction csvActionClass csvException.
-  ( FromNamedRecord csv, ToNamedRecord csv, DefaultOrdered csv
+  ( FromNamedRecord csv, ToNamedRecord csv
   , DBTableKey k'
   , RedirectUrl UniWorX route
   , Typeable csv
@@ -566,7 +569,8 @@ type DBFilterUI = Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map F
 noCsvEncode :: Maybe (DBTCsvEncode r' k' Void)
 noCsvEncode = Nothing
 
-simpleCsvEncode :: ( ToNamedRecord csv, DefaultOrdered csv, CsvColumnsExplained csv
+simpleCsvEncode :: forall fp r' k' csv.
+                   ( ToNamedRecord csv, DefaultOrdered csv, CsvColumnsExplained csv
                    , DBTableKey k'
                    , Textual fp
                    )
@@ -576,9 +580,11 @@ simpleCsvEncode fName f = Just DBTCsvEncode
   , dbtCsvDoEncode     = \() -> C.map (f . view _2)
   , dbtCsvName         = unpack fName
   , dbtCsvNoExportData = Just id
+  , dbtCsvHeader       = const . return $ headerOrder (error "headerOrder" :: csv)
   }
 
-simpleCsvEncodeM :: ( ToNamedRecord csv, DefaultOrdered csv, CsvColumnsExplained csv
+simpleCsvEncodeM :: forall fp r' k' csv.
+                    ( ToNamedRecord csv, DefaultOrdered csv, CsvColumnsExplained csv
                     , DBTableKey k'
                     , Textual fp
                     )
@@ -588,6 +594,7 @@ simpleCsvEncodeM fName f = Just DBTCsvEncode
   , dbtCsvDoEncode     = \() -> C.mapM (runReaderT f . view _2)
   , dbtCsvName         = unpack fName
   , dbtCsvNoExportData = Just id
+  , dbtCsvHeader       = const . return $ headerOrder (error "headerOrder" :: csv)
   }
 
 
@@ -964,11 +971,13 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
     DBCsvExport{..}
       | Just DBTCsvEncode{..} <- dbtCsvEncode
       , Just exportData <- fromDynamic dbCsvExportData -> do
+        hdr <- dbtCsvHeader $ Just exportData
         let ensureExtension ext fName = bool (addExtension ext) id (ext `isExtensionOf` fName) fName
         setContentDisposition' . Just $ ensureExtension (unpack extensionCsv) dbtCsvName
-        sendResponse <=< liftHandlerT . respondCsvDB $ C.sourceList (zip currentKeys rows) .| dbtCsvDoEncode exportData >> lift E.transactionSave
+        sendResponse <=< liftHandlerT . respondCsvDB hdr $ C.sourceList (zip currentKeys rows) .| dbtCsvDoEncode exportData >> lift E.transactionSave
     DBCsvImport{..}
-      | Just (DBTCsvDecode{ dbtCsvClassifyAction = dbtCsvClassifyAction :: csvAction -> csvActionClass
+      | Just DBTCsvEncode{..} <- dbtCsvEncode
+      , Just (DBTCsvDecode{ dbtCsvClassifyAction = dbtCsvClassifyAction :: csvAction -> csvActionClass
                           , ..
                           } :: DBTCsvDecode r' k' csv) <- dbtCsvDecode -> do
         let existing = Map.fromList $ zip currentKeys rows
@@ -1052,14 +1061,14 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
 
                   $(widgetFile "csv-import-confirmation-wrapper")
 
-        let defaultHeaderOrder = headerOrder (error "not to be forced" :: csv)
+        hdr <- dbtCsvHeader Nothing
         catches importCsv
           [ Catch.Handler $ \case
               (DBCsvDuplicateKey{..} :: DBCsvException k')
                 -> liftHandlerT $ sendResponseStatus badRequest400 =<< do
                      mr <- getMessageRender
 
-                     let offendingCsv = CsvRendered defaultHeaderOrder [ dbCsvDuplicateKeyRowA, dbCsvDuplicateKeyRowB ]
+                     let offendingCsv = CsvRendered hdr [ dbCsvDuplicateKeyRowA, dbCsvDuplicateKeyRowB ]
                          heading = ErrorResponseTitle $ InvalidArgs [mr MsgDBCsvDuplicateKey]
 
                      siteLayoutMsg heading $ do
@@ -1073,7 +1082,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
                 -> liftHandlerT $ sendResponseStatus badRequest400 =<< do
                      mr <- getMessageRender
 
-                     let offendingCsv = CsvRendered defaultHeaderOrder [ dbCsvExceptionRow ]
+                     let offendingCsv = CsvRendered hdr [ dbCsvExceptionRow ]
                          heading = ErrorResponseTitle $ InvalidArgs [mr MsgDBCsvException]
 
                      siteLayoutMsg heading $ do

src/Import/NoModel.hs

@@ -141,7 +141,7 @@ import Control.Lens as Import
   hiding ( (<.>)
          , universe
          , cons, uncons, snoc, unsnoc, (<|)
-         , Index, index, (<.)
+         , Index, index, (<.), (.>)
          )
 import Control.Lens.Extras as Import (is)
 import Data.Set.Lens as Import

src/Model.hs

@@ -33,13 +33,6 @@ import Text.Blaze (ToMarkup(..))
 share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll'", mkSave "currentModel"]
     $(persistDirectoryWith lowerCaseSettings "models")
 
--- (Eq Course) is impossible so we derive it for the Uniqueness Constraint only; comments helpful for searching in code
-deriving instance Eq (Unique Course)    -- instance Eq TermSchoolCourseShort; instance Eq TermSchoolCourseName
-deriving instance Eq (Unique Sheet)     -- instance Eq CourseSheet
-deriving instance Eq (Unique Material)  -- instance Eq UniqueMaterial
-deriving instance Eq (Unique Tutorial)  -- instance Eq Tutorial
-deriving instance Eq (Unique Exam)
-
 
 submissionRatingDone :: Submission -> Bool
 submissionRatingDone Submission{..} = isJust submissionRatingTime

src/Model/Migration.hs

@@ -47,6 +47,9 @@ import qualified Net.IPv6 as IPv6
 
 import Data.Aeson (toJSON)
 
+import qualified Data.Char as Char
+import qualified Data.CaseInsensitive as CI
+
 -- 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)
@@ -493,6 +496,33 @@ customMigrations = Map.fromListWith (>>)
           ALTER TABLE "user" ALTER COLUMN "display_email" SET NOT NULL;
         |]
     )
+  , ( AppliedMigrationKey [migrationVersion|20.0.0|] [version|21.0.0|]
+    , whenM (tableExists "exam_part") $ do
+        [executeQQ|
+          ALTER TABLE "exam_part" ADD COLUMN IF NOT EXISTS "number" citext;
+        |]
+
+        let getExamEntries = rawQuery [st|SELECT DISTINCT exam FROM exam_part ORDER BY exam;|] []
+            renameExamParts [fromPersistValue -> Right (eId :: ExamId)] = do
+              partNames' <- [sqlQQ|SELECT id, name FROM "exam_part" WHERE exam = #{eId};|]
+              let
+                partNames :: [(ExamPartId, ExamPartName)]
+                partNames = foldMap (\(Single epId, Single pName) -> singletonMap epId pName) partNames'
+
+                partsSorted = partNames
+                  & sortOn ( map (\x -> maybe (Left x) Right (readMay x :: Maybe Integer))
+                           . groupBy ((==) `on` Char.isDigit)
+                           . CI.foldedCase
+                           . snd
+                           )
+                  & map fst
+              forM_ (zip [_ExamPartNumber' # 1..] partsSorted) $ \(num :: ExamPartNumber, pId) -> 
+                [executeQQ|
+                  UPDATE "exam_part" SET "number" = #{num} WHERE "id" = #{pId};
+                |]
+            renameExamParts _ = return ()
+        runConduit $ getExamEntries .| C.mapM_ renameExamParts
+    )
   ]
 
 

src/Model/Types/Exam.hs

@@ -6,7 +6,20 @@ Module: Model.Types.Exam
 Description: Types for modeling Exams
 -}
 module Model.Types.Exam
-  ( module Model.Types.Exam
+  ( ExamResult'(..)
+  , _ExamAttended, _ExamNoShow, _ExamVoided
+  , _examResult
+  , ExamBonusRule(..)
+  , ExamOccurrenceRule(..)
+  , ExamGrade(..)
+  , numberGrade
+  , ExamGradingRule(..)
+  , ExamPassed(..)
+  , passingGrade
+  , ExamResultPoints, ExamResultGrade, ExamResultPassed
+  , ExamResultPassedGrade
+  , ExamPartNumber
+  , _ExamPartNumber, _ExamPartNumber'
   ) where
 
 import Import.NoModel
@@ -20,6 +33,15 @@ import qualified Data.Csv as Csv
 
 import Database.Persist.Sql
 
+import qualified Data.CaseInsensitive as CI
+import qualified Data.Char as Char
+
+import Text.Read
+
+import Text.Blaze (ToMarkup(..))
+
+import qualified Data.Foldable
+
 
 data ExamResult' res = ExamAttended { examResult :: res }
                      | ExamNoShow
@@ -56,6 +78,12 @@ instance Applicative ExamResult' where
   ExamNoShow     <*> _              = ExamNoShow
   ExamVoided     <*> _              = ExamVoided
 
+instance Foldable ExamResult' where
+  foldMap = foldMapOf _examResult
+  
+instance Traversable ExamResult' where
+  traverse = _examResult
+
 instance Semigroup res => Semigroup (ExamResult' res) where
   ExamAttended r <> ExamAttended r' = ExamAttended $ r <> r'
   ExamVoided     <> _               = ExamVoided
@@ -185,7 +213,7 @@ instance PersistFieldSql ExamGrade where
 data ExamGradingRule
   = ExamGradingManual
   | ExamGradingKey
-    { examGradingKey :: [Points] -- ^ @[n1, n2, n3, ..., n11]@ means @0 <= p < n1 -> p ~= 5@, @n1 <= p < n2 -> p ~ 4.7@, @n2 <= p < n3 -> p ~ 4.3@, ..., @n11 <= p -> p ~ 1.0@
+    { examGradingKey :: [Points] -- ^ @[n1, n2, n3, ..., n11]@ means @0 <= p < n1 -> p ~= 5@, @n1 <= p < n2 -> p ~ 4@, @n2 <= p < n3 -> p ~ 3.7@, ..., @n10 <= p -> p ~ 1.0@
     }
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
 deriveJSON defaultOptions
@@ -223,3 +251,55 @@ instance Csv.ToField (Either ExamPassed ExamGrade) where
 
 instance Csv.FromField (Either ExamPassed ExamGrade) where
   parseField x = (Left <$> Csv.parseField x) <|> (Right <$> Csv.parseField x) -- encodings are disjoint
+
+
+newtype ExamPartNumber = ExamPartNumber { examPartNumberFragments :: [Either (CI Text) Natural] }
+  deriving (Eq, Ord, Generic, Typeable)
+
+_ExamPartNumber :: Iso' ExamPartNumber (CI Text)
+_ExamPartNumber = iso pToText pFromText
+  where
+    pToText = foldMap (either id (CI.mk . tshow)) . examPartNumberFragments
+    pFromText = ExamPartNumber . map (\t -> maybe (Left $ CI.mk t) Right $ readMay t) . Text.groupBy ((==) `on` Char.isDigit) . CI.original
+
+_ExamPartNumber' :: Integral n => Prism' ExamPartNumber n
+_ExamPartNumber' = prism (ExamPartNumber . fromNum) (first ExamPartNumber . toNum . examPartNumberFragments)
+  where
+    fromNum (toInteger -> n)
+      | n < 0 = [Left "-", Right . fromInteger $ abs n]
+      | otherwise = [Right $ fromInteger n]
+    
+    toNum fs
+      | Just ns <- mapM (preview _Right) fs
+      = case ns of
+          []  -> Left []
+          [n] -> Right $ fromIntegral n
+          _   -> Right . fromInteger . read $ concatMap show ns
+      | otherwise
+      = Left fs
+
+instance Show ExamPartNumber where
+  showsPrec p = showsPrec p . CI.original . view _ExamPartNumber
+instance Read ExamPartNumber where
+  readPrec = review _ExamPartNumber . CI.mk <$> readPrec 
+
+instance PersistField ExamPartNumber where
+  toPersistValue = toPersistValue . view _ExamPartNumber
+  fromPersistValue = fmap (review _ExamPartNumber) . fromPersistValue
+instance PersistFieldSql ExamPartNumber where
+  sqlType _ = sqlType (Proxy @(CI Text))
+
+instance PathPiece ExamPartNumber where
+  toPathPiece = toPathPiece . view _ExamPartNumber
+  fromPathPiece = fmap (review _ExamPartNumber) . fromPathPiece
+
+instance ToMarkup ExamPartNumber where
+  toMarkup = toMarkup . view _ExamPartNumber
+
+pathPieceCsv ''ExamPartNumber
+pathPieceJSON ''ExamPartNumber
+pathPieceJSONKey ''ExamPartNumber
+
+instance Enum ExamPartNumber where
+  toEnum = review _ExamPartNumber' . toEnum
+  fromEnum = maybe (error "Converting non-numeric ExamPartNumber to Int") fromEnum . preview _ExamPartNumber'

src/Utils.hs

@@ -962,3 +962,21 @@ type DictMaybe constr a = Maybe (Dict constr, a)
 
 pattern DictJust :: constr => a -> DictMaybe constr a
 pattern DictJust a = Just (Dict, a)
+
+-------------
+-- Ord --
+-------------
+
+clamp :: Ord a
+      => a -- ^ Minimum
+      -> a -- ^ Maximum
+      -> a -- ^ Value
+      -> a -- ^ Clamped Value
+clamp minVal maxVal = clampMin minVal . clampMax maxVal
+
+clampMin, clampMax :: Ord a
+                   => a -- ^ Boundary
+                   -> a -- ^ Value
+                   -> a -- ^ Clamped Value
+clampMin minVal = max minVal
+clampMax maxVal = min maxVal

src/Utils/DB.hs

@@ -26,6 +26,12 @@ emptyOrIn criterion testSet
 entities2map :: PersistEntity record => [Entity record] -> Map (Key record) record
 entities2map = foldl' (\m entity -> Map.insert (entityKey entity) (entityVal entity) m) Map.empty
 
+getJustBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m, MonadThrow m, Show (Unique record))
+          => Unique record -> ReaderT backend m (Entity record)
+getJustBy u = getBy u >>= maybe
+  (throwM . PersistForeignConstraintUnmet $ tshow u)
+  return
+
 getKeyBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m)
          => Unique record -> ReaderT backend m (Maybe (Key record))
 getKeyBy u = fmap entityKey <$> getBy u -- TODO optimize this, so that DB does not deliver entire record!

src/Utils/Lens.hs

@@ -167,6 +167,8 @@ makeLenses_ ''Invitation
 makeLenses_ ''ExamBonusRule
 makeLenses_ ''ExamGradingRule
 makeLenses_ ''ExamResult
+makeLenses_ ''ExamPart
+makeLenses_ ''ExamPartResult
 
 makeLenses_ ''UTCTime
 

templates/exam-show.hamlet

@@ -138,24 +138,30 @@ $if gradingShown && not (null examParts)
     <table .table .table--striped .table--hover >
       <thead>
         <tr .table__row .table__row--head>
+          <th .table__th>_{MsgExamPartNumber}
           <th .table__th>_{MsgExamPartName}
-          <th .table__th>_{MsgExamPartMaxPoints}
+          $if showMaxPoints
-          <th .table__th>_{MsgExamPartResultPoints}
+            <th .table__th>_{MsgExamPartMaxPoints}
+          $if showAchievedPoints
+            <th .table__th>_{MsgExamPartResultPoints}
       <tbody>
-        $forall Entity partId ExamPart{examPartName, examPartWeight, examPartMaxPoints} <- examParts
+        $forall Entity partId ExamPart{examPartNumber, examPartName, examPartWeight, examPartMaxPoints} <- examParts
           <tr .table__row>
+            <td .table__td>#{examPartNumber}
             <td .table__td>#{examPartName}
-            <td .table__td>
+            $if showMaxPoints
-              $maybe mPoints <- examPartMaxPoints
+              <td .table__td>
-                #{showFixed True (fromRational examPartWeight * mPoints)}
+                $maybe mPoints <- examPartMaxPoints
-            <td .table__td>
+                  #{showFixed True (fromRational examPartWeight * mPoints)}
-              $case fmap (examPartResultResult . entityVal) (results !? partId)
+            $if showAchievedPoints
-                $of Nothing
+              <td .table__td>
-                $of Just (ExamAttended ps)
+                $case fmap (examPartResultResult . entityVal) (results !? partId)
-                  #{showFixed True ps}
+                  $of Nothing
-                $of Just ExamNoShow
+                  $of Just (ExamAttended ps)
-                  _{MsgExamNoShow}
+                    #{showFixed True ps}
-                $of Just ExamVoided
+                  $of Just ExamNoShow
-                  _{MsgExamVoided}
+                    _{MsgExamNoShow}
+                  $of Just ExamVoided
+                    _{MsgExamVoided}
 
 $# TODO: Statistics

templates/widgets/massinput/examParts/form.hamlet

@@ -1,4 +1,5 @@
 $newline never
-<td>#{csrf}^{fvInput epfIdView}^{fvInput epfNameView}
+<td>#{csrf}^{fvInput epfIdView}^{fvInput epfNumberView}
+<td>^{fvInput epfNameView}
 <td>^{fvInput epfMaxPointsView}
 <td>^{fvInput epfWeightView}

templates/widgets/massinput/examParts/layout.hamlet

@@ -1,10 +1,27 @@
 $newline never
 <table>
   <thead>
-    <th>_{MsgExamPartName}
+    <tr>
-    <th>_{MsgExamPartMaxPoints}
+      <th>
-    <th>_{MsgExamPartWeight}
+        _{MsgExamPartNumber} #
-    <td>
+        <span .form-group__required-marker>
+      <th>
+        _{MsgExamPartName} #
+        <span .form-group__required-marker>
+      <th>_{MsgExamPartMaxPoints}
+      <th>
+        _{MsgExamPartWeight} #
+        <span .form-group__required-marker>
+      <td>
+    <tr .form-group__hint>
+      <td>
+        _{MsgExamPartNumberTip}
+      <td>
+        _{MsgExamPartNameTip}
+      <td>
+      <td>
+        _{MsgExamPartWeightTip}
+      <td>
   <tbody>
     $forall coord <- review liveCoords lLength
       <tr .massinput__cell>

templates/widgets/massinput/examRooms/layout.hamlet

@@ -1,13 +1,22 @@
 $newline never
 <table>
   <thead>
-    <th>_{MsgExamRoomName}
+    <tr>
-    <th>_{MsgExamRoom}
+      <th>
-    <th>_{MsgExamRoomCapacity}
+        _{MsgExamRoomName} #
-    <th>_{MsgExamRoomStart}
+        <span .form-group__required-marker>
-    <th>_{MsgExamRoomEnd}
+      <th>
-    <th>_{MsgExamRoomDescription}
+        _{MsgExamRoom} #
-    <td>
+        <span .form-group__required-marker>
+      <th>
+        _{MsgExamRoomCapacity} #
+        <span .form-group__required-marker>
+      <th>
+        _{MsgExamRoomStart} #
+        <span .form-group__required-marker>
+      <th>_{MsgExamRoomEnd}
+      <th>_{MsgExamRoomDescription}
+      <td>
   <tbody>
     $forall coord <- review liveCoords lLength
       <tr .massinput__cell>