From 379a7edd12b16ed55d39e99637de647a51fb4267 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 15 Jul 2019 15:38:37 +0200 Subject: [PATCH 1/4] feat(exams): introduce examOccurrenceName BREAKING CHANGE: examOccurrenceName --- messages/uniworx/de.msg | 9 ++-- models/exams | 2 + src/Data/CaseInsensitive/Instances.hs | 12 ++++- src/Data/UUID/Instances.hs | 15 +++++- src/Handler/Corrections.hs | 2 +- src/Handler/Course.hs | 4 +- src/Handler/Exam.hs | 37 ++++++++++----- src/Handler/Home.hs | 10 ++-- src/Handler/Sheet.hs | 2 +- src/Handler/SystemMessage.hs | 2 +- src/Handler/Tutorial.hs | 2 +- src/Handler/Utils/Table/Cells.hs | 8 ++-- src/Handler/Utils/Table/Pagination.hs | 46 ++++++++++--------- src/Model/Migration.hs | 34 ++++++++++++-- src/Model/Types/Common.hs | 25 +++++----- templates/default-layout.lucius | 5 ++ templates/exam-show.hamlet | 8 +++- templates/table/cell/link.hamlet | 4 +- .../widgets/massinput/examRooms/form.hamlet | 3 +- .../widgets/massinput/examRooms/layout.hamlet | 1 + 20 files changed, 156 insertions(+), 75 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 8ae874e40..8d72c3384 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -1108,8 +1108,10 @@ ExamRoomSurname': Nach Nachname ExamRoomMatriculation': Nach Matrikelnummer ExamRoomRandom': Zufällig pro Teilnehmer +ExamOccurrence: Termin/Raum ExamOccurrences: Prüfungen ExamRoomAlreadyExists: Prüfung ist bereits eingetragen +ExamRoomName: Interne Bezeichnung ExamRoom: Raum ExamRoomCapacity: Kapazität ExamRoomCapacityNegative: Kapazität darf nicht negativ sein @@ -1167,10 +1169,11 @@ ExamClosedMustBeAfterFinished: "Noten stehen fest ab" muss nach "Bewertung abges ExamClosedMustBeAfterStart: "Noten stehen fest ab" muss nach Start liegen ExamClosedMustBeAfterEnd: "Noten stehen fest ab" muss nach Ende liegen -ExamOccurrenceEndMustBeAfterStart eoRoom@Text eoRange@Text: Beginn des Termins #{eoRoom} #{eoRange} muss vor seinem Ende liegen -ExamOccurrenceStartMustBeAfterExamStart eoRoom@Text eoRange@Text: Beginn des Termins #{eoRoom} #{eoRange} muss nach Beginn der Klausur liegen -ExamOccurrenceEndMustBeBeforeExamEnd eoRoom@Text eoRange@Text: Ende des Termins #{eoRoom} #{eoRange} muss vor Ende der Klausur liegen +ExamOccurrenceEndMustBeAfterStart eoName@ExamOccurrenceName: Beginn des Termins #{eoName} muss vor seinem Ende liegen +ExamOccurrenceStartMustBeAfterExamStart eoName@ExamOccurrenceName: Beginn des Termins #{eoName} muss nach Beginn der Klausur liegen +ExamOccurrenceEndMustBeBeforeExamEnd eoName@ExamOccurrenceName: Ende des Termins #{eoName} muss vor Ende der Klausur liegen ExamOccurrenceDuplicate eoRoom@Text eoRange@Text: Raum #{eoRoom}, Termin #{eoRange} kommt mehrfach mit der selben Beschreibung vor +ExamOccurrenceDuplicateName eoName@ExamOccurrenceName: Interne Terminbezeichnung #{eoName} kommt mehrfach vor VersionHistory: Versionsgeschichte KnownBugs: Bekannte Bugs diff --git a/models/exams b/models/exams index 14cd8784b..a98a427ca 100644 --- a/models/exams +++ b/models/exams @@ -25,11 +25,13 @@ ExamPart UniqueExamPart exam name ExamOccurrence exam ExamId + name ExamOccurrenceName room Text capacity Natural start UTCTime end UTCTime Maybe description Html Maybe + UniqueExamOccurrence exam name ExamRegistration exam ExamId user UserId diff --git a/src/Data/CaseInsensitive/Instances.hs b/src/Data/CaseInsensitive/Instances.hs index b6b69fa02..4fb1bf0a2 100644 --- a/src/Data/CaseInsensitive/Instances.hs +++ b/src/Data/CaseInsensitive/Instances.hs @@ -29,6 +29,8 @@ import Web.HttpApiData import Data.Binary (Binary) import qualified Data.Binary as Binary +import qualified Data.Csv as Csv + instance PersistField (CI Text) where toPersistValue ciText = PersistDbSpecific . Text.encodeUtf8 $ CI.original ciText @@ -86,11 +88,11 @@ instance (CI.FoldCase s, PathPiece s) => PathPiece (CI s) where fromPathPiece = fmap CI.mk . fromPathPiece toPathPiece = toPathPiece . CI.original -instance ToHttpApiData (CI Text) where +instance ToHttpApiData s => ToHttpApiData (CI s) where toUrlPiece = toUrlPiece . CI.original toEncodedUrlPiece = toEncodedUrlPiece . CI.original -instance FromHttpApiData (CI Text) where +instance (CI.FoldCase s, FromHttpApiData s) => FromHttpApiData (CI s) where parseUrlPiece = fmap CI.mk . parseUrlPiece instance (CI.FoldCase s, PathMultiPiece s) => PathMultiPiece (CI s) where @@ -101,3 +103,9 @@ instance (CI.FoldCase s, Binary s) => Binary (CI s) where get = CI.mk <$> Binary.get put = Binary.put . CI.original putList = Binary.putList . map CI.original + +instance Csv.ToField s => Csv.ToField (CI s) where + toField = Csv.toField . CI.original + +instance (CI.FoldCase s, Csv.FromField s) => Csv.FromField (CI s) where + parseField = fmap CI.original . Csv.parseField diff --git a/src/Data/UUID/Instances.hs b/src/Data/UUID/Instances.hs index 8a00de5e3..38b20d104 100644 --- a/src/Data/UUID/Instances.hs +++ b/src/Data/UUID/Instances.hs @@ -3,12 +3,13 @@ module Data.UUID.Instances () where -import ClassyPrelude +import ClassyPrelude.Yesod import Data.UUID (UUID) import qualified Data.UUID as UUID import Database.Persist.Sql -import Web.PathPieces + +import Text.Blaze (ToMarkup(..)) instance PathPiece UUID where @@ -25,3 +26,13 @@ instance PersistField UUID where instance PersistFieldSql UUID where sqlType _ = SqlOther "uuid" + +instance ToMarkup UUID where + toMarkup uuid = [shamlet| + $newline never + + #{UUID.toText uuid} + |] + +instance ToWidget site UUID where + toWidget = toWidget . toMarkup diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index f1d5085a5..3e0a5a825 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -168,7 +168,7 @@ colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DB colSMatrikel :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colSMatrikel = sortable Nothing (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput=(_, _, _, _, _, users) } -> let - protoCell = listCell (Map.toList users) $ \(userId, (User{..}, _)) -> anchorCellM (AdminUserR <$> encrypt userId) (maybe mempty toWidget userMatrikelnummer) + protoCell = listCell (Map.toList users) $ \(userId, (User{..}, _)) -> anchorCellM (AdminUserR <$> encrypt userId) (fromMaybe mempty userMatrikelnummer) in protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] colRating :: forall m a. IsDBTable m (a, SheetTypeSummary) => Colonnade Sortable CorrectionTableData (DBCell m (a, SheetTypeSummary)) diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index ef99c06de..0c72416e5 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -422,7 +422,7 @@ getCShowR tid ssh csh = do guardM . hasReadAccessTo $ CExamR tid ssh csh examName EShowR return r dbtColonnade = dbColonnade $ mconcat - [ sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> indicatorCell <> anchorCell (CExamR tid ssh csh examName EShowR) (toWidget examName) + [ sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> indicatorCell <> anchorCell (CExamR tid ssh csh examName EShowR) examName , sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom , sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo , sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> maybe mempty (cell . flip (formatTimeRangeW SelFormatDateTime) examEnd) examStart @@ -1053,7 +1053,7 @@ colUserComment tid ssh csh = sortable (Just "note") (i18nCell MsgCourseUserNote) $ \DBRow{ dbrOutput=(Entity uid _, _, mbNoteKey,_) } -> maybeEmpty mbNoteKey $ const $ - anchorCellM (courseLink <$> encrypt uid) (toWidget $ hasComment True) + anchorCellM (courseLink <$> encrypt uid) (hasComment True) where courseLink = CourseR tid ssh csh . CUserR diff --git a/src/Handler/Exam.hs b/src/Handler/Exam.hs index 1be2b99fa..03d92e282 100644 --- a/src/Handler/Exam.hs +++ b/src/Handler/Exam.hs @@ -52,7 +52,7 @@ getCExamListR tid ssh csh = do guardM . hasReadAccessTo $ CExamR tid ssh csh examName EShowR return x dbtColonnade = dbColonnade . mconcat $ catMaybes - [ Just . sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> anchorCell (CExamR tid ssh csh examName EShowR) $ toWidget examName + [ Just . sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> anchorCell (CExamR tid ssh csh examName EShowR) examName , (<$ guard mayCreate) . sortable (Just "visible") (i18nCell MsgExamVisibleFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty (dateTimeCellVisible now) examVisibleFrom , Just . sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom , Just . sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo @@ -167,6 +167,7 @@ data ExamForm = ExamForm data ExamOccurrenceForm = ExamOccurrenceForm { eofId :: Maybe CryptoUUIDExamOccurrence + , eofName :: ExamOccurrenceName , eofRoom :: Text , eofCapacity :: Natural , eofStart :: UTCTime @@ -279,7 +280,8 @@ examOccurrenceForm prev = wFormToAForm $ do where examOccurrenceForm' nudge mPrev csrf = do (eofIdRes, eofIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ eofId =<< mPrev) - (eofRoomRes, eofRoomView) <- mpreq textField ("" & addName (nudge "name")) (eofRoom <$> mPrev) + (eofNameRes, eofNameView) <- mpreq ciField ("" & addName (nudge "name")) (eofName <$> mPrev) + (eofRoomRes, eofRoomView) <- mpreq textField ("" & addName (nudge "room")) (eofRoom <$> mPrev) (eofCapacityRes, eofCapacityView) <- mpreq (natFieldI MsgExamRoomCapacityNegative) ("" & addName (nudge "capacity")) (eofCapacity <$> mPrev) (eofStartRes, eofStartView) <- mpreq utcTimeField ("" & addName (nudge "start")) (eofStart <$> mPrev) (eofEndRes, eofEndView) <- mopt utcTimeField ("" & addName (nudge "end")) (eofEnd <$> mPrev) @@ -287,6 +289,7 @@ examOccurrenceForm prev = wFormToAForm $ do return ( ExamOccurrenceForm <$> eofIdRes + <*> eofNameRes <*> eofRoomRes <*> eofCapacityRes <*> eofStartRes @@ -375,6 +378,7 @@ examFormTemplate (Entity eId Exam{..}) = do (Just -> eofId, ExamOccurrence{..}) <- occurrences' return ExamOccurrenceForm { eofId + , eofName = examOccurrenceName , eofRoom = examOccurrenceRoom , eofCapacity = examOccurrenceCapacity , eofStart = examOccurrenceStart @@ -459,11 +463,9 @@ validateExam = do guardValidation MsgExamClosedMustBeAfterEnd . fromMaybe True $ (>=) <$> efClosed <*> efEnd forM_ efOccurrences $ \ExamOccurrenceForm{..} -> do - eofRange' <- formatTimeRange SelFormatDateTime eofStart eofEnd - - guardValidation (MsgExamOccurrenceEndMustBeAfterStart eofRoom eofRange') $ NTop eofEnd >= NTop (Just eofStart) - guardValidation (MsgExamOccurrenceStartMustBeAfterExamStart eofRoom eofRange') $ NTop (Just eofStart) >= NTop efStart - guardValidation (MsgExamOccurrenceEndMustBeBeforeExamEnd eofRoom eofRange') $ NTop eofEnd <= NTop efEnd + guardValidation (MsgExamOccurrenceEndMustBeAfterStart eofName) $ NTop eofEnd >= NTop (Just eofStart) + guardValidation (MsgExamOccurrenceStartMustBeAfterExamStart eofName) $ NTop (Just eofStart) >= NTop efStart + guardValidation (MsgExamOccurrenceEndMustBeBeforeExamEnd eofName) $ NTop eofEnd <= NTop efEnd forM_ [ (a, b) | a <- Set.toAscList efOccurrences, b <- Set.toAscList efOccurrences, b > a ] $ \(a, b) -> do eofRange' <- formatTimeRange SelFormatDateTime (eofStart a) (eofEnd a) @@ -475,6 +477,8 @@ validateExam = do , (/=) `on` fmap renderHtml . eofDescription ] + guardValidation (MsgExamOccurrenceDuplicateName $ eofName a) $ ((/=) `on` eofName) a b + getCExamNewR, postCExamNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCExamNewR = postCExamNewR @@ -521,6 +525,7 @@ postCExamNewR tid ssh csh = do [ ExamOccurrence{..} | ExamOccurrenceForm{..} <- Set.toList efOccurrences , let examOccurrenceExam = examid + examOccurrenceName = eofName examOccurrenceRoom = eofRoom examOccurrenceCapacity = eofCapacity examOccurrenceStart = eofStart @@ -594,6 +599,7 @@ postEEditR tid ssh csh examn = do ExamOccurrenceForm{ eofId = Nothing, .. } -> insert_ ExamOccurrence { examOccurrenceExam = eId + , examOccurrenceName = eofName , examOccurrenceRoom = eofRoom , examOccurrenceCapacity = eofCapacity , examOccurrenceStart = eofStart @@ -607,6 +613,7 @@ postEEditR tid ssh csh examn = do guard $ examOccurrenceExam oldOcc == eId lift $ replace eofId' ExamOccurrence { examOccurrenceExam = eId + , examOccurrenceName = eofName , examOccurrenceRoom = eofRoom , examOccurrenceCapacity = eofCapacity , examOccurrenceStart = eofStart @@ -672,7 +679,7 @@ getEShowR tid ssh csh examn = do cTime <- liftIO getCurrentTime mUid <- maybeAuthId - (Entity _ Exam{..}, parts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister)) <- runDB $ do + (Entity _ Exam{..}, parts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister), occurrenceNamesShown) <- runDB $ do exam@(Entity eId Exam{..}) <- fetchExam tid ssh csh examn let examVisible = NTop (Just cTime) >= NTop examVisibleFrom @@ -712,7 +719,9 @@ getEShowR tid ssh csh examn = do registered <- for mUid $ existsBy . UniqueExamRegistration eId mayRegister <- (== Authorized) <$> evalAccessDB (CExamR tid ssh csh examName ERegisterR) True - return (exam, parts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister)) + occurrenceNamesShown <- hasReadAccessTo $ CExamR tid ssh csh examn EEditR + + return (exam, parts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister), occurrenceNamesShown) let examTimes = all (\(Entity _ ExamOccurrence{..}, _) -> Just examOccurrenceStart == examStart && examOccurrenceEnd == examEnd) occurrences registerWidget @@ -772,6 +781,9 @@ queryStudyFeatures = $(sqlIJproj 3 1) . $(sqlLOJproj 2 2) . $(sqlLOJproj 3 3) queryExamRegistration :: ExamUserTableExpr -> E.SqlExpr (Entity ExamRegistration) queryExamRegistration = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1) +queryExamOccurrence :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamOccurrence)) +queryExamOccurrence = $(sqlLOJproj 3 2) + queryStudyDegree :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyDegree)) queryStudyDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 2 2) . $(sqlLOJproj 3 3) @@ -800,7 +812,7 @@ data ExamUserTableCsv = ExamUserTableCsv , csvUserField :: Maybe Text , csvUserDegree :: Maybe Text , csvUserSemester :: Maybe Int - , csvUserRoom :: Maybe Text + , csvUserOccurrence :: Maybe (CI Text) } deriving (Generic) @@ -843,7 +855,7 @@ postEUsersR tid ssh csh examn = do , colField resultStudyField , colDegreeShort resultStudyDegree , colFeaturesSemester resultStudyFeatures - , sortable (Just "room") (i18nCell MsgExamRoom) (maybe mempty (cell . toWgt . examOccurrenceRoom . entityVal) . view _userTableOccurrence) + , sortable (Just "occurrence") (i18nCell MsgExamOccurrence) $ maybe mempty (anchorCell' (\n -> CExamR tid ssh csh examn EShowR :#: [st|exam-occurrence__#{n}|]) id . examOccurrenceName . entityVal) . view _userTableOccurrence ] dbtSorting = Map.fromList [ sortUserNameLink queryUser @@ -853,6 +865,7 @@ postEUsersR tid ssh csh examn = do , sortField queryStudyField , sortDegreeShort queryStudyDegree , sortFeaturesSemester queryStudyFeatures + , ("occurrence", SortColumn $ queryExamOccurrence >>> (E.?. ExamOccurrenceName)) ] dbtFilter = Map.fromList [ fltrUserNameEmail queryUser @@ -880,7 +893,7 @@ postEUsersR tid ssh csh examn = do <*> preview (resultStudyField . _entityVal . to (\StudyTerms{..} -> studyTermsName <|> studyTermsShorthand <|> Just (tshow studyTermsKey)) . _Just) <*> preview (resultStudyDegree . _entityVal . to (\StudyDegree{..} -> studyDegreeName <|> studyDegreeShorthand <|> Just (tshow studyDegreeKey)) . _Just) <*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester) - <*> preview (resultExamOccurrence . _entityVal . _examOccurrenceRoom) + <*> preview (resultExamOccurrence . _entityVal . _examOccurrenceName) dbtCsvDecode = Nothing examUsersDBTableValidator = def diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 4033e8ae1..e7c2ca93a 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -47,7 +47,7 @@ homeOpenCourses = do let tid = courseTerm course ssh = courseSchool course csh = courseShorthand course - anchorCell (CourseR tid ssh csh CShowR) (toWidget csh) + anchorCell (CourseR tid ssh csh CShowR) csh , sortable (Just "deadline") (i18nCell MsgRegisterTo) $ \DBRow{ dbrOutput=Entity{entityVal = course} } -> cell $ traverse (formatTime SelFormatDateTime) (courseRegisterTo course) >>= maybe mempty toWidget ] @@ -130,9 +130,9 @@ homeUpcomingSheets uid = do , sortable (Just "school") (i18nCell MsgCourseSchool) $ \DBRow{ dbrOutput=(_,E.Value ssh,_,_,_,_) } -> textCell $ toMessage ssh , sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, _, _, _) } -> - anchorCell (CourseR tid ssh csh CShowR) (toWidget csh) + anchorCell (CourseR tid ssh csh CShowR) csh , sortable (Just "sheet") (i18nCell MsgSheet) $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) } -> - anchorCell (CSheetR tid ssh csh shn SShowR) (toWidget shn) + anchorCell (CSheetR tid ssh csh shn SShowR) shn , sortable (Just "deadline") (i18nCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, _, E.Value deadline, _) } -> cell $ formatTime SelFormatDateTime deadline >>= toWidget , sortable (Just "done") (i18nCell MsgDone) $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, E.Value mbsid) } -> @@ -142,7 +142,7 @@ homeUpcomingSheets uid = do whenM (hasWriteAccessTo submitRoute) $ modal [whamlet|_{MsgMenuSubmissionNew}|] . Left $ SomeRoute submitRoute (Just sid) -> anchorCellM (CSubmissionR tid ssh csh shn <$> encrypt sid <*> pure SubShowR) - (toWidget $ hasTickmark True) + (hasTickmark True) ] let validator = def & defaultSorting [SortDescBy "done", SortAscBy "deadline"] sheetTable <- liftHandlerT . runDB $ dbTableWidget' validator DBTable @@ -228,7 +228,7 @@ homeUpcomingExams uid = do , sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput } -> do let Entity _ Exam{..} = view lensExam dbrOutput Entity _ Course{..} = view lensCourse dbrOutput - indicatorCell <> anchorCell (CExamR courseTerm courseSchool courseShorthand examName EShowR) (toWidget examName) + indicatorCell <> anchorCell (CExamR courseTerm courseSchool courseShorthand examName EShowR) examName , sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom , sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo , sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty (cell . flip (formatTimeRangeW SelFormatDateTime) examEnd) examStart diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index df31ec398..8194ef410 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -206,7 +206,7 @@ getSheetListR tid ssh csh = do sheetCol = widgetColonnade . mconcat $ [ -- dbRow , sortable (Just "name") (i18nCell MsgSheet) - $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> anchorCell (CSheetR tid ssh csh sheetName SShowR) (toWidget sheetName) + $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> anchorCell (CSheetR tid ssh csh sheetName SShowR) sheetName , sortable (Just "last-edit") (i18nCell MsgLastEdit) $ \DBRow{dbrOutput=(_, E.Value mEditTime, _, _)} -> foldMap dateTimeCell mEditTime , sortable (Just "visible-from") (i18nCell MsgAccessibleSince) diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs index 273e33d6d..ae1c7f757 100644 --- a/src/Handler/SystemMessage.hs +++ b/src/Handler/SystemMessage.hs @@ -165,7 +165,7 @@ postMessageListR = do dbtColonnade = mconcat [ dbSelect (applying _2) id $ \DBRow{ dbrOutput = (Entity smId _, _) } -> encrypt smId , dbRow - , sortable Nothing (i18nCell MsgSystemMessageId) $ \DBRow{ dbrOutput = (Entity smId _, _) } -> anchorCellM' (encrypt smId) MessageR (toWidget . tshow . ciphertext) + , sortable Nothing (i18nCell MsgSystemMessageId) $ \DBRow{ dbrOutput = (Entity smId _, _) } -> anchorCellM' (encrypt smId) MessageR ciphertext , sortable (Just "from") (i18nCell MsgSystemMessageFrom) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ maybe mempty (formatTimeW SelFormatDateTime) systemMessageFrom , sortable (Just "to") (i18nCell MsgSystemMessageTo) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ maybe mempty (formatTimeW SelFormatDateTime) systemMessageTo , sortable (Just "authenticated") (i18nCell MsgSystemMessageAuthenticatedOnly) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> tickmarkCell systemMessageAuthenticatedOnly diff --git a/src/Handler/Tutorial.hs b/src/Handler/Tutorial.hs index 1f56bcc8d..2f4123a22 100644 --- a/src/Handler/Tutorial.hs +++ b/src/Handler/Tutorial.hs @@ -61,7 +61,7 @@ getCTutorialListR tid ssh csh = do
  • ^{nameEmailWidget' tutor} |] - , sortable (Just "participants") (i18nCell MsgTutorialParticipants) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, n) } -> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) . toWidget $ tshow n + , sortable (Just "participants") (i18nCell MsgTutorialParticipants) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, n) } -> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) $ tshow n , sortable (Just "capacity") (i18nCell MsgTutorialCapacity) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybe mempty (textCell . tshow) tutorialCapacity , sortable (Just "room") (i18nCell MsgTutorialRoom) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> textCell tutorialRoom , sortable Nothing (i18nCell MsgTutorialTime) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> occurrencesCell tutorialTime diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index df62bbdbb..8262140eb 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -91,7 +91,7 @@ ifCell decision cTrue cFalse x | otherwise = cFalse x linkEmptyCell :: IsDBTable m a => Route UniWorX -> Widget -> DBCell m a -linkEmptyCell link wgt = linkEitherCell link (wgt,mempty) +linkEmptyCell = anchorCell msgCell :: (ToMessage t, IsDBTable m a) => t -> DBCell m a msgCell = textCell . toMessage @@ -123,7 +123,7 @@ isNewCell = cell . toWidget . isNew commentCell :: IsDBTable m a => Maybe (Route UniWorX) -> DBCell m a commentCell Nothing = mempty commentCell (Just link) = anchorCell link icon - where icon = toWidget $ hasComment True + where icon = hasComment True -- | whether something is visible or hidden isVisibleCell :: (IsDBTable m a) => Bool -> DBCell m a @@ -134,11 +134,11 @@ isVisibleCell False = (cell . toWidget $ isVisible False) & addUrgencyClass -- | for simple file downloads fileCell :: IsDBTable m a => Route UniWorX -> DBCell m a -fileCell route = anchorCell route $ toWidget fileDownload +fileCell route = anchorCell route fileDownload -- | for zip-archive downloads zipCell :: IsDBTable m a => Route UniWorX -> DBCell m a -zipCell route = anchorCell route $ toWidget zipDownload +zipCell route = anchorCell route zipDownload -- | Display an icon that opens a modal upon clicking modalCell :: (IsDBTable m a, ToWidget UniWorX w) => w -> DBCell m a diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 91c2bc24d..272c9ffaa 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -971,43 +971,47 @@ cellTooltip msg = cellContents.mapped %~ (<> tipWdgt) -- | Always display widget; maybe a link if user is Authorized. -- Also see variant `linkEmptyCell` -anchorCell :: IsDBTable m a => Route UniWorX -> Widget -> DBCell m a +anchorCell :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a) => url -> wgt -> DBCell m a anchorCell = anchorCellM . return -{-# DEPRECATED anchorCell' "For compatibility with Colonnade; better use anchorCell instead." #-} -anchorCell' :: IsDBTable m a - => (r -> Route UniWorX) - -> (r -> Widget) +anchorCell' :: ( IsDBTable m a + , ToWidget UniWorX wgt + , HasRoute UniWorX url + ) + => (r -> url) + -> (r -> wgt) -> (r -> DBCell m a) anchorCell' mkRoute mkWidget val = anchorCell (mkRoute val) (mkWidget val) -anchorCellM :: IsDBTable m a => WidgetT UniWorX IO (Route UniWorX) -> Widget -> DBCell m a +anchorCellM :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a, HandlerSite m ~ UniWorX) => WidgetT UniWorX IO url -> wgt -> DBCell m a anchorCellM routeM widget = anchorCellM' routeM id (const widget) -anchorCellM' :: IsDBTable m a => WidgetT UniWorX IO x -> (x -> Route UniWorX) -> (x -> Widget) -> DBCell m a -anchorCellM' xM x2route x2widget = cell $ do - x <- xM - let route = x2route x - widget = x2widget x - authResult <- liftHandlerT $ isAuthorized route False - case authResult of - Authorized -> $(widgetFile "table/cell/link") -- show allowed link - _otherwise -> widget -- don't show prohibited link +anchorCellM' :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a, HandlerSite m ~ UniWorX) => WidgetT UniWorX IO x -> (x -> url) -> (x -> wgt) -> DBCell m a +anchorCellM' xM x2route x2widget = linkEitherCellM' xM x2route (x2widget, x2widget) -- | Variant of `anchorCell` that displays different widgets depending whether the route is authorized for current user -linkEitherCell :: IsDBTable m a => Route UniWorX -> (Widget, Widget) -> DBCell m a +linkEitherCell :: (HasRoute UniWorX url, ToWidget UniWorX wgt, ToWidget UniWorX wgt', IsDBTable m a, HandlerSite m ~ UniWorX) => url -> (wgt, wgt') -> DBCell m a linkEitherCell = linkEitherCellM . return -linkEitherCellM :: IsDBTable m a => WidgetT UniWorX IO (Route UniWorX) -> (Widget, Widget) -> DBCell m a +linkEitherCellM :: (HasRoute UniWorX url, ToWidget UniWorX wgt, ToWidget UniWorX wgt', IsDBTable m a, HandlerSite m ~ UniWorX) => WidgetT UniWorX IO url -> (wgt, wgt') -> DBCell m a linkEitherCellM routeM (widgetAuth,widgetUnauth) = linkEitherCellM' routeM id (const widgetAuth, const widgetUnauth) -linkEitherCellM' :: IsDBTable m a => WidgetT UniWorX IO x -> (x -> Route UniWorX) -> (x -> Widget, x -> Widget) -> DBCell m a +linkEitherCellM' :: forall m url wgt wgt' a x. + ( HasRoute UniWorX url + , ToWidget UniWorX wgt + , ToWidget UniWorX wgt' + , IsDBTable m a + , HandlerSite m ~ UniWorX + ) + => WidgetT UniWorX IO x -> (x -> url) -> (x -> wgt, x -> wgt') -> DBCell m a linkEitherCellM' xM x2route (x2widgetAuth,x2widgetUnauth) = cell $ do x <- xM let route = x2route x - widget = x2widgetAuth x - widgetUnauth = x2widgetUnauth x - authResult <- liftHandlerT $ isAuthorized route False + widget, widgetUnauth :: WidgetT UniWorX IO () + widget = toWidget $ x2widgetAuth x + widgetUnauth = toWidget $ x2widgetUnauth x + authResult <- liftHandlerT $ isAuthorized (urlRoute route) False + linkUrl <- toTextUrl route case authResult of Authorized -> $(widgetFile "table/cell/link") -- show allowed link _otherwise -> widgetUnauth -- show alternative widget diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index e24c93de3..755434aa3 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -28,6 +28,8 @@ import Control.Monad.Trans.Reader (mapReaderT) import Control.Monad.Except (MonadError(..)) import Utils (exceptT) +import Numeric.Natural + -- Database versions must follow https://pvp.haskell.org: -- - Breaking changes are instances where manual migration is necessary (via customMigrations; i.e. changing a columns format) -- - Non-breaking changes are instances where the automatic migration done by persistent is sufficient (i.e. adding a column or table) @@ -57,7 +59,11 @@ share [mkPersist sqlSettings, mkMigrate "migrateDBVersioning"] deriving Show Eq Ord |] -migrateAll :: (MonadLogger m, MonadBaseControl IO m, MonadIO m) => ReaderT SqlBackend m () +migrateAll :: ( MonadLogger m + , MonadBaseControl IO m + , MonadIO m + ) + => ReaderT SqlBackend m () migrateAll = do $logDebugS "Migration" "Initial migration" mapM_ ($logInfoS "Migration") =<< runMigrationSilent initialMigration @@ -77,14 +83,19 @@ migrateAll = do $logDebugS "Migration" "Persistent automatic migration" mapM_ ($logInfoS "Migration") =<< runMigrationSilent migrateAll' -requiresMigration :: forall m. (MonadLogger m, MonadBaseControl IO m, MonadIO m) => ReaderT SqlBackend m Bool +requiresMigration :: forall m. + ( MonadLogger m + , MonadBaseControl IO m + , MonadIO m + ) + => ReaderT SqlBackend m Bool requiresMigration = mapReaderT (exceptT return return) $ do initial <- either id (map snd) <$> parseMigration initialMigration when (not $ null initial) $ do $logInfoS "Migration" $ intercalate "; " initial throwError True - customs <- getMissingMigrations @_ @m + customs <- mapReaderT lift $ getMissingMigrations @_ @m when (not $ Map.null customs) $ do $logInfoS "Migration" . intercalate ", " . map tshow $ Map.keys customs throwError True @@ -123,7 +134,8 @@ getMissingMigrations = do -} -customMigrations :: MonadIO m => Map (Key AppliedMigration) (ReaderT SqlBackend m ()) +customMigrations :: ( MonadIO m + ) => Map (Key AppliedMigration) (ReaderT SqlBackend m ()) customMigrations = Map.fromListWith (>>) [ ( AppliedMigrationKey [migrationVersion|initial|] [version|0.0.0|] , whenM (columnExists "user" "theme") $ do -- New theme format @@ -292,6 +304,20 @@ customMigrations = Map.fromListWith (>>) , whenM (tableExists "exam") $ -- Exams were an unused stub before tableDropEmpty "exam" ) + , ( AppliedMigrationKey [migrationVersion|13.0.0|] [version|14.0.0|] + , whenM ((&&) <$> tableExists "exam_occurrence" <*> (not <$> columnExists "exam_occurrence" "name")) $ do + examOccurrences <- [sqlQQ| SELECT "id" FROM "exam_occurrence" ORDER BY "exam"; |] + [executeQQ| + ALTER TABLE "exam_occurrence" ADD COLUMN "name" citext DEFAULT null; + |] + forM_ (zip [0..] examOccurrences) $ \(n :: Natural, Single eoId :: Single ExamOccurrenceId) -> do + let name = [st|occ-#{tshow n}|] + [executeQQ| UPDATE "exam_occurrence" SET "name" = #{name} WHERE "id" = #{eoId} |] + [executeQQ| + ALTER TABLE "exam_occurrence" ALTER COLUMN "name" DROP DEFAULT; + ALTER TABLE "exam_occurrence" ALTER COLUMN "name" SET NOT NULL; + |] + ) ] diff --git a/src/Model/Types/Common.hs b/src/Model/Types/Common.hs index c0cd4a30b..2d8e8b1d0 100644 --- a/src/Model/Types/Common.hs +++ b/src/Model/Types/Common.hs @@ -16,19 +16,20 @@ import qualified Yesod.Auth.Util.PasswordStore as PWStore type Count = Sum Integer type Points = Centi -type Email = Text +type Email = Text -type SchoolName = CI Text -type SchoolShorthand = CI Text -type CourseName = CI Text -type CourseShorthand = CI Text -type SheetName = CI Text -type MaterialName = CI Text -type UserEmail = CI Email -type UserIdent = CI Text -type TutorialName = CI Text -type ExamName = CI Text -type ExamPartName = CI Text +type SchoolName = CI Text +type SchoolShorthand = CI Text +type CourseName = CI Text +type CourseShorthand = CI Text +type SheetName = CI Text +type MaterialName = CI Text +type UserEmail = CI Email +type UserIdent = CI Text +type TutorialName = CI Text +type ExamName = CI Text +type ExamPartName = CI Text +type ExamOccurrenceName = CI Text type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString type InstanceId = UUID diff --git a/templates/default-layout.lucius b/templates/default-layout.lucius index 2fdc1b3de..57d417402 100644 --- a/templates/default-layout.lucius +++ b/templates/default-layout.lucius @@ -637,3 +637,8 @@ section { font-weight: var(--weight, 600); background-color: rgba(var(--red), var(--green), 0, var(--opacity)); } + + +.uuid { + font-family: monospace; +} diff --git a/templates/exam-show.hamlet b/templates/exam-show.hamlet index 56b8b0fd1..e7d2a777b 100644 --- a/templates/exam-show.hamlet +++ b/templates/exam-show.hamlet @@ -93,6 +93,10 @@ $if not (null occurrences) + $if occurrenceNamesShown + - $forall (Entity _occId ExamOccurrence{examOccurrenceRoom, examOccurrenceStart, examOccurrenceEnd, examOccurrenceDescription}, registered) <- occurrences + $forall (Entity _occId ExamOccurrence{examOccurrenceName, examOccurrenceRoom, examOccurrenceStart, examOccurrenceEnd, examOccurrenceDescription}, registered) <- occurrences + $if occurrenceNamesShown +
    + _{MsgExamRoomName} + ^{isVisible False} _{MsgExamRoom} $if not examTimes _{MsgExamRoomTime} @@ -103,8 +107,10 @@ $if not (null occurrences) $if not occurrenceAssignmentsVisible \ ^{isVisible False}
    #{examOccurrenceName} #{examOccurrenceRoom} $if not examTimes diff --git a/templates/table/cell/link.hamlet b/templates/table/cell/link.hamlet index cdf41888f..2d9a2b1a0 100644 --- a/templates/table/cell/link.hamlet +++ b/templates/table/cell/link.hamlet @@ -1,3 +1,3 @@ $newline never - - ^{widget} \ No newline at end of file + + ^{widget} diff --git a/templates/widgets/massinput/examRooms/form.hamlet b/templates/widgets/massinput/examRooms/form.hamlet index bd0fd06ed..4df09253e 100644 --- a/templates/widgets/massinput/examRooms/form.hamlet +++ b/templates/widgets/massinput/examRooms/form.hamlet @@ -1,5 +1,6 @@ $newline never -#{csrf}^{fvInput eofIdView}^{fvInput eofRoomView} +#{csrf}^{fvInput eofIdView}^{fvInput eofNameView} +^{fvInput eofRoomView} ^{fvInput eofCapacityView} ^{fvInput eofStartView} ^{fvInput eofEndView} diff --git a/templates/widgets/massinput/examRooms/layout.hamlet b/templates/widgets/massinput/examRooms/layout.hamlet index cc4211e5c..c8a4bf270 100644 --- a/templates/widgets/massinput/examRooms/layout.hamlet +++ b/templates/widgets/massinput/examRooms/layout.hamlet @@ -1,6 +1,7 @@ $newline never +
    _{MsgExamRoomName} _{MsgExamRoom} _{MsgExamRoomCapacity} _{MsgExamRoomStart} From 2b23600a2287e96e5b482c4e53125a55b64bbb93 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 16 Jul 2019 10:10:21 +0200 Subject: [PATCH 2/4] feat(exams): show exam bonus in webinterface --- messages/uniworx/de.msg | 8 +- src/Handler/Exam.hs | 152 +++++++++++++++++-------------- src/Handler/Utils/Exam.hs | 36 ++++++++ src/Handler/Utils/Table/Cells.hs | 3 + src/Model/Types/Sheet.hs | 28 ++++-- src/Utils.hs | 6 ++ 6 files changed, 157 insertions(+), 76 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 8d72c3384..783f75491 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -433,7 +433,9 @@ HasCorrector: Korrektor zugeteilt AssignedTime: Zuteilung AchievedBonusPoints: Erreichte Bonuspunkte AchievedNormalPoints: Erreichte Punkte -AchievedPassPoints: Erreichte Punkte +AchievedPoints: Erreichte Punkte +AchievedPassPoints: Erreichte Punkte zum Bestehen +AchievedPasses: Bestandene Blätter AchievedOf achieved@Points possible@Points: #{achieved} von #{possible} PassAchievedOf points@Points passingPoints@Points maxPoints@Points: #{points} von #{maxPoints} (Bestanden ab #{passingPoints}) PassedResult: Ergebnis @@ -1185,4 +1187,6 @@ CsvModifyExisting: Existierende Einträge angleichen CsvAddNew: Neue Einträge einfügen CsvDeleteMissing: Fehlende Einträge entfernen BtnCsvExport: CSV-Datei exportieren -BtnCsvImport: CSV-Datei importieren \ No newline at end of file +BtnCsvImport: CSV-Datei importieren + +Proportion c@Text of@Text prop@Rational: #{c}/#{of} (#{rationalToFixed2 (100 * prop)}%) \ No newline at end of file diff --git a/src/Handler/Exam.hs b/src/Handler/Exam.hs index 03d92e282..230bb405c 100644 --- a/src/Handler/Exam.hs +++ b/src/Handler/Exam.hs @@ -831,73 +831,93 @@ instance DefaultOrdered ExamUserTableCsv where getEUsersR, postEUsersR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html getEUsersR = postEUsersR postEUsersR tid ssh csh examn = do - Entity eid Exam{..} <- runDB $ fetchExam tid ssh csh examn - - let - examUsersDBTable = DBTable{..} - where - dbtSQLQuery ((examRegistration `E.InnerJoin` user) `E.LeftOuterJoin` occurrence `E.LeftOuterJoin` (courseParticipant `E.LeftOuterJoin` (studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyField))) = do - E.on $ studyField E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField - E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree - E.on $ studyFeatures E.?. StudyFeaturesId E.==. E.joinV (courseParticipant E.?. CourseParticipantField) - E.on $ courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val examCourse) - E.&&. courseParticipant E.?. CourseParticipantUser E.==. E.just (user E.^. UserId) - E.on $ occurrence E.?. ExamOccurrenceExam E.==. E.just (E.val eid) - E.&&. occurrence E.?. ExamOccurrenceId E.==. examRegistration E.^. ExamRegistrationOccurrence - E.on $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId - E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eid - return (examRegistration, user, occurrence, studyFeatures, studyDegree, studyField) - dbtRowKey = queryExamRegistration >>> (E.^. ExamRegistrationId) - dbtProj = return - dbtColonnade = dbColonnade $ mconcat - [ colUserNameLink (CourseR tid ssh csh . CUserR) - , colUserMatriclenr - , colField resultStudyField - , colDegreeShort resultStudyDegree - , colFeaturesSemester resultStudyFeatures - , sortable (Just "occurrence") (i18nCell MsgExamOccurrence) $ maybe mempty (anchorCell' (\n -> CExamR tid ssh csh examn EShowR :#: [st|exam-occurrence__#{n}|]) id . examOccurrenceName . entityVal) . view _userTableOccurrence - ] - dbtSorting = Map.fromList - [ sortUserNameLink queryUser - , sortUserSurname queryUser - , sortUserDisplayName queryUser - , sortUserMatriclenr queryUser - , sortField queryStudyField - , sortDegreeShort queryStudyDegree - , sortFeaturesSemester queryStudyFeatures - , ("occurrence", SortColumn $ queryExamOccurrence >>> (E.?. ExamOccurrenceName)) - ] - dbtFilter = Map.fromList - [ fltrUserNameEmail queryUser - , fltrUserMatriclenr queryUser - , fltrField queryStudyField - , fltrDegree queryStudyDegree - , fltrFeaturesSemester queryStudyFeatures - ] - dbtFilterUI mPrev = mconcat - [ fltrUserNameEmailUI mPrev - , fltrUserMatriclenrUI mPrev - , fltrFieldUI mPrev - , fltrDegreeUI mPrev - , fltrFeaturesSemesterUI mPrev - ] - dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } - dbtParams = def - dbtIdent :: Text - dbtIdent = "exam-users" - dbtCsvEncode :: DBTCsvEncode ExamUserTableData ExamUserTableCsv - dbtCsvEncode = DictJust . C.map $ ExamUserTableCsv - <$> view (resultUser . _entityVal . _userSurname) - <*> view (resultUser . _entityVal . _userDisplayName) - <*> view (resultUser . _entityVal . _userMatrikelnummer) - <*> preview (resultStudyField . _entityVal . to (\StudyTerms{..} -> studyTermsName <|> studyTermsShorthand <|> Just (tshow studyTermsKey)) . _Just) - <*> preview (resultStudyDegree . _entityVal . to (\StudyDegree{..} -> studyDegreeName <|> studyDegreeShorthand <|> Just (tshow studyDegreeKey)) . _Just) - <*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester) - <*> preview (resultExamOccurrence . _entityVal . _examOccurrenceName) - dbtCsvDecode = Nothing + ((), examUsersTable) <- runDB $ do + exam@(Entity eid Exam{..}) <- fetchExam tid ssh csh examn + bonus <- examBonus exam - examUsersDBTableValidator = def - ((), examUsersTable) <- runDB $ dbTable examUsersDBTableValidator examUsersDBTable + let + allBoni = (mappend <$> normalSummary <*> bonusSummary) $ fold bonus + showPasses = numSheetsPasses allBoni /= 0 + showPoints = getSum (numSheetsPoints allBoni) - getSum (numSheetsPassPoints allBoni) /= 0 + showPassPoints = numSheetsPassPoints allBoni /= 0 + + let + examUsersDBTable = DBTable{..} + where + dbtSQLQuery ((examRegistration `E.InnerJoin` user) `E.LeftOuterJoin` occurrence `E.LeftOuterJoin` (courseParticipant `E.LeftOuterJoin` (studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyField))) = do + E.on $ studyField E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField + E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree + E.on $ studyFeatures E.?. StudyFeaturesId E.==. E.joinV (courseParticipant E.?. CourseParticipantField) + E.on $ courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val examCourse) + E.&&. courseParticipant E.?. CourseParticipantUser E.==. E.just (user E.^. UserId) + E.on $ occurrence E.?. ExamOccurrenceExam E.==. E.just (E.val eid) + E.&&. occurrence E.?. ExamOccurrenceId E.==. examRegistration E.^. ExamRegistrationOccurrence + E.on $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId + E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eid + return (examRegistration, user, occurrence, studyFeatures, studyDegree, studyField) + dbtRowKey = queryExamRegistration >>> (E.^. ExamRegistrationId) + dbtProj = return + dbtColonnade = dbColonnade . mconcat $ catMaybes + [ pure $ colUserNameLink (CourseR tid ssh csh . CUserR) + , pure colUserMatriclenr + , pure $ colField resultStudyField + , pure $ colDegreeShort resultStudyDegree + , pure $ colFeaturesSemester resultStudyFeatures + , pure $ sortable (Just "occurrence") (i18nCell MsgExamOccurrence) $ maybe mempty (anchorCell' (\n -> CExamR tid ssh csh examn EShowR :#: [st|exam-occurrence__#{n}|]) id . examOccurrenceName . entityVal) . view _userTableOccurrence + , guardOn showPasses $ sortable Nothing (i18nCell MsgAchievedPasses) $ \(view $ resultUser . _entityKey -> uid) -> fromMaybe mempty $ do + SheetGradeSummary{achievedPasses} <- examBonusAchieved uid bonus + SheetGradeSummary{numSheetsPasses} <- examBonusPossible uid bonus + return $ propCell (getSum achievedPasses) (getSum numSheetsPasses) + , guardOn showPassPoints $ sortable Nothing (i18nCell MsgAchievedPassPoints) $ \(view $ resultUser . _entityKey -> uid) -> fromMaybe mempty $ do + SheetGradeSummary{achievedPassPoints} <- examBonusAchieved uid bonus + SheetGradeSummary{sumSheetsPassPoints} <- examBonusPossible uid bonus + return $ propCell (getSum achievedPassPoints) (getSum sumSheetsPassPoints) + , guardOn showPoints $ sortable Nothing (i18nCell MsgAchievedPoints) $ \(view $ resultUser . _entityKey -> uid) -> fromMaybe mempty $ do + SheetGradeSummary{achievedPoints, achievedPassPoints} <- examBonusAchieved uid bonus + SheetGradeSummary{sumSheetsPoints, sumSheetsPassPoints} <- examBonusPossible uid bonus + return $ propCell (getSum achievedPoints - getSum achievedPassPoints) (getSum sumSheetsPoints - getSum sumSheetsPassPoints) + ] + dbtSorting = Map.fromList + [ sortUserNameLink queryUser + , sortUserSurname queryUser + , sortUserDisplayName queryUser + , sortUserMatriclenr queryUser + , sortField queryStudyField + , sortDegreeShort queryStudyDegree + , sortFeaturesSemester queryStudyFeatures + , ("occurrence", SortColumn $ queryExamOccurrence >>> (E.?. ExamOccurrenceName)) + ] + dbtFilter = Map.fromList + [ fltrUserNameEmail queryUser + , fltrUserMatriclenr queryUser + , fltrField queryStudyField + , fltrDegree queryStudyDegree + , fltrFeaturesSemester queryStudyFeatures + ] + dbtFilterUI mPrev = mconcat + [ fltrUserNameEmailUI mPrev + , fltrUserMatriclenrUI mPrev + , fltrFieldUI mPrev + , fltrDegreeUI mPrev + , fltrFeaturesSemesterUI mPrev + ] + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } + dbtParams = def + dbtIdent :: Text + dbtIdent = "exam-users" + dbtCsvEncode :: DBTCsvEncode ExamUserTableData ExamUserTableCsv + dbtCsvEncode = DictJust . C.map $ ExamUserTableCsv + <$> view (resultUser . _entityVal . _userSurname) + <*> view (resultUser . _entityVal . _userDisplayName) + <*> view (resultUser . _entityVal . _userMatrikelnummer) + <*> preview (resultStudyField . _entityVal . to (\StudyTerms{..} -> studyTermsName <|> studyTermsShorthand <|> Just (tshow studyTermsKey)) . _Just) + <*> preview (resultStudyDegree . _entityVal . to (\StudyDegree{..} -> studyDegreeName <|> studyDegreeShorthand <|> Just (tshow studyDegreeKey)) . _Just) + <*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester) + <*> preview (resultExamOccurrence . _entityVal . _examOccurrenceName) + dbtCsvDecode = Nothing + + examUsersDBTableValidator = def + dbTable examUsersDBTableValidator examUsersDBTable siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamUsersHeading) $ do setTitleI $ prependCourseTitle tid ssh csh MsgExamUsersHeading diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs index 3d1d43845..f3cda795c 100644 --- a/src/Handler/Utils/Exam.hs +++ b/src/Handler/Utils/Exam.hs @@ -1,6 +1,7 @@ module Handler.Utils.Exam ( fetchExamAux , fetchExam, fetchExamId, fetchCourseIdExamId, fetchCourseIdExam + , examBonus, examBonusPossible, examBonusAchieved ) where import Import.NoFoundation @@ -12,6 +13,10 @@ import Database.Esqueleto.Utils.TH import Utils.Lens +import qualified Data.Conduit.List as C + +import qualified Data.Map as Map + fetchExamAux :: ( SqlBackendCanRead backend , E.SqlSelect b a @@ -45,3 +50,34 @@ fetchCourseIdExamId tid ssh cid examn = $(unValueN 2) <$> fetchExamAux (\tutoria fetchCourseIdExam :: MonadHandler m => TermId -> SchoolId -> CourseShorthand -> ExamName -> ReaderT SqlBackend m (Key Course, Entity Exam) fetchCourseIdExam tid ssh cid examn = over _1 E.unValue <$> fetchExamAux (\tutorial course -> (course E.^. CourseId, tutorial)) tid ssh cid examn + + +examBonus :: MonadHandler m => Entity Exam -> ReaderT SqlBackend m (Map UserId SheetTypeSummary) +examBonus (Entity eId Exam{..}) = runConduit $ + let + rawData = E.selectSource . E.from $ \((examRegistration `E.LeftOuterJoin` examOccurrence) `E.InnerJoin` (sheet `E.InnerJoin` submission)) -> E.distinctOnOrderBy [ E.asc $ examRegistration E.^. ExamRegistrationUser, E.asc $ sheet E.^. SheetId ] $ do + E.on $ submission E.?. SubmissionSheet E.==. E.just (sheet E.^. SheetId) + E.on $ E.exists (E.from $ \submissionUser -> E.where_ $ submissionUser E.^. SubmissionUserUser E.==. examRegistration E.^. ExamRegistrationUser + E.&&. E.just (submissionUser E.^. SubmissionUserSubmission) E.==. submission E.?. SubmissionId + ) + E.on $ examRegistration E.^. ExamRegistrationOccurrence E.==. examOccurrence E.?. ExamOccurrenceId + E.where_ $ sheet E.^. SheetCourse E.==. E.val examCourse + E.&&. examRegistration E.^. ExamRegistrationExam E.==. E.val eId + E.where_ $ E.case_ + [ E.when_ + ( E.not_ . E.isNothing $ examRegistration E.^. ExamRegistrationOccurrence ) + E.then_ + ( E.just (sheet E.^. SheetActiveTo) E.<=. examOccurrence E.?. ExamOccurrenceStart + E.&&. sheet E.^. SheetVisibleFrom E.<=. examOccurrence E.?. ExamOccurrenceStart + ) + ] + ( E.else_ . E.not_ . E.isNothing $ sheet E.^. SheetVisibleFrom + ) + return (examRegistration E.^. ExamRegistrationUser, sheet E.^. SheetType, submission) + accum = C.fold ?? Map.empty $ \acc (E.Value uid, E.Value sheetType, fmap entityVal -> sub) -> + Map.unionWith mappend acc . Map.singleton uid . sheetTypeSum sheetType . (>>= submissionRatingPoints) $ assertM submissionRatingDone sub + in rawData .| accum + +examBonusPossible, examBonusAchieved :: UserId -> Map UserId SheetTypeSummary -> Maybe SheetGradeSummary +examBonusPossible uid bonusMap = normalSummary <$> Map.lookup uid bonusMap +examBonusAchieved uid bonusMap = (mappend <$> normalSummary <*> bonusSummary) <$> Map.lookup uid bonusMap diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 8262140eb..948febc54 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -214,6 +214,9 @@ maybeDateTimeCell = maybe mempty dateTimeCell numCell :: (IsDBTable m a, Num b, ToMessage b) => b -> DBCell m a numCell = textCell . toMessage +propCell :: (IsDBTable m a, Real b, ToMessage b) => b -> b -> DBCell m a +propCell curr max' = i18nCell $ MsgProportion (toMessage curr) (toMessage max') (toRational curr / toRational max') + int64Cell :: (IsDBTable m a) => Int64-> DBCell m a int64Cell = numCell diff --git a/src/Model/Types/Sheet.hs b/src/Model/Types/Sheet.hs index b4a6b0a90..4a6c60a32 100644 --- a/src/Model/Types/Sheet.hs +++ b/src/Model/Types/Sheet.hs @@ -12,6 +12,7 @@ import Model.Types.Common import Utils.Lens.TH import Control.Lens +import Control.Lens.Extras (is) import Generics.Deriving.Monoid (memptydefault, mappenddefault) import Data.Set (Set) @@ -40,6 +41,7 @@ deriveJSON defaultOptions derivePersistFieldJSON ''SheetGrading makeLenses_ ''SheetGrading +makePrisms ''SheetGrading _passingBound :: Fold SheetGrading (Either () Points) _passingBound = folding passPts @@ -57,17 +59,22 @@ gradingPassed gr pts = either pBinary pPoints <$> gr ^? _passingBound data SheetGradeSummary = SheetGradeSummary { numSheets :: Count -- Total number of sheets, includes all - , numSheetsPasses :: Count -- Number of sheets required to pass FKA: numGradePasses - , numSheetsPoints :: Count -- Number of sheets having points FKA: sumGradePointsd + , numSheetsPasses :: Count -- Number of sheets admitting passing FKA: numGradePasses + , numSheetsPoints :: Count -- Number of sheets having points FKA: sumGradePointsd + , numSheetsPassPoints :: Count -- Number of sheets where passing is by points , sumSheetsPoints :: Sum Points -- Total of all points in all sheets + , sumSheetsPassPoints :: Sum Points -- Achieved points within marked sheets where passing is by points -- Marking dependend , numMarked :: Count -- Number of already marked sheets , numMarkedPasses :: Count -- Number of already marked sheets with passes , numMarkedPoints :: Count -- Number of already marked sheets with points + , numMarkedPassPoints :: Count -- Number of already marked sheets where passing is by points , sumMarkedPoints :: Sum Points -- Achieveable points within marked sheets + , sumMarkedPassPoints :: Sum Points -- Achieved points within marked sheets where passing is by points -- , achievedPasses :: Count -- Achieved passes (within marked sheets) , achievedPoints :: Sum Points -- Achieved points (within marked sheets) + , achievedPassPoints :: Sum Points -- Achieved points within marked sheets where passing is by points } deriving (Generic, Read, Show, Eq) instance Monoid SheetGradeSummary where @@ -82,19 +89,24 @@ makeLenses_ ''SheetGradeSummary sheetGradeSum :: SheetGrading -> Maybe Points -> SheetGradeSummary sheetGradeSum gr Nothing = mempty { numSheets = 1 - , numSheetsPasses = bool mempty 1 $ has _passingBound gr - , numSheetsPoints = bool mempty 1 $ has _maxPoints gr + , numSheetsPasses = bool mempty 1 $ has _passingBound gr + , numSheetsPoints = bool mempty 1 $ has _maxPoints gr + , numSheetsPassPoints = bool mempty 1 $ is _PassPoints gr , sumSheetsPoints = maybe mempty Sum $ gr ^? _maxPoints + , sumSheetsPassPoints = maybe mempty Sum . (<* guard (is _PassPoints gr)) $ gr ^? _maxPoints } sheetGradeSum gr (Just p) = let unmarked@SheetGradeSummary{..} = sheetGradeSum gr Nothing in unmarked - { numMarked = numSheets - , numMarkedPasses = numSheetsPasses - , numMarkedPoints = numSheetsPoints - , sumMarkedPoints = sumSheetsPoints + { numMarked = numSheets + , numMarkedPasses = numSheetsPasses + , numMarkedPoints = numSheetsPoints + , numMarkedPassPoints = numSheetsPassPoints + , sumMarkedPoints = sumSheetsPoints + , sumMarkedPassPoints = sumSheetsPassPoints , achievedPasses = maybe mempty (bool 0 1) (gradingPassed gr p) , achievedPoints = bool mempty (Sum p) $ has _maxPoints gr + , achievedPassPoints = bool mempty (Sum p) $ is _PassPoints gr } diff --git a/src/Utils.hs b/src/Utils.hs index 96dd4535e..06639a3c1 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -262,6 +262,9 @@ rationalToFixed = MkFixed . round . (* (fromIntegral $ resolution (Proxy :: HasR rationalToFixed3 :: Rational -> Fixed E3 rationalToFixed3 = rationalToFixed + +rationalToFixed2 :: Rational -> Fixed E2 +rationalToFixed2 = rationalToFixed -- | Convert `part` and `whole` into percentage including symbol -- showing trailing zeroes and to decimal digits @@ -693,6 +696,9 @@ assertM_ f x = guard . f =<< x assertM' :: Alternative m => (a -> Bool) -> a -> m a assertM' f x = x <$ guard (f x) +guardOn :: Alternative m => Bool -> a -> m a +guardOn b x = x <$ guard b + -- Some Utility Functions from Agda.Utils.Monad -- | Monadic if-then-else. ifM :: Monad m => m Bool -> m a -> m a -> m a From cf040ce6863488f4708c1c2059f783413b1183d1 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 16 Jul 2019 10:29:39 +0200 Subject: [PATCH 3/4] feat(exams): filter on occurrence --- src/Handler/Exam.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Handler/Exam.hs b/src/Handler/Exam.hs index 230bb405c..b9ebc0893 100644 --- a/src/Handler/Exam.hs +++ b/src/Handler/Exam.hs @@ -893,6 +893,7 @@ postEUsersR tid ssh csh examn = do , fltrField queryStudyField , fltrDegree queryStudyDegree , fltrFeaturesSemester queryStudyFeatures + , ("occurrence", FilterColumn . E.mkContainsFilterWith Just $ queryExamOccurrence >>> (E.?. ExamOccurrenceName)) ] dbtFilterUI mPrev = mconcat [ fltrUserNameEmailUI mPrev @@ -900,6 +901,7 @@ postEUsersR tid ssh csh examn = do , fltrFieldUI mPrev , fltrDegreeUI mPrev , fltrFeaturesSemesterUI mPrev + , prismAForm (singletonFilter "occurrence") mPrev $ aopt textField (fslI MsgExamOccurrence) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtParams = def From 2218103cbd6a021fd24629f9215c71dd115f08e4 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 16 Jul 2019 11:45:21 +0200 Subject: [PATCH 4/4] feat(exams): csv-export exercise data --- src/Data/Fixed/Instances.hs | 15 ++++++++++++++- src/Handler/Exam.hs | 32 ++++++++++++++++++++++---------- 2 files changed, 36 insertions(+), 11 deletions(-) diff --git a/src/Data/Fixed/Instances.hs b/src/Data/Fixed/Instances.hs index 03afaeb0e..53696e9e6 100644 --- a/src/Data/Fixed/Instances.hs +++ b/src/Data/Fixed/Instances.hs @@ -9,5 +9,18 @@ import Data.Fixed import Text.Blaze (ToMarkup(..)) +import qualified Data.Csv as Csv + +import Data.Proxy (Proxy(..)) + +import Data.Scientific + + instance HasResolution a => ToMarkup (Fixed a) where - toMarkup = toMarkup . showFixed True \ No newline at end of file + toMarkup = toMarkup . showFixed True + + +instance HasResolution a => Csv.ToField (Fixed a) where + toField = Csv.toField . (realToFrac :: Fixed a -> Scientific) +instance HasResolution a => Csv.FromField (Fixed a) where + parseField = fmap (MkFixed . (round :: Scientific -> Integer) . (* fromInteger (resolution $ Proxy @a))) . Csv.parseField diff --git a/src/Handler/Exam.hs b/src/Handler/Exam.hs index b9ebc0893..4add0d9ba 100644 --- a/src/Handler/Exam.hs +++ b/src/Handler/Exam.hs @@ -34,6 +34,8 @@ import qualified Data.Csv as Csv import qualified Data.Conduit.List as C +import Numeric.Lens (integral) + getCExamListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCExamListR tid ssh csh = do @@ -806,18 +808,22 @@ resultExamOccurrence :: Traversal' ExamUserTableData (Entity ExamOccurrence) resultExamOccurrence = _dbrOutput . _3 . _Just data ExamUserTableCsv = ExamUserTableCsv - { csvUserSurname :: Text - , csvUserName :: Text - , csvUserMatriculation :: Maybe Text - , csvUserField :: Maybe Text - , csvUserDegree :: Maybe Text - , csvUserSemester :: Maybe Int - , csvUserOccurrence :: Maybe (CI Text) + { csvEUserSurname :: Maybe Text + , csvEUserName :: Maybe Text + , csvEUserMatriculation :: Maybe Text + , csvEUserField :: Maybe Text + , csvEUserDegree :: Maybe Text + , csvEUserSemester :: Maybe Int + , csvEUserOccurrence :: Maybe (CI Text) + , csvEUserExercisePoints, csvEUserExercisePassPoints :: Maybe Points + , csvEUserExercisePasses :: Maybe Int + , csvEUserExercisePointsMax, csvEUserExercisePassPointsMax :: Maybe Points + , csvEUserExercisePassesMax :: Maybe Int } deriving (Generic) examUserTableCsvOptions :: Csv.Options -examUserTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 1 } +examUserTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 3 } instance ToNamedRecord ExamUserTableCsv where toNamedRecord = Csv.genericToNamedRecord examUserTableCsvOptions @@ -909,13 +915,19 @@ postEUsersR tid ssh csh examn = do dbtIdent = "exam-users" dbtCsvEncode :: DBTCsvEncode ExamUserTableData ExamUserTableCsv dbtCsvEncode = DictJust . C.map $ ExamUserTableCsv - <$> view (resultUser . _entityVal . _userSurname) - <*> view (resultUser . _entityVal . _userDisplayName) + <$> view (resultUser . _entityVal . _userSurname . to Just) + <*> view (resultUser . _entityVal . _userDisplayName . to Just) <*> view (resultUser . _entityVal . _userMatrikelnummer) <*> preview (resultStudyField . _entityVal . to (\StudyTerms{..} -> studyTermsName <|> studyTermsShorthand <|> Just (tshow studyTermsKey)) . _Just) <*> preview (resultStudyDegree . _entityVal . to (\StudyDegree{..} -> studyDegreeName <|> studyDegreeShorthand <|> Just (tshow studyDegreeKey)) . _Just) <*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester) <*> preview (resultExamOccurrence . _entityVal . _examOccurrenceName) + <*> preview (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPoints . _Wrapped) + <*> preview (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPassPoints . _Wrapped) + <*> preview (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPasses . _Wrapped . integral) + <*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _sumSheetsPoints . _Wrapped) + <*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _sumSheetsPassPoints . _Wrapped) + <*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _numSheetsPasses . _Wrapped . integral) dbtCsvDecode = Nothing examUsersDBTableValidator = def