From 09261ac7578d8abdcaa39bbdcf12fc6ddad9ce22 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Thu, 25 Nov 2021 22:19:16 +0100 Subject: [PATCH 01/50] feat(eoexamsr): introduce GET param to control synced display --- src/Handler/ExamOffice/Exams.hs | 38 +++++++++++++++++++++------------ 1 file changed, 24 insertions(+), 14 deletions(-) diff --git a/src/Handler/ExamOffice/Exams.hs b/src/Handler/ExamOffice/Exams.hs index f98eac37f..cf10c2338 100644 --- a/src/Handler/ExamOffice/Exams.hs +++ b/src/Handler/ExamOffice/Exams.hs @@ -19,22 +19,22 @@ import qualified Data.Conduit.Combinators as C data ExamsTableFilterProj = ExamsTableFilterProj - { etProjFilterMayAccess :: Maybe Bool + { etProjFilterMayAccess :: Maybe Bool , etProjFilterHasResults :: Maybe Bool - , etProjFilterIsSynced :: Maybe Bool + , etProjFilterIsSynced :: Maybe Bool } instance Default ExamsTableFilterProj where def = ExamsTableFilterProj - { etProjFilterMayAccess = Nothing + { etProjFilterMayAccess = Nothing , etProjFilterHasResults = Nothing - , etProjFilterIsSynced = Nothing + , etProjFilterIsSynced = Nothing } makeLenses_ ''ExamsTableFilterProj -type ExamsTableExpr = ( E.SqlExpr (Maybe (Entity Exam)) +type ExamsTableExpr = ( E.SqlExpr (Maybe (Entity Exam )) `E.InnerJoin` E.SqlExpr (Maybe (Entity Course)) `E.InnerJoin` E.SqlExpr (Maybe (Entity School)) ) @@ -84,6 +84,12 @@ getEOExamsR = do uid <- requireAuthId now <- liftIO getCurrentTime + getSynced <- lookupGetParam "synced" >>= \case + Just "yes" -> return True + Just "no" -> return False + _ -> return True -- TODO: lookup user setting + -- TODO: lookup GET param and user setting for getLabels + examsTable <- runDB $ do let examLink :: Course -> Exam -> SomeRoute UniWorX @@ -203,7 +209,7 @@ getEOExamsR = do dbtColonnade :: Colonnade Sortable _ _ dbtColonnade = mconcat - [ colSynced + [ bool mempty colSynced getSynced , maybeAnchorColonnade ( runMaybeT $ mpreview ($(multifocusG 2) (pre $ resultCourse . _entityVal) (pre $ resultExam . _entityVal) . to (uncurry $ liftA2 examLink) . _Just) <|> mpreviews (resultExternalExam . _entityVal) externalExamLink ) @@ -216,12 +222,14 @@ getEOExamsR = do , emptyOpticColonnade (resultCourse . _entityVal . _courseSchool <> resultExternalExam . _entityVal . _externalExamSchool) colSchool , emptyOpticColonnade (resultCourse . _entityVal . _courseTerm <> resultExternalExam . _entityVal . _externalExamTerm) colTermShort ] - dbtSorting = mconcat + dbtSorting = mconcat $ + (bool mempty [ singletonMap "synced" $ SortProjected . comparing $ ((/) `on` toRational) <$> view resultSynchronised <*> view resultResults , singletonMap "is-synced" $ SortProjected . comparing $ (>=) <$> view resultSynchronised <*> view resultResults - , sortExamName (to $ E.unsafeCoalesce . sequence [views queryExam (E.?. ExamName), views queryExternalExam (E.?. ExternalExamExamName)]) + ] getSynced) <> + [ sortExamName (to $ E.unsafeCoalesce . sequence [views queryExam (E.?. ExamName), views queryExternalExam (E.?. ExternalExamExamName)]) , sortExamTime (queryExam . $(multifocusG 2) (to $ E.joinV . (E.?. ExamStart)) (to $ E.joinV . (E.?. ExamEnd))) , sortExamFinished (queryExam . to (E.joinV . (E.?. ExamFinished))) , sortExamClosed (queryExam . to (E.joinV . (E.?. ExamClosed))) @@ -230,14 +238,16 @@ getEOExamsR = do , sortTerm (to $ E.unsafeCoalesce . sequence [views queryCourse (E.?. CourseTerm), views queryExternalExam (E.?. ExternalExamTerm)]) ] - dbtFilter = mconcat + dbtFilter = mconcat $ [ singletonMap "may-access" . FilterProjected $ (_etProjFilterMayAccess ?~) . getAny , singletonMap "has-results" . FilterProjected $ (_etProjFilterHasResults ?~) . getAny - , singletonMap "is-synced" . FilterProjected $ (_etProjFilterIsSynced ?~) . getAny - ] - dbtFilterUI = mconcat + ] <> (bool mempty + [ singletonMap "is-synced" . FilterProjected $ (_etProjFilterIsSynced ?~) . getAny + ] getSynced) + dbtFilterUI = mconcat $ + (bool mempty [ flip (prismAForm $ singletonFilter "is-synced" . maybePrism _PathPiece) $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgExamSynchronised) - ] + ] getSynced) dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtParams = def @@ -251,7 +261,7 @@ getEOExamsR = do dbtExtraReps = [] examsDBTableValidator = def - & defaultSorting [SortAscBy "is-synced", SortAscBy "exam-time"] + & defaultSorting (bool mempty [SortAscBy "is-synced"] getSynced <> [SortAscBy "exam-time"]) & forceFilter "may-access" (Any True) & forceFilter "has-results" (Any True) From e702b2e14de85572fb2e35c6ee6f4743ff051fee Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Thu, 25 Nov 2021 23:09:16 +0100 Subject: [PATCH 02/50] chore(eoexamsr): suppress synced computation on synced=no --- src/Handler/ExamOffice/Exams.hs | 41 +++++++++++++++++++-------------- 1 file changed, 24 insertions(+), 17 deletions(-) diff --git a/src/Handler/ExamOffice/Exams.hs b/src/Handler/ExamOffice/Exams.hs index cf10c2338..e01555ad1 100644 --- a/src/Handler/ExamOffice/Exams.hs +++ b/src/Handler/ExamOffice/Exams.hs @@ -41,7 +41,7 @@ type ExamsTableExpr = ( E.SqlExpr (Maybe (Entity Exam )) `E.FullOuterJoin` E.SqlExpr (Maybe (Entity ExternalExam)) type ExamsTableData = DBRow ( Either (Entity ExternalExam) (Entity Exam, Entity Course, Entity School) - , Natural, Natural + , Maybe Natural, Maybe Natural ) queryExam :: Getter ExamsTableExpr (E.SqlExpr (Maybe (Entity Exam))) @@ -69,7 +69,7 @@ resultSchool = _dbrOutput . _1 . _Right . _3 resultExternalExam :: Traversal' ExamsTableData (Entity ExternalExam) resultExternalExam = _dbrOutput . _1 . _Left -resultSynchronised, resultResults :: Lens' ExamsTableData Natural +resultSynchronised, resultResults :: Lens' ExamsTableData (Maybe Natural) resultSynchronised = _dbrOutput . _2 resultResults = _dbrOutput . _3 @@ -162,24 +162,32 @@ getEOExamsR = do return $ ExternalExam.resultIsSynced (E.val uid) externalExamResult getResults = getExamResults >> getExternalExamResults foldResult (E.Value isSynced) = (Sum 1, guardMonoid isSynced $ Sum 1) - (Sum resultCount, Sum syncedCount) <- lift . lift . runConduit $ getResults .| C.foldMap foldResult - - forMM_ (view $ _dbtProjFilter . _etProjFilterHasResults) $ \b -> - guard $ b == (resultCount > 0) - forMM_ (view $ _dbtProjFilter . _etProjFilterIsSynced) $ \b -> - guard $ b == (syncedCount >= resultCount) + + mCounts <- if getSynced + then do + (Sum resCount, Sum synCount) <- lift . lift . runConduit $ getResults .| C.foldMap foldResult + forMM_ (view $ _dbtProjFilter . _etProjFilterHasResults) $ \b -> + guard $ b == (resCount > 0) + forMM_ (view $ _dbtProjFilter . _etProjFilterIsSynced) $ \b -> + guard $ b == (synCount >= resCount) + return $ Just (resCount, synCount) + else do + forMM_ (view $ _dbtProjFilter . _etProjFilterHasResults) guard + return Nothing case (exam, course, school, externalExam) of (Just exam', Just course', Just school', Nothing) -> return - (Right (exam', course', school'), syncedCount, resultCount) + (Right (exam', course', school'), snd <$> mCounts, fst <$> mCounts) (Nothing, Nothing, Nothing, Just externalExam') -> return - (Left externalExam', syncedCount, resultCount) + (Left externalExam', snd <$> mCounts, fst <$> mCounts) _other -> return $ error "Got exam & externalExam in same result" colSynced = Colonnade.singleton (fromSortable . Sortable (Just "synced") $ i18nCell MsgExamSynchronised) $ \x -> flip runReader x $ do - mExam <- preview resultExam - mSchool <- preview resultSchool + mExam <- preview resultExam + mSchool <- preview resultSchool + mSynced <- view resultSynchronised + mResults <- view resultResults if | Just (Entity _ Exam{examClosed, examFinished}) <- mExam @@ -188,12 +196,10 @@ getEOExamsR = do (NTop examClosed > NTop (Just now)) $ is _ExamCloseSeparate schoolExamCloseMode -> return . cell $ toWidget iconNew - | otherwise + | Just synced <- mSynced + , Just results <- mResults -> do - synced <- view resultSynchronised - results <- view resultResults isSynced <- view resultIsSynced - return $ cell [whamlet| $newline never @@ -205,6 +211,7 @@ getEOExamsR = do & cellAttrs <>~ [ ("class", "heated") , ("style", [st|--hotness: #{tshow (heat results synced)}|]) ] + | otherwise -> return $ cell mempty dbtColonnade :: Colonnade Sortable _ _ @@ -225,7 +232,7 @@ getEOExamsR = do dbtSorting = mconcat $ (bool mempty [ singletonMap "synced" $ - SortProjected . comparing $ ((/) `on` toRational) <$> view resultSynchronised <*> view resultResults + SortProjected . comparing $ ((/) `on` toRational . fromMaybe 0) <$> view resultSynchronised <*> view resultResults , singletonMap "is-synced" $ SortProjected . comparing $ (>=) <$> view resultSynchronised <*> view resultResults ] getSynced) <> From ef358baeabe1eb549d4707ad970424a4c4a54b58 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Fri, 26 Nov 2021 14:37:40 +0100 Subject: [PATCH 03/50] chore(user): introduce get-synced default for ExamOffice users --- models/users.model | 5 +++-- src/Handler/Utils/Users.hs | 1 + 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/models/users.model b/models/users.model index 707da5e2f..476451943 100644 --- a/models/users.model +++ b/models/users.model @@ -53,8 +53,9 @@ UserSystemFunction UniqueUserSystemFunction user function deriving Generic UserExamOffice - user UserId - field StudyTermsId + user UserId + field StudyTermsId + getSynced Bool default=true -- whether synced status should be displayed for exam results by default UniqueUserExamOffice user field deriving Generic UserSchool -- Managed by users themselves, encodes "schools of interest" diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index f851d4fc9..139485552 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -469,6 +469,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do return $ UserExamOffice E.<# E.val newUserId E.<&> (userExamOffice E.^. UserExamOfficeField) + E.<&> (userExamOffice E.^. UserExamOfficeGetSynced) ) (\_current _excluded -> []) deleteWhere [ UserExamOfficeUser ==. oldUserId ] From acc0ceaf404a34263d212111a82de4d63f499c88 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Mon, 29 Nov 2021 21:25:10 +0100 Subject: [PATCH 04/50] chore: move exam office settings to User --- config/settings.yml | 1 + models/users.model | 2 +- src/Foundation/Yesod/Auth.hs | 1 + src/Handler/Users/Add.hs | 1 + src/Handler/Utils/Users.hs | 1 - src/Settings.hs | 1 + test/Database/Fill.hs | 8 ++++++++ 7 files changed, 13 insertions(+), 2 deletions(-) diff --git a/config/settings.yml b/config/settings.yml index ff72cb3c0..eaaa6483b 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -232,6 +232,7 @@ user-defaults: download-files: false warning-days: 1209600 show-sex: false + exam-office-get-synced: true # During central allocations lecturer-given ratings of applications (as # ExamGrades) are combined with a central priority. diff --git a/models/users.model b/models/users.model index 476451943..80db0f66b 100644 --- a/models/users.model +++ b/models/users.model @@ -35,6 +35,7 @@ User json -- Each Uni2work user has a corresponding row in this table; create csvOptions CsvOptions "default='{}'::jsonb" sex Sex Maybe showSex Bool default=false + examOfficeGetSynced Bool default=true -- whether synced status should be displayed for exam results by default UniqueAuthentication ident -- Column 'ident' can be used as a row-key in this table UniqueEmail email -- Column 'email' can be used as a row-key in this table deriving Show Eq Ord Generic -- Haskell-specific settings for runtime-value representing a row in memory @@ -55,7 +56,6 @@ UserSystemFunction UserExamOffice user UserId field StudyTermsId - getSynced Bool default=true -- whether synced status should be displayed for exam results by default UniqueUserExamOffice user field deriving Generic UserSchool -- Managed by users themselves, encodes "schools of interest" diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index 29c77c654..cf2d01e53 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -257,6 +257,7 @@ upsertCampusUser upsertMode ldapData = do , userDownloadFiles = userDefaultDownloadFiles , userWarningDays = userDefaultWarningDays , userShowSex = userDefaultShowSex + , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced , userNotificationSettings = def , userLanguages = Nothing , userCsvOptions = def diff --git a/src/Handler/Users/Add.hs b/src/Handler/Users/Add.hs index 01196e7ec..339f7164c 100644 --- a/src/Handler/Users/Add.hs +++ b/src/Handler/Users/Add.hs @@ -75,6 +75,7 @@ postAdminUserAddR = do , userDownloadFiles = userDefaultDownloadFiles , userWarningDays = userDefaultWarningDays , userShowSex = userDefaultShowSex + , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced , userNotificationSettings = def , userLanguages = Nothing , userCsvOptions = def diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index 139485552..f851d4fc9 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -469,7 +469,6 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do return $ UserExamOffice E.<# E.val newUserId E.<&> (userExamOffice E.^. UserExamOfficeField) - E.<&> (userExamOffice E.^. UserExamOfficeGetSynced) ) (\_current _excluded -> []) deleteWhere [ UserExamOfficeUser ==. oldUserId ] diff --git a/src/Settings.hs b/src/Settings.hs index c9ab18286..bb64d4979 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -255,6 +255,7 @@ data UserDefaultConf = UserDefaultConf , userDefaultDownloadFiles :: Bool , userDefaultWarningDays :: NominalDiffTime , userDefaultShowSex :: Bool + , userDefaultExamOfficeGetSynced :: Bool } deriving (Show) data PWHashConf = PWHashConf diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index b57095456..94f5d208e 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -150,6 +150,7 @@ fillDb = do , userCsvOptions = def { csvFormat = csvPreset # CsvPresetRFC } , userSex = Just SexMale , userShowSex = userDefaultShowSex + , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced } fhamann <- insert User { userIdent = "felix.hamann@campus.lmu.de" @@ -179,6 +180,7 @@ fillDb = do , userCsvOptions = def { csvFormat = csvPreset # CsvPresetExcel } , userSex = Just SexMale , userShowSex = userDefaultShowSex + , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced } jost <- insert User { userIdent = "jost@tcs.ifi.lmu.de" @@ -208,6 +210,7 @@ fillDb = do , userSex = Just SexMale , userCsvOptions = def , userShowSex = userDefaultShowSex + , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced } maxMuster <- insert User { userIdent = "max@campus.lmu.de" @@ -237,6 +240,7 @@ fillDb = do , userCsvOptions = def , userSex = Just SexMale , userShowSex = userDefaultShowSex + , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced } tinaTester <- insert $ User { userIdent = "tester@campus.lmu.de" @@ -266,6 +270,7 @@ fillDb = do , userCsvOptions = def , userSex = Just SexNotApplicable , userShowSex = userDefaultShowSex + , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced } svaupel <- insert User { userIdent = "vaupel.sarah@campus.lmu.de" @@ -295,6 +300,7 @@ fillDb = do , userCsvOptions = def , userSex = Just SexFemale , userShowSex = userDefaultShowSex + , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced } sbarth <- insert User { userIdent = "Stephan.Barth@campus.lmu.de" @@ -324,6 +330,7 @@ fillDb = do , userCsvOptions = def , userSex = Just SexMale , userShowSex = userDefaultShowSex + , userExamOfficeGetSynced = False } let @@ -383,6 +390,7 @@ fillDb = do , userCsvOptions = def , userSex = Nothing , userShowSex = userDefaultShowSex + , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced } where userIdent :: IsString t => t From 6788f923ed10759a4d5235c119b94e4c2a35a8b4 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Tue, 30 Nov 2021 00:04:49 +0100 Subject: [PATCH 05/50] feat(user): introduce exam office user settings --- .../courses/exam/exam_office/de-de-formal.msg | 3 +++ .../courses/exam/exam_office/en-eu.msg | 3 +++ .../uniworx/categories/settings/de-de-formal.msg | 2 ++ messages/uniworx/categories/settings/en-eu.msg | 4 +++- src/Handler/Profile.hs | 16 ++++++++++++++++ src/Handler/Utils/Profile.hs | 7 +++++++ 6 files changed, 34 insertions(+), 1 deletion(-) diff --git a/messages/uniworx/categories/courses/exam/exam_office/de-de-formal.msg b/messages/uniworx/categories/courses/exam/exam_office/de-de-formal.msg index ee5a84a00..39d033ade 100644 --- a/messages/uniworx/categories/courses/exam/exam_office/de-de-formal.msg +++ b/messages/uniworx/categories/courses/exam/exam_office/de-de-formal.msg @@ -55,3 +55,6 @@ ExamOfficeFieldSubscribed: Abboniert UtilExamClosed: Noten gemeldet ExamFinishedOffice: Noten bekannt gegeben ExamOfficeFieldForced: Forcierte Einsicht + +ExamOfficeGetSynced: Synchronisiert-Status in Prüfungsliste anzeigen +ExamOfficeGetSyncedTip: Soll unter „Prüfungen“ der Synchronisiert-Status zu jeder Prüfung angezeigt werden? (Ein Deaktivieren dieser Option kann zu kürzeren Ladezeiten der Prüfungsliste führen.) diff --git a/messages/uniworx/categories/courses/exam/exam_office/en-eu.msg b/messages/uniworx/categories/courses/exam/exam_office/en-eu.msg index 99ccc888c..b8cd4743e 100644 --- a/messages/uniworx/categories/courses/exam/exam_office/en-eu.msg +++ b/messages/uniworx/categories/courses/exam/exam_office/en-eu.msg @@ -53,3 +53,6 @@ ExamOfficeFieldSubscribed: subscribed UtilExamClosed: Exam achievements registered ExamFinishedOffice: Exam achievements published ExamOfficeFieldForced: Forced access + +ExamOfficeGetSynced: Show synchronised status in exam list +ExamOfficeGetSyncedTip: Should the synchronised status be displayed in “Exams”? (Disabling this option may lead to shorter loading times of the exam list.) diff --git a/messages/uniworx/categories/settings/de-de-formal.msg b/messages/uniworx/categories/settings/de-de-formal.msg index 1c92b705e..9f45045b0 100644 --- a/messages/uniworx/categories/settings/de-de-formal.msg +++ b/messages/uniworx/categories/settings/de-de-formal.msg @@ -112,3 +112,5 @@ AllocNotifyNewCourseDefault: Systemweite Einstellung AllocNotifyNewCourseForceOff: Nein AllocNotifyNewCourseForceOn: Ja Settings: Individuelle Benutzereinstellungen + +FormExamOffice: Prüfungsverwaltung diff --git a/messages/uniworx/categories/settings/en-eu.msg b/messages/uniworx/categories/settings/en-eu.msg index fe8374754..d94b9b7cc 100644 --- a/messages/uniworx/categories/settings/en-eu.msg +++ b/messages/uniworx/categories/settings/en-eu.msg @@ -112,4 +112,6 @@ LanguageChanged: Language changed successfully AllocNotifyNewCourseDefault: System-wide setting AllocNotifyNewCourseForceOff: No AllocNotifyNewCourseForceOn: Yes -Settings: Settings \ No newline at end of file +Settings: Settings + +FormExamOffice: Exam Office \ No newline at end of file diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 9b7dc1ee0..4a9e12dea 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -43,6 +43,7 @@ data SettingsForm = SettingsForm , stgDownloadFiles :: Bool , stgWarningDays :: NominalDiffTime , stgShowSex :: Bool + , stgExamOfficeSettings :: ExamOfficeSettings , stgSchools :: Set SchoolId , stgNotificationSettings :: NotificationSettings , stgAllocationNotificationSettings :: Map AllocationId (Maybe Bool) @@ -115,6 +116,7 @@ makeSettingForm template html = do & setTooltip MsgWarningDaysTip ) (stgWarningDays <$> template) <*> apopt checkBoxField (fslI MsgShowSex & setTooltip MsgShowSexTip) (stgShowSex <$> template) + <*> examOfficeForm (stgExamOfficeSettings <$> template) <* aformSection MsgFormNotifications <*> schoolsForm (stgSchools <$> template) <*> notificationForm (stgNotificationSettings <$> template) @@ -310,6 +312,16 @@ allocationNotificationForm = maybe (pure mempty) allocationNotificationForm' . ( fmap (review _AllocNotify) <$> wpopt (radioGroupField Nothing optionsFinite) (fsl allocDesc & addName [st|alloc-notify__#{toPathPiece cID}|]) (Just $ mPrev ^. _AllocNotify) where funcForm' forms = funcForm forms (fslI MsgFormAllocationNotifications & setTooltip MsgFormAllocationNotificationsTip) False +examOfficeForm :: Maybe ExamOfficeSettings -> AForm Handler ExamOfficeSettings +examOfficeForm template = wFormToAForm $ do + (_uid, User{userExamOfficeGetSynced}) <- requireAuthPair + userIsExamOffice <- liftHandler . hasReadAccessTo $ ExamOfficeR EOExamsR + if userIsExamOffice + then aFormToWForm . fmap ExamOfficeSettings $ + aformSection MsgFormExamOffice + *> apopt checkBoxField (fslI MsgExamOfficeGetSynced & setTooltip MsgExamOfficeGetSyncedTip) (eosettingsGetSynced <$> template) + else return . pure . fromMaybe (ExamOfficeSettings userExamOfficeGetSynced) $ template + validateSettings :: User -> FormValidator SettingsForm Handler () validateSettings User{..} = do @@ -363,6 +375,9 @@ postProfileR = do , stgNotificationSettings = userNotificationSettings , stgWarningDays = userWarningDays , stgShowSex = userShowSex + , stgExamOfficeSettings = ExamOfficeSettings + { eosettingsGetSynced = userExamOfficeGetSynced + } , stgAllocationNotificationSettings = allocs } ((res,formWidget), formEnctype) <- runFormPost . validateForm (validateSettings user) . identifyForm ProfileSettings $ makeSettingForm settingsTemplate @@ -381,6 +396,7 @@ postProfileR = do , UserWarningDays =. stgWarningDays , UserNotificationSettings =. stgNotificationSettings , UserShowSex =. stgShowSex + , UserExamOfficeGetSynced =. (stgExamOfficeSettings & eosettingsGetSynced) ] ++ [ UserDisplayEmail =. stgDisplayEmail | userDisplayEmail == stgDisplayEmail ] setAllocationNotifications uid stgAllocationNotificationSettings updateFavourites Nothing diff --git a/src/Handler/Utils/Profile.hs b/src/Handler/Utils/Profile.hs index ca272d6b8..95fe228cb 100644 --- a/src/Handler/Utils/Profile.hs +++ b/src/Handler/Utils/Profile.hs @@ -1,5 +1,6 @@ module Handler.Utils.Profile ( validDisplayName + , ExamOfficeSettings(..) ) where import Import.NoFoundation @@ -33,3 +34,9 @@ validDisplayName (fmap Text.strip -> mTitle) (Text.strip -> fName) (Text.strip - sNameLetters = Set.fromList $ unpack sName dNameLetters = Set.fromList $ unpack dName addLetters = Set.fromList [' '] + + +newtype ExamOfficeSettings + = ExamOfficeSettings + { eosettingsGetSynced :: Bool + } From e60d125e05bcf152b57fa132b4957405c40ae03f Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Tue, 30 Nov 2021 01:07:09 +0100 Subject: [PATCH 06/50] feat(eoexamsr): use user get-synced setting if no param present --- src/Handler/ExamOffice/Exams.hs | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/src/Handler/ExamOffice/Exams.hs b/src/Handler/ExamOffice/Exams.hs index e01555ad1..c6d72d734 100644 --- a/src/Handler/ExamOffice/Exams.hs +++ b/src/Handler/ExamOffice/Exams.hs @@ -81,13 +81,14 @@ resultIsSynced = to $ (>=) <$> view resultSynchronised <*> view resultResults -- exam-office) access users grades getEOExamsR :: Handler Html getEOExamsR = do - uid <- requireAuthId + (uid, User{..}) <- requireAuthPair now <- liftIO getCurrentTime - getSynced <- lookupGetParam "synced" >>= \case - Just "yes" -> return True - Just "no" -> return False - _ -> return True -- TODO: lookup user setting + getSynced <- lookupGetParam "synced" >>= return . \case + Just "yes" -> True + Just "no" -> False + _ -> userExamOfficeGetSynced + -- TODO: lookup GET param and user setting for getLabels examsTable <- runDB $ do @@ -264,7 +265,7 @@ getEOExamsR = do dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing - + dbtExtraReps = [] examsDBTableValidator = def From 280de8686549eb29d9c55969447b94052873cb1a Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Tue, 30 Nov 2021 20:02:49 +0100 Subject: [PATCH 07/50] style: add inactive message style --- frontend/src/app.sass | 8 ++++++++ messages/uniworx/utils/utils/de-de-formal.msg | 1 + messages/uniworx/utils/utils/en-eu.msg | 1 + src/Utils/Frontend/Notification.hs | 9 +++++---- src/Utils/Icon.hs | 2 ++ src/Utils/Message.hs | 4 ++-- 6 files changed, 19 insertions(+), 6 deletions(-) diff --git a/frontend/src/app.sass b/frontend/src/app.sass index 8665aad07..fe1160511 100644 --- a/frontend/src/app.sass +++ b/frontend/src/app.sass @@ -10,6 +10,8 @@ --color-success-dark: #1ca64c --color-info: #c4c4c4 --color-info-dark: #919191 + --color-nonactive: #efefef + --color-nonactive-dark: #9a989e --color-lightblack: #1A2A36 --color-lightwhite: #fcfffa --color-grey: #B1B5C0 @@ -740,6 +742,9 @@ section .notification-success color: var(--color-success-dark) +.notification-nonactive + color: var(--color-nonactive) + // "Heated" element. // Set custom property "--hotness" to a value from 0 to 1 to turn // the element's background to a color on a gradient from green to red. @@ -1476,6 +1481,9 @@ a.breadcrumbs__home &--success border-left-color: var(--color-success) + + &--disabled + border-left-color: var(--color-nonactive) .active-allocations__wrapper diff --git a/messages/uniworx/utils/utils/de-de-formal.msg b/messages/uniworx/utils/utils/de-de-formal.msg index 1464f36ae..06cc8c861 100644 --- a/messages/uniworx/utils/utils/de-de-formal.msg +++ b/messages/uniworx/utils/utils/de-de-formal.msg @@ -133,6 +133,7 @@ MessageError: Fehler MessageWarning: Warnung MessageInfo !ident-ok: Information MessageSuccess: Erfolg +MessageNonactive: Inaktiv ShortFieldPrimary: HF ShortFieldSecondary: NF SheetGradingPassPoints': Bestehen nach Punkten diff --git a/messages/uniworx/utils/utils/en-eu.msg b/messages/uniworx/utils/utils/en-eu.msg index 1539fdf4c..41938f486 100644 --- a/messages/uniworx/utils/utils/en-eu.msg +++ b/messages/uniworx/utils/utils/en-eu.msg @@ -133,6 +133,7 @@ MessageError: Error MessageWarning: Warning MessageInfo: Information MessageSuccess: Success +MessageNonactive: Inactive ShortFieldPrimary: Mj ShortFieldSecondary: Mn SheetGradingPassPoints': Passing by points diff --git a/src/Utils/Frontend/Notification.hs b/src/Utils/Frontend/Notification.hs index d4ec0758a..395bbf144 100644 --- a/src/Utils/Frontend/Notification.hs +++ b/src/Utils/Frontend/Notification.hs @@ -30,10 +30,11 @@ notification nType Message{ messageIcon = messageIcon', .. } where messageIcon = fromMaybe defaultIcon messageIcon' defaultIcon = case messageStatus of - Success -> IconNotificationSuccess - Info -> IconNotificationInfo - Warning -> IconNotificationWarning - Error -> IconNotificationError + Success -> IconNotificationSuccess + Info -> IconNotificationInfo + Warning -> IconNotificationWarning + Error -> IconNotificationError + Nonactive -> IconNotificationNonactive notificationWidget :: Yesod site => NotificationType diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index d220f9f7f..f9fdc4234 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -72,6 +72,7 @@ data Icon | IconNotificationInfo | IconNotificationWarning | IconNotificationError + | IconNotificationNonactive | IconFavourite | IconLanguage | IconNavContainerClose | IconPageActionChildrenClose @@ -150,6 +151,7 @@ iconText = \case IconNotificationInfo -> "info-circle" IconNotificationWarning -> "exclamation-circle" IconNotificationError -> "exclamation-triangle" + IconNotificationNonactive -> "info" IconFavourite -> "star" IconLanguage -> "flag-alt" IconNavContainerClose -> "chevron-up" diff --git a/src/Utils/Message.hs b/src/Utils/Message.hs index 27ccafe41..61bce17c7 100644 --- a/src/Utils/Message.hs +++ b/src/Utils/Message.hs @@ -29,7 +29,7 @@ import Text.Blaze.Html.Renderer.Text (renderHtml) import Text.HTML.SanitizeXSS (sanitizeBalance) -data MessageStatus = Error | Warning | Info | Success +data MessageStatus = Error | Warning | Info | Success | Nonactive deriving (Eq, Ord, Enum, Bounded, Show, Read, Lift, Generic, Typeable) deriving anyclass (Universe, Finite, NFData) @@ -219,7 +219,7 @@ messageTooltip Message{..} = let urgency = statusToUrgencyClass messageStatus Utils.Message.Error -> IconProblem Utils.Message.Warning -> IconWarning Utils.Message.Success -> IconOK - Utils.Message.Info -> IconTooltipDefault) + _ -> IconTooltipDefault) messageIcon tooltip = toWidget messageContent :: WidgetFor site () isInlineTooltip = False From 6a10bd78f55068eca71a0c190dcee5b066430b93 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Tue, 30 Nov 2021 21:21:33 +0100 Subject: [PATCH 08/50] feat(user): add get-labels user setting --- config/settings.yml | 1 + models/users.model | 1 + src/Foundation/Yesod/Auth.hs | 1 + src/Handler/Users/Add.hs | 1 + src/Settings.hs | 1 + test/Database/Fill.hs | 8 ++++++++ 6 files changed, 13 insertions(+) diff --git a/config/settings.yml b/config/settings.yml index eaaa6483b..e7153913a 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -233,6 +233,7 @@ user-defaults: warning-days: 1209600 show-sex: false exam-office-get-synced: true + exam-office-get-labels: true # During central allocations lecturer-given ratings of applications (as # ExamGrades) are combined with a central priority. diff --git a/models/users.model b/models/users.model index 80db0f66b..80846e952 100644 --- a/models/users.model +++ b/models/users.model @@ -36,6 +36,7 @@ User json -- Each Uni2work user has a corresponding row in this table; create sex Sex Maybe showSex Bool default=false examOfficeGetSynced Bool default=true -- whether synced status should be displayed for exam results by default + examOfficeGetLabels Bool default=true -- whether labels should be displayed for exam results by default UniqueAuthentication ident -- Column 'ident' can be used as a row-key in this table UniqueEmail email -- Column 'email' can be used as a row-key in this table deriving Show Eq Ord Generic -- Haskell-specific settings for runtime-value representing a row in memory diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index cf2d01e53..17042dbb6 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -258,6 +258,7 @@ upsertCampusUser upsertMode ldapData = do , userWarningDays = userDefaultWarningDays , userShowSex = userDefaultShowSex , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced + , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels , userNotificationSettings = def , userLanguages = Nothing , userCsvOptions = def diff --git a/src/Handler/Users/Add.hs b/src/Handler/Users/Add.hs index 339f7164c..aa64839cf 100644 --- a/src/Handler/Users/Add.hs +++ b/src/Handler/Users/Add.hs @@ -76,6 +76,7 @@ postAdminUserAddR = do , userWarningDays = userDefaultWarningDays , userShowSex = userDefaultShowSex , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced + , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels , userNotificationSettings = def , userLanguages = Nothing , userCsvOptions = def diff --git a/src/Settings.hs b/src/Settings.hs index bb64d4979..3e904da07 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -256,6 +256,7 @@ data UserDefaultConf = UserDefaultConf , userDefaultWarningDays :: NominalDiffTime , userDefaultShowSex :: Bool , userDefaultExamOfficeGetSynced :: Bool + , userDefaultExamOfficeGetLabels :: Bool } deriving (Show) data PWHashConf = PWHashConf diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 94f5d208e..1a3bd069c 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -151,6 +151,7 @@ fillDb = do , userSex = Just SexMale , userShowSex = userDefaultShowSex , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced + , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels } fhamann <- insert User { userIdent = "felix.hamann@campus.lmu.de" @@ -181,6 +182,7 @@ fillDb = do , userSex = Just SexMale , userShowSex = userDefaultShowSex , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced + , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels } jost <- insert User { userIdent = "jost@tcs.ifi.lmu.de" @@ -211,6 +213,7 @@ fillDb = do , userCsvOptions = def , userShowSex = userDefaultShowSex , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced + , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels } maxMuster <- insert User { userIdent = "max@campus.lmu.de" @@ -241,6 +244,7 @@ fillDb = do , userSex = Just SexMale , userShowSex = userDefaultShowSex , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced + , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels } tinaTester <- insert $ User { userIdent = "tester@campus.lmu.de" @@ -271,6 +275,7 @@ fillDb = do , userSex = Just SexNotApplicable , userShowSex = userDefaultShowSex , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced + , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels } svaupel <- insert User { userIdent = "vaupel.sarah@campus.lmu.de" @@ -301,6 +306,7 @@ fillDb = do , userSex = Just SexFemale , userShowSex = userDefaultShowSex , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced + , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels } sbarth <- insert User { userIdent = "Stephan.Barth@campus.lmu.de" @@ -331,6 +337,7 @@ fillDb = do , userSex = Just SexMale , userShowSex = userDefaultShowSex , userExamOfficeGetSynced = False + , userExamOfficeGetLabels = True } let @@ -391,6 +398,7 @@ fillDb = do , userSex = Nothing , userShowSex = userDefaultShowSex , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced + , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels } where userIdent :: IsString t => t From 5a3c590b72394fb1fd4544aace2a762300b4551d Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Wed, 1 Dec 2021 23:51:37 +0100 Subject: [PATCH 09/50] feat(user): add get-labels to exam office user setting --- .../courses/exam/exam_office/de-de-formal.msg | 8 ++++++++ .../categories/courses/exam/exam_office/en-eu.msg | 8 ++++++++ src/Handler/Profile.hs | 14 +++++++++----- src/Handler/Utils/Profile.hs | 3 ++- 4 files changed, 27 insertions(+), 6 deletions(-) diff --git a/messages/uniworx/categories/courses/exam/exam_office/de-de-formal.msg b/messages/uniworx/categories/courses/exam/exam_office/de-de-formal.msg index 39d033ade..6f5442534 100644 --- a/messages/uniworx/categories/courses/exam/exam_office/de-de-formal.msg +++ b/messages/uniworx/categories/courses/exam/exam_office/de-de-formal.msg @@ -58,3 +58,11 @@ ExamOfficeFieldForced: Forcierte Einsicht ExamOfficeGetSynced: Synchronisiert-Status in Prüfungsliste anzeigen ExamOfficeGetSyncedTip: Soll unter „Prüfungen“ der Synchronisiert-Status zu jeder Prüfung angezeigt werden? (Ein Deaktivieren dieser Option kann zu kürzeren Ladezeiten der Prüfungsliste führen.) +ExamOfficeGetLabels: Labels in Prüfungsliste anzeigen +ExamOfficeGetLabelsTip: Sollen unter „Prüfungen“ die gesetzten Labels zu jeder Prüfung angezeigt werden? + +ExamOfficeSettings: Prüfungsliste („Prüfungen“) +ExamOfficeSettingsGetSynced: Synchronisiert-Status anzeigen +ExamOfficeSettingsGetSyncedTip: Soll der Synchronisiert-Status zu jeder Prüfung angezeigt werden? (Ein Deaktivieren dieser Option kann die Ladezeiten der Prüfungsliste verkürzen.) +ExamOfficeSettingsGetLabels: Labels anzeigen +ExamOfficeSettingsGetLabelsTip: Sollen die gesetzten Labels zu jeder Prüfung angezeigt werden? diff --git a/messages/uniworx/categories/courses/exam/exam_office/en-eu.msg b/messages/uniworx/categories/courses/exam/exam_office/en-eu.msg index b8cd4743e..4194f8905 100644 --- a/messages/uniworx/categories/courses/exam/exam_office/en-eu.msg +++ b/messages/uniworx/categories/courses/exam/exam_office/en-eu.msg @@ -56,3 +56,11 @@ ExamOfficeFieldForced: Forced access ExamOfficeGetSynced: Show synchronised status in exam list ExamOfficeGetSyncedTip: Should the synchronised status be displayed in “Exams”? (Disabling this option may lead to shorter loading times of the exam list.) +ExamOfficeGetLabels: Show labels in exam list +ExamOfficeGetLabelsTip: Should the labels of each exam be displayed in “Exams”? + +ExamOfficeSettings: Exam list (“Exams”) +ExamOfficeSettingsGetSynced: Show synchronised status +ExamOfficeSettingsGetSyncedTip: Should the synchronised status be displayed for each exam? (Disabling this option may lead to shorter loading times of the exam list.) +ExamOfficeSettingsGetLabels: Show labels +ExamOfficeSettingsGetLabelsTip: Should the labels of each exam be displayed? diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 4a9e12dea..90dbdaa76 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -314,13 +314,16 @@ allocationNotificationForm = maybe (pure mempty) allocationNotificationForm' . ( examOfficeForm :: Maybe ExamOfficeSettings -> AForm Handler ExamOfficeSettings examOfficeForm template = wFormToAForm $ do - (_uid, User{userExamOfficeGetSynced}) <- requireAuthPair + (_uid, User{userExamOfficeGetSynced,userExamOfficeGetLabels}) <- requireAuthPair userIsExamOffice <- liftHandler . hasReadAccessTo $ ExamOfficeR EOExamsR if userIsExamOffice - then aFormToWForm . fmap ExamOfficeSettings $ - aformSection MsgFormExamOffice - *> apopt checkBoxField (fslI MsgExamOfficeGetSynced & setTooltip MsgExamOfficeGetSyncedTip) (eosettingsGetSynced <$> template) - else return . pure . fromMaybe (ExamOfficeSettings userExamOfficeGetSynced) $ template + then aFormToWForm $ liftA2 ExamOfficeSettings + ( aformSection MsgFormExamOffice + *> apopt checkBoxField (fslI MsgExamOfficeGetSynced & setTooltip MsgExamOfficeGetSyncedTip) (eosettingsGetSynced <$> template) + ) + ( apopt checkBoxField (fslI MsgExamOfficeGetLabels & setTooltip MsgExamOfficeGetLabelsTip) (eosettingsGetLabels <$> template) + ) + else return . pure . fromMaybe (ExamOfficeSettings userExamOfficeGetSynced userExamOfficeGetLabels) $ template validateSettings :: User -> FormValidator SettingsForm Handler () @@ -377,6 +380,7 @@ postProfileR = do , stgShowSex = userShowSex , stgExamOfficeSettings = ExamOfficeSettings { eosettingsGetSynced = userExamOfficeGetSynced + , eosettingsGetLabels = userExamOfficeGetLabels } , stgAllocationNotificationSettings = allocs } diff --git a/src/Handler/Utils/Profile.hs b/src/Handler/Utils/Profile.hs index 95fe228cb..2a5c2a1f6 100644 --- a/src/Handler/Utils/Profile.hs +++ b/src/Handler/Utils/Profile.hs @@ -36,7 +36,8 @@ validDisplayName (fmap Text.strip -> mTitle) (Text.strip -> fName) (Text.strip - addLetters = Set.fromList [' '] -newtype ExamOfficeSettings +data ExamOfficeSettings = ExamOfficeSettings { eosettingsGetSynced :: Bool + , eosettingsGetLabels :: Bool } From 76110117940e1006e4a1c2c41f45ff7992df5878 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Thu, 2 Dec 2021 15:13:11 +0100 Subject: [PATCH 10/50] chore(model): add exam label model --- models/exam-office/exam-labels.model | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) create mode 100644 models/exam-office/exam-labels.model diff --git a/models/exam-office/exam-labels.model b/models/exam-office/exam-labels.model new file mode 100644 index 000000000..922965522 --- /dev/null +++ b/models/exam-office/exam-labels.model @@ -0,0 +1,18 @@ +ExamOfficeLabel + user UserId + content Text + status MessageStatus + priority Int -- determines label ordering + UniqueExamOfficeLabel user content + deriving Generic + +ExamOfficeExamLabel + exam ExamId + label ExamOfficeLabelId + UniqueExamOfficeExamLabel exam + deriving Generic +ExamOfficeExternalExamLabel + externalExam ExternalExamId + label ExamOfficeLabelId + UniqueExamOfficeExternalExamLabel externalExam + deriving Generic From ca1081c9962f6a631a825af685d4222b64ec8875 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Thu, 2 Dec 2021 16:19:28 +0100 Subject: [PATCH 11/50] chore(profile): add profile form stub for eo-labels --- src/Handler/Profile.hs | 20 +++++++++++++------- src/Handler/Utils/Profile.hs | 1 + 2 files changed, 14 insertions(+), 7 deletions(-) diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 90dbdaa76..4e3fcf82e 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -316,14 +316,17 @@ examOfficeForm :: Maybe ExamOfficeSettings -> AForm Handler ExamOfficeSettings examOfficeForm template = wFormToAForm $ do (_uid, User{userExamOfficeGetSynced,userExamOfficeGetLabels}) <- requireAuthPair userIsExamOffice <- liftHandler . hasReadAccessTo $ ExamOfficeR EOExamsR + userExamOfficeLabels <- return $ maybe Set.empty eosettingsLabels template + let + eoLabelForm :: AForm Handler (Set ExamOfficeLabel) + eoLabelForm = pure userExamOfficeLabels -- TODO if userIsExamOffice - then aFormToWForm $ liftA2 ExamOfficeSettings - ( aformSection MsgFormExamOffice - *> apopt checkBoxField (fslI MsgExamOfficeGetSynced & setTooltip MsgExamOfficeGetSyncedTip) (eosettingsGetSynced <$> template) - ) - ( apopt checkBoxField (fslI MsgExamOfficeGetLabels & setTooltip MsgExamOfficeGetLabelsTip) (eosettingsGetLabels <$> template) - ) - else return . pure . fromMaybe (ExamOfficeSettings userExamOfficeGetSynced userExamOfficeGetLabels) $ template + then aFormToWForm $ ExamOfficeSettings + <$ aformSection MsgFormExamOffice + <*> apopt checkBoxField (fslI MsgExamOfficeGetSynced & setTooltip MsgExamOfficeGetSyncedTip) (eosettingsGetSynced <$> template) + <*> apopt checkBoxField (fslI MsgExamOfficeGetLabels & setTooltip MsgExamOfficeGetLabelsTip) (eosettingsGetLabels <$> template) + <*> eoLabelForm + else return . pure . fromMaybe (ExamOfficeSettings userExamOfficeGetSynced userExamOfficeGetLabels userExamOfficeLabels) $ template validateSettings :: User -> FormValidator SettingsForm Handler () @@ -363,6 +366,7 @@ postProfileR = do E.&&. userSchool E.^. UserSchoolUser E.==. E.val uid E.&&. userSchool E.^. UserSchoolSchool E.==. school E.^. SchoolId return $ school E.^. SchoolId + userExamOfficeLabels <- return Set.empty -- TODO allocs <- runDB $ getAllocationNotifications uid let settingsTemplate = Just SettingsForm { stgDisplayName = userDisplayName @@ -381,6 +385,7 @@ postProfileR = do , stgExamOfficeSettings = ExamOfficeSettings { eosettingsGetSynced = userExamOfficeGetSynced , eosettingsGetLabels = userExamOfficeGetLabels + , eosettingsLabels = userExamOfficeLabels } , stgAllocationNotificationSettings = allocs } @@ -401,6 +406,7 @@ postProfileR = do , UserNotificationSettings =. stgNotificationSettings , UserShowSex =. stgShowSex , UserExamOfficeGetSynced =. (stgExamOfficeSettings & eosettingsGetSynced) + , UserExamOfficeGetLabels =. (stgExamOfficeSettings & eosettingsGetLabels) ] ++ [ UserDisplayEmail =. stgDisplayEmail | userDisplayEmail == stgDisplayEmail ] setAllocationNotifications uid stgAllocationNotificationSettings updateFavourites Nothing diff --git a/src/Handler/Utils/Profile.hs b/src/Handler/Utils/Profile.hs index 2a5c2a1f6..647e9a7c5 100644 --- a/src/Handler/Utils/Profile.hs +++ b/src/Handler/Utils/Profile.hs @@ -40,4 +40,5 @@ data ExamOfficeSettings = ExamOfficeSettings { eosettingsGetSynced :: Bool , eosettingsGetLabels :: Bool + , eosettingsLabels :: Set ExamOfficeLabel } From fe0a016337e39e348f003dcf9bf4c42efa3a5415 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Thu, 2 Dec 2021 17:02:02 +0100 Subject: [PATCH 12/50] chore: eo-label content -> name --- .../courses/exam/exam_office/de-de-formal.msg | 10 ++++------ .../categories/courses/exam/exam_office/en-eu.msg | 10 ++++------ models/exam-office/exam-labels.model | 4 ++-- 3 files changed, 10 insertions(+), 14 deletions(-) diff --git a/messages/uniworx/categories/courses/exam/exam_office/de-de-formal.msg b/messages/uniworx/categories/courses/exam/exam_office/de-de-formal.msg index 6f5442534..23e730d63 100644 --- a/messages/uniworx/categories/courses/exam/exam_office/de-de-formal.msg +++ b/messages/uniworx/categories/courses/exam/exam_office/de-de-formal.msg @@ -60,9 +60,7 @@ ExamOfficeGetSynced: Synchronisiert-Status in Prüfungsliste anzeigen ExamOfficeGetSyncedTip: Soll unter „Prüfungen“ der Synchronisiert-Status zu jeder Prüfung angezeigt werden? (Ein Deaktivieren dieser Option kann zu kürzeren Ladezeiten der Prüfungsliste führen.) ExamOfficeGetLabels: Labels in Prüfungsliste anzeigen ExamOfficeGetLabelsTip: Sollen unter „Prüfungen“ die gesetzten Labels zu jeder Prüfung angezeigt werden? - -ExamOfficeSettings: Prüfungsliste („Prüfungen“) -ExamOfficeSettingsGetSynced: Synchronisiert-Status anzeigen -ExamOfficeSettingsGetSyncedTip: Soll der Synchronisiert-Status zu jeder Prüfung angezeigt werden? (Ein Deaktivieren dieser Option kann die Ladezeiten der Prüfungsliste verkürzen.) -ExamOfficeSettingsGetLabels: Labels anzeigen -ExamOfficeSettingsGetLabelsTip: Sollen die gesetzten Labels zu jeder Prüfung angezeigt werden? +ExamOfficeLabels !ident-ok: Labels +ExamOfficeLabelName !ident-ok: Name +ExamOfficeLabelStatus !ident-ok: Status +ExamOfficeLabelPriority: Priorität diff --git a/messages/uniworx/categories/courses/exam/exam_office/en-eu.msg b/messages/uniworx/categories/courses/exam/exam_office/en-eu.msg index 4194f8905..2983232a7 100644 --- a/messages/uniworx/categories/courses/exam/exam_office/en-eu.msg +++ b/messages/uniworx/categories/courses/exam/exam_office/en-eu.msg @@ -58,9 +58,7 @@ ExamOfficeGetSynced: Show synchronised status in exam list ExamOfficeGetSyncedTip: Should the synchronised status be displayed in “Exams”? (Disabling this option may lead to shorter loading times of the exam list.) ExamOfficeGetLabels: Show labels in exam list ExamOfficeGetLabelsTip: Should the labels of each exam be displayed in “Exams”? - -ExamOfficeSettings: Exam list (“Exams”) -ExamOfficeSettingsGetSynced: Show synchronised status -ExamOfficeSettingsGetSyncedTip: Should the synchronised status be displayed for each exam? (Disabling this option may lead to shorter loading times of the exam list.) -ExamOfficeSettingsGetLabels: Show labels -ExamOfficeSettingsGetLabelsTip: Should the labels of each exam be displayed? +ExamOfficeLabels: Labels +ExamOfficeLabelName: Name +ExamOfficeLabelStatus: Status +ExamOfficeLabelPriority: Priority diff --git a/models/exam-office/exam-labels.model b/models/exam-office/exam-labels.model index 922965522..be02e158d 100644 --- a/models/exam-office/exam-labels.model +++ b/models/exam-office/exam-labels.model @@ -1,9 +1,9 @@ ExamOfficeLabel user UserId - content Text + name Text status MessageStatus priority Int -- determines label ordering - UniqueExamOfficeLabel user content + UniqueExamOfficeLabel user name deriving Generic ExamOfficeExamLabel From 43711eb6e176cc2eb9d279878cd98ac394cff11a Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Thu, 2 Dec 2021 17:38:42 +0100 Subject: [PATCH 13/50] chore(messages): labels -> exam labels --- .../categories/courses/exam/exam_office/de-de-formal.msg | 2 +- messages/uniworx/categories/courses/exam/exam_office/en-eu.msg | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/messages/uniworx/categories/courses/exam/exam_office/de-de-formal.msg b/messages/uniworx/categories/courses/exam/exam_office/de-de-formal.msg index 23e730d63..c352b0157 100644 --- a/messages/uniworx/categories/courses/exam/exam_office/de-de-formal.msg +++ b/messages/uniworx/categories/courses/exam/exam_office/de-de-formal.msg @@ -60,7 +60,7 @@ ExamOfficeGetSynced: Synchronisiert-Status in Prüfungsliste anzeigen ExamOfficeGetSyncedTip: Soll unter „Prüfungen“ der Synchronisiert-Status zu jeder Prüfung angezeigt werden? (Ein Deaktivieren dieser Option kann zu kürzeren Ladezeiten der Prüfungsliste führen.) ExamOfficeGetLabels: Labels in Prüfungsliste anzeigen ExamOfficeGetLabelsTip: Sollen unter „Prüfungen“ die gesetzten Labels zu jeder Prüfung angezeigt werden? -ExamOfficeLabels !ident-ok: Labels +ExamOfficeLabels: Prüfungs-Labels ExamOfficeLabelName !ident-ok: Name ExamOfficeLabelStatus !ident-ok: Status ExamOfficeLabelPriority: Priorität diff --git a/messages/uniworx/categories/courses/exam/exam_office/en-eu.msg b/messages/uniworx/categories/courses/exam/exam_office/en-eu.msg index 2983232a7..ee960df36 100644 --- a/messages/uniworx/categories/courses/exam/exam_office/en-eu.msg +++ b/messages/uniworx/categories/courses/exam/exam_office/en-eu.msg @@ -58,7 +58,7 @@ ExamOfficeGetSynced: Show synchronised status in exam list ExamOfficeGetSyncedTip: Should the synchronised status be displayed in “Exams”? (Disabling this option may lead to shorter loading times of the exam list.) ExamOfficeGetLabels: Show labels in exam list ExamOfficeGetLabelsTip: Should the labels of each exam be displayed in “Exams”? -ExamOfficeLabels: Labels +ExamOfficeLabels: Exam labels ExamOfficeLabelName: Name ExamOfficeLabelStatus: Status ExamOfficeLabelPriority: Priority From a4aaa0fbdaad37eff840df94616e02427fcd770f Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Fri, 3 Dec 2021 00:13:38 +0100 Subject: [PATCH 14/50] chore(messages): add label tooltip --- .../uniworx/categories/courses/exam/exam_office/de-de-formal.msg | 1 + messages/uniworx/categories/courses/exam/exam_office/en-eu.msg | 1 + 2 files changed, 2 insertions(+) diff --git a/messages/uniworx/categories/courses/exam/exam_office/de-de-formal.msg b/messages/uniworx/categories/courses/exam/exam_office/de-de-formal.msg index c352b0157..ffb0fb974 100644 --- a/messages/uniworx/categories/courses/exam/exam_office/de-de-formal.msg +++ b/messages/uniworx/categories/courses/exam/exam_office/de-de-formal.msg @@ -61,6 +61,7 @@ ExamOfficeGetSyncedTip: Soll unter „Prüfungen“ der Synchronisiert-Status zu ExamOfficeGetLabels: Labels in Prüfungsliste anzeigen ExamOfficeGetLabelsTip: Sollen unter „Prüfungen“ die gesetzten Labels zu jeder Prüfung angezeigt werden? ExamOfficeLabels: Prüfungs-Labels +ExamOfficeLabelsTip: Sie können hier Labels anlegen und verwalten, welche sie einzelnen Prüfungen über die Prüfungsliste (siehe „Prüfungen“) zuweisen können. ExamOfficeLabelName !ident-ok: Name ExamOfficeLabelStatus !ident-ok: Status ExamOfficeLabelPriority: Priorität diff --git a/messages/uniworx/categories/courses/exam/exam_office/en-eu.msg b/messages/uniworx/categories/courses/exam/exam_office/en-eu.msg index ee960df36..65fdd1cca 100644 --- a/messages/uniworx/categories/courses/exam/exam_office/en-eu.msg +++ b/messages/uniworx/categories/courses/exam/exam_office/en-eu.msg @@ -59,6 +59,7 @@ ExamOfficeGetSyncedTip: Should the synchronised status be displayed in “Exams ExamOfficeGetLabels: Show labels in exam list ExamOfficeGetLabelsTip: Should the labels of each exam be displayed in “Exams”? ExamOfficeLabels: Exam labels +ExamOfficeLabelsTip: Here you can add and manage labels, which you can assign exam list entries (see “Exams”). ExamOfficeLabelName: Name ExamOfficeLabelStatus: Status ExamOfficeLabelPriority: Priority From 4442b7df292d4f6f305f48b7b01eceedde4d56ea Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Fri, 3 Dec 2021 00:14:49 +0100 Subject: [PATCH 15/50] chore(model): designated eo-label name type --- models/exam-office/exam-labels.model | 2 +- src/Model/Types.hs | 1 + src/Model/Types/ExamOffice.hs | 8 ++++++++ 3 files changed, 10 insertions(+), 1 deletion(-) create mode 100644 src/Model/Types/ExamOffice.hs diff --git a/models/exam-office/exam-labels.model b/models/exam-office/exam-labels.model index be02e158d..a22a8ebc7 100644 --- a/models/exam-office/exam-labels.model +++ b/models/exam-office/exam-labels.model @@ -1,6 +1,6 @@ ExamOfficeLabel user UserId - name Text + name ExamOfficeLabelName status MessageStatus priority Int -- determines label ordering UniqueExamOfficeLabel user name diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 5b5562675..4966c28b5 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -6,6 +6,7 @@ import Model.Types.Common as Types import Model.Types.Course as Types import Model.Types.DateTime as Types import Model.Types.Exam as Types +import Model.Types.ExamOffice as Types import Model.Types.Health as Types import Model.Types.Mail as Types import Model.Types.Security as Types diff --git a/src/Model/Types/ExamOffice.hs b/src/Model/Types/ExamOffice.hs new file mode 100644 index 000000000..60dc51bbf --- /dev/null +++ b/src/Model/Types/ExamOffice.hs @@ -0,0 +1,8 @@ +module Model.Types.ExamOffice + ( ExamOfficeLabelName + ) where + +import Import.NoModel + + +type ExamOfficeLabelName = Text From f68facefe97c0d9f22767b638c883ea7863573a7 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Fri, 3 Dec 2021 00:15:32 +0100 Subject: [PATCH 16/50] chore(profile): add massinput stub for label management --- src/Handler/Profile.hs | 88 +++++++++++++++++++++++++++++------- src/Handler/Utils/Profile.hs | 9 ---- 2 files changed, 71 insertions(+), 26 deletions(-) diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 4e3fcf82e..98e081d96 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -31,6 +31,20 @@ import Jobs import Foundation.Yesod.Auth (updateUserLanguage) +data ExamOfficeSettings + = ExamOfficeSettings + { eosettingsGetSynced :: Bool + , eosettingsGetLabels :: Bool + , eosettingsLabels :: EOLabels + } + +type EOLabelData + = ( ExamOfficeLabelName + , MessageStatus -- status + , Int -- priority; also used for label ordering + ) +type EOLabels = Map (Either ExamOfficeLabelName ExamOfficeLabelId) EOLabelData + data SettingsForm = SettingsForm { stgDisplayName :: UserDisplayName , stgDisplayEmail :: UserEmail @@ -315,18 +329,50 @@ allocationNotificationForm = maybe (pure mempty) allocationNotificationForm' . ( examOfficeForm :: Maybe ExamOfficeSettings -> AForm Handler ExamOfficeSettings examOfficeForm template = wFormToAForm $ do (_uid, User{userExamOfficeGetSynced,userExamOfficeGetLabels}) <- requireAuthPair - userIsExamOffice <- liftHandler . hasReadAccessTo $ ExamOfficeR EOExamsR - userExamOfficeLabels <- return $ maybe Set.empty eosettingsLabels template let - eoLabelForm :: AForm Handler (Set ExamOfficeLabel) - eoLabelForm = pure userExamOfficeLabels -- TODO + userExamOfficeLabels = fromMaybe mempty $ eosettingsLabels <$> template + eoLabelForm :: AForm Handler EOLabels + eoLabelForm = wFormToAForm $ do + let + miAdd :: ListPosition -> Natural -> ListLength -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition (Either ExamOfficeLabelName ExamOfficeLabelId) -> FormResult (Map ListPosition (Either ExamOfficeLabelName ExamOfficeLabelId)))) + miAdd = error "WIP" + + miCell :: ListPosition -> Either ExamOfficeLabelName ExamOfficeLabelId -> Maybe EOLabelData -> (Text -> Text) -> Form EOLabelData + miCell = error "WIP" + + miDelete :: Map ListPosition (Either ExamOfficeLabelName ExamOfficeLabelId) -> ListPosition -> MaybeT (MForm Handler) (Map ListPosition ListPosition) + miDelete = error "WIP" + + miAddEmpty :: ListPosition -> Natural -> ListLength -> Set ListPosition + miAddEmpty = error "WIP" + + miButtonAction :: forall p. p -> Maybe (SomeRoute UniWorX) + -- miButtonAction :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) + miButtonAction = error "WIP" + + miLayout :: ListLength -> Map ListPosition (Either ExamOfficeLabelName ExamOfficeLabelId, FormResult EOLabelData) -> Map ListPosition Widget -> Map ListPosition (FieldView UniWorX) -> Map (Natural, ListPosition) Widget -> Widget + miLayout = error "WIP" + + miIdent :: Text + miIdent = "exam-office-labels" + + postProcess :: Map ListPosition (Either ExamOfficeLabelName ExamOfficeLabelId, EOLabelData) -> EOLabels + postProcess = error "WIP" + + filledData :: Maybe (Map ListPosition (Either ExamOfficeLabelName ExamOfficeLabelId, EOLabelData)) + filledData = Just . Map.fromList . zip [0..] $ Map.toList userExamOfficeLabels + + fmap postProcess <$> massInputW MassInput{..} (fslI MsgExamOfficeLabels & setTooltip MsgExamOfficeLabelsTip) False filledData + userIsExamOffice <- liftHandler . hasReadAccessTo $ ExamOfficeR EOExamsR if userIsExamOffice - then aFormToWForm $ ExamOfficeSettings - <$ aformSection MsgFormExamOffice - <*> apopt checkBoxField (fslI MsgExamOfficeGetSynced & setTooltip MsgExamOfficeGetSyncedTip) (eosettingsGetSynced <$> template) - <*> apopt checkBoxField (fslI MsgExamOfficeGetLabels & setTooltip MsgExamOfficeGetLabelsTip) (eosettingsGetLabels <$> template) - <*> eoLabelForm - else return . pure . fromMaybe (ExamOfficeSettings userExamOfficeGetSynced userExamOfficeGetLabels userExamOfficeLabels) $ template + then + aFormToWForm $ ExamOfficeSettings + <$ aformSection MsgFormExamOffice + <*> apopt checkBoxField (fslI MsgExamOfficeGetSynced & setTooltip MsgExamOfficeGetSyncedTip) (eosettingsGetSynced <$> template) + <*> apopt checkBoxField (fslI MsgExamOfficeGetLabels & setTooltip MsgExamOfficeGetLabelsTip) (eosettingsGetLabels <$> template) + <*> eoLabelForm + else + return . pure . fromMaybe (ExamOfficeSettings userExamOfficeGetSynced userExamOfficeGetLabels userExamOfficeLabels) $ template validateSettings :: User -> FormValidator SettingsForm Handler () @@ -360,13 +406,21 @@ getProfileR, postProfileR :: Handler Html getProfileR = postProfileR postProfileR = do (uid, user@User{..}) <- requireAuthPair - userSchools <- fmap (setOf $ folded . _Value) . runDB . E.select . E.from $ \school -> do - E.where_ . E.exists . E.from $ \userSchool -> - E.where_ $ E.not_ (userSchool E.^. UserSchoolIsOptOut) - E.&&. userSchool E.^. UserSchoolUser E.==. E.val uid - E.&&. userSchool E.^. UserSchoolSchool E.==. school E.^. SchoolId - return $ school E.^. SchoolId - userExamOfficeLabels <- return Set.empty -- TODO + (userSchools, userExamOfficeLabels) <- runDB $ do + userSchools <- fmap (setOf $ folded . _Value) . E.select . E.from $ \school -> do + E.where_ . E.exists . E.from $ \userSchool -> + E.where_ $ E.not_ (userSchool E.^. UserSchoolIsOptOut) + E.&&. userSchool E.^. UserSchoolUser E.==. E.val uid + E.&&. userSchool E.^. UserSchoolSchool E.==. school E.^. SchoolId + return $ school E.^. SchoolId + userExamOfficeLabels <- fmap (foldMap $ \(Entity eolid ExamOfficeLabel{..}) -> Map.singleton (Right eolid) (examOfficeLabelName,examOfficeLabelStatus,examOfficeLabelPriority)) (selectList [ ExamOfficeLabelUser ==. uid ] []) + --Map.union + -- <$> fmap foldMap $ \(Entity eolid ExamOfficeLabel{..}) -> Map.singleton (Right eolid) (examOfficeLabelName,examOfficeLabelStatus,examOfficeLabelPriority)) (selectList [ ExamOfficeLabelUser ==. uid ] []) + -- E.select . E.from $ \examOfficeLabel -> do + -- E.where_ $ examOfficeLabel E.^. ExamOfficeLabelUser E.==. E.val uid + -- E.orderBy [ E.desc $ examOfficeLabel E.^. ExamOfficeLabelPriority ] + -- return examOfficeLabel + return (userSchools, userExamOfficeLabels) allocs <- runDB $ getAllocationNotifications uid let settingsTemplate = Just SettingsForm { stgDisplayName = userDisplayName diff --git a/src/Handler/Utils/Profile.hs b/src/Handler/Utils/Profile.hs index 647e9a7c5..ca272d6b8 100644 --- a/src/Handler/Utils/Profile.hs +++ b/src/Handler/Utils/Profile.hs @@ -1,6 +1,5 @@ module Handler.Utils.Profile ( validDisplayName - , ExamOfficeSettings(..) ) where import Import.NoFoundation @@ -34,11 +33,3 @@ validDisplayName (fmap Text.strip -> mTitle) (Text.strip -> fName) (Text.strip - sNameLetters = Set.fromList $ unpack sName dNameLetters = Set.fromList $ unpack dName addLetters = Set.fromList [' '] - - -data ExamOfficeSettings - = ExamOfficeSettings - { eosettingsGetSynced :: Bool - , eosettingsGetLabels :: Bool - , eosettingsLabels :: Set ExamOfficeLabel - } From a00afa2150a05db518376bb37e508f46604f0546 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Sat, 4 Dec 2021 00:39:12 +0100 Subject: [PATCH 17/50] chore(profile): add (currently no-op) massinput for label-creation --- .../courses/exam/exam_office/de-de-formal.msg | 1 + .../courses/exam/exam_office/en-eu.msg | 1 + .../utils/table_column/de-de-formal.msg | 5 ++- messages/uniworx/utils/table_column/en-eu.msg | 5 ++- src/Handler/Profile.hs | 42 ++++++++++++++----- .../profile/exam-office-labels/add.hamlet | 6 +++ .../profile/exam-office-labels/cell.hamlet | 8 ++++ .../profile/exam-office-labels/layout.hamlet | 17 ++++++++ 8 files changed, 72 insertions(+), 13 deletions(-) create mode 100644 templates/profile/exam-office-labels/add.hamlet create mode 100644 templates/profile/exam-office-labels/cell.hamlet create mode 100644 templates/profile/exam-office-labels/layout.hamlet diff --git a/messages/uniworx/categories/courses/exam/exam_office/de-de-formal.msg b/messages/uniworx/categories/courses/exam/exam_office/de-de-formal.msg index ffb0fb974..ae3c2c7ab 100644 --- a/messages/uniworx/categories/courses/exam/exam_office/de-de-formal.msg +++ b/messages/uniworx/categories/courses/exam/exam_office/de-de-formal.msg @@ -65,3 +65,4 @@ ExamOfficeLabelsTip: Sie können hier Labels anlegen und verwalten, welche sie e ExamOfficeLabelName !ident-ok: Name ExamOfficeLabelStatus !ident-ok: Status ExamOfficeLabelPriority: Priorität +ExamOfficeLabelAlreadyExists: Es existiert bereits ein Prüfungs-Label mit diesem Namen! diff --git a/messages/uniworx/categories/courses/exam/exam_office/en-eu.msg b/messages/uniworx/categories/courses/exam/exam_office/en-eu.msg index 65fdd1cca..b499f22fe 100644 --- a/messages/uniworx/categories/courses/exam/exam_office/en-eu.msg +++ b/messages/uniworx/categories/courses/exam/exam_office/en-eu.msg @@ -63,3 +63,4 @@ ExamOfficeLabelsTip: Here you can add and manage labels, which you can assign ex ExamOfficeLabelName: Name ExamOfficeLabelStatus: Status ExamOfficeLabelPriority: Priority +ExamOfficeLabelAlreadyExists: There already exists an exam label with this name! diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index e91267835..a402d6591 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -61,4 +61,7 @@ SelectColumn: Auswahl CsvExport: CSV-Export TableProportion c@Text of'@Text prop@Rational !ident-ok: #{c}/#{of'} (#{rationalToFixed2 (100 * prop)}%) TableProportionNoRatio c@Text of'@Text !ident-ok: #{c}/#{of'} -TableExamFinished: Ergebnisse sichtbar ab \ No newline at end of file +TableExamFinished: Ergebnisse sichtbar ab +TableExamOfficeLabel: Prüfungs-Label +TableExamOfficeLabelStatus: Label-Farbe +TableExamOfficeLabelPriority: Label-Priorität \ No newline at end of file diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index 5913fddca..e377432b2 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -61,4 +61,7 @@ SelectColumn: Selection CsvExport: CSV export TableProportion c of' prop: #{c}/#{of'} (#{rationalToFixed2 (100 * prop)}%) TableProportionNoRatio c of': #{c}/#{of'} -TableExamFinished: Results visible from \ No newline at end of file +TableExamFinished: Results visible from +TableExamOfficeLabel: Exam label +TableExamOfficeLabelStatus: Label colour +TableExamOfficeLabelPriority: Label priority \ No newline at end of file diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 98e081d96..957ed3e99 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -329,29 +329,49 @@ allocationNotificationForm = maybe (pure mempty) allocationNotificationForm' . ( examOfficeForm :: Maybe ExamOfficeSettings -> AForm Handler ExamOfficeSettings examOfficeForm template = wFormToAForm $ do (_uid, User{userExamOfficeGetSynced,userExamOfficeGetLabels}) <- requireAuthPair + currentRoute <- fromMaybe (error "examOfficeForm called from 404-handler") <$> liftHandler getCurrentRoute + mr <- getMessageRender let userExamOfficeLabels = fromMaybe mempty $ eosettingsLabels <$> template - eoLabelForm :: AForm Handler EOLabels - eoLabelForm = wFormToAForm $ do + eoLabelsForm :: AForm Handler EOLabels + eoLabelsForm = wFormToAForm $ do let miAdd :: ListPosition -> Natural -> ListLength -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition (Either ExamOfficeLabelName ExamOfficeLabelId) -> FormResult (Map ListPosition (Either ExamOfficeLabelName ExamOfficeLabelId)))) - miAdd = error "WIP" + miAdd _ _ _ nudge submitView = Just $ \csrf -> do + (addRes, addView) <- mpreq textField (fslI MsgExamOfficeLabelName & addName (nudge "name")) Nothing + let + addRes' = addRes <&> \nLabel oldData@(maybe 0 (succ . fst) . Map.lookupMax -> kStart) -> if + | Set.member (Left nLabel) . Set.fromList $ Map.elems oldData + -> FormFailure [mr MsgExamOfficeLabelAlreadyExists] + | otherwise + -> FormSuccess . Map.fromList $ [(kStart, Left nLabel)] + return (addRes', $(widgetFile "profile/exam-office-labels/add")) miCell :: ListPosition -> Either ExamOfficeLabelName ExamOfficeLabelId -> Maybe EOLabelData -> (Text -> Text) -> Form EOLabelData - miCell = error "WIP" + miCell _ eoLabel initRes nudge csrf = do + labelIdent <- case eoLabel of + Left lblName -> return lblName + Right lblId -> do + ExamOfficeLabel{examOfficeLabelName} <- liftHandler . runDB $ getJust lblId + return examOfficeLabelName + (statusRes, statusView) <- mreq (selectField optionsFinite) (fslI MsgExamOfficeLabelStatus & addName (nudge "status")) ((\(_,x,_) -> x) <$> initRes) + (priorityRes, priorityView) <- mreq intField (fslI MsgExamOfficeLabelPriority & addName (nudge "priority")) (((\(_,_,x) -> x) <$> initRes) <|> Just 0) + let + res :: FormResult EOLabelData + res = (,,) <$> (FormSuccess labelIdent) <*> statusRes <*> priorityRes + return (res, $(widgetFile "profile/exam-office-labels/cell")) miDelete :: Map ListPosition (Either ExamOfficeLabelName ExamOfficeLabelId) -> ListPosition -> MaybeT (MForm Handler) (Map ListPosition ListPosition) - miDelete = error "WIP" + miDelete = miDeleteList miAddEmpty :: ListPosition -> Natural -> ListLength -> Set ListPosition - miAddEmpty = error "WIP" + miAddEmpty _ _ _ = Set.empty - miButtonAction :: forall p. p -> Maybe (SomeRoute UniWorX) - -- miButtonAction :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) - miButtonAction = error "WIP" + miButtonAction :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) + miButtonAction frag = Just . SomeRoute $ currentRoute :#: frag miLayout :: ListLength -> Map ListPosition (Either ExamOfficeLabelName ExamOfficeLabelId, FormResult EOLabelData) -> Map ListPosition Widget -> Map ListPosition (FieldView UniWorX) -> Map (Natural, ListPosition) Widget -> Widget - miLayout = error "WIP" + miLayout lLength _ cellWdgts delButtons addWdgets = $(widgetFile "profile/exam-office-labels/layout") miIdent :: Text miIdent = "exam-office-labels" @@ -370,7 +390,7 @@ examOfficeForm template = wFormToAForm $ do <$ aformSection MsgFormExamOffice <*> apopt checkBoxField (fslI MsgExamOfficeGetSynced & setTooltip MsgExamOfficeGetSyncedTip) (eosettingsGetSynced <$> template) <*> apopt checkBoxField (fslI MsgExamOfficeGetLabels & setTooltip MsgExamOfficeGetLabelsTip) (eosettingsGetLabels <$> template) - <*> eoLabelForm + <*> eoLabelsForm else return . pure . fromMaybe (ExamOfficeSettings userExamOfficeGetSynced userExamOfficeGetLabels userExamOfficeLabels) $ template diff --git a/templates/profile/exam-office-labels/add.hamlet b/templates/profile/exam-office-labels/add.hamlet new file mode 100644 index 000000000..03342b9a2 --- /dev/null +++ b/templates/profile/exam-office-labels/add.hamlet @@ -0,0 +1,6 @@ +$newline never + + #{csrf} + ^{fvWidget addView} + + ^{fvWidget submitView} diff --git a/templates/profile/exam-office-labels/cell.hamlet b/templates/profile/exam-office-labels/cell.hamlet new file mode 100644 index 000000000..ab926a48c --- /dev/null +++ b/templates/profile/exam-office-labels/cell.hamlet @@ -0,0 +1,8 @@ +$newline never + + ^{labelIdent} + + #{csrf} + ^{fvWidget statusView} + + ^{fvWidget priorityView} diff --git a/templates/profile/exam-office-labels/layout.hamlet b/templates/profile/exam-office-labels/layout.hamlet new file mode 100644 index 000000000..95f9a9c00 --- /dev/null +++ b/templates/profile/exam-office-labels/layout.hamlet @@ -0,0 +1,17 @@ +$newline never + + + + + $forall coord <- review liveCoords lLength + + ^{cellWdgts ! coord} + + + ^{addWdgets ! (0, 0)} From 614b8a18a9434ff41fc2ccede591a8d3c8f95959 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Sat, 4 Dec 2021 00:41:50 +0100 Subject: [PATCH 18/50] chore(profile): rename eo-label name column --- messages/uniworx/utils/table_column/de-de-formal.msg | 2 +- messages/uniworx/utils/table_column/en-eu.msg | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index a402d6591..51bdf2c81 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -62,6 +62,6 @@ CsvExport: CSV-Export TableProportion c@Text of'@Text prop@Rational !ident-ok: #{c}/#{of'} (#{rationalToFixed2 (100 * prop)}%) TableProportionNoRatio c@Text of'@Text !ident-ok: #{c}/#{of'} TableExamFinished: Ergebnisse sichtbar ab -TableExamOfficeLabel: Prüfungs-Label +TableExamOfficeLabel: Label-Name TableExamOfficeLabelStatus: Label-Farbe TableExamOfficeLabelPriority: Label-Priorität \ No newline at end of file diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index e377432b2..736223a18 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -62,6 +62,6 @@ CsvExport: CSV export TableProportion c of' prop: #{c}/#{of'} (#{rationalToFixed2 (100 * prop)}%) TableProportionNoRatio c of': #{c}/#{of'} TableExamFinished: Results visible from -TableExamOfficeLabel: Exam label +TableExamOfficeLabel: Label name TableExamOfficeLabelStatus: Label colour TableExamOfficeLabelPriority: Label priority \ No newline at end of file From 5d7b87e75aa373b52a9f03a1689a7fb258d1f594 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Mon, 6 Dec 2021 23:13:51 +0100 Subject: [PATCH 19/50] refactor(profile): more readable eo-label-form --- src/Handler/Profile.hs | 53 +++++++++++++++++++++++++++++++++++------- 1 file changed, 44 insertions(+), 9 deletions(-) diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 957ed3e99..3601f6c0a 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -326,17 +326,29 @@ allocationNotificationForm = maybe (pure mempty) allocationNotificationForm' . ( fmap (review _AllocNotify) <$> wpopt (radioGroupField Nothing optionsFinite) (fsl allocDesc & addName [st|alloc-notify__#{toPathPiece cID}|]) (Just $ mPrev ^. _AllocNotify) where funcForm' forms = funcForm forms (fslI MsgFormAllocationNotifications & setTooltip MsgFormAllocationNotificationsTip) False + examOfficeForm :: Maybe ExamOfficeSettings -> AForm Handler ExamOfficeSettings examOfficeForm template = wFormToAForm $ do (_uid, User{userExamOfficeGetSynced,userExamOfficeGetLabels}) <- requireAuthPair currentRoute <- fromMaybe (error "examOfficeForm called from 404-handler") <$> liftHandler getCurrentRoute mr <- getMessageRender + let + userExamOfficeLabels :: EOLabels userExamOfficeLabels = fromMaybe mempty $ eosettingsLabels <$> template + eoLabelsForm :: AForm Handler EOLabels eoLabelsForm = wFormToAForm $ do let - miAdd :: ListPosition -> Natural -> ListLength -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition (Either ExamOfficeLabelName ExamOfficeLabelId) -> FormResult (Map ListPosition (Either ExamOfficeLabelName ExamOfficeLabelId)))) + miAdd :: ListPosition + -> Natural + -> ListLength + -> (Text -> Text) + -> FieldView UniWorX + -> Maybe + (Form (Map ListPosition (Either ExamOfficeLabelName ExamOfficeLabelId) + -> FormResult (Map ListPosition (Either ExamOfficeLabelName ExamOfficeLabelId))) + ) miAdd _ _ _ nudge submitView = Just $ \csrf -> do (addRes, addView) <- mpreq textField (fslI MsgExamOfficeLabelName & addName (nudge "name")) Nothing let @@ -344,10 +356,14 @@ examOfficeForm template = wFormToAForm $ do | Set.member (Left nLabel) . Set.fromList $ Map.elems oldData -> FormFailure [mr MsgExamOfficeLabelAlreadyExists] | otherwise - -> FormSuccess . Map.fromList $ [(kStart, Left nLabel)] + -> FormSuccess $ Map.singleton kStart (Left nLabel) return (addRes', $(widgetFile "profile/exam-office-labels/add")) - miCell :: ListPosition -> Either ExamOfficeLabelName ExamOfficeLabelId -> Maybe EOLabelData -> (Text -> Text) -> Form EOLabelData + miCell :: ListPosition + -> Either ExamOfficeLabelName ExamOfficeLabelId + -> Maybe EOLabelData + -> (Text -> Text) + -> Form EOLabelData miCell _ eoLabel initRes nudge csrf = do labelIdent <- case eoLabel of Left lblName -> return lblName @@ -361,28 +377,47 @@ examOfficeForm template = wFormToAForm $ do res = (,,) <$> (FormSuccess labelIdent) <*> statusRes <*> priorityRes return (res, $(widgetFile "profile/exam-office-labels/cell")) - miDelete :: Map ListPosition (Either ExamOfficeLabelName ExamOfficeLabelId) -> ListPosition -> MaybeT (MForm Handler) (Map ListPosition ListPosition) + miDelete :: Map ListPosition (Either ExamOfficeLabelName ExamOfficeLabelId) + -> ListPosition + -> MaybeT (MForm Handler) (Map ListPosition ListPosition) miDelete = miDeleteList - miAddEmpty :: ListPosition -> Natural -> ListLength -> Set ListPosition + miAddEmpty :: ListPosition + -> Natural + -> ListLength + -> Set ListPosition miAddEmpty _ _ _ = Set.empty - miButtonAction :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) + miButtonAction :: forall p. + PathPiece p + => p + -> Maybe (SomeRoute UniWorX) miButtonAction frag = Just . SomeRoute $ currentRoute :#: frag - miLayout :: ListLength -> Map ListPosition (Either ExamOfficeLabelName ExamOfficeLabelId, FormResult EOLabelData) -> Map ListPosition Widget -> Map ListPosition (FieldView UniWorX) -> Map (Natural, ListPosition) Widget -> Widget + miLayout :: ListLength + -> Map ListPosition (Either ExamOfficeLabelName ExamOfficeLabelId, FormResult EOLabelData) + -> Map ListPosition Widget + -> Map ListPosition (FieldView UniWorX) + -> Map (Natural, ListPosition) Widget + -> Widget miLayout lLength _ cellWdgts delButtons addWdgets = $(widgetFile "profile/exam-office-labels/layout") miIdent :: Text miIdent = "exam-office-labels" - postProcess :: Map ListPosition (Either ExamOfficeLabelName ExamOfficeLabelId, EOLabelData) -> EOLabels - postProcess = error "WIP" + postProcess :: Map ListPosition (Either ExamOfficeLabelName ExamOfficeLabelId, EOLabelData) + -> EOLabels + postProcess = Map.fromList . map postProcess' . Map.elems + where + postProcess' :: (Either ExamOfficeLabelName ExamOfficeLabelId, EOLabelData) + -> (Either ExamOfficeLabelName ExamOfficeLabelId, EOLabelData) + postProcess' = error "WIP" filledData :: Maybe (Map ListPosition (Either ExamOfficeLabelName ExamOfficeLabelId, EOLabelData)) filledData = Just . Map.fromList . zip [0..] $ Map.toList userExamOfficeLabels fmap postProcess <$> massInputW MassInput{..} (fslI MsgExamOfficeLabels & setTooltip MsgExamOfficeLabelsTip) False filledData + userIsExamOffice <- liftHandler . hasReadAccessTo $ ExamOfficeR EOExamsR if userIsExamOffice then From 555747993782cb47a886a87591086d343054d525 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Mon, 6 Dec 2021 23:23:14 +0100 Subject: [PATCH 20/50] refactor(profile): cleanup eo-label-form --- src/Handler/Profile.hs | 10 +--------- 1 file changed, 1 insertion(+), 9 deletions(-) diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 3601f6c0a..b56884799 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -405,18 +405,10 @@ examOfficeForm template = wFormToAForm $ do miIdent :: Text miIdent = "exam-office-labels" - postProcess :: Map ListPosition (Either ExamOfficeLabelName ExamOfficeLabelId, EOLabelData) - -> EOLabels - postProcess = Map.fromList . map postProcess' . Map.elems - where - postProcess' :: (Either ExamOfficeLabelName ExamOfficeLabelId, EOLabelData) - -> (Either ExamOfficeLabelName ExamOfficeLabelId, EOLabelData) - postProcess' = error "WIP" - filledData :: Maybe (Map ListPosition (Either ExamOfficeLabelName ExamOfficeLabelId, EOLabelData)) filledData = Just . Map.fromList . zip [0..] $ Map.toList userExamOfficeLabels - fmap postProcess <$> massInputW MassInput{..} (fslI MsgExamOfficeLabels & setTooltip MsgExamOfficeLabelsTip) False filledData + fmap (Map.fromList . Map.elems) <$> massInputW MassInput{..} (fslI MsgExamOfficeLabels & setTooltip MsgExamOfficeLabelsTip) False filledData userIsExamOffice <- liftHandler . hasReadAccessTo $ ExamOfficeR EOExamsR if userIsExamOffice From a96ecb94bcbd8fbdca08aa7657e8cc70800c560f Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Tue, 7 Dec 2021 16:26:57 +0100 Subject: [PATCH 21/50] chore(model): make eo-labels unique for name and status --- models/exam-office/exam-labels.model | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/models/exam-office/exam-labels.model b/models/exam-office/exam-labels.model index a22a8ebc7..9b31293b9 100644 --- a/models/exam-office/exam-labels.model +++ b/models/exam-office/exam-labels.model @@ -3,7 +3,7 @@ ExamOfficeLabel name ExamOfficeLabelName status MessageStatus priority Int -- determines label ordering - UniqueExamOfficeLabel user name + UniqueExamOfficeLabel user name status deriving Generic ExamOfficeExamLabel From cae652b512137d3a85248d164fb16a6a7d8c097f Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Tue, 7 Dec 2021 18:31:34 +0100 Subject: [PATCH 22/50] feat(profile): upsert eo-labels on form submit --- src/Handler/Profile.hs | 17 +++++++++++------ 1 file changed, 11 insertions(+), 6 deletions(-) diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index b56884799..d25e24036 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -461,12 +461,6 @@ postProfileR = do E.&&. userSchool E.^. UserSchoolSchool E.==. school E.^. SchoolId return $ school E.^. SchoolId userExamOfficeLabels <- fmap (foldMap $ \(Entity eolid ExamOfficeLabel{..}) -> Map.singleton (Right eolid) (examOfficeLabelName,examOfficeLabelStatus,examOfficeLabelPriority)) (selectList [ ExamOfficeLabelUser ==. uid ] []) - --Map.union - -- <$> fmap foldMap $ \(Entity eolid ExamOfficeLabel{..}) -> Map.singleton (Right eolid) (examOfficeLabelName,examOfficeLabelStatus,examOfficeLabelPriority)) (selectList [ ExamOfficeLabelUser ==. uid ] []) - -- E.select . E.from $ \examOfficeLabel -> do - -- E.where_ $ examOfficeLabel E.^. ExamOfficeLabelUser E.==. E.val uid - -- E.orderBy [ E.desc $ examOfficeLabel E.^. ExamOfficeLabelPriority ] - -- return examOfficeLabel return (userSchools, userExamOfficeLabels) allocs <- runDB $ getAllocationNotifications uid let settingsTemplate = Just SettingsForm @@ -533,6 +527,17 @@ postProfileR = do } [ UserSchoolIsOptOut =. True ] + forM_ (Map.toList $ stgExamOfficeSettings & eosettingsLabels) $ \(eoLabelIdent, (examOfficeLabelName, examOfficeLabelStatus, examOfficeLabelPriority)) -> case eoLabelIdent of + Left _ -> void $ upsert ExamOfficeLabel{ examOfficeLabelUser=uid, .. } + [ ExamOfficeLabelName =. examOfficeLabelName + , ExamOfficeLabelStatus =. examOfficeLabelStatus + , ExamOfficeLabelPriority =. examOfficeLabelPriority + ] + Right lblId -> update lblId + [ ExamOfficeLabelName =. examOfficeLabelName + , ExamOfficeLabelStatus =. examOfficeLabelStatus + , ExamOfficeLabelPriority =. examOfficeLabelPriority + ] addMessageI Success MsgSettingsUpdate redirect $ ProfileR :#: ProfileSettings From ad39c2755f2b25ff3cb290d718a6558ae1cef57f Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Tue, 7 Dec 2021 18:42:44 +0100 Subject: [PATCH 23/50] chore(eo-exams): lookup labels GET param --- src/Handler/ExamOffice/Exams.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Handler/ExamOffice/Exams.hs b/src/Handler/ExamOffice/Exams.hs index c6d72d734..c05859ef5 100644 --- a/src/Handler/ExamOffice/Exams.hs +++ b/src/Handler/ExamOffice/Exams.hs @@ -89,7 +89,10 @@ getEOExamsR = do Just "no" -> False _ -> userExamOfficeGetSynced - -- TODO: lookup GET param and user setting for getLabels + getLabels <- lookupGetParam "labels" >>= return . \case + Just "yes" -> True + Just "no" -> False + _ -> userExamOfficeGetLabels examsTable <- runDB $ do let From 3ae9d5274be9bed64e28389dd9ec32826ef9c7d7 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Tue, 7 Dec 2021 20:11:26 +0100 Subject: [PATCH 24/50] chore(eo-exams): query eo-labels --- src/Handler/ExamOffice/Exams.hs | 63 ++++++++++++++++++++++----------- 1 file changed, 42 insertions(+), 21 deletions(-) diff --git a/src/Handler/ExamOffice/Exams.hs b/src/Handler/ExamOffice/Exams.hs index c05859ef5..41511a43c 100644 --- a/src/Handler/ExamOffice/Exams.hs +++ b/src/Handler/ExamOffice/Exams.hs @@ -34,28 +34,45 @@ instance Default ExamsTableFilterProj where makeLenses_ ''ExamsTableFilterProj -type ExamsTableExpr = ( E.SqlExpr (Maybe (Entity Exam )) - `E.InnerJoin` E.SqlExpr (Maybe (Entity Course)) - `E.InnerJoin` E.SqlExpr (Maybe (Entity School)) +type ExamsTableExpr = ( E.SqlExpr (Maybe (Entity Exam )) + `E.InnerJoin` E.SqlExpr (Maybe (Entity ExamOfficeExamLabel)) + `E.InnerJoin` E.SqlExpr (Maybe (Entity Course )) + `E.InnerJoin` E.SqlExpr (Maybe (Entity School )) + ) + `E.FullOuterJoin` ( E.SqlExpr (Maybe (Entity ExternalExam )) + `E.InnerJoin` E.SqlExpr (Maybe (Entity ExamOfficeExternalExamLabel)) ) - `E.FullOuterJoin` E.SqlExpr (Maybe (Entity ExternalExam)) -type ExamsTableData = DBRow ( Either (Entity ExternalExam) (Entity Exam, Entity Course, Entity School) - , Maybe Natural, Maybe Natural +type ExamsTableData = DBRow ( Either + ( Entity ExternalExam + , Maybe (Entity ExamOfficeExternalExamLabel) + ) + ( Entity Exam + , Entity Course + , Entity School + , Maybe (Entity ExamOfficeExamLabel) + ) + , Maybe Natural + , Maybe Natural ) queryExam :: Getter ExamsTableExpr (E.SqlExpr (Maybe (Entity Exam))) -queryExam = to $ $(E.sqlIJproj 3 1) . $(E.sqlFOJproj 2 1) +queryExam = to $ $(E.sqlIJproj 4 1) . $(E.sqlFOJproj 2 1) + +queryExamLabel :: Getter ExamsTableExpr (E.SqlExpr (Maybe (Entity ExamOfficeExamLabel))) +queryExamLabel = to $ $(E.sqlIJproj 4 2) . $(E.sqlFOJproj 2 1) queryCourse :: Getter ExamsTableExpr (E.SqlExpr (Maybe (Entity Course))) -queryCourse = to $ $(E.sqlIJproj 3 2) . $(E.sqlFOJproj 2 1) +queryCourse = to $ $(E.sqlIJproj 4 3) . $(E.sqlFOJproj 2 1) querySchool :: Getter ExamsTableExpr (E.SqlExpr (Maybe (Entity School))) -querySchool = to $ $(E.sqlIJproj 3 3) . $(E.sqlFOJproj 2 1) +querySchool = to $ $(E.sqlIJproj 4 4) . $(E.sqlFOJproj 2 1) queryExternalExam :: Getter ExamsTableExpr (E.SqlExpr (Maybe (Entity ExternalExam))) -queryExternalExam = to $(E.sqlFOJproj 2 2) +queryExternalExam = to $ $(E.sqlIJproj 2 1) . $(E.sqlFOJproj 2 2) +queryExternalExamLabel :: Getter ExamsTableExpr (E.SqlExpr (Maybe (Entity ExamOfficeExternalExamLabel))) +queryExternalExamLabel = to $ $(E.sqlIJproj 2 2) . $(E.sqlFOJproj 2 2) resultExam :: Traversal' ExamsTableData (Entity Exam) resultExam = _dbrOutput . _1 . _Right . _1 @@ -67,7 +84,7 @@ resultSchool :: Traversal' ExamsTableData (Entity School) resultSchool = _dbrOutput . _1 . _Right . _3 resultExternalExam :: Traversal' ExamsTableData (Entity ExternalExam) -resultExternalExam = _dbrOutput . _1 . _Left +resultExternalExam = _dbrOutput . _1 . _Left . _1 resultSynchronised, resultResults :: Lens' ExamsTableData (Maybe Natural) resultSynchronised = _dbrOutput . _2 @@ -89,7 +106,7 @@ getEOExamsR = do Just "no" -> False _ -> userExamOfficeGetSynced - getLabels <- lookupGetParam "labels" >>= return . \case + _getLabels <- lookupGetParam "labels" >>= return . \case Just "yes" -> True Just "no" -> False _ -> userExamOfficeGetLabels @@ -112,9 +129,11 @@ getEOExamsR = do where dbtSQLQuery = runReaderT $ do exam <- view queryExam + mExamLabel <- view queryExamLabel course <- view queryCourse school <- view querySchool externalExam <- view queryExternalExam + mExternalExamLabel <- view queryExternalExamLabel lift $ do E.on E.false @@ -124,7 +143,7 @@ getEOExamsR = do E.where_ $ (E.not_ (E.isNothing $ exam E.?. ExamId) E.&&. E.not_ (E.isNothing $ course E.?. CourseId) E.&&. E.isNothing (externalExam E.?. ExternalExamId)) E.||. ( E.isNothing (exam E.?. ExamId) E.&&. E.isNothing (course E.?. CourseId) E.&&. E.not_ (E.isNothing $ externalExam E.?. ExternalExamId)) - return (exam, course, school, externalExam) + return (exam, mExamLabel, course, school, externalExam, mExternalExamLabel) dbtRowKey = views ($(multifocusG 2) queryExam queryExternalExam) (bimap (E.?. ExamId) (E.?. ExternalExamId)) -- [ singletonMap "may-access" . FilterProjected $ \(Any b) r -> (== b) <$> if @@ -142,9 +161,11 @@ getEOExamsR = do dbtProj :: _ ExamsTableData dbtProj = (views _dbtProjRow . set _dbrOutput) =<< do -- dbtProjSimple . runReaderT $ do exam <- view $ _dbtProjRow . _dbrOutput . _1 - course <- view $ _dbtProjRow . _dbrOutput . _2 - school <- view $ _dbtProjRow . _dbrOutput . _3 - externalExam <- view $ _dbtProjRow . _dbrOutput . _4 + mExamLabel <- view $ _dbtProjRow . _dbrOutput . _2 + course <- view $ _dbtProjRow . _dbrOutput . _3 + school <- view $ _dbtProjRow . _dbrOutput . _4 + externalExam <- view $ _dbtProjRow . _dbrOutput . _5 + mExternalExamLabel <- view $ _dbtProjRow . _dbrOutput . _6 forMM_ (view $ _dbtProjFilter . _etProjFilterMayAccess) $ \b -> if | Just (Entity _ exam') <- exam @@ -179,11 +200,11 @@ getEOExamsR = do forMM_ (view $ _dbtProjFilter . _etProjFilterHasResults) guard return Nothing - case (exam, course, school, externalExam) of - (Just exam', Just course', Just school', Nothing) -> return - (Right (exam', course', school'), snd <$> mCounts, fst <$> mCounts) - (Nothing, Nothing, Nothing, Just externalExam') -> return - (Left externalExam', snd <$> mCounts, fst <$> mCounts) + case (exam, mExamLabel, course, school, externalExam, mExternalExamLabel) of + (Just exam', mExamLabel', Just course', Just school', Nothing, Nothing) -> return + (Right (exam', course', school', mExamLabel'), snd <$> mCounts, fst <$> mCounts) + (Nothing, Nothing, Nothing, Nothing, Just externalExam', mExternalExamLabel') -> return + (Left (externalExam', mExternalExamLabel'), snd <$> mCounts, fst <$> mCounts) _other -> return $ error "Got exam & externalExam in same result" From 80634913c3d3709a2aa7bf918ad67806ab85cf95 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Wed, 8 Dec 2021 13:12:43 +0100 Subject: [PATCH 25/50] chore(eo-exams): fix eo-label query --- src/Handler/ExamOffice/Exams.hs | 38 ++++++++++++++++----------------- src/Handler/Profile.hs | 1 + 2 files changed, 20 insertions(+), 19 deletions(-) diff --git a/src/Handler/ExamOffice/Exams.hs b/src/Handler/ExamOffice/Exams.hs index 41511a43c..32fda0d88 100644 --- a/src/Handler/ExamOffice/Exams.hs +++ b/src/Handler/ExamOffice/Exams.hs @@ -34,13 +34,13 @@ instance Default ExamsTableFilterProj where makeLenses_ ''ExamsTableFilterProj -type ExamsTableExpr = ( E.SqlExpr (Maybe (Entity Exam )) - `E.InnerJoin` E.SqlExpr (Maybe (Entity ExamOfficeExamLabel)) - `E.InnerJoin` E.SqlExpr (Maybe (Entity Course )) - `E.InnerJoin` E.SqlExpr (Maybe (Entity School )) +type ExamsTableExpr = ( ( E.SqlExpr (Maybe (Entity Exam )) + `E.InnerJoin` E.SqlExpr (Maybe (Entity Course )) + `E.InnerJoin` E.SqlExpr (Maybe (Entity School )) + ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamOfficeExamLabel)) ) - `E.FullOuterJoin` ( E.SqlExpr (Maybe (Entity ExternalExam )) - `E.InnerJoin` E.SqlExpr (Maybe (Entity ExamOfficeExternalExamLabel)) + `E.FullOuterJoin` ( E.SqlExpr (Maybe (Entity ExternalExam )) + `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamOfficeExternalExamLabel)) ) type ExamsTableData = DBRow ( Either @@ -57,22 +57,22 @@ type ExamsTableData = DBRow ( Either ) queryExam :: Getter ExamsTableExpr (E.SqlExpr (Maybe (Entity Exam))) -queryExam = to $ $(E.sqlIJproj 4 1) . $(E.sqlFOJproj 2 1) - -queryExamLabel :: Getter ExamsTableExpr (E.SqlExpr (Maybe (Entity ExamOfficeExamLabel))) -queryExamLabel = to $ $(E.sqlIJproj 4 2) . $(E.sqlFOJproj 2 1) +queryExam = to $ $(E.sqlIJproj 3 1) . $(E.sqlLOJproj 2 1) . $(E.sqlFOJproj 2 1) queryCourse :: Getter ExamsTableExpr (E.SqlExpr (Maybe (Entity Course))) -queryCourse = to $ $(E.sqlIJproj 4 3) . $(E.sqlFOJproj 2 1) +queryCourse = to $ $(E.sqlIJproj 3 2) . $(E.sqlLOJproj 2 1) . $(E.sqlFOJproj 2 1) querySchool :: Getter ExamsTableExpr (E.SqlExpr (Maybe (Entity School))) -querySchool = to $ $(E.sqlIJproj 4 4) . $(E.sqlFOJproj 2 1) +querySchool = to $ $(E.sqlIJproj 3 3) . $(E.sqlLOJproj 2 1) . $(E.sqlFOJproj 2 1) + +queryExamLabel :: Getter ExamsTableExpr (E.SqlExpr (Maybe (Entity ExamOfficeExamLabel))) +queryExamLabel = to $ $(E.sqlLOJproj 2 2) . $(E.sqlFOJproj 2 1) queryExternalExam :: Getter ExamsTableExpr (E.SqlExpr (Maybe (Entity ExternalExam))) -queryExternalExam = to $ $(E.sqlIJproj 2 1) . $(E.sqlFOJproj 2 2) +queryExternalExam = to $ $(E.sqlLOJproj 2 1) . $(E.sqlFOJproj 2 2) queryExternalExamLabel :: Getter ExamsTableExpr (E.SqlExpr (Maybe (Entity ExamOfficeExternalExamLabel))) -queryExternalExamLabel = to $ $(E.sqlIJproj 2 2) . $(E.sqlFOJproj 2 2) +queryExternalExamLabel = to $ $(E.sqlLOJproj 2 2) . $(E.sqlFOJproj 2 2) resultExam :: Traversal' ExamsTableData (Entity Exam) resultExam = _dbrOutput . _1 . _Right . _1 @@ -160,11 +160,11 @@ getEOExamsR = do dbtProj :: _ ExamsTableData dbtProj = (views _dbtProjRow . set _dbrOutput) =<< do -- dbtProjSimple . runReaderT $ do - exam <- view $ _dbtProjRow . _dbrOutput . _1 - mExamLabel <- view $ _dbtProjRow . _dbrOutput . _2 - course <- view $ _dbtProjRow . _dbrOutput . _3 - school <- view $ _dbtProjRow . _dbrOutput . _4 - externalExam <- view $ _dbtProjRow . _dbrOutput . _5 + exam <- view $ _dbtProjRow . _dbrOutput . _1 + mExamLabel <- view $ _dbtProjRow . _dbrOutput . _2 + course <- view $ _dbtProjRow . _dbrOutput . _3 + school <- view $ _dbtProjRow . _dbrOutput . _4 + externalExam <- view $ _dbtProjRow . _dbrOutput . _5 mExternalExamLabel <- view $ _dbtProjRow . _dbrOutput . _6 forMM_ (view $ _dbtProjFilter . _etProjFilterMayAccess) $ \b -> if diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index d25e24036..06c297d38 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -527,6 +527,7 @@ postProfileR = do } [ UserSchoolIsOptOut =. True ] + -- TODO: delete labels forM_ (Map.toList $ stgExamOfficeSettings & eosettingsLabels) $ \(eoLabelIdent, (examOfficeLabelName, examOfficeLabelStatus, examOfficeLabelPriority)) -> case eoLabelIdent of Left _ -> void $ upsert ExamOfficeLabel{ examOfficeLabelUser=uid, .. } [ ExamOfficeLabelName =. examOfficeLabelName From eba56e4d621aa62fdee7535c8b83e0b61f0352d8 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Wed, 8 Dec 2021 15:01:23 +0100 Subject: [PATCH 26/50] fix(eo-exams): fix eo-labels query --- src/Handler/ExamOffice/Exams.hs | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/src/Handler/ExamOffice/Exams.hs b/src/Handler/ExamOffice/Exams.hs index 32fda0d88..6d86d220e 100644 --- a/src/Handler/ExamOffice/Exams.hs +++ b/src/Handler/ExamOffice/Exams.hs @@ -129,21 +129,23 @@ getEOExamsR = do where dbtSQLQuery = runReaderT $ do exam <- view queryExam - mExamLabel <- view queryExamLabel course <- view queryCourse school <- view querySchool + mExamLabel <- view queryExamLabel externalExam <- view queryExternalExam mExternalExamLabel <- view queryExternalExamLabel lift $ do + E.on $ externalExam E.?. ExternalExamId E.==. mExternalExamLabel E.?. ExamOfficeExternalExamLabelExternalExam E.on E.false + E.on $ exam E.?. ExamId E.==. mExamLabel E.?. ExamOfficeExamLabelExam E.on $ school E.?. SchoolId E.==. course E.?. CourseSchool E.on $ exam E.?. ExamCourse E.==. course E.?. CourseId E.where_ $ (E.not_ (E.isNothing $ exam E.?. ExamId) E.&&. E.not_ (E.isNothing $ course E.?. CourseId) E.&&. E.isNothing (externalExam E.?. ExternalExamId)) E.||. ( E.isNothing (exam E.?. ExamId) E.&&. E.isNothing (course E.?. CourseId) E.&&. E.not_ (E.isNothing $ externalExam E.?. ExternalExamId)) - return (exam, mExamLabel, course, school, externalExam, mExternalExamLabel) + return (exam, course, school, mExamLabel, externalExam, mExternalExamLabel) dbtRowKey = views ($(multifocusG 2) queryExam queryExternalExam) (bimap (E.?. ExamId) (E.?. ExternalExamId)) -- [ singletonMap "may-access" . FilterProjected $ \(Any b) r -> (== b) <$> if @@ -161,9 +163,9 @@ getEOExamsR = do dbtProj :: _ ExamsTableData dbtProj = (views _dbtProjRow . set _dbrOutput) =<< do -- dbtProjSimple . runReaderT $ do exam <- view $ _dbtProjRow . _dbrOutput . _1 - mExamLabel <- view $ _dbtProjRow . _dbrOutput . _2 - course <- view $ _dbtProjRow . _dbrOutput . _3 - school <- view $ _dbtProjRow . _dbrOutput . _4 + course <- view $ _dbtProjRow . _dbrOutput . _2 + school <- view $ _dbtProjRow . _dbrOutput . _3 + mExamLabel <- view $ _dbtProjRow . _dbrOutput . _4 externalExam <- view $ _dbtProjRow . _dbrOutput . _5 mExternalExamLabel <- view $ _dbtProjRow . _dbrOutput . _6 @@ -200,8 +202,8 @@ getEOExamsR = do forMM_ (view $ _dbtProjFilter . _etProjFilterHasResults) guard return Nothing - case (exam, mExamLabel, course, school, externalExam, mExternalExamLabel) of - (Just exam', mExamLabel', Just course', Just school', Nothing, Nothing) -> return + case (exam, course, school, mExamLabel, externalExam, mExternalExamLabel) of + (Just exam', Just course', Just school', mExamLabel', Nothing, Nothing) -> return (Right (exam', course', school', mExamLabel'), snd <$> mCounts, fst <$> mCounts) (Nothing, Nothing, Nothing, Nothing, Just externalExam', mExternalExamLabel') -> return (Left (externalExam', mExternalExamLabel'), snd <$> mCounts, fst <$> mCounts) From 12c79612b725d3bdfcddc907dcf852093c0768c4 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Wed, 8 Dec 2021 22:19:42 +0100 Subject: [PATCH 27/50] chore(eo-exams): extend label query with label data --- src/Handler/ExamOffice/Exams.hs | 63 ++++++++++++++++++++++----------- 1 file changed, 42 insertions(+), 21 deletions(-) diff --git a/src/Handler/ExamOffice/Exams.hs b/src/Handler/ExamOffice/Exams.hs index 6d86d220e..9b8defab3 100644 --- a/src/Handler/ExamOffice/Exams.hs +++ b/src/Handler/ExamOffice/Exams.hs @@ -34,23 +34,30 @@ instance Default ExamsTableFilterProj where makeLenses_ ''ExamsTableFilterProj -type ExamsTableExpr = ( ( E.SqlExpr (Maybe (Entity Exam )) - `E.InnerJoin` E.SqlExpr (Maybe (Entity Course )) - `E.InnerJoin` E.SqlExpr (Maybe (Entity School )) - ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamOfficeExamLabel)) +type ExamsTableExpr = ( ( E.SqlExpr (Maybe (Entity Exam )) + `E.InnerJoin` E.SqlExpr (Maybe (Entity Course)) + `E.InnerJoin` E.SqlExpr (Maybe (Entity School)) + ) + `E.LeftOuterJoin` + ( E.SqlExpr (Maybe (Entity ExamOfficeExamLabel)) + `E.InnerJoin` E.SqlExpr (Maybe (Entity ExamOfficeLabel)) + ) ) - `E.FullOuterJoin` ( E.SqlExpr (Maybe (Entity ExternalExam )) - `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamOfficeExternalExamLabel)) + `E.FullOuterJoin` ( E.SqlExpr (Maybe (Entity ExternalExam)) + `E.LeftOuterJoin` + ( E.SqlExpr (Maybe (Entity ExamOfficeExternalExamLabel)) + `E.InnerJoin` E.SqlExpr (Maybe (Entity ExamOfficeLabel)) + ) ) type ExamsTableData = DBRow ( Either ( Entity ExternalExam - , Maybe (Entity ExamOfficeExternalExamLabel) + , Maybe (Entity ExamOfficeLabel) ) ( Entity Exam , Entity Course , Entity School - , Maybe (Entity ExamOfficeExamLabel) + , Maybe (Entity ExamOfficeLabel) ) , Maybe Natural , Maybe Natural @@ -66,13 +73,19 @@ querySchool :: Getter ExamsTableExpr (E.SqlExpr (Maybe (Entity School))) querySchool = to $ $(E.sqlIJproj 3 3) . $(E.sqlLOJproj 2 1) . $(E.sqlFOJproj 2 1) queryExamLabel :: Getter ExamsTableExpr (E.SqlExpr (Maybe (Entity ExamOfficeExamLabel))) -queryExamLabel = to $ $(E.sqlLOJproj 2 2) . $(E.sqlFOJproj 2 1) +queryExamLabel = to $ $(E.sqlIJproj 2 1) . $(E.sqlLOJproj 2 2) . $(E.sqlFOJproj 2 1) + +queryLabelExam :: Getter ExamsTableExpr (E.SqlExpr (Maybe (Entity ExamOfficeLabel))) +queryLabelExam = to $ $(E.sqlIJproj 2 2) . $(E.sqlLOJproj 2 2) . $(E.sqlFOJproj 2 1) queryExternalExam :: Getter ExamsTableExpr (E.SqlExpr (Maybe (Entity ExternalExam))) queryExternalExam = to $ $(E.sqlLOJproj 2 1) . $(E.sqlFOJproj 2 2) queryExternalExamLabel :: Getter ExamsTableExpr (E.SqlExpr (Maybe (Entity ExamOfficeExternalExamLabel))) -queryExternalExamLabel = to $ $(E.sqlLOJproj 2 2) . $(E.sqlFOJproj 2 2) +queryExternalExamLabel = to $ $(E.sqlIJproj 2 1) . $(E.sqlLOJproj 2 2) . $(E.sqlFOJproj 2 2) + +queryLabelExternalExam :: Getter ExamsTableExpr (E.SqlExpr (Maybe (Entity ExamOfficeLabel))) +queryLabelExternalExam = to $ $(E.sqlIJproj 2 2) . $(E.sqlLOJproj 2 2) . $(E.sqlFOJproj 2 2) resultExam :: Traversal' ExamsTableData (Entity Exam) resultExam = _dbrOutput . _1 . _Right . _1 @@ -106,7 +119,7 @@ getEOExamsR = do Just "no" -> False _ -> userExamOfficeGetSynced - _getLabels <- lookupGetParam "labels" >>= return . \case + getLabels <- lookupGetParam "labels" >>= return . \case Just "yes" -> True Just "no" -> False _ -> userExamOfficeGetLabels @@ -128,24 +141,32 @@ getEOExamsR = do examsDBTable = DBTable{..} where dbtSQLQuery = runReaderT $ do - exam <- view queryExam - course <- view queryCourse - school <- view querySchool - mExamLabel <- view queryExamLabel - externalExam <- view queryExternalExam + exam <- view queryExam + course <- view queryCourse + school <- view querySchool + mExamLabel <- view queryExamLabel + mLabelExam <- view queryLabelExam + externalExam <- view queryExternalExam mExternalExamLabel <- view queryExternalExamLabel + mLabelExternalExam <- view queryLabelExternalExam lift $ do - E.on $ externalExam E.?. ExternalExamId E.==. mExternalExamLabel E.?. ExamOfficeExternalExamLabelExternalExam + E.on $ externalExam E.?. ExternalExamId E.==. mExternalExamLabel E.?. ExamOfficeExternalExamLabelExternalExam + E.on $ mExternalExamLabel E.?. ExamOfficeExternalExamLabelLabel E.==. mLabelExternalExam E.?. ExamOfficeLabelId E.on E.false - E.on $ exam E.?. ExamId E.==. mExamLabel E.?. ExamOfficeExamLabelExam - E.on $ school E.?. SchoolId E.==. course E.?. CourseSchool - E.on $ exam E.?. ExamCourse E.==. course E.?. CourseId + E.on $ exam E.?. ExamId E.==. mExamLabel E.?. ExamOfficeExamLabelExam + E.on $ mExamLabel E.?. ExamOfficeExamLabelLabel E.==. mLabelExam E.?. ExamOfficeLabelId + E.on $ course E.?. CourseSchool E.==. school E.?. SchoolId + E.on $ exam E.?. ExamCourse E.==. course E.?. CourseId E.where_ $ (E.not_ (E.isNothing $ exam E.?. ExamId) E.&&. E.not_ (E.isNothing $ course E.?. CourseId) E.&&. E.isNothing (externalExam E.?. ExternalExamId)) E.||. ( E.isNothing (exam E.?. ExamId) E.&&. E.isNothing (course E.?. CourseId) E.&&. E.not_ (E.isNothing $ externalExam E.?. ExternalExamId)) + E.where_ $ E.val (not getLabels) E.||. ( + E.val getLabels + E.&&. mLabelExam E.?. ExamOfficeLabelUser E.==. E.just (E.val uid) + E.&&. mLabelExternalExam E.?. ExamOfficeLabelUser E.==. E.just (E.val uid)) - return (exam, course, school, mExamLabel, externalExam, mExternalExamLabel) + return (exam, course, school, mLabelExam, externalExam, mLabelExternalExam) dbtRowKey = views ($(multifocusG 2) queryExam queryExternalExam) (bimap (E.?. ExamId) (E.?. ExternalExamId)) -- [ singletonMap "may-access" . FilterProjected $ \(Any b) r -> (== b) <$> if From 808c2fc7708cbf69172cc348e8a2c47c641287b1 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Thu, 16 Dec 2021 20:45:52 +0100 Subject: [PATCH 28/50] feat(eoexamsr): implement label sorting --- .../utils/table_column/de-de-formal.msg | 1 + messages/uniworx/utils/table_column/en-eu.msg | 1 + src/Handler/ExamOffice/Exams.hs | 40 ++++++++++++------- src/Handler/Utils/Table/Columns.hs | 9 +++++ src/Utils/Lens.hs | 2 + 5 files changed, 39 insertions(+), 14 deletions(-) diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index 51bdf2c81..6077dcfc3 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -22,6 +22,7 @@ TableExamName !ident-ok: Name TableExamTime: Termin TableExamRegistration: Prüfungsanmeldung TableExamResult: Prüfungsergebnis +TableExamLabel !ident-ok: Label TableSheet: Blatt TableLastEdit: Letzte Änderung TableSubmission: Abgabenummer diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index 736223a18..627867eb7 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -22,6 +22,7 @@ TableExamName: Name TableExamTime: Time TableExamRegistration: Exam registration TableExamResult: Exam result +TableExamLabel: Label TableSheet: Sheet TableLastEdit: Latest edit TableSubmission: Submission-number diff --git a/src/Handler/ExamOffice/Exams.hs b/src/Handler/ExamOffice/Exams.hs index 9b8defab3..0336592d3 100644 --- a/src/Handler/ExamOffice/Exams.hs +++ b/src/Handler/ExamOffice/Exams.hs @@ -99,6 +99,9 @@ resultSchool = _dbrOutput . _1 . _Right . _3 resultExternalExam :: Traversal' ExamsTableData (Entity ExternalExam) resultExternalExam = _dbrOutput . _1 . _Left . _1 +resultLabel :: Traversal' ExamsTableData (Maybe (Entity ExamOfficeLabel)) +resultLabel = _dbrOutput . _1 . choosing _2 _4 + resultSynchronised, resultResults :: Lens' ExamsTableData (Maybe Natural) resultSynchronised = _dbrOutput . _2 resultResults = _dbrOutput . _3 @@ -169,18 +172,6 @@ getEOExamsR = do return (exam, course, school, mLabelExam, externalExam, mLabelExternalExam) dbtRowKey = views ($(multifocusG 2) queryExam queryExternalExam) (bimap (E.?. ExamId) (E.?. ExternalExamId)) - -- [ singletonMap "may-access" . FilterProjected $ \(Any b) r -> (== b) <$> if - -- | Just exam <- r ^? resultExam . _entityVal - -- , Just course <- r ^? resultCourse . _entityVal - -- -> hasReadAccessTo . urlRoute $ examLink course exam - -- | Just eexam <- r ^? resultExternalExam . _entityVal - -- -> hasReadAccessTo . urlRoute $ externalExamLink eexam :: DB Bool - -- | otherwise - -- -> return $ error "Got neither exam nor externalExam in result" - -- , singletonMap "has-results" . FilterProjected $ \(Any b) r -> (return $ b == (r ^. resultResults > 0) :: DB Bool) - -- , singletonMap "is-synced" . FilterProjected $ \(Any b) r -> (return $ b == (r ^. resultSynchronised >= r ^. resultResults) :: DB Bool) - -- ] - dbtProj :: _ ExamsTableData dbtProj = (views _dbtProjRow . set _dbrOutput) =<< do -- dbtProjSimple . runReaderT $ do exam <- view $ _dbtProjRow . _dbrOutput . _1 @@ -231,6 +222,19 @@ getEOExamsR = do _other -> return $ error "Got exam & externalExam in same result" + colLabel = Colonnade.singleton (fromSortable . Sortable (Just "label") $ i18nCell MsgTableExamLabel) $ \x -> flip runReader x $ do + mLabel <- preview resultLabel + + -- TODO: implement and use select widget for setting label + if + | Just (Just (Entity _ ExamOfficeLabel{..})) <- mLabel + -> return $ cell + [whamlet| + $newline never + #{examOfficeLabelName} + |] + | otherwise -> return $ cell mempty + colSynced = Colonnade.singleton (fromSortable . Sortable (Just "synced") $ i18nCell MsgExamSynchronised) $ \x -> flip runReader x $ do mExam <- preview resultExam mSchool <- preview resultSchool @@ -264,7 +268,8 @@ getEOExamsR = do dbtColonnade :: Colonnade Sortable _ _ dbtColonnade = mconcat - [ bool mempty colSynced getSynced + [ bool mempty colLabel getLabels + , bool mempty colSynced getSynced , maybeAnchorColonnade ( runMaybeT $ mpreview ($(multifocusG 2) (pre $ resultCourse . _entityVal) (pre $ resultExam . _entityVal) . to (uncurry $ liftA2 examLink) . _Just) <|> mpreviews (resultExternalExam . _entityVal) externalExamLink ) @@ -278,6 +283,12 @@ getEOExamsR = do , emptyOpticColonnade (resultCourse . _entityVal . _courseTerm <> resultExternalExam . _entityVal . _externalExamTerm) colTermShort ] dbtSorting = mconcat $ + (bool mempty + [ singletonMap "label-prio" $ + SortProjected . comparing $ (fmap . fmap $ examOfficeLabelPriority . entityVal) <$> preview resultLabel + , singletonMap "label-status" $ + SortProjected . comparing $ (fmap . fmap $ examOfficeLabelStatus . entityVal) <$> preview resultLabel + ] getLabels) <> (bool mempty [ singletonMap "synced" $ SortProjected . comparing $ ((/) `on` toRational . fromMaybe 0) <$> view resultSynchronised <*> view resultResults @@ -293,6 +304,7 @@ getEOExamsR = do , sortTerm (to $ E.unsafeCoalesce . sequence [views queryCourse (E.?. CourseTerm), views queryExternalExam (E.?. ExternalExamTerm)]) ] + -- TODO: implement label filters: prio, status, name dbtFilter = mconcat $ [ singletonMap "may-access" . FilterProjected $ (_etProjFilterMayAccess ?~) . getAny , singletonMap "has-results" . FilterProjected $ (_etProjFilterHasResults ?~) . getAny @@ -316,7 +328,7 @@ getEOExamsR = do dbtExtraReps = [] examsDBTableValidator = def - & defaultSorting (bool mempty [SortAscBy "is-synced"] getSynced <> [SortAscBy "exam-time"]) + & defaultSorting (bool mempty [SortDescBy "label-prio", SortAscBy "label-status"] getLabels <> bool mempty [SortAscBy "is-synced"] getSynced <> [SortAscBy "exam-time"]) & forceFilter "may-access" (Any True) & forceFilter "has-results" (Any True) diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index e13284064..fd0e2c4a8 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -248,6 +248,15 @@ colExamFinishedOffice resultFinished = Colonnade.singleton (fromSortable header) sortExamFinished :: OpticSortColumn (Maybe UTCTime) sortExamFinished queryFinished = singletonMap "exam-finished" . SortColumn $ view queryFinished +colExamLabel :: OpticColonnade (Maybe ExamOfficeLabelName) +colExamLabel resultLabel = Colonnade.singleton (fromSortable header) body + where + header = Sortable (Just "exam-label") (i18nCell MsgTableExamLabel) + body = views resultLabel $ maybe mempty i18nCell + +sortExamLabel :: OpticSortColumn (Maybe ExamOfficeLabelName) +sortExamLabel queryLabel = singletonMap "exam-label" . SortColumn $ view queryLabel + --------------------- -- Exam occurences -- --------------------- diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 59f8266fa..8464e5b36 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -215,6 +215,8 @@ makeLenses_ ''UTCTime makeLenses_ ''Exam makeLenses_ ''ExamOccurrence +makeLenses_ ''ExamOfficeLabel + makePrisms ''AuthenticationMode makeLenses_ ''CourseUserNote From 5fe01ce8dc87e4a318be1885a053b7403813cffa Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Tue, 28 Dec 2021 01:22:49 +0100 Subject: [PATCH 29/50] fix(eo-exams): display exams without label --- src/Handler/ExamOffice/Exams.hs | 19 +++++++++++++++---- 1 file changed, 15 insertions(+), 4 deletions(-) diff --git a/src/Handler/ExamOffice/Exams.hs b/src/Handler/ExamOffice/Exams.hs index 0336592d3..115181b0c 100644 --- a/src/Handler/ExamOffice/Exams.hs +++ b/src/Handler/ExamOffice/Exams.hs @@ -154,11 +154,15 @@ getEOExamsR = do mLabelExternalExam <- view queryLabelExternalExam lift $ do - E.on $ externalExam E.?. ExternalExamId E.==. mExternalExamLabel E.?. ExamOfficeExternalExamLabelExternalExam E.on $ mExternalExamLabel E.?. ExamOfficeExternalExamLabelLabel E.==. mLabelExternalExam E.?. ExamOfficeLabelId + E.on $ E.maybe E.true (\externalExamLabelExternalExamId -> + externalExam E.?. ExternalExamId E.==. E.just externalExamLabelExternalExamId + ) (mExternalExamLabel E.?. ExamOfficeExternalExamLabelExternalExam) E.on E.false - E.on $ exam E.?. ExamId E.==. mExamLabel E.?. ExamOfficeExamLabelExam E.on $ mExamLabel E.?. ExamOfficeExamLabelLabel E.==. mLabelExam E.?. ExamOfficeLabelId + E.on $ E.maybe E.true (\examLabelExamId -> + exam E.?. ExamId E.==. E.just examLabelExamId + ) (mExamLabel E.?. ExamOfficeExamLabelExam) E.on $ course E.?. CourseSchool E.==. school E.?. SchoolId E.on $ exam E.?. ExamCourse E.==. course E.?. CourseId @@ -166,8 +170,15 @@ getEOExamsR = do E.||. ( E.isNothing (exam E.?. ExamId) E.&&. E.isNothing (course E.?. CourseId) E.&&. E.not_ (E.isNothing $ externalExam E.?. ExternalExamId)) E.where_ $ E.val (not getLabels) E.||. ( E.val getLabels - E.&&. mLabelExam E.?. ExamOfficeLabelUser E.==. E.just (E.val uid) - E.&&. mLabelExternalExam E.?. ExamOfficeLabelUser E.==. E.just (E.val uid)) + E.&&. ( E.maybe E.true (\labelExamUser -> + labelExamUser E.==. E.val uid + ) (mLabelExam E.?. ExamOfficeLabelUser) + ) + E.&&. ( E.maybe E.true (\labelExternalExamUser -> + labelExternalExamUser E.==. E.val uid + ) (mLabelExternalExam E.?. ExamOfficeLabelUser) + ) + ) return (exam, course, school, mLabelExam, externalExam, mLabelExternalExam) dbtRowKey = views ($(multifocusG 2) queryExam queryExternalExam) (bimap (E.?. ExamId) (E.?. ExternalExamId)) From 5c2070e1d722ac930e915f93d1be28d3a9db0143 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Tue, 28 Dec 2021 14:16:38 +0100 Subject: [PATCH 30/50] chore(label-select): add frontend util stub --- .../src/utils/label-select/label-select.js | 32 +++++++++++++++++++ .../src/utils/label-select/label-select.sass | 0 frontend/src/utils/utils.js | 2 ++ 3 files changed, 34 insertions(+) create mode 100644 frontend/src/utils/label-select/label-select.js create mode 100644 frontend/src/utils/label-select/label-select.sass diff --git a/frontend/src/utils/label-select/label-select.js b/frontend/src/utils/label-select/label-select.js new file mode 100644 index 000000000..3002a379d --- /dev/null +++ b/frontend/src/utils/label-select/label-select.js @@ -0,0 +1,32 @@ +import { Utility } from '../../core/utility'; + +import './label-select.sass'; + + +@Utility({ + selector: '.uw-label-select', +}) +export class LabelSelect { + + _element; + _app; + + constructor(element, app) { + if (!element) { + throw new Error('LabelSelect utility cannot be setup without an element!'); + } + + if (!app) { + throw new Error('LabelSelect utility cannot be setup without an app!'); + } + + this._element = element; + this._app = app; + } + + // TODO cleanUp event manager etc. + destroy() { + console.log('TODO LabelSelect destroy'); + } + +} diff --git a/frontend/src/utils/label-select/label-select.sass b/frontend/src/utils/label-select/label-select.sass new file mode 100644 index 000000000..e69de29bb diff --git a/frontend/src/utils/utils.js b/frontend/src/utils/utils.js index 8727b1844..86c2d7e05 100644 --- a/frontend/src/utils/utils.js +++ b/frontend/src/utils/utils.js @@ -15,6 +15,7 @@ import { PageActionsUtils } from './pageactions/pageactions'; import { HideColumns } from './hide-columns/hide-columns'; import { ExamCorrect } from './exam-correct/exam-correct'; import { SortTable } from './sort-table/sort-table'; +import { LabelSelect } from './label-select/label-select'; export const Utils = [ Alerts, @@ -35,4 +36,5 @@ export const Utils = [ HideColumns, ExamCorrect, SortTable, + LabelSelect, ]; From fca96bfae83518197234134e9dee8fc38ef716c3 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Sat, 22 Jan 2022 01:41:52 +0100 Subject: [PATCH 31/50] chore(frontend): remove label-select util stub --- .../src/utils/label-select/label-select.js | 32 ------------------- .../src/utils/label-select/label-select.sass | 0 frontend/src/utils/utils.js | 2 -- 3 files changed, 34 deletions(-) delete mode 100644 frontend/src/utils/label-select/label-select.js delete mode 100644 frontend/src/utils/label-select/label-select.sass diff --git a/frontend/src/utils/label-select/label-select.js b/frontend/src/utils/label-select/label-select.js deleted file mode 100644 index 3002a379d..000000000 --- a/frontend/src/utils/label-select/label-select.js +++ /dev/null @@ -1,32 +0,0 @@ -import { Utility } from '../../core/utility'; - -import './label-select.sass'; - - -@Utility({ - selector: '.uw-label-select', -}) -export class LabelSelect { - - _element; - _app; - - constructor(element, app) { - if (!element) { - throw new Error('LabelSelect utility cannot be setup without an element!'); - } - - if (!app) { - throw new Error('LabelSelect utility cannot be setup without an app!'); - } - - this._element = element; - this._app = app; - } - - // TODO cleanUp event manager etc. - destroy() { - console.log('TODO LabelSelect destroy'); - } - -} diff --git a/frontend/src/utils/label-select/label-select.sass b/frontend/src/utils/label-select/label-select.sass deleted file mode 100644 index e69de29bb..000000000 diff --git a/frontend/src/utils/utils.js b/frontend/src/utils/utils.js index 86c2d7e05..8727b1844 100644 --- a/frontend/src/utils/utils.js +++ b/frontend/src/utils/utils.js @@ -15,7 +15,6 @@ import { PageActionsUtils } from './pageactions/pageactions'; import { HideColumns } from './hide-columns/hide-columns'; import { ExamCorrect } from './exam-correct/exam-correct'; import { SortTable } from './sort-table/sort-table'; -import { LabelSelect } from './label-select/label-select'; export const Utils = [ Alerts, @@ -36,5 +35,4 @@ export const Utils = [ HideColumns, ExamCorrect, SortTable, - LabelSelect, ]; From 544b9ef76260eb9aecb1a5ee2ca3467f08cd99f7 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Sat, 22 Jan 2022 01:42:34 +0100 Subject: [PATCH 32/50] feat(labels): label filter --- .../courses/exam/exam_office/de-de-formal.msg | 3 ++ .../courses/exam/exam_office/en-eu.msg | 3 ++ models/exam-office/exam-labels.model | 2 +- src/Handler/ExamOffice/Exams.hs | 41 ++++++++++++++----- 4 files changed, 37 insertions(+), 12 deletions(-) diff --git a/messages/uniworx/categories/courses/exam/exam_office/de-de-formal.msg b/messages/uniworx/categories/courses/exam/exam_office/de-de-formal.msg index ae3c2c7ab..90d102753 100644 --- a/messages/uniworx/categories/courses/exam/exam_office/de-de-formal.msg +++ b/messages/uniworx/categories/courses/exam/exam_office/de-de-formal.msg @@ -58,6 +58,8 @@ ExamOfficeFieldForced: Forcierte Einsicht ExamOfficeGetSynced: Synchronisiert-Status in Prüfungsliste anzeigen ExamOfficeGetSyncedTip: Soll unter „Prüfungen“ der Synchronisiert-Status zu jeder Prüfung angezeigt werden? (Ein Deaktivieren dieser Option kann zu kürzeren Ladezeiten der Prüfungsliste führen.) + +ExamLabel: Prüfungs-Label ExamOfficeGetLabels: Labels in Prüfungsliste anzeigen ExamOfficeGetLabelsTip: Sollen unter „Prüfungen“ die gesetzten Labels zu jeder Prüfung angezeigt werden? ExamOfficeLabels: Prüfungs-Labels @@ -66,3 +68,4 @@ ExamOfficeLabelName !ident-ok: Name ExamOfficeLabelStatus !ident-ok: Status ExamOfficeLabelPriority: Priorität ExamOfficeLabelAlreadyExists: Es existiert bereits ein Prüfungs-Label mit diesem Namen! +ExamOfficeExamsNoLabel: Kein Label diff --git a/messages/uniworx/categories/courses/exam/exam_office/en-eu.msg b/messages/uniworx/categories/courses/exam/exam_office/en-eu.msg index b499f22fe..1bfbb416a 100644 --- a/messages/uniworx/categories/courses/exam/exam_office/en-eu.msg +++ b/messages/uniworx/categories/courses/exam/exam_office/en-eu.msg @@ -56,6 +56,8 @@ ExamOfficeFieldForced: Forced access ExamOfficeGetSynced: Show synchronised status in exam list ExamOfficeGetSyncedTip: Should the synchronised status be displayed in “Exams”? (Disabling this option may lead to shorter loading times of the exam list.) + +ExamLabel: Exam label ExamOfficeGetLabels: Show labels in exam list ExamOfficeGetLabelsTip: Should the labels of each exam be displayed in “Exams”? ExamOfficeLabels: Exam labels @@ -64,3 +66,4 @@ ExamOfficeLabelName: Name ExamOfficeLabelStatus: Status ExamOfficeLabelPriority: Priority ExamOfficeLabelAlreadyExists: There already exists an exam label with this name! +ExamOfficeExamsNoLabel: No label diff --git a/models/exam-office/exam-labels.model b/models/exam-office/exam-labels.model index 9b31293b9..a22a8ebc7 100644 --- a/models/exam-office/exam-labels.model +++ b/models/exam-office/exam-labels.model @@ -3,7 +3,7 @@ ExamOfficeLabel name ExamOfficeLabelName status MessageStatus priority Int -- determines label ordering - UniqueExamOfficeLabel user name status + UniqueExamOfficeLabel user name deriving Generic ExamOfficeExamLabel diff --git a/src/Handler/ExamOffice/Exams.hs b/src/Handler/ExamOffice/Exams.hs index 115181b0c..796634074 100644 --- a/src/Handler/ExamOffice/Exams.hs +++ b/src/Handler/ExamOffice/Exams.hs @@ -21,6 +21,7 @@ import qualified Data.Conduit.Combinators as C data ExamsTableFilterProj = ExamsTableFilterProj { etProjFilterMayAccess :: Maybe Bool , etProjFilterHasResults :: Maybe Bool + , etProjFilterLabel :: Maybe (Either ExamOfficeExternalExamLabelId ExamOfficeExamLabelId) , etProjFilterIsSynced :: Maybe Bool } @@ -28,6 +29,7 @@ instance Default ExamsTableFilterProj where def = ExamsTableFilterProj { etProjFilterMayAccess = Nothing , etProjFilterHasResults = Nothing + , etProjFilterLabel = Nothing , etProjFilterIsSynced = Nothing } @@ -116,6 +118,7 @@ getEOExamsR :: Handler Html getEOExamsR = do (uid, User{..}) <- requireAuthPair now <- liftIO getCurrentTime + mr <- getMessageRender getSynced <- lookupGetParam "synced" >>= return . \case Just "yes" -> True @@ -128,6 +131,22 @@ getEOExamsR = do _ -> userExamOfficeGetLabels examsTable <- runDB $ do + let labelFilterNoLabelOption = Option + { optionDisplay = mr MsgExamOfficeExamsNoLabel + , optionInternalValue = Nothing + , optionExternalValue = "no-label" + } + labelFilterOptions <- mkOptionList . (labelFilterNoLabelOption :) <$> do + labels <- E.select . E.from $ \examOfficeLabel -> do + E.where_ $ examOfficeLabel E.^. ExamOfficeLabelUser E.==. E.val uid + E.orderBy [ E.asc $ examOfficeLabel E.^. ExamOfficeLabelName ] + return examOfficeLabel + return . flip map labels $ \(Entity lblId ExamOfficeLabel{..}) + -> Option { optionDisplay = examOfficeLabelName + , optionInternalValue = Just lblId + , optionExternalValue = examOfficeLabelName + } + let examLink :: Course -> Exam -> SomeRoute UniWorX examLink Course{..} Exam{..} @@ -236,13 +255,13 @@ getEOExamsR = do colLabel = Colonnade.singleton (fromSortable . Sortable (Just "label") $ i18nCell MsgTableExamLabel) $ \x -> flip runReader x $ do mLabel <- preview resultLabel - -- TODO: implement and use select widget for setting label + -- TODO: use select frontend util if | Just (Just (Entity _ ExamOfficeLabel{..})) <- mLabel -> return $ cell [whamlet| $newline never - #{examOfficeLabelName} + #{examOfficeLabelName} (_{examOfficeLabelStatus}, #{tshow examOfficeLabelPriority}) |] | otherwise -> return $ cell mempty @@ -315,17 +334,17 @@ getEOExamsR = do , sortTerm (to $ E.unsafeCoalesce . sequence [views queryCourse (E.?. CourseTerm), views queryExternalExam (E.?. ExternalExamTerm)]) ] - -- TODO: implement label filters: prio, status, name dbtFilter = mconcat $ - [ singletonMap "may-access" . FilterProjected $ (_etProjFilterMayAccess ?~) . getAny + [ singletonMap "may-access" . FilterProjected $ (_etProjFilterMayAccess ?~) . getAny , singletonMap "has-results" . FilterProjected $ (_etProjFilterHasResults ?~) . getAny - ] <> (bool mempty - [ singletonMap "is-synced" . FilterProjected $ (_etProjFilterIsSynced ?~) . getAny - ] getSynced) - dbtFilterUI = mconcat $ - (bool mempty - [ flip (prismAForm $ singletonFilter "is-synced" . maybePrism _PathPiece) $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgExamSynchronised) - ] getSynced) + , singletonMap "is-synced" . FilterProjected $ (_etProjFilterIsSynced ?~) . getAny + , singletonMap "label" . FilterColumn . E.mkExactFilter $ views queryLabelExam (E.?. ExamOfficeLabelId) + ] + dbtFilterUI mPrev = mconcat $ + [ prismAForm (singletonFilter "label" . maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgTableNoFilter) $ return labelFilterOptions) (fslI MsgExamLabel) + | getLabels ] <> + [ prismAForm (singletonFilter "is-synced" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgExamSynchronised) + | getSynced ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtParams = def From a2a8957c572166605e11b05fdef52cd2587e1411 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Sat, 22 Jan 2022 21:50:38 +0100 Subject: [PATCH 33/50] chore(testdata): add exam label test data --- test/Database/Fill.hs | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 1a3bd069c..4ed996c40 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -488,6 +488,22 @@ fillDb = do void . insert' $ UserSchool uid ifi False for_ [gkleen, tinaTester] $ \uid -> void . insert' $ UserSchool uid mi False + + let + examLabels = Map.fromList + [ ( sbarth + , [ ("In Bearbeitung" , Success , 4) + , ("Sonderfall" , Warning , 1) + , ("Zu überprüfen" , Error , 1) + , ("Weiterzuleiten" , Info , 3) + , ("Nicht zu bearbeiten" , Nonactive , -1) + ] + ) + ] + for_ (Map.toList examLabels) $ \(examOfficeLabelUser, labels) -> + for_ labels $ \(examOfficeLabelName, examOfficeLabelStatus, examOfficeLabelPriority) -> + void $ insert' ExamOfficeLabel{..} + let sdBsc = StudyDegreeKey' 82 sdMst = StudyDegreeKey' 88 From 9e81f03742586ef40e8ff896e303ba11d95f120a Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Mon, 24 Jan 2022 01:09:47 +0100 Subject: [PATCH 34/50] feat(labels): actions for setting and removing labels --- .../courses/exam/exam_office/de-de-formal.msg | 4 + .../courses/exam/exam_office/en-eu.msg | 4 + routes | 2 +- src/Handler/ExamOffice/Exams.hs | 76 ++++++++++++++++--- 4 files changed, 74 insertions(+), 12 deletions(-) diff --git a/messages/uniworx/categories/courses/exam/exam_office/de-de-formal.msg b/messages/uniworx/categories/courses/exam/exam_office/de-de-formal.msg index 90d102753..432900ace 100644 --- a/messages/uniworx/categories/courses/exam/exam_office/de-de-formal.msg +++ b/messages/uniworx/categories/courses/exam/exam_office/de-de-formal.msg @@ -69,3 +69,7 @@ ExamOfficeLabelStatus !ident-ok: Status ExamOfficeLabelPriority: Priorität ExamOfficeLabelAlreadyExists: Es existiert bereits ein Prüfungs-Label mit diesem Namen! ExamOfficeExamsNoLabel: Kein Label +ExamSetLabel: Label setzen +ExamLabelsSet n@Int: #{n} Prüfungs-#{pluralDE n "Label" "Labels"} gesetzt +ExamRemoveLabel: Label entfernen +ExamLabelsRemoved n@Int: #{n} Prüfungs-#{pluralDE n "Label" "Labels"} entfernt diff --git a/messages/uniworx/categories/courses/exam/exam_office/en-eu.msg b/messages/uniworx/categories/courses/exam/exam_office/en-eu.msg index 1bfbb416a..32f662a7f 100644 --- a/messages/uniworx/categories/courses/exam/exam_office/en-eu.msg +++ b/messages/uniworx/categories/courses/exam/exam_office/en-eu.msg @@ -67,3 +67,7 @@ ExamOfficeLabelStatus: Status ExamOfficeLabelPriority: Priority ExamOfficeLabelAlreadyExists: There already exists an exam label with this name! ExamOfficeExamsNoLabel: No label +ExamSetLabel: Set label +ExamLabelsSet n: Successfully set #{n} exam #{pluralEN n "label" "labels"} +ExamRemoveLabel: Remove label +ExamLabelsRemoved n: Successfully removed #{n} exam #{pluralEN n "label" "labels"} diff --git a/routes b/routes index 8051d646f..f5083251c 100644 --- a/routes +++ b/routes @@ -112,7 +112,7 @@ /user/storage-key StorageKeyR POST !free /exam-office ExamOfficeR !exam-office: - / EOExamsR GET !system-exam-office + / EOExamsR GET POST !system-exam-office /fields EOFieldsR GET POST /users EOUsersR GET POST !system-exam-office /users/invite EOUsersInviteR GET POST !system-exam-office diff --git a/src/Handler/ExamOffice/Exams.hs b/src/Handler/ExamOffice/Exams.hs index 796634074..352f2fb62 100644 --- a/src/Handler/ExamOffice/Exams.hs +++ b/src/Handler/ExamOffice/Exams.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} module Handler.ExamOffice.Exams - ( getEOExamsR + ( getEOExamsR, postEOExamsR ) where import Import @@ -16,6 +16,22 @@ import qualified Database.Esqueleto.Utils as E import qualified Colonnade import qualified Data.Conduit.Combinators as C +import qualified Data.Map as Map +import qualified Data.Set as Set + + +data ExamAction = ExamSetLabel | ExamRemoveLabel + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + deriving anyclass (Universe, Finite) + +nullaryPathPiece ''ExamAction $ camelToPathPiece' 1 +embedRenderMessage ''UniWorX ''ExamAction id + +data ExamActionData = ExamSetLabelData + { easlNewLabel :: ExamOfficeLabelId + } + | ExamRemoveLabelData + deriving (Eq, Ord, Read, Show, Generic, Typeable) data ExamsTableFilterProj = ExamsTableFilterProj @@ -114,8 +130,9 @@ 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 = do +getEOExamsR, postEOExamsR :: Handler Html +getEOExamsR = postEOExamsR +postEOExamsR = do (uid, User{..}) <- requireAuthPair now <- liftIO getCurrentTime mr <- getMessageRender @@ -130,7 +147,7 @@ getEOExamsR = do Just "no" -> False _ -> userExamOfficeGetLabels - examsTable <- runDB $ do + (examsRes, examsTable) <- runDB $ do let labelFilterNoLabelOption = Option { optionDisplay = mr MsgExamOfficeExamsNoLabel , optionInternalValue = Nothing @@ -160,6 +177,7 @@ getEOExamsR = do externalExamLink ExternalExam{..} = SomeRoute $ EExamR externalExamTerm externalExamSchool externalExamCourseName externalExamExamName EEGradesR + examsDBTable = DBTable{..} where dbtSQLQuery = runReaderT $ do @@ -203,7 +221,7 @@ getEOExamsR = do dbtRowKey = views ($(multifocusG 2) queryExam queryExternalExam) (bimap (E.?. ExamId) (E.?. ExternalExamId)) dbtProj :: _ ExamsTableData - dbtProj = (views _dbtProjRow . set _dbrOutput) =<< do -- dbtProjSimple . runReaderT $ do + dbtProj = (views _dbtProjRow . set _dbrOutput) =<< do exam <- view $ _dbtProjRow . _dbrOutput . _1 course <- view $ _dbtProjRow . _dbrOutput . _2 school <- view $ _dbtProjRow . _dbrOutput . _3 @@ -313,18 +331,18 @@ getEOExamsR = do , emptyOpticColonnade (resultCourse . _entityVal . _courseTerm <> resultExternalExam . _entityVal . _externalExamTerm) colTermShort ] dbtSorting = mconcat $ - (bool mempty + bool mempty [ singletonMap "label-prio" $ SortProjected . comparing $ (fmap . fmap $ examOfficeLabelPriority . entityVal) <$> preview resultLabel , singletonMap "label-status" $ SortProjected . comparing $ (fmap . fmap $ examOfficeLabelStatus . entityVal) <$> preview resultLabel - ] getLabels) <> - (bool mempty + ] getLabels <> + bool mempty [ singletonMap "synced" $ SortProjected . comparing $ ((/) `on` toRational . fromMaybe 0) <$> view resultSynchronised <*> view resultResults , singletonMap "is-synced" $ SortProjected . comparing $ (>=) <$> view resultSynchronised <*> view resultResults - ] getSynced) <> + ] getSynced <> [ sortExamName (to $ E.unsafeCoalesce . sequence [views queryExam (E.?. ExamName), views queryExternalExam (E.?. ExternalExamExamName)]) , sortExamTime (queryExam . $(multifocusG 2) (to $ E.joinV . (E.?. ExamStart)) (to $ E.joinV . (E.?. ExamEnd))) , sortExamFinished (queryExam . to (E.joinV . (E.?. ExamFinished))) @@ -347,7 +365,28 @@ getEOExamsR = do | getSynced ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } - dbtParams = def + + dbtParams = DBParamsForm + { dbParamsFormMethod = POST + , dbParamsFormAction = Just . SomeRoute $ ExamOfficeR EOExamsR + , dbParamsFormAttrs = [] + , dbParamsFormSubmit = FormSubmit + , dbParamsFormAdditional + = let actions :: Map ExamAction (AForm Handler ExamActionData) + actions = Map.fromList $ + bool mempty + [ ( ExamSetLabel, ExamSetLabelData + <$> apopt (selectField' Nothing . fmap (fmap entityKey) $ optionsPersist [ExamOfficeLabelUser ==. uid] [Asc ExamOfficeLabelName] examOfficeLabelName) (fslI MsgExamLabel) Nothing + ) + , ( ExamRemoveLabel, pure ExamRemoveLabelData ) + ] getLabels + in renderAForm FormStandard + $ (, mempty) . First . Just + <$> multiActionA actions (fslI MsgTableAction) Nothing + , dbParamsFormEvaluate = liftHandler . runFormPost + , dbParamsFormResult = id + , dbParamsFormIdent = def + } dbtIdent :: Text dbtIdent = "exams" @@ -362,7 +401,22 @@ getEOExamsR = do & forceFilter "may-access" (Any True) & forceFilter "has-results" (Any True) - dbTableWidget' examsDBTableValidator examsDBTable + postprocess :: FormResult (First ExamActionData, DBFormResult (Either ExternalExamId ExamId) Bool (DBRow (Either (Entity ExternalExam) (Entity Exam)))) -> FormResult (ExamActionData, Set (Either ExternalExamId ExamId)) + postprocess (FormFailure errs) = FormFailure errs + postprocess FormMissing = FormMissing + postprocess (FormSuccess (First mExamActionData, examRes)) = maybe FormMissing (\act -> FormSuccess . (act,) . Map.keysSet . Map.filter id $ getDBFormResult (const False) examRes) mExamActionData + + over _1 postprocess <$> dbTable examsDBTableValidator examsDBTable + + formResult examsRes $ \(examAction, exams) -> case examAction of + ExamSetLabelData{..} -> do + runDB . forM_ (Set.toList exams) $ either (\eeid -> void $ upsert (ExamOfficeExternalExamLabel eeid easlNewLabel) [ExamOfficeExternalExamLabelLabel =. easlNewLabel]) (\eid -> void $ upsert (ExamOfficeExamLabel eid easlNewLabel) [ExamOfficeExamLabelLabel =. easlNewLabel]) + addMessageI Success $ MsgExamLabelsSet (Set.size exams) + redirect $ ExamOfficeR EOExamsR + ExamRemoveLabelData -> do + runDB . forM_ (Set.toList exams) $ either delete delete + addMessageI Success $ MsgExamLabelsRemoved (Set.size exams) + redirect $ ExamOfficeR EOExamsR siteLayoutMsg MsgHeadingExamList $ do setTitleI MsgHeadingExamList From 42f58da44fe1b0cc016979b9cde0300832cc0ae1 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Mon, 24 Jan 2022 19:16:33 +0100 Subject: [PATCH 35/50] feat(eo-exams): select column for exam list in case of actions --- src/Handler/ExamOffice/Exams.hs | 39 ++++++++++++++++++--------------- 1 file changed, 21 insertions(+), 18 deletions(-) diff --git a/src/Handler/ExamOffice/Exams.hs b/src/Handler/ExamOffice/Exams.hs index 352f2fb62..abdf5e4a9 100644 --- a/src/Handler/ExamOffice/Exams.hs +++ b/src/Handler/ExamOffice/Exams.hs @@ -128,8 +128,7 @@ 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 +-- | List of all exams where the current user may (in their function as exam-office) access users grades getEOExamsR, postEOExamsR :: Handler Html getEOExamsR = postEOExamsR postEOExamsR = do @@ -177,6 +176,14 @@ postEOExamsR = do externalExamLink ExternalExam{..} = SomeRoute $ EExamR externalExamTerm externalExamSchool externalExamCourseName externalExamExamName EEGradesR + examActions :: Map ExamAction (AForm Handler ExamActionData) + examActions = Map.fromList $ + bool mempty + [ ( ExamSetLabel, ExamSetLabelData + <$> apopt (selectField' Nothing . fmap (fmap entityKey) $ optionsPersist [ExamOfficeLabelUser ==. uid] [Asc ExamOfficeLabelName] examOfficeLabelName) (fslI MsgExamLabel) Nothing + ) + , ( ExamRemoveLabel, pure ExamRemoveLabelData ) + ] getLabels examsDBTable = DBTable{..} where @@ -316,7 +323,8 @@ postEOExamsR = do dbtColonnade :: Colonnade Sortable _ _ dbtColonnade = mconcat - [ bool mempty colLabel getLabels + [ bool mempty (dbSelect (applying _2) id $ \DBRow{ dbrOutput=(ex,_,_) } -> return $ bimap (\(Entity eeId _,_) -> eeId) (\(Entity eId _,_,_,_) -> eId) ex) (not $ Map.null examActions) + , bool mempty colLabel getLabels , bool mempty colSynced getSynced , maybeAnchorColonnade ( runMaybeT $ mpreview ($(multifocusG 2) (pre $ resultCourse . _entityVal) (pre $ resultExam . _entityVal) . to (uncurry $ liftA2 examLink) . _Just) <|> mpreviews (resultExternalExam . _entityVal) externalExamLink @@ -372,17 +380,9 @@ postEOExamsR = do , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormSubmit , dbParamsFormAdditional - = let actions :: Map ExamAction (AForm Handler ExamActionData) - actions = Map.fromList $ - bool mempty - [ ( ExamSetLabel, ExamSetLabelData - <$> apopt (selectField' Nothing . fmap (fmap entityKey) $ optionsPersist [ExamOfficeLabelUser ==. uid] [Asc ExamOfficeLabelName] examOfficeLabelName) (fslI MsgExamLabel) Nothing - ) - , ( ExamRemoveLabel, pure ExamRemoveLabelData ) - ] getLabels - in renderAForm FormStandard - $ (, mempty) . First . Just - <$> multiActionA actions (fslI MsgTableAction) Nothing + = renderAForm FormStandard + $ (, mempty) . First . Just + <$> multiActionA examActions (fslI MsgTableAction) Nothing , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormResult = id , dbParamsFormIdent = def @@ -401,10 +401,13 @@ postEOExamsR = do & forceFilter "may-access" (Any True) & forceFilter "has-results" (Any True) - postprocess :: FormResult (First ExamActionData, DBFormResult (Either ExternalExamId ExamId) Bool (DBRow (Either (Entity ExternalExam) (Entity Exam)))) -> FormResult (ExamActionData, Set (Either ExternalExamId ExamId)) - postprocess (FormFailure errs) = FormFailure errs - postprocess FormMissing = FormMissing - postprocess (FormSuccess (First mExamActionData, examRes)) = maybe FormMissing (\act -> FormSuccess . (act,) . Map.keysSet . Map.filter id $ getDBFormResult (const False) examRes) mExamActionData + postprocess :: FormResult (First ExamActionData , DBFormResult (Either ExternalExamId ExamId) Bool (DBRow (Either (Entity ExternalExam, Maybe (Entity ExamOfficeLabel)) (Entity Exam, Entity Course, Entity School, Maybe (Entity ExamOfficeLabel)), Maybe Natural, Maybe Natural))) + -> FormResult ( ExamActionData , Set (Either ExternalExamId ExamId)) + postprocess (FormFailure errs) = FormFailure errs + postprocess FormMissing = FormMissing + postprocess (FormSuccess (First mExamActionData, examRes)) + | Just act <- mExamActionData = FormSuccess . (act,) . Map.keysSet . Map.filter id $ getDBFormResult (const False) examRes + | otherwise = FormMissing over _1 postprocess <$> dbTable examsDBTableValidator examsDBTable From b1991eead90a21a296fa0436485ea2532223c72d Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Mon, 24 Jan 2022 19:33:26 +0100 Subject: [PATCH 36/50] fix(labels): fix exam-label delete action --- src/Handler/ExamOffice/Exams.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Handler/ExamOffice/Exams.hs b/src/Handler/ExamOffice/Exams.hs index abdf5e4a9..366f226d6 100644 --- a/src/Handler/ExamOffice/Exams.hs +++ b/src/Handler/ExamOffice/Exams.hs @@ -417,7 +417,9 @@ postEOExamsR = do addMessageI Success $ MsgExamLabelsSet (Set.size exams) redirect $ ExamOfficeR EOExamsR ExamRemoveLabelData -> do - runDB . forM_ (Set.toList exams) $ either delete delete + runDB . forM_ (Set.toList exams) $ either + (\eeId -> E.delete . E.from $ \extExLabel -> E.where_ (extExLabel E.^. ExamOfficeExternalExamLabelExternalExam E.==. E.val eeId)) + (\eId -> E.delete . E.from $ \exLabel -> E.where_ (exLabel E.^. ExamOfficeExamLabelExam E.==. E.val eId)) addMessageI Success $ MsgExamLabelsRemoved (Set.size exams) redirect $ ExamOfficeR EOExamsR From 7764265deee4c0a085becca597930c06b93b2cf4 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Tue, 25 Jan 2022 00:04:06 +0100 Subject: [PATCH 37/50] style(labels): display labels as pill --- frontend/src/app.sass | 25 ++++++++++++++++++++++ src/Handler/ExamOffice/Exams.hs | 6 +----- templates/widgets/exam-office-label.hamlet | 4 ++++ 3 files changed, 30 insertions(+), 5 deletions(-) create mode 100644 templates/widgets/exam-office-label.hamlet diff --git a/frontend/src/app.sass b/frontend/src/app.sass index fe1160511..6ee3f9a04 100644 --- a/frontend/src/app.sass +++ b/frontend/src/app.sass @@ -1745,3 +1745,28 @@ video font-size: .5em font-family: var(--font-monospace) color: var(--color-fontsec) + +.exam-office-label + --lbl-padding-vert: 5px + --lbl-padding-hori: 15px + padding: var(--lbl-padding-vert) var(--lbl-padding-hori) + border-radius: 20px 20px 20px 20px + font-weight: 600 + text-align: center + width: fit-content + margin: 0 auto + &.success + background-color: var(--color-success-dark) + color: var(--color-lightwhite) + &.error + background-color: var(--color-error) + color: var(--color-lightwhite) + &.warning + background-color: var(--color-warning) + color: var(--color-lightwhite) + &.info + background-color: var(--color-lightblack) + color: var(--color-lightwhite) + &.nonactive + background-color: var(--color-nonactive) + color: var(--color-nonactive-dark) diff --git a/src/Handler/ExamOffice/Exams.hs b/src/Handler/ExamOffice/Exams.hs index 366f226d6..0f61875e6 100644 --- a/src/Handler/ExamOffice/Exams.hs +++ b/src/Handler/ExamOffice/Exams.hs @@ -283,11 +283,7 @@ postEOExamsR = do -- TODO: use select frontend util if | Just (Just (Entity _ ExamOfficeLabel{..})) <- mLabel - -> return $ cell - [whamlet| - $newline never - #{examOfficeLabelName} (_{examOfficeLabelStatus}, #{tshow examOfficeLabelPriority}) - |] + -> return $ cell $(widgetFile "widgets/exam-office-label") | otherwise -> return $ cell mempty colSynced = Colonnade.singleton (fromSortable . Sortable (Just "synced") $ i18nCell MsgExamSynchronised) $ \x -> flip runReader x $ do diff --git a/templates/widgets/exam-office-label.hamlet b/templates/widgets/exam-office-label.hamlet new file mode 100644 index 000000000..db8d43354 --- /dev/null +++ b/templates/widgets/exam-office-label.hamlet @@ -0,0 +1,4 @@ +$newline never + +
+ #{examOfficeLabelName} From da39b05627058a1472929b46ae1c2adb0b1fe2c9 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Wed, 26 Jan 2022 00:43:57 +0100 Subject: [PATCH 38/50] fix(labels): implement label deletion on ProfileR --- src/Handler/Profile.hs | 29 ++++++++++++++--------------- 1 file changed, 14 insertions(+), 15 deletions(-) diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 06c297d38..99b06a835 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -460,7 +460,7 @@ postProfileR = do E.&&. userSchool E.^. UserSchoolUser E.==. E.val uid E.&&. userSchool E.^. UserSchoolSchool E.==. school E.^. SchoolId return $ school E.^. SchoolId - userExamOfficeLabels <- fmap (foldMap $ \(Entity eolid ExamOfficeLabel{..}) -> Map.singleton (Right eolid) (examOfficeLabelName,examOfficeLabelStatus,examOfficeLabelPriority)) (selectList [ ExamOfficeLabelUser ==. uid ] []) + userExamOfficeLabels <- selectList [ ExamOfficeLabelUser ==. uid ] [] return (userSchools, userExamOfficeLabels) allocs <- runDB $ getAllocationNotifications uid let settingsTemplate = Just SettingsForm @@ -480,7 +480,7 @@ postProfileR = do , stgExamOfficeSettings = ExamOfficeSettings { eosettingsGetSynced = userExamOfficeGetSynced , eosettingsGetLabels = userExamOfficeGetLabels - , eosettingsLabels = userExamOfficeLabels + , eosettingsLabels = flip foldMap userExamOfficeLabels $ \(Entity eolid ExamOfficeLabel{..}) -> Map.singleton (Right eolid) (examOfficeLabelName,examOfficeLabelStatus,examOfficeLabelPriority) } , stgAllocationNotificationSettings = allocs } @@ -527,8 +527,14 @@ postProfileR = do } [ UserSchoolIsOptOut =. True ] - -- TODO: delete labels - forM_ (Map.toList $ stgExamOfficeSettings & eosettingsLabels) $ \(eoLabelIdent, (examOfficeLabelName, examOfficeLabelStatus, examOfficeLabelPriority)) -> case eoLabelIdent of + let + oldExamLabels = userExamOfficeLabels + newExamLabels = stgExamOfficeSettings & eosettingsLabels + forM_ oldExamLabels $ \(Entity eolid ExamOfficeLabel{..}) -> unless ((Right eolid) `Map.member` newExamLabels || (Left examOfficeLabelName) `Map.member` newExamLabels) $ do + E.delete . E.from $ \examOfficeExternalExamLabel -> E.where_ $ examOfficeExternalExamLabel E.^. ExamOfficeExternalExamLabelLabel E.==. E.val eolid + E.delete . E.from $ \examOfficeExamLabel -> E.where_ $ examOfficeExamLabel E.^. ExamOfficeExamLabelLabel E.==. E.val eolid + delete eolid + forM_ (Map.toList newExamLabels) $ \(eoLabelIdent, (examOfficeLabelName, examOfficeLabelStatus, examOfficeLabelPriority)) -> case eoLabelIdent of Left _ -> void $ upsert ExamOfficeLabel{ examOfficeLabelUser=uid, .. } [ ExamOfficeLabelName =. examOfficeLabelName , ExamOfficeLabelStatus =. examOfficeLabelStatus @@ -587,7 +593,6 @@ getProfileDataR = do makeProfileData :: Entity User -> DB Widget makeProfileData (Entity uid User{..}) = do - -- MsgRenderer mr <- getMsgRenderer functions <- Map.fromListWith Set.union . map (\(Entity _ UserFunction{..}) -> (userFunctionFunction, Set.singleton userFunctionSchool)) <$> selectList [UserFunctionUser ==. uid] [] lecture_corrector <- E.select $ E.distinct $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId @@ -619,8 +624,8 @@ makeProfileData (Entity uid User{..}) = do +-- | Table listing all courses that the given user is a lecturer for mkOwnedCoursesTable :: UserId -> DB (Bool, Widget) --- Table listing all courses that the given user is a lecturer for mkOwnedCoursesTable = let dbtIdent = "courseOwnership" :: Text dbtStyle = def @@ -670,9 +675,8 @@ mkOwnedCoursesTable = in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in (_1 %~ getAny) <$> dbTableWidget validator DBTable{..} - +-- | Table listing all courses that the given user is enrolled in mkEnrolledCoursesTable :: UserId -> DB Widget --- Table listing all courses that the given user is enrolled in mkEnrolledCoursesTable = let withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a) -> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a) @@ -723,9 +727,8 @@ mkEnrolledCoursesTable = } - +-- | Table listing all submissions for the given user mkSubmissionTable :: UserId -> DB Widget --- Table listing all submissions for the given user mkSubmissionTable = let dbtIdent = "submissions" :: Text dbtStyle = def @@ -809,9 +812,8 @@ mkSubmissionTable = -- return $ dbTableWidget' validator $ DBTable {..} - +-- | Table listing all submissions for the given user mkSubmissionGroupTable :: UserId -> DB Widget --- Table listing all submissions for the given user mkSubmissionGroupTable = let dbtIdent = "subGroups" :: Text dbtStyle = def @@ -866,13 +868,10 @@ mkSubmissionGroupTable = in dbTableWidget' validator DBTable{..} - mkCorrectionsTable :: UserId -> DB Widget --- Table listing sum of corrections made by the given user per sheet mkCorrectionsTable = let dbtIdent = "corrections" :: Text dbtStyle = def --- TODO Continue here withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity SheetCorrector))->a) -> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity SheetCorrector))->a) withType = id From de917a8d8646c4df599d945bc4979e226dd5192f Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Wed, 26 Jan 2022 19:24:04 +0100 Subject: [PATCH 39/50] feat(csv): add export-exam-label as csv option --- .../settings/csv_options/de-de-formal.msg | 2 ++ .../categories/settings/csv_options/en-eu.msg | 2 ++ src/Handler/Profile.hs | 8 +++++++- src/Handler/Utils/Form.hs | 10 +++++++++- src/Model/Types/Csv.hs | 20 +++++++++++-------- 5 files changed, 32 insertions(+), 10 deletions(-) diff --git a/messages/uniworx/categories/settings/csv_options/de-de-formal.msg b/messages/uniworx/categories/settings/csv_options/de-de-formal.msg index 5041a5918..31d411eb0 100644 --- a/messages/uniworx/categories/settings/csv_options/de-de-formal.msg +++ b/messages/uniworx/categories/settings/csv_options/de-de-formal.msg @@ -3,6 +3,8 @@ CsvOptionsTip: Diese Einstellungen betreffen primär den CSV-Export; beim Import CsvFormatOptions: Dateiformat CsvTimestamp: Zeitstempel CsvTimestampTip: Soll an den Namen jeder exportierten CSV-Datei ein Zeitstempel vorne angehängt werden? +CsvExportLabel: Prüfungs-Label bei Export +CsvExportLabelTip: Soll beim CSV-Export von Prüfungsleistungen automatisch ein gegebenes Label für diese Prüfung gesetzt werden? CsvPresetRFC: Standard-Konform (RFC 4180) CsvPresetExcel: Excel-Kompatibel CsvCustom: Benutzerdefiniert diff --git a/messages/uniworx/categories/settings/csv_options/en-eu.msg b/messages/uniworx/categories/settings/csv_options/en-eu.msg index 2900dc672..2f9d76ab8 100644 --- a/messages/uniworx/categories/settings/csv_options/en-eu.msg +++ b/messages/uniworx/categories/settings/csv_options/en-eu.msg @@ -3,6 +3,8 @@ CsvOptionsTip: These settings primarily affect CSV export. During import most se CsvFormatOptions: File format CsvTimestamp: Timestamp CsvTimestampTip: Should the name of every exported csv file contain a timestamp? +CsvExportLabel: Exam label on export +CsvExportLabelTip: Should a given label be automatically set for an exam of which results are exported to CSV? CsvPresetRFC: Standards-compliant (RFC 4180) CsvPresetExcel: Excel compatible CsvCustom: User defined diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 99b06a835..6ce9b02dc 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -1061,8 +1061,14 @@ getCsvOptionsR = postCsvOptionsR postCsvOptionsR = do Entity uid User{userCsvOptions} <- requireAuth + userIsExamOffice <- hasReadAccessTo $ ExamOfficeR EOExamsR + examOfficeLabels <- if not userIsExamOffice then return mempty else runDB . E.select . E.from $ \examOfficeLabel -> do + E.where_ $ examOfficeLabel E.^. ExamOfficeLabelUser E.==. E.val uid + E.orderBy [ E.asc (examOfficeLabel E.^. ExamOfficeLabelName) ] + return $ examOfficeLabel E.^. ExamOfficeLabelName + ((optionsRes, optionsWgt'), optionsEnctype) <- runFormPost . renderAForm FormStandard $ - csvOptionsForm (Just userCsvOptions) + csvOptionsForm (Just userCsvOptions) (Set.fromList $ E.unValue <$> examOfficeLabels) formResultModal optionsRes CsvOptionsR $ \opts -> do lift . runDB $ update uid [ UserCsvOptions =. opts ] diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 92940d471..b39d89428 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -2125,10 +2125,18 @@ csvOptionsForm :: forall m. , HandlerSite m ~ UniWorX ) => Maybe CsvOptions + -> Set ExamOfficeLabelName -> AForm m CsvOptions -csvOptionsForm mPrev = hoistAForm liftHandler $ CsvOptions +csvOptionsForm mPrev (Set.toList -> exportLabels) = hoistAForm liftHandler $ CsvOptions <$> csvFormatOptionsForm (fslI MsgCsvFormatOptions & setTooltip MsgCsvOptionsTip) (csvFormat <$> mPrev) <*> apopt checkBoxField (fslI MsgCsvTimestamp & setTooltip MsgCsvTimestampTip) (csvTimestamp <$> mPrev) + <*> bool (aopt (selectField $ return exportLabelOptions) (fslI MsgCsvExportLabel & setTooltip MsgCsvExportLabelTip) (csvExportLabel <$> mPrev)) (pure Nothing) (null exportLabels) + where + exportLabelOptions = mkOptionList $ exportLabels <&> \exportLabel -> Option + { optionDisplay = exportLabel + , optionInternalValue = exportLabel + , optionExternalValue = exportLabel + } courseSelectForm :: forall ident handler. diff --git a/src/Model/Types/Csv.hs b/src/Model/Types/Csv.hs index 88f183de9..ca7ec802b 100644 --- a/src/Model/Types/Csv.hs +++ b/src/Model/Types/Csv.hs @@ -51,8 +51,9 @@ nullaryPathPiece ''Quoting $ \q -> if data CsvOptions = CsvOptions - { csvFormat :: CsvFormatOptions - , csvTimestamp :: Bool + { csvFormat :: CsvFormatOptions + , csvTimestamp :: Bool + , csvExportLabel :: Maybe Text } deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving anyclass (Hashable, NFData) @@ -73,8 +74,9 @@ makeLenses_ ''CsvFormatOptions instance Default CsvOptions where def = CsvOptions - { csvFormat = def - , csvTimestamp = False + { csvFormat = def + , csvTimestamp = False + , csvExportLabel = Nothing } instance Default CsvFormatOptions where @@ -128,14 +130,16 @@ _CsvEncodeOptions = prism' fromEncode toEncode instance ToJSON CsvOptions where toJSON CsvOptions{..} = JSON.object - [ "format" JSON..= csvFormat - , "timestamp" JSON..= csvTimestamp + [ "format" JSON..= csvFormat + , "timestamp" JSON..= csvTimestamp + , "export-label" JSON..= csvExportLabel ] instance FromJSON CsvOptions where parseJSON = JSON.withObject "CsvOptions" $ \o -> do - csvFormat <- o JSON..:? "format" JSON..!= csvFormat def - csvTimestamp <- o JSON..:? "timestamp" JSON..!= csvTimestamp def + csvFormat <- o JSON..:? "format" JSON..!= csvFormat def + csvTimestamp <- o JSON..:? "timestamp" JSON..!= csvTimestamp def + csvExportLabel <- o JSON..:? "export-label" JSON..!= csvExportLabel def return CsvOptions{..} data CsvFormat = FormatCsv | FormatXlsx From 1caba13ac3fdbf001f070d5ca19f247da23b956a Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Wed, 26 Jan 2022 22:06:33 +0100 Subject: [PATCH 40/50] chore(profile): delete csvExportLabel on label deletion --- src/Handler/Profile.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 6ce9b02dc..e45e24e03 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -533,6 +533,8 @@ postProfileR = do forM_ oldExamLabels $ \(Entity eolid ExamOfficeLabel{..}) -> unless ((Right eolid) `Map.member` newExamLabels || (Left examOfficeLabelName) `Map.member` newExamLabels) $ do E.delete . E.from $ \examOfficeExternalExamLabel -> E.where_ $ examOfficeExternalExamLabel E.^. ExamOfficeExternalExamLabelLabel E.==. E.val eolid E.delete . E.from $ \examOfficeExamLabel -> E.where_ $ examOfficeExamLabel E.^. ExamOfficeExamLabelLabel E.==. E.val eolid + when (csvExportLabel userCsvOptions == Just examOfficeLabelName) $ + update uid [ UserCsvOptions =. userCsvOptions { csvExportLabel = Nothing } ] delete eolid forM_ (Map.toList newExamLabels) $ \(eoLabelIdent, (examOfficeLabelName, examOfficeLabelStatus, examOfficeLabelPriority)) -> case eoLabelIdent of Left _ -> void $ upsert ExamOfficeLabel{ examOfficeLabelUser=uid, .. } From 4557fdda928fa5f24f4da48aff44fa8b8d955344 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Wed, 26 Jan 2022 23:42:45 +0100 Subject: [PATCH 41/50] feat(labels): set export label on exam csv export --- .../courses/exam/exam_office/de-de-formal.msg | 3 +++ .../courses/exam/exam_office/en-eu.msg | 3 +++ src/Handler/ExamOffice/Exam.hs | 23 +++++++++++++++---- src/Handler/Utils/ExternalExam/Users.hs | 2 +- .../exam-office/exam-result-synced.hamlet | 2 +- 5 files changed, 26 insertions(+), 7 deletions(-) diff --git a/messages/uniworx/categories/courses/exam/exam_office/de-de-formal.msg b/messages/uniworx/categories/courses/exam/exam_office/de-de-formal.msg index 432900ace..db7a4baa0 100644 --- a/messages/uniworx/categories/courses/exam/exam_office/de-de-formal.msg +++ b/messages/uniworx/categories/courses/exam/exam_office/de-de-formal.msg @@ -73,3 +73,6 @@ ExamSetLabel: Label setzen ExamLabelsSet n@Int: #{n} Prüfungs-#{pluralDE n "Label" "Labels"} gesetzt ExamRemoveLabel: Label entfernen ExamLabelsRemoved n@Int: #{n} Prüfungs-#{pluralDE n "Label" "Labels"} entfernt +ExamOfficeLabelSetLabelOnExport: Prüfungs-Label beim Export setzen +ExamOfficeLabelSetLabelOnExportTip t@Text: Soll beim CSV-Export automatisch das Export-Label für die jeweilige Prüfung gesetzt werden? Von Ihnen gesetzte Prüfungs-Label sind ausschließlich für Sie sichtbar und können von jedem Prüfungsbeauftragten unabhängig voneinander verwaltet bzw. verwendet werden. Ihr aktuell für den CSV-Export eingestelltes Prüfungs-Label ist „#{t}“. Sie können das zu setzende Prüfungs-Label unter „Export-Optionen“ oder in Ihren persönlichen Benutzereinstellungen ändern. +ExamOfficeLabelSetLabelOnExportForcedTip: Soll beim CSV-Export automatisch das Export-Label für die jeweilige Prüfung gesetzt werden? Von Ihnen gesetzte Prüfungs-Label sind ausschließlich für Sie sichtbar und können von jedem Prüfungsbeauftragten unabhängig voneinander verwaltet bzw. verwendet werden. Sie haben aktuell kein Export-Label festgelegt und können diese Option daher nicht auswählen. Sie können das beim CSV-Export zu setzende Prüfungs-Label unter „Export-Optionen“ oder in Ihren persönlichen Benutzereinstellungen wählen. diff --git a/messages/uniworx/categories/courses/exam/exam_office/en-eu.msg b/messages/uniworx/categories/courses/exam/exam_office/en-eu.msg index 32f662a7f..397e21d7f 100644 --- a/messages/uniworx/categories/courses/exam/exam_office/en-eu.msg +++ b/messages/uniworx/categories/courses/exam/exam_office/en-eu.msg @@ -71,3 +71,6 @@ ExamSetLabel: Set label ExamLabelsSet n: Successfully set #{n} exam #{pluralEN n "label" "labels"} ExamRemoveLabel: Remove label ExamLabelsRemoved n: Successfully removed #{n} exam #{pluralEN n "label" "labels"} +ExamOfficeLabelSetLabelOnExport: Set exam label while exporting +ExamOfficeLabelSetLabelOnExportTip t: Should the export label be set for the respective exam? Your set exam labels are exclusively visible to you and may be managed and used by each exam office member independently. Your saved exam label for CSV export is currently “#{t}”. You can change the exam label set while exporting under “Export options” or in your user settings. +ExamOfficeLabelSetLabelOnExportForcedTip: Should the export label be set for the respective exam? Your set exam labels are exclusively visible to you and may be managed and used by each exam office member independently. You do not currently have any exam label selected as export label and therefor cannot active this setting. To set an exam label as export label, go to “Export options” or your user settings. diff --git a/src/Handler/ExamOffice/Exam.hs b/src/Handler/ExamOffice/Exam.hs index cc631665f..338bf284f 100644 --- a/src/Handler/ExamOffice/Exam.hs +++ b/src/Handler/ExamOffice/Exam.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints -fno-warn-name-shadowing #-} module Handler.ExamOffice.Exam ( getEGradesR, postEGradesR @@ -216,16 +216,18 @@ embedRenderMessage ''UniWorX ''ExamUserAction id data ExamUserActionData = ExamUserMarkSynchronisedData -newtype ExamUserCsvExportData = ExamUserCsvExportData +data ExamUserCsvExportData = ExamUserCsvExportData { csvEUserMarkSynchronised :: Bool - } deriving (Eq, Ord, Read, Show, Generic, Typeable) + , csvEUserSetLabel :: Bool + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) -- | View a list of all users' grades that the current user has access to getEGradesR, postEGradesR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html getEGradesR = postEGradesR postEGradesR tid ssh csh examn = do - uid <- requireAuthId + Entity uid User{..} <- requireAuth now <- liftIO getCurrentTime ((usersResult, examUsersTable), Entity eId Exam{examFinished}) <- runDB $ do exam@(Entity eid Exam{..}) <- fetchExam tid ssh csh examn @@ -234,6 +236,12 @@ postEGradesR tid ssh csh examn = do isLecturer <- hasReadAccessTo $ CExamR tid ssh csh examn EUsersR userFunctions <- selectList [ UserFunctionUser ==. uid, UserFunctionFunction ==. SchoolExamOffice ] [] + userCsvExportLabel' <- E.select . E.from $ \examOfficeLabel -> do + E.where_ $ maybe E.false (\expLbl -> examOfficeLabel E.^. ExamOfficeLabelName E.==. E.val expLbl) (csvExportLabel userCsvOptions) + E.&&. examOfficeLabel E.^. ExamOfficeLabelUser E.==. E.val uid + return examOfficeLabel + let userCsvExportLabel = listToMaybe userCsvExportLabel' + let participantLink :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m (SomeRoute UniWorX) participantLink partId = liftHandler $ do @@ -332,7 +340,7 @@ postEGradesR tid ssh csh examn = do colSynced = Colonnade.singleton (fromSortable . Sortable (Just "is-synced") $ i18nCell MsgExamUserSynchronised) $ \x -> cell . flip runReaderT x $ do syncs <- asks $ sortOn (Down . view _3) . toListOf resultSynchronised lastChange <- view $ resultExamResult . _entityVal . _examResultLastChanged - user <- view $ resultUser . _entityVal + User{..} <- view $ resultUser . _entityVal isSynced <- view resultIsSynced let hasSyncs = has folded syncs @@ -431,8 +439,13 @@ postEGradesR tid ssh csh examn = do dbtCsvEncode = Just DBTCsvEncode { dbtCsvExportForm = ExamUserCsvExportData <$> apopt checkBoxField (fslI MsgExamOfficeExamUserMarkSynchronisedCsv & setTooltip MsgExamOfficeExamUserMarkSynchronisedCsvTip) (Just False) + <*> maybe + (aforced checkBoxField (fslI MsgExamOfficeLabelSetLabelOnExport & setTooltip MsgExamOfficeLabelSetLabelOnExportForcedTip) True) + (\expLbl -> apopt checkBoxField (fslI MsgExamOfficeLabelSetLabelOnExport & setTooltip (MsgExamOfficeLabelSetLabelOnExportTip expLbl)) (Just True)) + ((examOfficeLabelName . entityVal) <$> userCsvExportLabel) , dbtCsvDoEncode = \ExamUserCsvExportData{..} -> C.mapM $ \(E.Value k, row) -> do when csvEUserMarkSynchronised $ markSynced k + when csvEUserSetLabel $ maybe (return ()) (\lbl -> void $ upsert (ExamOfficeExamLabel eid lbl) [ExamOfficeExamLabelLabel =. lbl]) (entityKey <$> userCsvExportLabel) return $ ExamUserTableCsv (row ^. resultUser . _entityVal . _userSurname) (row ^. resultUser . _entityVal . _userFirstName) diff --git a/src/Handler/Utils/ExternalExam/Users.hs b/src/Handler/Utils/ExternalExam/Users.hs index 70a20fec6..f9ed09ce7 100644 --- a/src/Handler/Utils/ExternalExam/Users.hs +++ b/src/Handler/Utils/ExternalExam/Users.hs @@ -245,7 +245,7 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do colSynced = Colonnade.singleton (fromSortable . Sortable (Just "is-synced") $ i18nCell MsgExternalExamUserSynchronised) $ \x -> cell . flip runReaderT x $ do syncs <- asks $ sortOn (Down . view _3) . toListOf resultSynchronised lastChange <- view $ resultResult . _entityVal . _externalExamResultLastChanged - user <- view $ resultUser . _entityVal + User{..} <- view $ resultUser . _entityVal isSynced <- view resultIsSynced let hasSyncs = has folded syncs diff --git a/templates/exam-office/exam-result-synced.hamlet b/templates/exam-office/exam-result-synced.hamlet index a121c879e..e60f7d809 100644 --- a/templates/exam-office/exam-result-synced.hamlet +++ b/templates/exam-office/exam-result-synced.hamlet @@ -1,6 +1,6 @@ $newline never

- ^{nameWidget (userDisplayName user) (userSurname user)} + ^{nameWidget userDisplayName userSurname}

_{MsgTableExamOfficeLabel} + _{MsgTableExamOfficeLabelStatus} + _{MsgTableExamOfficeLabelPriority} + +
+ ^{fvWidget (delButtons ! coord)} +
From 7b16351e4b84eba0be1db7d723b4953e991b42b5 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Thu, 27 Jan 2022 20:40:13 +0100 Subject: [PATCH 42/50] fix(labels): correct forced bool value for no export label --- src/Handler/ExamOffice/Exam.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Handler/ExamOffice/Exam.hs b/src/Handler/ExamOffice/Exam.hs index 338bf284f..09d6222fb 100644 --- a/src/Handler/ExamOffice/Exam.hs +++ b/src/Handler/ExamOffice/Exam.hs @@ -440,7 +440,7 @@ postEGradesR tid ssh csh examn = do { dbtCsvExportForm = ExamUserCsvExportData <$> apopt checkBoxField (fslI MsgExamOfficeExamUserMarkSynchronisedCsv & setTooltip MsgExamOfficeExamUserMarkSynchronisedCsvTip) (Just False) <*> maybe - (aforced checkBoxField (fslI MsgExamOfficeLabelSetLabelOnExport & setTooltip MsgExamOfficeLabelSetLabelOnExportForcedTip) True) + (aforced checkBoxField (fslI MsgExamOfficeLabelSetLabelOnExport & setTooltip MsgExamOfficeLabelSetLabelOnExportForcedTip) False) (\expLbl -> apopt checkBoxField (fslI MsgExamOfficeLabelSetLabelOnExport & setTooltip (MsgExamOfficeLabelSetLabelOnExportTip expLbl)) (Just True)) ((examOfficeLabelName . entityVal) <$> userCsvExportLabel) , dbtCsvDoEncode = \ExamUserCsvExportData{..} -> C.mapM $ \(E.Value k, row) -> do From 2071f5912d4d183abb55f258450b374821f426e6 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Thu, 27 Jan 2022 22:27:33 +0100 Subject: [PATCH 43/50] feat(labels): set export label on external exam csv export --- src/Handler/Utils/ExternalExam/Users.hs | 16 ++++++++++++++-- 1 file changed, 14 insertions(+), 2 deletions(-) diff --git a/src/Handler/Utils/ExternalExam/Users.hs b/src/Handler/Utils/ExternalExam/Users.hs index f9ed09ce7..a7bac7c90 100644 --- a/src/Handler/Utils/ExternalExam/Users.hs +++ b/src/Handler/Utils/ExternalExam/Users.hs @@ -135,8 +135,9 @@ data ExternalExamUserActionData | ExternalExamUserEditResultData ExamResultPassedGrade | ExternalExamUserDeleteData -newtype ExternalExamUserCsvExportDataGrades = ExternalExamUserCsvExportDataGrades +data ExternalExamUserCsvExportDataGrades = ExternalExamUserCsvExportDataGrades { csvEEUserMarkSynchronised :: Bool + , csvEEUserSetLabel :: Bool } deriving (Eq, Ord, Read, Show, Generic, Typeable) @@ -192,12 +193,18 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do coursen = externalExamCourseName examn = externalExamExamName - uid <- requireAuthId + Entity uid currentUser <- requireAuth isLecturer <- hasReadAccessTo $ EExamR tid ssh coursen examn EEUsersR currentRoute <- fromMaybe (error "makeExternalExamUsersTable called from 404-handler") <$> getCurrentRoute MsgRenderer mr <- getMsgRenderer exampleTime <- over _utctDayTime (fromInteger . round . toRational) <$> liftIO getCurrentTime + userCsvExportLabel' <- E.select . E.from $ \examOfficeLabel -> do + E.where_ $ maybe E.false (\expLbl -> examOfficeLabel E.^. ExamOfficeLabelName E.==. E.val expLbl) (csvExportLabel $ userCsvOptions currentUser) + E.&&. examOfficeLabel E.^. ExamOfficeLabelUser E.==. E.val uid + return examOfficeLabel + let userCsvExportLabel = listToMaybe userCsvExportLabel' + let dbtSQLQuery = runReaderT $ do result <- view queryResult @@ -363,8 +370,13 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do EEUMGrades -> Just DBTCsvEncode { dbtCsvExportForm = ExternalExamUserCsvExportDataGrades <$> apopt checkBoxField (fslI MsgExternalExamUserMarkSynchronisedCsv & setTooltip MsgExternalExamUserMarkSynchronisedCsvTip) (Just False) + <*> maybe + (aforced checkBoxField (fslI MsgExamOfficeLabelSetLabelOnExport & setTooltip MsgExamOfficeLabelSetLabelOnExportForcedTip) False) + (\expLbl -> apopt checkBoxField (fslI MsgExamOfficeLabelSetLabelOnExport & setTooltip (MsgExamOfficeLabelSetLabelOnExportTip expLbl)) (Just True)) + ((examOfficeLabelName . entityVal) <$> userCsvExportLabel) , dbtCsvDoEncode = \ExternalExamUserCsvExportDataGrades{..} -> C.mapM $ \(E.Value k, row) -> do when csvEEUserMarkSynchronised $ externalExamResultMarkSynchronised k + when csvEEUserSetLabel $ maybe (return ()) (\lbl -> void $ upsert (ExamOfficeExternalExamLabel eeId lbl) [ExamOfficeExternalExamLabelLabel =. lbl]) (entityKey <$> userCsvExportLabel) return $ encodeCsv' row , dbtCsvName, dbtCsvSheetName , dbtCsvNoExportData = Nothing From 11b77867acd83a1fe23341d6aa9b0e3fd66506c0 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Thu, 27 Jan 2022 23:28:14 +0100 Subject: [PATCH 44/50] fix(tests): complete test user definition --- test/User.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/test/User.hs b/test/User.hs index 35ba6a848..ff7e14c62 100644 --- a/test/User.hs +++ b/test/User.hs @@ -37,6 +37,8 @@ fakeUser adjUser = adjUser User{..} userLanguages = Nothing userWarningDays = userDefaultWarningDays userCsvOptions = def + userExamOfficeGetSynced = True + userExamOfficeGetLabels = True userSex = Nothing userShowSex = userDefaultShowSex userNotificationSettings = def From ec55a40bc11500105de0b9b9c5cbeb1ba035d53f Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Fri, 28 Jan 2022 19:07:34 +0100 Subject: [PATCH 45/50] feat(labels): hide csv export option for non-exam offices --- src/Handler/ExamOffice/Exam.hs | 13 +++++++++---- src/Handler/Utils/ExternalExam/Users.hs | 13 +++++++++---- 2 files changed, 18 insertions(+), 8 deletions(-) diff --git a/src/Handler/ExamOffice/Exam.hs b/src/Handler/ExamOffice/Exam.hs index 09d6222fb..7d30e4719 100644 --- a/src/Handler/ExamOffice/Exam.hs +++ b/src/Handler/ExamOffice/Exam.hs @@ -234,6 +234,7 @@ postEGradesR tid ssh csh examn = do Course{..} <- getJust examCourse isLecturer <- hasReadAccessTo $ CExamR tid ssh csh examn EUsersR + isExamOffice <- hasReadAccessTo $ ExamOfficeR EOExamsR userFunctions <- selectList [ UserFunctionUser ==. uid, UserFunctionFunction ==. SchoolExamOffice ] [] userCsvExportLabel' <- E.select . E.from $ \examOfficeLabel -> do @@ -439,10 +440,14 @@ postEGradesR tid ssh csh examn = do dbtCsvEncode = Just DBTCsvEncode { dbtCsvExportForm = ExamUserCsvExportData <$> apopt checkBoxField (fslI MsgExamOfficeExamUserMarkSynchronisedCsv & setTooltip MsgExamOfficeExamUserMarkSynchronisedCsvTip) (Just False) - <*> maybe - (aforced checkBoxField (fslI MsgExamOfficeLabelSetLabelOnExport & setTooltip MsgExamOfficeLabelSetLabelOnExportForcedTip) False) - (\expLbl -> apopt checkBoxField (fslI MsgExamOfficeLabelSetLabelOnExport & setTooltip (MsgExamOfficeLabelSetLabelOnExportTip expLbl)) (Just True)) - ((examOfficeLabelName . entityVal) <$> userCsvExportLabel) + <*> bool + ( pure False ) + ( maybe + (aforced checkBoxField (fslI MsgExamOfficeLabelSetLabelOnExport & setTooltip MsgExamOfficeLabelSetLabelOnExportForcedTip) False) + (\expLbl -> apopt checkBoxField (fslI MsgExamOfficeLabelSetLabelOnExport & setTooltip (MsgExamOfficeLabelSetLabelOnExportTip expLbl)) (Just True)) + ((examOfficeLabelName . entityVal) <$> userCsvExportLabel) + ) + isExamOffice , dbtCsvDoEncode = \ExamUserCsvExportData{..} -> C.mapM $ \(E.Value k, row) -> do when csvEUserMarkSynchronised $ markSynced k when csvEUserSetLabel $ maybe (return ()) (\lbl -> void $ upsert (ExamOfficeExamLabel eid lbl) [ExamOfficeExamLabelLabel =. lbl]) (entityKey <$> userCsvExportLabel) diff --git a/src/Handler/Utils/ExternalExam/Users.hs b/src/Handler/Utils/ExternalExam/Users.hs index a7bac7c90..056e08dec 100644 --- a/src/Handler/Utils/ExternalExam/Users.hs +++ b/src/Handler/Utils/ExternalExam/Users.hs @@ -195,6 +195,7 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do Entity uid currentUser <- requireAuth isLecturer <- hasReadAccessTo $ EExamR tid ssh coursen examn EEUsersR + isExamOffice <- hasReadAccessTo $ ExamOfficeR EOExamsR currentRoute <- fromMaybe (error "makeExternalExamUsersTable called from 404-handler") <$> getCurrentRoute MsgRenderer mr <- getMsgRenderer exampleTime <- over _utctDayTime (fromInteger . round . toRational) <$> liftIO getCurrentTime @@ -370,10 +371,14 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do EEUMGrades -> Just DBTCsvEncode { dbtCsvExportForm = ExternalExamUserCsvExportDataGrades <$> apopt checkBoxField (fslI MsgExternalExamUserMarkSynchronisedCsv & setTooltip MsgExternalExamUserMarkSynchronisedCsvTip) (Just False) - <*> maybe - (aforced checkBoxField (fslI MsgExamOfficeLabelSetLabelOnExport & setTooltip MsgExamOfficeLabelSetLabelOnExportForcedTip) False) - (\expLbl -> apopt checkBoxField (fslI MsgExamOfficeLabelSetLabelOnExport & setTooltip (MsgExamOfficeLabelSetLabelOnExportTip expLbl)) (Just True)) - ((examOfficeLabelName . entityVal) <$> userCsvExportLabel) + <*> bool + ( pure False ) + ( maybe + (aforced checkBoxField (fslI MsgExamOfficeLabelSetLabelOnExport & setTooltip MsgExamOfficeLabelSetLabelOnExportForcedTip) False) + (\expLbl -> apopt checkBoxField (fslI MsgExamOfficeLabelSetLabelOnExport & setTooltip (MsgExamOfficeLabelSetLabelOnExportTip expLbl)) (Just True)) + ((examOfficeLabelName . entityVal) <$> userCsvExportLabel) + ) + isExamOffice , dbtCsvDoEncode = \ExternalExamUserCsvExportDataGrades{..} -> C.mapM $ \(E.Value k, row) -> do when csvEEUserMarkSynchronised $ externalExamResultMarkSynchronised k when csvEEUserSetLabel $ maybe (return ()) (\lbl -> void $ upsert (ExamOfficeExternalExamLabel eeId lbl) [ExamOfficeExternalExamLabelLabel =. lbl]) (entityKey <$> userCsvExportLabel) From d54885a37fa1655e1436778857c398758a431c7e Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Fri, 28 Jan 2022 19:17:31 +0100 Subject: [PATCH 46/50] style(labels): correct label table layout --- templates/profile/exam-office-labels/add.hamlet | 2 +- templates/profile/exam-office-labels/cell.hamlet | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/templates/profile/exam-office-labels/add.hamlet b/templates/profile/exam-office-labels/add.hamlet index 03342b9a2..2935c0b46 100644 --- a/templates/profile/exam-office-labels/add.hamlet +++ b/templates/profile/exam-office-labels/add.hamlet @@ -1,5 +1,5 @@ $newline never -
+ #{csrf} ^{fvWidget addView} diff --git a/templates/profile/exam-office-labels/cell.hamlet b/templates/profile/exam-office-labels/cell.hamlet index ab926a48c..32d4fab7b 100644 --- a/templates/profile/exam-office-labels/cell.hamlet +++ b/templates/profile/exam-office-labels/cell.hamlet @@ -1,8 +1,8 @@ $newline never - + ^{labelIdent} - + #{csrf} ^{fvWidget statusView} - + ^{fvWidget priorityView} From 814c06a9a669dcb104b73f9800a9de3cc2347609 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Fri, 28 Jan 2022 19:50:06 +0100 Subject: [PATCH 47/50] chore: fix tests --- test/Model/TypesSpec.hs | 1 + test/ModelSpec.hs | 2 ++ 2 files changed, 3 insertions(+) diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index fad24d3f7..15e9377d5 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -298,6 +298,7 @@ instance Arbitrary CsvOptions where arbitrary = CsvOptions <$> arbitrary <*> arbitrary + <*> arbitrary shrink = genericShrink instance Arbitrary CsvPreset where diff --git a/test/ModelSpec.hs b/test/ModelSpec.hs index 66b90b480..27a5bed3f 100644 --- a/test/ModelSpec.hs +++ b/test/ModelSpec.hs @@ -128,6 +128,8 @@ instance Arbitrary User where userNotificationSettings <- arbitrary userCsvOptions <- arbitrary userShowSex <- arbitrary + userExamOfficeGetSynced <- arbitrary + userExamOfficeGetLabels <- arbitrary userCreated <- arbitrary userLastLdapSynchronisation <- arbitrary From 22860863e59f0f927d6424552b913297fee24f14 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Fri, 28 Jan 2022 20:20:04 +0100 Subject: [PATCH 48/50] fix: hlint --- src/Handler/ExamOffice/Exam.hs | 2 +- src/Handler/ExamOffice/Exams.hs | 32 +++++++++++++------------ src/Handler/Profile.hs | 6 ++--- src/Handler/Utils/ExternalExam/Users.hs | 2 +- 4 files changed, 22 insertions(+), 20 deletions(-) diff --git a/src/Handler/ExamOffice/Exam.hs b/src/Handler/ExamOffice/Exam.hs index 7d30e4719..5ad1d0133 100644 --- a/src/Handler/ExamOffice/Exam.hs +++ b/src/Handler/ExamOffice/Exam.hs @@ -445,7 +445,7 @@ postEGradesR tid ssh csh examn = do ( maybe (aforced checkBoxField (fslI MsgExamOfficeLabelSetLabelOnExport & setTooltip MsgExamOfficeLabelSetLabelOnExportForcedTip) False) (\expLbl -> apopt checkBoxField (fslI MsgExamOfficeLabelSetLabelOnExport & setTooltip (MsgExamOfficeLabelSetLabelOnExportTip expLbl)) (Just True)) - ((examOfficeLabelName . entityVal) <$> userCsvExportLabel) + (examOfficeLabelName . entityVal <$> userCsvExportLabel) ) isExamOffice , dbtCsvDoEncode = \ExamUserCsvExportData{..} -> C.mapM $ \(E.Value k, row) -> do diff --git a/src/Handler/ExamOffice/Exams.hs b/src/Handler/ExamOffice/Exams.hs index 0f61875e6..c6ec5ee37 100644 --- a/src/Handler/ExamOffice/Exams.hs +++ b/src/Handler/ExamOffice/Exams.hs @@ -136,15 +136,19 @@ postEOExamsR = do now <- liftIO getCurrentTime mr <- getMessageRender - getSynced <- lookupGetParam "synced" >>= return . \case - Just "yes" -> True - Just "no" -> False - _ -> userExamOfficeGetSynced + getSynced <- lookupGetParam "synced" <&> + (\case + Just "yes" -> True + Just "no" -> False + _ -> userExamOfficeGetSynced + ) - getLabels <- lookupGetParam "labels" >>= return . \case - Just "yes" -> True - Just "no" -> False - _ -> userExamOfficeGetLabels + getLabels <- lookupGetParam "labels" <&> + (\case + Just "yes" -> True + Just "no" -> False + _ -> userExamOfficeGetLabels + ) (examsRes, examsTable) <- runDB $ do let labelFilterNoLabelOption = Option @@ -214,14 +218,12 @@ postEOExamsR = do E.||. ( E.isNothing (exam E.?. ExamId) E.&&. E.isNothing (course E.?. CourseId) E.&&. E.not_ (E.isNothing $ externalExam E.?. ExternalExamId)) E.where_ $ E.val (not getLabels) E.||. ( E.val getLabels - E.&&. ( E.maybe E.true (\labelExamUser -> + E.&&. E.maybe E.true (\labelExamUser -> labelExamUser E.==. E.val uid - ) (mLabelExam E.?. ExamOfficeLabelUser) - ) - E.&&. ( E.maybe E.true (\labelExternalExamUser -> + ) (mLabelExam E.?. ExamOfficeLabelUser) + E.&&. E.maybe E.true (\labelExternalExamUser -> labelExternalExamUser E.==. E.val uid - ) (mLabelExternalExam E.?. ExamOfficeLabelUser) - ) + ) (mLabelExternalExam E.?. ExamOfficeLabelUser) ) return (exam, course, school, mLabelExam, externalExam, mLabelExternalExam) @@ -356,7 +358,7 @@ postEOExamsR = do , sortTerm (to $ E.unsafeCoalesce . sequence [views queryCourse (E.?. CourseTerm), views queryExternalExam (E.?. ExternalExamTerm)]) ] - dbtFilter = mconcat $ + dbtFilter = mconcat [ singletonMap "may-access" . FilterProjected $ (_etProjFilterMayAccess ?~) . getAny , singletonMap "has-results" . FilterProjected $ (_etProjFilterHasResults ?~) . getAny , singletonMap "is-synced" . FilterProjected $ (_etProjFilterIsSynced ?~) . getAny diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index e45e24e03..4a7cdcbab 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -335,7 +335,7 @@ examOfficeForm template = wFormToAForm $ do let userExamOfficeLabels :: EOLabels - userExamOfficeLabels = fromMaybe mempty $ eosettingsLabels <$> template + userExamOfficeLabels = maybe mempty eosettingsLabels template eoLabelsForm :: AForm Handler EOLabels eoLabelsForm = wFormToAForm $ do @@ -374,7 +374,7 @@ examOfficeForm template = wFormToAForm $ do (priorityRes, priorityView) <- mreq intField (fslI MsgExamOfficeLabelPriority & addName (nudge "priority")) (((\(_,_,x) -> x) <$> initRes) <|> Just 0) let res :: FormResult EOLabelData - res = (,,) <$> (FormSuccess labelIdent) <*> statusRes <*> priorityRes + res = (,,) <$> FormSuccess labelIdent <*> statusRes <*> priorityRes return (res, $(widgetFile "profile/exam-office-labels/cell")) miDelete :: Map ListPosition (Either ExamOfficeLabelName ExamOfficeLabelId) @@ -530,7 +530,7 @@ postProfileR = do let oldExamLabels = userExamOfficeLabels newExamLabels = stgExamOfficeSettings & eosettingsLabels - forM_ oldExamLabels $ \(Entity eolid ExamOfficeLabel{..}) -> unless ((Right eolid) `Map.member` newExamLabels || (Left examOfficeLabelName) `Map.member` newExamLabels) $ do + forM_ oldExamLabels $ \(Entity eolid ExamOfficeLabel{..}) -> unless (Right eolid `Map.member` newExamLabels || Left examOfficeLabelName `Map.member` newExamLabels) $ do E.delete . E.from $ \examOfficeExternalExamLabel -> E.where_ $ examOfficeExternalExamLabel E.^. ExamOfficeExternalExamLabelLabel E.==. E.val eolid E.delete . E.from $ \examOfficeExamLabel -> E.where_ $ examOfficeExamLabel E.^. ExamOfficeExamLabelLabel E.==. E.val eolid when (csvExportLabel userCsvOptions == Just examOfficeLabelName) $ diff --git a/src/Handler/Utils/ExternalExam/Users.hs b/src/Handler/Utils/ExternalExam/Users.hs index 056e08dec..9823e1905 100644 --- a/src/Handler/Utils/ExternalExam/Users.hs +++ b/src/Handler/Utils/ExternalExam/Users.hs @@ -376,7 +376,7 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do ( maybe (aforced checkBoxField (fslI MsgExamOfficeLabelSetLabelOnExport & setTooltip MsgExamOfficeLabelSetLabelOnExportForcedTip) False) (\expLbl -> apopt checkBoxField (fslI MsgExamOfficeLabelSetLabelOnExport & setTooltip (MsgExamOfficeLabelSetLabelOnExportTip expLbl)) (Just True)) - ((examOfficeLabelName . entityVal) <$> userCsvExportLabel) + (examOfficeLabelName . entityVal <$> userCsvExportLabel) ) isExamOffice , dbtCsvDoEncode = \ExternalExamUserCsvExportDataGrades{..} -> C.mapM $ \(E.Value k, row) -> do From c60117f0769b615c9f649ab341f6ae75172415a3 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Thu, 3 Feb 2022 22:34:06 +0100 Subject: [PATCH 49/50] refactor(eo-exams): avoid name shadowing --- src/Handler/ExamOffice/Exam.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Handler/ExamOffice/Exam.hs b/src/Handler/ExamOffice/Exam.hs index 5ad1d0133..cde8a0015 100644 --- a/src/Handler/ExamOffice/Exam.hs +++ b/src/Handler/ExamOffice/Exam.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -fno-warn-redundant-constraints -fno-warn-name-shadowing #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} module Handler.ExamOffice.Exam ( getEGradesR, postEGradesR @@ -227,7 +227,7 @@ data ExamUserCsvExportData = ExamUserCsvExportData getEGradesR, postEGradesR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html getEGradesR = postEGradesR postEGradesR tid ssh csh examn = do - Entity uid User{..} <- requireAuth + Entity uid User{userCsvOptions=csvOpts} <- requireAuth now <- liftIO getCurrentTime ((usersResult, examUsersTable), Entity eId Exam{examFinished}) <- runDB $ do exam@(Entity eid Exam{..}) <- fetchExam tid ssh csh examn @@ -238,7 +238,7 @@ postEGradesR tid ssh csh examn = do userFunctions <- selectList [ UserFunctionUser ==. uid, UserFunctionFunction ==. SchoolExamOffice ] [] userCsvExportLabel' <- E.select . E.from $ \examOfficeLabel -> do - E.where_ $ maybe E.false (\expLbl -> examOfficeLabel E.^. ExamOfficeLabelName E.==. E.val expLbl) (csvExportLabel userCsvOptions) + E.where_ $ maybe E.false (\expLbl -> examOfficeLabel E.^. ExamOfficeLabelName E.==. E.val expLbl) (csvExportLabel csvOpts) E.&&. examOfficeLabel E.^. ExamOfficeLabelUser E.==. E.val uid return examOfficeLabel let userCsvExportLabel = listToMaybe userCsvExportLabel' From 5889c7e1a46b10dc245afa05d5b9cb74300ddb5e Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Fri, 4 Feb 2022 01:37:29 +0100 Subject: [PATCH 50/50] test: fix tests --- test/Model/TypesSpec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index 15e9377d5..10da379ed 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -298,7 +298,7 @@ instance Arbitrary CsvOptions where arbitrary = CsvOptions <$> arbitrary <*> arbitrary - <*> arbitrary + <*> suchThat arbitrary (maybe True $ not . elem (Char.chr 0)) shrink = genericShrink instance Arbitrary CsvPreset where