From 9e81f03742586ef40e8ff896e303ba11d95f120a Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Mon, 24 Jan 2022 01:09:47 +0100 Subject: [PATCH] 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