fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore(tutorial): towards #2347 exam occurrence form design finished, but buggy somehow (WIP)

Browse Source 
Propably due to multiActionAForm badly interacting with contained massInputForm
This commit is contained in:
Steffen Jost 2025-01-09 12:48:09 +01:00 committed by Sarah Vaupel
parent afbeb86762
commit 7b7ffab109
7 changed files with 96 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
messages/uniworx/categories/courses/tutorial/de-de-formal.msg
View File

@ -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

2
messages/uniworx/categories/courses/tutorial/en-eu.msg
View File

@ -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

88
src/Handler/Tutorial/Users.hs
View File

@ -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|
<h2 .show-hide__toggle uw-show-hide data-show-hide-collapsed>
_{MsgGenTutActions}
<div>
<P>
^{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

26
src/Utils/Form.hs
View File

@ -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 --
---------------------

11
templates/i18n/exam-missing/de-de-formal.hamlet Normal file
View File

@ -0,0 +1,11 @@
$newline never
$# SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
<section>
<p>
Keine momentan offene Prüfung gefunden für _{MsgTableCourse} #{csh}.
<p>
^{mkCreateExamBtn}

11
templates/i18n/exam-missing/en-eu.hamlet Normal file
View File

@ -0,0 +1,11 @@
$newline never
$# SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
<section>
<p>
No currently open exam found for _{MsgTableCourse} #{csh}.
<p>
^{mkCreateExamBtn}

8
templates/tutorial-participants.hamlet
View File

@ -15,7 +15,11 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
$forall (Entity _ usr) <- tutors
<li>
^{userEmailWidget usr}
<section>
<section>
^{participantTable}
<section>
^{genTutActWgt}
<h2 .show-hide__toggle uw-show-hide data-show-hide-collapsed>
_{MsgExamFormOccurrences}
<div>
<p>
^{examOccWgt}