diff --git a/messages/uniworx/categories/courses/tutorial/de-de-formal.msg b/messages/uniworx/categories/courses/tutorial/de-de-formal.msg index 4e7522146..b7087be47 100644 --- a/messages/uniworx/categories/courses/tutorial/de-de-formal.msg +++ b/messages/uniworx/categories/courses/tutorial/de-de-formal.msg @@ -62,5 +62,3 @@ TutorialParticipantsDayEdits day@Text: Kursteilnehmer-Tagesnotizen aktualisiert CheckEyePermitMissing: Sehtest oder Führerschein fehlen noch CheckEyePermitIncompatible: Sehtest und Führerschein passen nicht zusammen - -GenTutActions: Prüfungsaktionen diff --git a/messages/uniworx/categories/courses/tutorial/en-eu.msg b/messages/uniworx/categories/courses/tutorial/en-eu.msg index 600da8712..d205f11f6 100644 --- a/messages/uniworx/categories/courses/tutorial/en-eu.msg +++ b/messages/uniworx/categories/courses/tutorial/en-eu.msg @@ -63,5 +63,3 @@ TutorialParticipantsDayEdits day: course participant day notes updated for #{day CheckEyePermitMissing: Eye exam or driving permit missing CheckEyePermitIncompatible: Eye exam and driving permit are incompatible - -GenTutActions: Examination actions diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index 12c562b0d..477bf4b5d 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -2,7 +2,7 @@ -- -- SPDX-License-Identifier: AGPL-3.0-or-later -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications, BlockArguments #-} module Handler.Tutorial.Users ( getTUsersR, postTUsersR @@ -40,7 +40,7 @@ import Handler.Course.Users -- | Generate multiForm with one entry for each course exam showing only day-relevant exam occurrences -mkExamOccurrenceForm :: [(ExamId, CryptoUUIDExam, ExamName)] -> ExamOccurrenceMap -> Form (CryptoUUIDExam, Set CryptoUUIDExamOccurrence, Set ExamOccurrenceForm) +mkExamOccurrenceForm :: [(Entity Exam, CryptoUUIDExam)] -> ExamOccurrenceMap -> Form (CryptoUUIDExam, Set CryptoUUIDExamOccurrence, Set ExamOccurrenceForm) mkExamOccurrenceForm exs eom = renderAForm FormStandard maa where maa = multiActionA acts (fslI MsgCourseExam) Nothing @@ -49,12 +49,13 @@ mkExamOccurrenceForm exs eom = renderAForm FormStandard maa acts :: Map Text (AForm Handler (CryptoUUIDExam, Set CryptoUUIDExamOccurrence, Set ExamOccurrenceForm)) acts = Map.fromList $ map mkAct exs - mkAct :: (ExamId, CryptoUUIDExam, ExamName) -> (Text, AForm Handler (CryptoUUIDExam, Set CryptoUUIDExamOccurrence, Set ExamOccurrenceForm)) - mkAct (eId, cueId, eName) = (ciOriginal eName, + mkAct :: (Entity Exam, CryptoUUIDExam) -> (Text, AForm Handler (CryptoUUIDExam, Set CryptoUUIDExamOccurrence, Set ExamOccurrenceForm)) + mkAct (Entity{entityKey=eId, entityVal=Exam{examName=eName, examDescription=eDescr}}, cueId) = (ciOriginal eName, let (cuEoIds, eos) = munzip $ Map.lookup eId eid2eos in (,,) - <$> areq hiddenField "teoExam" (Just cueId) - <*> areq (mkSetField hiddenField) "teoOccs" cuEoIds + <$ for_ eDescr (aformInfoWidget . toWgt) + <*> areq hiddenField "" (Just cueId) + <*> areq (mkSetField hiddenField) "" cuEoIds <*> examOccurrenceMultiForm eos ) @@ -95,7 +96,7 @@ postTUsersR tid ssh csh tutn = do let croute = CTutorialR tid ssh csh tutn TUsersR now <- liftIO getCurrentTime isAdmin <- hasReadAccessTo AdminR - (Entity tutid tut@Tutorial{..}, (participantRes, participantTable), qualifications, exOccs) <- runDB $ do + (cid, Entity tutid tut@Tutorial{..}, (participantRes, participantTable), qualifications, exOccs) <- runDB do trm <- get404 tid -- cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh -- tutEnt@(Entity tutid _) <- fetchTutorial tid ssh csh tutn @@ -118,7 +119,7 @@ postTUsersR tid ssh csh tutn = do & defaultSortingByName & restrictSorting (\name _ -> none (== name) ["note", "registration", "tutorials", "exams", "submission-group", "state"]) -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information & restrictFilter (\name _ -> none (== name) ["tutorial", "exam", "submission-group", "active", "has-personalised-sheet-files"]) - isInTut q = E.exists $ do + isInTut q = E.exists do tutorialParticipant <- E.from $ E.table @TutorialParticipant E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser q E.^. UserId E.&&. tutorialParticipant E.^. TutorialParticipantTutorial E.==. E.val tutid @@ -153,7 +154,7 @@ postTUsersR tid ssh csh tutn = do , ( TutorialUserPrintQualification, pure TutorialUserPrintQualificationData ) ] table <- makeCourseUserTable cid acts isInTut colChoices psValidator (Just csvColChoices) - return (tutEnt, table, qualifications, exOccs) + return (cid, tutEnt, table, qualifications, exOccs) let courseQids = Set.fromList (entityKey <$> qualifications) tcontent <- formResultMaybe participantRes $ \case @@ -205,7 +206,7 @@ postTUsersR tid ssh csh tutn = do let ok = totalCap - usedCap >= n unless ok $ addMessageI Error $ MsgExamRommCapacityInsufficient $ totalCap - usedCap pure ok - when capOk $ do + when capOk do let regTemplate uid = ExamRegistration eid uid (Just tuOccurrenceId) now nrOk <- runDB $ if tuReassign then putMany [regTemplate uid | uid <- Set.toList selectedUsers] >> pure n @@ -219,41 +220,42 @@ postTUsersR tid ssh csh tutn = do case tcontent of Just act -> act -- execute action and return produced content Nothing -> do -- no table action, continue normally - tutors <- runDB $ E.select $ do - (tutor :& user) <- E.from $ E.table @Tutor `E.innerJoin` E.table @User - `E.on` (\(tutor :& user) -> tutor E.^. TutorUser E.==. user E.^. UserId) - E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid - return user + (openExams, tutors) <- runDBRead $ (,) + <$> selectList ([ExamCourse ==. cid, ExamRegisterFrom <=. Just now] ++ ([ExamRegisterTo >=. Just now] ||. [ExamRegisterTo ==. Nothing])) [Asc ExamName] + <*> E.select (do + (tutor :& user) <- E.from $ E.table @Tutor `E.innerJoin` E.table @User + `E.on` (\(tutor :& user) -> tutor E.^. TutorUser E.==. user E.^. UserId) + E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid + return user + ) - genTutActWgt <- do - ((gtaRes, gtaWgt), gtaEnctype) <- runFormPost . identifyForm FIDGeneralTutorialAction $ mkExamOccurrenceForm [] exOccs -- TODO - let gtaAnchor = "general-tutorial-action-form" :: Text - gtaRoute = croute :#: gtaAnchor - gtaForm = wrapForm gtaWgt FormSettings - { formMethod = POST - , formAction = Just . SomeRoute $ gtaRoute - , formEncoding = gtaEnctype - , formAttrs = [] - , formSubmit = FormSubmit - , formAnchor = Just gtaAnchor - } - formResult gtaRes $ \(cEId, cEOIds, occs) -> do -- (CryptoUUIDExam, Set CryptoUUIDExamOccurrence, Set ExamOccurrenceForm) - let ceoidsDelete = cEOIds `Set.difference` setMapMaybe eofId occs - eId <- decrypt cEId - eoIdsDelete <- mapM decrypt $ Set.toList ceoidsDelete - runDB $ do - deleteWhere [ExamOccurrenceExam ==. eId, ExamOccurrenceId <-. eoIdsDelete] - upsertExamOccurrences eId $ Set.toList occs - - return [whamlet| -

- _{MsgGenTutActions} -
-

- ^{gtaForm} - |] + examOccWgt <- if null openExams + then + let mkCreateExamBtn = linkButton mempty (msg2widget MsgMenuExamNew) [BCIsButton, BCPrimary] $ SomeRoute $ CourseR tid ssh csh CExamNewR + in return $(i18nWidgetFile "exam-missing") + else do + openExamsUUIDs <- forM openExams $ \ent@Entity{entityKey=k} -> (ent,) <$> encrypt k + ((gtaRes, gtaWgt), gtaEnctype) <- runFormPost . identifyForm FIDGeneralTutorialAction $ mkExamOccurrenceForm openExamsUUIDs exOccs -- TODO + let gtaAnchor = "general-tutorial-action-form" :: Text + gtaRoute = croute :#: gtaAnchor + gtaForm = wrapForm gtaWgt FormSettings + { formMethod = POST + , formAction = Just . SomeRoute $ gtaRoute + , formEncoding = gtaEnctype + , formAttrs = [] + , formSubmit = FormSubmit + , formAnchor = Just gtaAnchor + } + formResult gtaRes $ \(cEId, cEOIds, occs) -> do -- (CryptoUUIDExam, Set CryptoUUIDExamOccurrence, Set ExamOccurrenceForm) + let ceoidsDelete = cEOIds `Set.difference` setMapMaybe eofId occs + eId <- decrypt cEId + eoIdsDelete <- mapM decrypt $ Set.toList ceoidsDelete + runDB do + deleteWhere [ExamOccurrenceExam ==. eId, ExamOccurrenceId <-. eoIdsDelete] + upsertExamOccurrences eId $ Set.toList occs + return gtaForm let heading = prependCourseTitle tid ssh csh $ CI.original tutorialName - html <- siteLayoutMsg heading $ do + html <- siteLayoutMsg heading do setTitleI heading $(widgetFile "tutorial-participants") return $ toTypedContent html diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 716718928..55027a7f6 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -1392,12 +1392,12 @@ aformHoneypot (aFormToWForm -> wform) = wFormToAForm . maybeT wform $ do -- Special Forms -- ------------------- --- | Alternative implementation for 'aformSection' in a more standard that +-- | Alternative implementation for 'aformSection' in a more standard way that -- allows tooltips and arbitrary attributs. Section header must be given through `fsLabel` aformSection' :: (MonadHandler m, site ~ HandlerSite m, RenderMessage site FormMessage) => FieldSettings site -> AForm m () aformSection' = formToAForm . fmap (second pure) . formSection' --- | Alternative implementation for 'formSection' in a more standard that +-- | Alternative implementation for 'formSection' in a more standard wat that -- allows tooltips and arbitrary attributs. Section header must be given through `fsLabel` formSection' :: (MonadHandler m, site ~ HandlerSite m, RenderMessage site FormMessage) => FieldSettings site -> MForm m (FormResult (), FieldView site) -- TODO: WIP, delete @@ -1423,7 +1423,7 @@ aformMessage = formToAForm . fmap (second pure) . formMessage wformMessage :: (MonadHandler m) => Message -> WForm m () wformMessage = void . aFormToWForm . aformMessage -formMessage :: (MonadHandler m) => Message -> MForm m (FormResult (), FieldView site) +formMessage :: (MonadHandler m) => Message -> MForm m (FormResult (), FieldView site) formMessage msg = do return (FormSuccess (), FieldView { fvLabel = mempty @@ -1434,6 +1434,26 @@ formMessage msg = do , fvInput = notification NotificationNarrow msg }) +-- | Similar to aformMessage, generates a form having just a view widget, but no input. +-- Currently only correctly rendered by 'renderAForm' and mforms using 'widget/form.hamlet' +aformInfoWidget :: (MonadHandler m, HandlerSite m ~ site) => WidgetFor site () -> AForm m () +aformInfoWidget = formToAForm . fmap (second pure) . formInfoWidget + +wformInfoWidget :: (MonadHandler m, HandlerSite m ~ site) => WidgetFor site () -> WForm m () +wformInfoWidget = void . aFormToWForm . aformInfoWidget + +formInfoWidget :: (MonadHandler m, HandlerSite m ~ site) => WidgetFor site () -> MForm m (FormResult (), FieldView site) +formInfoWidget wgt = do + return (FormSuccess (), FieldView + { fvLabel = mempty + , fvTooltip = Nothing + , fvId = idFormMessageNoinput + , fvErrors = Nothing + , fvRequired = False + , fvInput = wgt + }) + + --------------------- -- Form evaluation -- --------------------- diff --git a/templates/i18n/exam-missing/de-de-formal.hamlet b/templates/i18n/exam-missing/de-de-formal.hamlet new file mode 100644 index 000000000..e0416ccd4 --- /dev/null +++ b/templates/i18n/exam-missing/de-de-formal.hamlet @@ -0,0 +1,11 @@ +$newline never + +$# SPDX-FileCopyrightText: 2024 Steffen Jost +$# +$# SPDX-License-Identifier: AGPL-3.0-or-later + +

+

+ Keine momentan offene Prüfung gefunden für _{MsgTableCourse} #{csh}. +

+ ^{mkCreateExamBtn} diff --git a/templates/i18n/exam-missing/en-eu.hamlet b/templates/i18n/exam-missing/en-eu.hamlet new file mode 100644 index 000000000..d1e5bee1d --- /dev/null +++ b/templates/i18n/exam-missing/en-eu.hamlet @@ -0,0 +1,11 @@ +$newline never + +$# SPDX-FileCopyrightText: 2024 Steffen Jost +$# +$# SPDX-License-Identifier: AGPL-3.0-or-later + +

+

+ No currently open exam found for _{MsgTableCourse} #{csh}. +

+ ^{mkCreateExamBtn} diff --git a/templates/tutorial-participants.hamlet b/templates/tutorial-participants.hamlet index 21569c580..c5929e969 100644 --- a/templates/tutorial-participants.hamlet +++ b/templates/tutorial-participants.hamlet @@ -15,7 +15,11 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later $forall (Entity _ usr) <- tutors

  • ^{userEmailWidget usr} -
    +
    ^{participantTable}
    - ^{genTutActWgt} \ No newline at end of file +

    + _{MsgExamFormOccurrences} +
    +

    + ^{examOccWgt} \ No newline at end of file