From 651f0bc4d47477f5f60ed1f91b038cfe6c74cf92 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 11 Sep 2019 12:13:36 +0200 Subject: [PATCH] feat(exam-office): exams list --- messages/uniworx/de.msg | 2 + src/Handler/Corrections.hs | 4 - src/Handler/ExamOffice/Exams.hs | 178 ++++++++++++++++++++++++++++- src/Handler/Utils/Table/Columns.hs | 37 ++++++ src/Handler/Utils/Widgets.hs | 4 + src/Utils/Lens.hs | 3 +- 6 files changed, 222 insertions(+), 6 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 075848b85..88c0a59c1 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -1400,6 +1400,8 @@ VersionHistory: Versionsgeschichte KnownBugs: Bekannte Bugs ImplementationDetails: Implementierung +ExamSynchronised: Synchronisiert + ExamUsersHeading: Prüfungsteilnehmer ExamUserDeregister: Teilnehmer von Prüfung abmelden ExamUserAssignOccurrence: Termin/Raum zuweisen diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index d2049c7ca..2074fd3b4 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -1265,10 +1265,6 @@ assignHandler tid ssh csh cid assignSids = do showAvgsDays :: Maybe NominalDiffTime -> Integer -> Text showAvgsDays Nothing _ = mempty showAvgsDays (Just dt) n = formatDiffDays $ dt / fromIntegral n - heat :: Integer -> Integer -> Double - heat = heat' 0.3 - heat' :: Double -> Integer -> Integer -> Double - heat' cut full achieved = roundToDigits 3 $ cutOffPercent cut (fromIntegral full^2) (fromIntegral achieved^2) let headingShort | 0 < Map.size assignment = MsgMenuCorrectionsAssignSheet $ Text.intercalate ", " $ fmap CI.original $ Map.keys assignment | otherwise = MsgMenuCorrectionsAssign diff --git a/src/Handler/ExamOffice/Exams.hs b/src/Handler/ExamOffice/Exams.hs index dfeae9214..69ce6d6f3 100644 --- a/src/Handler/ExamOffice/Exams.hs +++ b/src/Handler/ExamOffice/Exams.hs @@ -4,7 +4,183 @@ module Handler.ExamOffice.Exams import Import +import Handler.Utils +import Handler.Utils.ExamOffice.Exam.Auth +import qualified Handler.Utils.ExamOffice.Exam as Exam + +import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E + +import qualified Colonnade + + +type ExamsTableExpr = E.SqlExpr (Entity Exam) + `E.InnerJoin` E.SqlExpr (Entity Course) + +type ExamsTableData = DBRow ( Entity Exam + , Entity Course + , Natural, Natural + ) + +queryExam :: Getter ExamsTableExpr (E.SqlExpr (Entity Exam)) +queryExam = to $(E.sqlIJproj 2 1) + +queryCourse :: Getter ExamsTableExpr (E.SqlExpr (Entity Course)) +queryCourse = to $(E.sqlIJproj 2 2) + +querySynchronised :: E.SqlExpr (E.Value UserId) -> Getter ExamsTableExpr (E.SqlExpr (E.Value Natural)) +querySynchronised office = to . runReader $ do + exam <- view queryExam + let + synchronised = E.sub_select . E.from $ \examResult -> do + E.where_ $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId + E.where_ $ examOfficeExamResultAuth office examResult + E.where_ $ Exam.resultIsSynced office examResult + return E.countRows + return synchronised + +queryResults :: E.SqlExpr (E.Value UserId) -> Getter ExamsTableExpr (E.SqlExpr (E.Value Natural)) +queryResults office = to . runReader $ do + exam <- view queryExam + let + results = E.sub_select . E.from $ \examResult -> do + E.where_ $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId + E.where_ $ examOfficeExamResultAuth office examResult + return E.countRows + return results + +queryIsSynced :: E.SqlExpr (E.Value UserId) -> Getter ExamsTableExpr (E.SqlExpr (E.Value Bool)) +queryIsSynced office = to . runReader $ do + exam <- view queryExam + let + synchronised = E.not_ . E.exists . E.from $ \examResult -> do + E.where_ $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId + E.where_ $ examOfficeExamResultAuth office examResult + E.where_ . E.not_ $ Exam.resultIsSynced office examResult + return synchronised + + +resultExam :: Lens' ExamsTableData (Entity Exam) +resultExam = _dbrOutput . _1 + +resultCourse :: Lens' ExamsTableData (Entity Course) +resultCourse = _dbrOutput . _2 + +resultSynchronised, resultResults :: Lens' ExamsTableData Natural +resultSynchronised = _dbrOutput . _3 +resultResults = _dbrOutput . _4 + +resultIsSynced :: Getter ExamsTableData Bool +resultIsSynced = to $ (>=) <$> view resultSynchronised <*> view resultResults + + -- | List of all exams where the current user may (in her function as -- exam-office) access users grades getEOExamsR :: Handler Html -getEOExamsR = fail "not implemented" +getEOExamsR = do + uid <- requireAuthId + + examsTable <- runDB $ do + let + examLink :: Course -> Exam -> SomeRoute UniWorX + examLink Course{..} Exam{..} + = SomeRoute $ CExamR courseTerm courseSchool courseShorthand examName EGradesR + + courseLink :: Course -> SomeRoute UniWorX + courseLink Course{..} + = SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR + + querySynchronised' = querySynchronised $ E.val uid + queryResults' = queryResults $ E.val uid + queryIsSynced' = queryIsSynced $ E.val uid + + examsDBTable = DBTable{..} + where + dbtSQLQuery = runReaderT $ do + exam <- view queryExam + course <- view queryCourse + + synchronised <- view querySynchronised' + results <- view queryResults' + + lift $ do + E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId + + E.where_ $ results E.>. E.val 0 + + return (exam, course, synchronised, results) + dbtRowKey = views queryExam (E.^. ExamId) + + dbtProj :: DBRow _ -> MaybeT (YesodDB UniWorX) ExamsTableData + dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $ do + exam <- view $ _1 . _entityVal + course <- view $ _2 . _entityVal + + guard =<< hasReadAccessTo (urlRoute $ examLink course exam) + + (,,,) + <$> view _1 <*> view _2 <*> view (_3 . _Value) <*> view (_4 . _Value) + + + colSynced = Colonnade.singleton (fromSortable . Sortable (Just "synced") $ i18nCell MsgExamSynchronised) $ \x -> flip runReader x $ do + synced <- view resultSynchronised + results <- view resultResults + isSynced <- view resultIsSynced + + return $ cell + [whamlet| + $newline never + $if isSynced + #{iconOK} + $else + #{synced}/#{results} + |] + & cellAttrs <>~ [ ("class", "heated") + , ("style", [st|--hotness: #{tshow (heat results synced)}|]) + ] + + + dbtColonnade :: Colonnade Sortable _ _ + dbtColonnade = mconcat + [ colSynced + , anchorColonnade (views ($(multifocusG 2) (resultCourse . _entityVal) (resultExam . _entityVal)) (uncurry examLink)) + $ colExamName (resultExam . _entityVal . _examName) + , colExamTime (resultExam . _entityVal . $(multifocusG 2) _examStart _examEnd) + , anchorColonnade (views (resultCourse . _entityVal) courseLink) + $ colCourseName (resultCourse . _entityVal . _courseName) + , colSchool (resultCourse . _entityVal . _courseSchool) + , colTermShort (resultCourse . _entityVal . _courseTerm) + ] + dbtSorting = mconcat + [ singletonMap "synced" . SortColumn $ (E./.) <$> view querySynchronised' <*> view queryResults' + , singletonMap "is-synced" . SortColumn $ view queryIsSynced' + , sortExamName (queryExam . to (E.^. ExamName)) + , sortExamTime (queryExam . $(multifocusG 2) (to (E.^. ExamStart)) (to (E.^. ExamEnd))) + , sortCourseName (queryCourse . to (E.^. CourseName)) + , sortSchool (queryCourse . to (E.^. CourseSchool)) + , sortTerm (queryCourse . to (E.^. CourseTerm)) + ] + + dbtFilter = mconcat + [ + ] + dbtFilterUI = mconcat + [ + ] + + dbtStyle = def -- { dbsFilterLayout = defaultDBSFilterLayout } + dbtParams = def + + dbtIdent :: Text + dbtIdent = "exams" + + dbtCsvEncode = noCsvEncode + dbtCsvDecode = Nothing + + examsDBTableValidator = def & defaultSorting [SortAscBy "is-synced", SortAscBy "exam-time"] + + dbTableWidget' examsDBTableValidator examsDBTable + + siteLayoutMsg MsgMenuExamList $ do + setTitleI MsgMenuExamList + examsTable diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index 0bbfaf1b1..38b656c39 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -19,6 +19,7 @@ import Handler.Utils.Table.Cells import Handler.Utils.Table.Pagination import Handler.Utils.Form import Handler.Utils.Widgets +import Handler.Utils.DateTime import qualified Data.CaseInsensitive as CI @@ -203,6 +204,29 @@ fltrAllocationActiveUI :: DBFilterUI fltrAllocationActiveUI mPrev = prismAForm (singletonFilter "active" . maybePrism _PathPiece) mPrev $ aopt boolField (fslI MsgAllocationActive) +----------- +-- Exams -- +----------- + +colExamName :: OpticColonnade ExamName +colExamName resultName = Colonnade.singleton (fromSortable header) body + where + header = Sortable (Just "exam-name") (i18nCell MsgExamName) + body = views resultName i18nCell + +sortExamName :: OpticSortColumn ExamName +sortExamName queryName = singletonMap "exam-name" . SortColumn $ view queryName + +colExamTime :: OpticColonnade (Maybe UTCTime, Maybe UTCTime) +colExamTime resultTimes = Colonnade.singleton (fromSortable header) body + where + header = Sortable (Just "exam-time") (i18nCell MsgExamTime) + body = views resultTimes $ \(eStart, eEnd) + -> maybe mempty (cell . flip (formatTimeRangeW SelFormatDateTime) eEnd) eStart + +sortExamTime :: OpticSortColumn' (E.SqlExpr (E.Value (Maybe UTCTime)), E.SqlExpr (E.Value (Maybe UTCTime))) +sortExamTime queryTimes = singletonMap "exam-time" . SortColumns . toListOf $ queryTimes . _1 . to SomeExprValue <> queryTimes . _2 . to SomeExprValue + --------------------- -- Exam occurences -- --------------------- @@ -253,6 +277,19 @@ fltrExamResultPointsUI showGrades mPrev = prismAForm (singletonFilter "exam-resu field | showGrades = examResultField examGradeField | otherwise = convertField (over _examResult $ review passingGrade) (over _examResult $ view passingGrade) $ examResultField examPassedField + +------------- +-- Courses -- +------------- + +colCourseName :: OpticColonnade CourseName +colCourseName resultName = Colonnade.singleton (fromSortable header) body + where + header = Sortable (Just "course-name") (i18nCell MsgCourse) + body = views resultName i18nCell + +sortCourseName :: OpticSortColumn CourseName +sortCourseName queryName = singletonMap "course-name" . SortColumn $ view queryName ------------------------- -- Course Applications -- diff --git a/src/Handler/Utils/Widgets.hs b/src/Handler/Utils/Widgets.hs index 7668e706b..01a2c6f01 100644 --- a/src/Handler/Utils/Widgets.hs +++ b/src/Handler/Utils/Widgets.hs @@ -92,3 +92,7 @@ editedByW :: SelDateTimeFormat -> UTCTime -> Text -> Widget editedByW fmt tm usr = do ft <- handlerToWidget $ formatTime fmt tm [whamlet|_{MsgEditedBy usr ft}|] + +heat :: Integral a => a -> a -> Double +heat (toInteger -> full) (toInteger -> achieved) + = roundToDigits 3 $ cutOffPercent 0.3 (fromIntegral full^2) (fromIntegral achieved^2) diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index ad4dc26b9..6e1fd70a3 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -170,6 +170,7 @@ makeLenses_ ''ExamResult makeLenses_ ''UTCTime +makeLenses_ ''Exam makeLenses_ ''ExamOccurrence makePrisms ''AuthenticationMode @@ -189,7 +190,7 @@ makeLenses_ ''School makeLenses_ ''SchoolLdap makeLenses_ ''UserFunction - + -- makeClassy_ ''Load