diff --git a/frontend/src/utils/inputs/inputs.scss b/frontend/src/utils/inputs/inputs.scss index c4cb63373..2d8fb8db5 100644 --- a/frontend/src/utils/inputs/inputs.scss +++ b/frontend/src/utils/inputs/inputs.scss @@ -33,11 +33,14 @@ margin: 7px 0; } -.form-section-title__hint { - margin-top: 7px; +.form-group__hint, .form-section-title__hint { 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 { diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index babad5c46..9e433582a 100644 --- a/messages/uniworx/de.msg +++ b/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 diff --git a/models/exams b/models/exams index 694f1a9bc..bcd6703c8 100644 --- a/models/exams +++ b/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 diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs index 4d1e77356..994f74357 100644 --- a/src/Audit/Types.hs +++ b/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 diff --git a/src/Database/Persist/Class/Instances.hs b/src/Database/Persist/Class/Instances.hs index 2dbb2bfb0..8666a2c87 100644 --- a/src/Database/Persist/Class/Instances.hs +++ b/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 diff --git a/src/Handler/Exam/Edit.hs b/src/Handler/Exam/Edit.hs index fbd0c1acc..52d90559f 100644 --- a/src/Handler/Exam/Edit.hs +++ b/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 diff --git a/src/Handler/Exam/Form.hs b/src/Handler/Exam/Form.hs index 452b0aa3d..38213c7ed 100644 --- a/src/Handler/Exam/Form.hs +++ b/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 diff --git a/src/Handler/Exam/New.hs b/src/Handler/Exam/New.hs index 0f863f75b..d4e6582a7 100644 --- a/src/Handler/Exam/New.hs +++ b/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 diff --git a/src/Handler/Exam/Show.hs b/src/Handler/Exam/Show.hs index 72c6058b4..eceeecc1c 100644 --- a/src/Handler/Exam/Show.hs +++ b/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 diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index 42a1f12f5..fa087816e 100644 --- a/src/Handler/Exam/Users.hs +++ b/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" - -instance DefaultOrdered ExamUserTableCsv where - headerOrder = Csv.genericHeaderOrder examUserTableCsvOptions + where + examPartResults = fmap fold . sequence . flip HashMap.mapMaybeWithKey csv $ \pNumber' _ -> do + pNumber <- pNumber' ^? csvExamPartHeader + return . fmap (singletonMap pNumber ) $ csv .:?? pNumber' instance CsvColumnsExplained ExamUserTableCsv where - csvColumnsExplanations = genericCsvColumnsExplanations examUserTableCsvOptions $ Map.fromList - [ ('csvEUserSurname , MsgCsvColumnExamUserSurname ) - , ('csvEUserFirstName , MsgCsvColumnExamUserFirstName ) - , ('csvEUserName , MsgCsvColumnExamUserName ) - , ('csvEUserMatriculation , MsgCsvColumnExamUserMatriculation ) - , ('csvEUserField , MsgCsvColumnExamUserField ) - , ('csvEUserDegree , MsgCsvColumnExamUserDegree ) - , ('csvEUserSemester , MsgCsvColumnExamUserSemester ) - , ('csvEUserOccurrence , MsgCsvColumnExamUserOccurrence ) - , ('csvEUserExercisePoints , MsgCsvColumnExamUserExercisePoints ) - , ('csvEUserExerciseNumPasses , MsgCsvColumnExamUserExercisePasses ) - , ('csvEUserExercisePointsMax , MsgCsvColumnExamUserExercisePointsMax ) - , ('csvEUserExerciseNumPassesMax, MsgCsvColumnExamUserExercisePassesMax ) - , ('csvEUserExamResult , MsgCsvColumnExamUserResult ) - , ('csvEUserCourseNote , MsgCsvColumnExamUserCourseNote ) + csvColumnsExplanations _ = mconcat + [ single "surname" MsgCsvColumnExamUserSurname + , single "first-name" MsgCsvColumnExamUserFirstName + , single "name" MsgCsvColumnExamUserName + , single "matriculation" MsgCsvColumnExamUserMatriculation + , single "field" MsgCsvColumnExamUserField + , single "degree" MsgCsvColumnExamUserDegree + , single "semester" MsgCsvColumnExamUserSemester + , single "occurrence" MsgCsvColumnExamUserOccurrence + , single "exercise-points" MsgCsvColumnExamUserExercisePoints + , single "exercise-num-passes" MsgCsvColumnExamUserExercisePasses + , single "exercise-points-max" MsgCsvColumnExamUserExercisePointsMax + , single "exercise-num-passes-max" MsgCsvColumnExamUserExercisePassesMax + , single "exam-result" MsgCsvColumnExamUserResult + , 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 - <$> view (resultUser . _entityVal . _userSurname . to Just) - <*> view (resultUser . _entityVal . _userFirstName . 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 . _achievedPasses . _Wrapped . integral) - <*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _sumSheetsPoints . _Wrapped) - <*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _numSheetsPasses . _Wrapped . integral) - <*> preview (resultExamResult . _entityVal . _examResultResult . to resultView) - <*> preview (resultCourseNote . _entityVal . _courseUserNoteNote) + dbtCsvEncode = Just DBTCsvEncode + { dbtCsvExportForm = pure () + , dbtCsvDoEncode = \() -> C.map (doEncode' . view _2) + , dbtCsvName = unpack csvName + , dbtCsvNoExportData = Just id + , dbtCsvHeader = const . return . examUserTableCsvHeader $ examParts ^.. folded . _entityVal . _examPartNumber + } + where + doEncode' = ExamUserTableCsv + <$> view (resultUser . _entityVal . _userSurname . to Just) + <*> view (resultUser . _entityVal . _userFirstName . 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 . _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) $ - yield . ExamUserCsvSetResultData (dbCsvOld ^. resultUser . _entityKey) $ csvEUserExamResult dbCsvNew + let uid = dbCsvOld ^. resultUser . _entityKey + + 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| diff --git a/src/Handler/ExamOffice/Exam.hs b/src/Handler/ExamOffice/Exam.hs index c44f50ee1..61b6a778d 100644 --- a/src/Handler/ExamOffice/Exam.hs +++ b/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 diff --git a/src/Handler/Utils/Csv.hs b/src/Handler/Utils/Csv.hs index 0ebbb4cdb..a8e0d7201 100644 --- a/src/Handler/Utils/Csv.hs +++ b/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 - , DefaultOrdered csv - ) - => Source (HandlerT site IO) csv +respondCsv :: ToNamedRecord csv + => Header + -> 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 -toCsvRendered (otoList -> csvs) = CsvRendered{..} + => Header + -> 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) diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs index 5cdd6fd29..11d1fb446 100644 --- a/src/Handler/Utils/Exam.hs +++ b/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' + diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 99616ae6e..d9823153a 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/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 diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index 7d8b81322..4f08fbebb 100644 --- a/src/Import/NoModel.hs +++ b/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 diff --git a/src/Model.hs b/src/Model.hs index d798d98bf..5e049e254 100644 --- a/src/Model.hs +++ b/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 diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index fb64f2129..eab6af88a 100644 --- a/src/Model/Migration.hs +++ b/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 + ) ] diff --git a/src/Model/Types/Exam.hs b/src/Model/Types/Exam.hs index c829532b4..fc92e3f58 100644 --- a/src/Model/Types/Exam.hs +++ b/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' diff --git a/src/Utils.hs b/src/Utils.hs index e3201af90..a02ec0a65 100644 --- a/src/Utils.hs +++ b/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 diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs index 412e2527f..95e0c4236 100644 --- a/src/Utils/DB.hs +++ b/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! diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index b7dc95ef0..1da95cd38 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -167,6 +167,8 @@ makeLenses_ ''Invitation makeLenses_ ''ExamBonusRule makeLenses_ ''ExamGradingRule makeLenses_ ''ExamResult +makeLenses_ ''ExamPart +makeLenses_ ''ExamPartResult makeLenses_ ''UTCTime diff --git a/templates/exam-show.hamlet b/templates/exam-show.hamlet index 4602c9184..07d6b0c40 100644 --- a/templates/exam-show.hamlet +++ b/templates/exam-show.hamlet @@ -138,24 +138,30 @@ $if gradingShown && not (null examParts) + - $forall Entity partId ExamPart{examPartName, examPartWeight, examPartMaxPoints} <- examParts + $forall Entity partId ExamPart{examPartNumber, examPartName, examPartWeight, examPartMaxPoints} <- examParts +
_{MsgExamPartNumber} _{MsgExamPartName} - _{MsgExamPartMaxPoints} - _{MsgExamPartResultPoints} + $if showMaxPoints + _{MsgExamPartMaxPoints} + $if showAchievedPoints + _{MsgExamPartResultPoints}
#{examPartNumber} #{examPartName} - - $maybe mPoints <- examPartMaxPoints - #{showFixed True (fromRational examPartWeight * mPoints)} - - $case fmap (examPartResultResult . entityVal) (results !? partId) - $of Nothing - $of Just (ExamAttended ps) - #{showFixed True ps} - $of Just ExamNoShow - _{MsgExamNoShow} - $of Just ExamVoided - _{MsgExamVoided} + $if showMaxPoints + + $maybe mPoints <- examPartMaxPoints + #{showFixed True (fromRational examPartWeight * mPoints)} + $if showAchievedPoints + + $case fmap (examPartResultResult . entityVal) (results !? partId) + $of Nothing + $of Just (ExamAttended ps) + #{showFixed True ps} + $of Just ExamNoShow + _{MsgExamNoShow} + $of Just ExamVoided + _{MsgExamVoided} $# TODO: Statistics diff --git a/templates/widgets/massinput/examParts/form.hamlet b/templates/widgets/massinput/examParts/form.hamlet index 0ef5c4f7a..5b0b0e9a1 100644 --- a/templates/widgets/massinput/examParts/form.hamlet +++ b/templates/widgets/massinput/examParts/form.hamlet @@ -1,4 +1,5 @@ $newline never -#{csrf}^{fvInput epfIdView}^{fvInput epfNameView} +#{csrf}^{fvInput epfIdView}^{fvInput epfNumberView} +^{fvInput epfNameView} ^{fvInput epfMaxPointsView} ^{fvInput epfWeightView} diff --git a/templates/widgets/massinput/examParts/layout.hamlet b/templates/widgets/massinput/examParts/layout.hamlet index 87ab7fef4..1a89a8a11 100644 --- a/templates/widgets/massinput/examParts/layout.hamlet +++ b/templates/widgets/massinput/examParts/layout.hamlet @@ -1,10 +1,27 @@ $newline never - + + $forall coord <- review liveCoords lLength diff --git a/templates/widgets/massinput/examRooms/layout.hamlet b/templates/widgets/massinput/examRooms/layout.hamlet index c8a4bf270..8bd82ae6e 100644 --- a/templates/widgets/massinput/examRooms/layout.hamlet +++ b/templates/widgets/massinput/examRooms/layout.hamlet @@ -1,13 +1,22 @@ $newline never
_{MsgExamPartName} - _{MsgExamPartMaxPoints} - _{MsgExamPartWeight} - +
+ _{MsgExamPartNumber} # + + + _{MsgExamPartName} # + + _{MsgExamPartMaxPoints} + + _{MsgExamPartWeight} # + + +
+ _{MsgExamPartNumberTip} + + _{MsgExamPartNameTip} + + + _{MsgExamPartWeightTip} +
- + $forall coord <- review liveCoords lLength
_{MsgExamRoomName} - _{MsgExamRoom} - _{MsgExamRoomCapacity} - _{MsgExamRoomStart} - _{MsgExamRoomEnd} - _{MsgExamRoomDescription} - +
+ _{MsgExamRoomName} # + + + _{MsgExamRoom} # + + + _{MsgExamRoomCapacity} # + + + _{MsgExamRoomStart} # + + _{MsgExamRoomEnd} + _{MsgExamRoomDescription} +