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

Propably due to multiActionAForm badly interacting with contained massInputForm

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

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

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 :: (Entity Exam, CryptoUUIDExam) -> (Text, AForm Handler (CryptoUUIDExam, Set CryptoUUIDExamOccurrence, Set ExamOccurrenceForm))
-    mkAct (eId, cueId, eName) = (ciOriginal eName,
+    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)
+          <$  for_ eDescr (aformInfoWidget . toWgt)
-          <*> areq (mkSetField hiddenField) "teoOccs" cuEoIds
+          <*> 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
+      (openExams, tutors) <- runDBRead $ (,)
-        (tutor :& user) <- E.from $ E.table @Tutor `E.innerJoin` E.table @User
+        <$> selectList ([ExamCourse ==. cid, ExamRegisterFrom <=. Just now] ++ ([ExamRegisterTo >=. Just now] ||. [ExamRegisterTo ==. Nothing])) [Asc ExamName]
-          `E.on` (\(tutor :& user) -> tutor E.^. TutorUser E.==. user E.^. UserId)
+        <*> E.select (do
-        E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid
+              (tutor :& user) <- E.from $ E.table @Tutor `E.innerJoin` E.table @User
-        return 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
+      examOccWgt <- if null openExams
-        ((gtaRes, gtaWgt), gtaEnctype) <- runFormPost . identifyForm FIDGeneralTutorialAction $ mkExamOccurrenceForm [] exOccs -- TODO
+        then
-        let gtaAnchor  = "general-tutorial-action-form" :: Text
+          let mkCreateExamBtn = linkButton mempty (msg2widget MsgMenuExamNew) [BCIsButton, BCPrimary] $ SomeRoute $ CourseR tid ssh csh CExamNewR
-            gtaRoute   = croute :#: gtaAnchor
+          in  return $(i18nWidgetFile "exam-missing")
-            gtaForm    = wrapForm gtaWgt FormSettings
+        else do
-                              { formMethod = POST
+          openExamsUUIDs <- forM openExams $ \ent@Entity{entityKey=k} -> (ent,) <$> encrypt k
-                              , formAction = Just . SomeRoute $ gtaRoute
+          ((gtaRes, gtaWgt), gtaEnctype) <- runFormPost . identifyForm FIDGeneralTutorialAction $ mkExamOccurrenceForm openExamsUUIDs exOccs -- TODO
-                              , formEncoding = gtaEnctype
+          let gtaAnchor  = "general-tutorial-action-form" :: Text
-                              , formAttrs = []
+              gtaRoute   = croute :#: gtaAnchor
-                              , formSubmit = FormSubmit
+              gtaForm    = wrapForm gtaWgt FormSettings
-                              , formAnchor = Just gtaAnchor
+                                { formMethod = POST
-                              }
+                                , formAction = Just . SomeRoute $ gtaRoute
-        formResult gtaRes $ \(cEId, cEOIds, occs) -> do -- (CryptoUUIDExam, Set CryptoUUIDExamOccurrence, Set ExamOccurrenceForm)
+                                , formEncoding = gtaEnctype
-          let ceoidsDelete = cEOIds `Set.difference` setMapMaybe eofId occs
+                                , formAttrs = []
-          eId <- decrypt cEId
+                                , formSubmit = FormSubmit
-          eoIdsDelete <- mapM decrypt $ Set.toList ceoidsDelete
+                                , formAnchor = Just gtaAnchor
-          runDB $ do
+                                }
-            deleteWhere [ExamOccurrenceExam ==. eId, ExamOccurrenceId <-. eoIdsDelete]
+          formResult gtaRes $ \(cEId, cEOIds, occs) -> do -- (CryptoUUIDExam, Set CryptoUUIDExamOccurrence, Set ExamOccurrenceForm)
-            upsertExamOccurrences eId $ Set.toList occs
+            let ceoidsDelete = cEOIds `Set.difference` setMapMaybe eofId occs
-
+            eId <- decrypt cEId
-        return [whamlet|
+            eoIdsDelete <- mapM decrypt $ Set.toList ceoidsDelete
-            <h2 .show-hide__toggle uw-show-hide data-show-hide-collapsed>
+            runDB do
-              _{MsgGenTutActions}
+              deleteWhere [ExamOccurrenceExam ==. eId, ExamOccurrenceId <-. eoIdsDelete]
-            <div>
+              upsertExamOccurrences eId $ Set.toList occs
-              <P>
+          return gtaForm
-                ^{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

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

templates/i18n/exam-missing/de-de-formal.hamlet

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

templates/i18n/exam-missing/en-eu.hamlet

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

templates/tutorial-participants.hamlet

@@ -18,4 +18,8 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
 <section>
   ^{participantTable}
 <section>
-  ^{genTutActWgt}
+  <h2 .show-hide__toggle uw-show-hide data-show-hide-collapsed>
+    _{MsgExamFormOccurrences}
+  <div>
+    <p>
+      ^{examOccWgt}