chore(tutorial): towards #2347 exam occurrence form mostly working (WIP)

form is completed, but the initial call needs proper arguments from DB about all apropriate exams

messages/uniworx/categories/courses/tutorial/de-de-formal.msg

@@ -64,6 +64,3 @@ CheckEyePermitMissing: Sehtest oder Führerschein fehlen noch
 CheckEyePermitIncompatible: Sehtest und Führerschein passen nicht zusammen
 
 GenTutActions: Prüfungsaktionen
-GenTutActNone !ident-ok: --
-GenTutActOccAdd: Neuen Prüfungstermin hinzufügen
-GenTutActOccEdit: Prüfungstermin bearbeiten

messages/uniworx/categories/courses/tutorial/en-eu.msg

@@ -65,6 +65,3 @@ CheckEyePermitMissing: Eye exam or driving permit missing
 CheckEyePermitIncompatible: Eye exam and driving permit are incompatible
 
 GenTutActions: Examination actions
-GenTutActNone: --
-GenTutActOccAdd: Add new exam occurence
-GenTutActOccEdit: Edit exam occurence

models/exams.model

@@ -47,7 +47,7 @@ ExamOccurrence
   end         UTCTime Maybe  
   description StoredMarkup Maybe  
   UniqueExamOccurrence exam name
-  deriving Show Generic Binary
+  deriving Eq Ord Show Generic Binary
 ExamRegistration
   exam ExamId
   user UserId

src/Handler/Exam/Edit.hs

@@ -75,35 +75,7 @@ postEEditR tid ssh csh examn = do
 
         occIds <- fmap catMaybes . forM (Set.toList efOccurrences) $ traverse decrypt . eofId
         deleteWhere [ ExamOccurrenceExam ==. eId, ExamOccurrenceId /<-. occIds ]
-        forM_ (Set.toList efOccurrences) $ \case
+        upsertExamOccurrences eId $ Set.toList efOccurrences
-          ExamOccurrenceForm{ eofId = Nothing, .. } -> insert_
-            ExamOccurrence
-              { examOccurrenceExam = eId
-              , examOccurrenceName = eofName
-              , examOccurrenceExaminer = eofExaminer
-              , examOccurrenceRoom = eofRoom
-              , examOccurrenceRoomHidden = eofRoomHidden
-              , examOccurrenceCapacity = eofCapacity
-              , examOccurrenceStart = eofStart
-              , examOccurrenceEnd = eofEnd
-              , examOccurrenceDescription = eofDescription
-              }
-          ExamOccurrenceForm{ .. } -> void . runMaybeT $ do
-            cID <- hoistMaybe eofId
-            eofId' <- decrypt cID
-            oldOcc <- MaybeT $ get eofId'
-            guard $ examOccurrenceExam oldOcc == eId
-            lift $ replace eofId' ExamOccurrence
-              { examOccurrenceExam = eId
-              , examOccurrenceName = eofName
-              , examOccurrenceExaminer = eofExaminer
-              , examOccurrenceRoom = eofRoom
-              , examOccurrenceRoomHidden = eofRoomHidden
-              , examOccurrenceCapacity = eofCapacity
-              , examOccurrenceStart = eofStart
-              , examOccurrenceEnd = eofEnd
-              , examOccurrenceDescription = eofDescription
-              }
 
         pIds <- fmap catMaybes . forM (Set.toList efExamParts) $ traverse decrypt . epfId
 

src/Handler/Exam/Form.hs

@@ -8,6 +8,7 @@ module Handler.Exam.Form
   , ExamPartForm(..)
   , examForm
   , examOccurrenceMultiForm, examOccurrenceForm
+  , upsertExamOccurrences
   , examFormTemplate, examTemplate
   , validateExam
   ) where
@@ -309,6 +310,40 @@ examOccurrenceMultiForm prev = wFormToAForm $ do
     miIdent' :: Text
     miIdent' = "exam-occurrences"
 
+-- upsertExamOccurrences :: (MonoFoldable mono, Element mono ~ ExamOccurrenceForm) => ExamId -> mono -> DB ()     -- to specific
+upsertExamOccurrences :: (MonoFoldable mono, Element mono ~ ExamOccurrenceForm,
+                          PersistStoreWrite backend, MonadHandler m, BaseBackend backend ~ SqlBackend, HandlerSite m ~ UniWorX)
+  => Key Exam -> mono -> ReaderT backend m ()
+upsertExamOccurrences eId = mapM_ $ \case
+  ExamOccurrenceForm{ eofId = Nothing, .. } -> insert_
+    ExamOccurrence
+      { examOccurrenceExam = eId
+      , examOccurrenceName = eofName
+      , examOccurrenceExaminer = eofExaminer
+      , examOccurrenceRoom = eofRoom
+      , examOccurrenceRoomHidden = eofRoomHidden
+      , examOccurrenceCapacity = eofCapacity
+      , examOccurrenceStart = eofStart
+      , examOccurrenceEnd = eofEnd
+      , examOccurrenceDescription = eofDescription
+      }
+  ExamOccurrenceForm{ .. } -> void . runMaybeT $ do
+    cID <- hoistMaybe eofId
+    eofId' <- decrypt cID
+    oldOcc <- MaybeT $ get eofId'
+    guard $ examOccurrenceExam oldOcc == eId
+    lift $ replace eofId' ExamOccurrence
+      { examOccurrenceExam = eId
+      , examOccurrenceName = eofName
+      , examOccurrenceExaminer = eofExaminer
+      , examOccurrenceRoom = eofRoom
+      , examOccurrenceRoomHidden = eofRoomHidden
+      , examOccurrenceCapacity = eofCapacity
+      , examOccurrenceStart = eofStart
+      , examOccurrenceEnd = eofEnd
+      , examOccurrenceDescription = eofDescription
+      }
+
 examPartsForm :: Maybe (Set ExamPartForm) -> AForm Handler (Set ExamPartForm)
 examPartsForm prev = wFormToAForm $ do
   currentRoute <- fromMaybe (error "examPartsForm called from 404-handler") <$> getCurrentRoute

src/Handler/Tutorial/Users.hs

@@ -3,12 +3,15 @@
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
 {-# LANGUAGE TypeApplications #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
 
 module Handler.Tutorial.Users
   ( getTUsersR, postTUsersR
   ) where
 
 import Import
+import Control.Monad.Zip (munzip)
 
 import Utils.Form
 import Utils.Print
@@ -16,11 +19,12 @@ import Handler.Utils
 import Handler.Utils.Course
 import Handler.Utils.Course.Cache
 import Handler.Utils.Tutorial
-import Handler.Exam.Form (examOccurrenceMultiForm, ExamOccurrenceForm(..))
+import Handler.Exam.Form (ExamOccurrenceForm(..), examOccurrenceMultiForm, upsertExamOccurrences)
 import Database.Persist.Sql (deleteWhereCount)
 
 import qualified Data.CaseInsensitive as CI
 
+import qualified Data.Text as Text
 import qualified Data.Set as Set
 import qualified Data.Map as Map
 import qualified Data.ByteString.Lazy as LBS
@@ -32,42 +36,39 @@ import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications
 import Handler.Course.Users
 
 
-data GenTutAction
-  = GenTutActNone               -- Dummy action to hide form in a more natural way
-  | GenTutActOccAdd
-  | GenTutActOccEdit
-  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
-  deriving anyclass (Universe, Finite)
-
-nullaryPathPiece ''GenTutAction $ camelToPathPiece' 1
-embedRenderMessage ''UniWorX ''GenTutAction id
-
-data GenTutActionData
-  = GenTutActNoneData           -- Dummy action to hide form in a more natural way
-  | GenTutActOccAddData
-      { -- gtaoaExam :: ExamId,
-        gtaoaOcc  :: Set ExamOccurrenceForm
-      }
-  | GenTutActOccEditData
-  deriving (Eq, Ord, Show, Generic)
-
-genTutActionMap ::(_ -> Text) -> Map GenTutAction (AForm Handler GenTutActionData)
-genTutActionMap _mr = Map.fromList
-  [ (GenTutActNone
-    , pure GenTutActNoneData )
-  , (GenTutActOccAdd, GenTutActOccAddData
-      <$> examOccurrenceMultiForm Nothing -- TODO
-    )
-  , (GenTutActOccEdit
-    , pure GenTutActOccEditData) -- TODO
-  ]
-
-makeGenTutActionForm :: (_ -> Text) -> Form GenTutActionData
-makeGenTutActionForm mr html = flip (renderAForm FormStandard) html $ multiActionA (genTutActionMap mr) (fslI MsgAction) (Just GenTutActNone)
 -- TODO: Idee: MultiAction für jedes Exam, um so die einzelnen Occurrences zu markieren!
 --       Default muss auch entsprechend generiert werden, wenn keine Occurrences für den Tag existieren
 --       Im Form sollten die neuen markiert werden als ungespeichert! Generell wünschenswert für MassInput!
 
+instance PathPiece a => PathPiece [a] where
+  toPathPiece   = tshow . map toPathPiece
+  fromPathPiece (Text.uncons -> Just ('[', Text.unsnoc -> Just (Text.split (==',') -> xs,']'))) =
+    mapM fromPathPiece xs
+  fromPathPiece _ = Nothing
+
+-- instance PathPiece [Data.CryptoID.CryptoID "ExamOccurrence" UUID] where
+--   toPathPiece   = tshow $ map toPathPiece
+--   fromPathPiece = error "TODO"
+
+-- | 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 exs eom = renderAForm FormStandard maa
+  where
+    maa = multiActionA acts (fslI MsgCourseExam) Nothing
+    eid2eos = convertExamOccurrenceMap eom
+
+    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,
+        let (cuEoIds, eos) = munzip $ Map.lookup eId eid2eos
+        in (,,)
+          <$> areq hiddenField "teoExam" (Just cueId)
+          <*> areq (mkSetField hiddenField) "teoOccs" cuEoIds
+          <*> examOccurrenceMultiForm eos
+      )
+
 data TutorialUserAction
   = TutorialUserAssignExam
   | TutorialUserPrintQualification
@@ -136,7 +137,7 @@ postTUsersR tid ssh csh tutn = do
         qualOptions = qualificationsOptionList qualifications
         lessons  = occurringLessons trm $ tutEnt ^. _entityVal . _tutorialTime . _Wrapped'
         timespan = lessonTimesSpan lessons
-    exOccs <- flip foldMapM timespan $ getDayExamOccurrences False ssh $ Just cid -- TODO: change back default to True
+    exOccs <- flip foldMapM timespan $ getDayExamOccurrences True ssh $ Just cid
     let
       acts :: Map TutorialUserAction (AForm Handler TutorialUserActionData)
       acts = Map.fromList $
@@ -208,7 +209,7 @@ postTUsersR tid ssh csh tutn = do
         addMessageI Success $ MsgTutorialUsersDeregistered nrDel
         reloadKeepGetParams croute
     (TutorialUserAssignExamData{..}, selectedUsers)
-      | (Just (ExamOccurrence{..}, (eid,_))) <- Map.lookup tuOccurrenceId exOccs -> do
+      | (Just (ExamOccurrence{..}, _, (eid,_))) <- Map.lookup tuOccurrenceId exOccs -> do
             let n = Set.size selectedUsers
             capOk <- ifNothing examOccurrenceCapacity (pure True) $ \(fromIntegral -> totalCap) -> do
               usedCap <- runDBRead $ count [ExamRegistrationOccurrence ==. Just tuOccurrenceId, ExamRegistrationUser /<-. Set.toList selectedUsers]
@@ -235,9 +236,8 @@ postTUsersR tid ssh csh tutn = do
         E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid
         return user
 
-      let mr :: (() -> Text) = const "TODO: message renderer for general tutorial action form" -- getMessageRender
       genTutActWgt <- do
-        ((gtaRes, gtaWgt), gtaEnctype) <- runFormPost . identifyForm FIDGeneralTutorialAction $ makeGenTutActionForm mr
+        ((gtaRes, gtaWgt), gtaEnctype) <- runFormPost . identifyForm FIDGeneralTutorialAction $ mkExamOccurrenceForm [] exOccs -- TODO
         let gtaAnchor  = "general-tutorial-action-form" :: Text
             gtaRoute   = croute :#: gtaAnchor
             gtaForm    = wrapForm gtaWgt FormSettings
@@ -248,15 +248,13 @@ postTUsersR tid ssh csh tutn = do
                               , formSubmit = FormSubmit
                               , formAnchor = Just gtaAnchor
                               }
-        formResult gtaRes $ \case
+        formResult gtaRes $ \(cEId, cEOIds, occs) -> do -- (CryptoUUIDExam, Set CryptoUUIDExamOccurrence, Set ExamOccurrenceForm)
-          GenTutActNoneData -> return ()
+          let ceoidsDelete = cEOIds `Set.difference` setMapMaybe eofId occs
-          GenTutActOccAddData{} -> error "not yet implemended" -- TODO
+          eId <- decrypt cEId
-
+          eoIdsDelete <- mapM decrypt $ Set.toList ceoidsDelete
-          GenTutActOccEditData{} -> error "not yet implemended" -- TODO
+          runDB $ do
-
+            deleteWhere [ExamOccurrenceExam ==. eId, ExamOccurrenceId <-. eoIdsDelete]
-        -----------------------------------------------
+            upsertExamOccurrences eId $ Set.toList occs
-        -- !!!!!TODO: evaluate form result !!!!!!!!! --
-        -----------------------------------------------
 
         return [whamlet|
             <h2 .show-hide__toggle uw-show-hide data-show-hide-collapsed>

src/Handler/Utils/Course/Cache.hs

@@ -8,6 +8,7 @@ import Import
 
 import Handler.Utils
 -- import Handler.Utils.Occurrences
+import Handler.Exam.Form (ExamOccurrenceForm(..))
 
 import qualified Data.Set as Set
 import qualified Data.Map as Map
@@ -131,7 +132,8 @@ getDayTutorials ssh dlimit@(dstart, dend )
 --     mkOccMap :: (Entity Exam, Entity ExamOccurrence) -> Map ExamOccurrenceId (CourseId, ExamName, ExamOccurrence)
 --     mkOccMap (entityVal -> exm, Entity{..}) = Map.singleton entityKey (exm ^. _examCourse, exm ^. _examName, entityVal)
 
-type ExamOccurrenceMap = Map ExamOccurrenceId (ExamOccurrence, (ExamId, ExamName))
+type ExamOccurrenceMap = Map ExamOccurrenceId (ExamOccurrence, CryptoUUIDExamOccurrence, (ExamId, ExamName))
+type ExamToOccurrencesMap  = Map ExamId (Set CryptoUUIDExamOccurrence, Set ExamOccurrenceForm)
 
 -- | retrieve all exam occurrences for a school in a given time period, ignoring term times; uses caching
 --   if a CourseId is specified, only exams from that course are returned
@@ -152,17 +154,34 @@ getDayExamOccurrences onlyOpen ssh mbcid dlimit@(dstart, dend)
         , Just $ E.withinPeriod dlimit (occ E.^. ExamOccurrenceStart) (occ E.^. ExamOccurrenceEnd)
         ]
       return (occ, exm E.^. ExamId, exm E.^. ExamName) -- No Binary instance for Entity Exam, so we only extract what is needed for now
-    return $ foldMap mkOccMap candidates
+    foldMapM mkOccMap candidates
   where
-    mkOccMap :: (Entity ExamOccurrence, E.Value ExamId, E.Value ExamName) -> ExamOccurrenceMap
+    mkOccMap :: (Entity ExamOccurrence, E.Value ExamId, E.Value ExamName) -> DB ExamOccurrenceMap
-    mkOccMap (Entity{..}, E.Value eId, E.Value eName) = Map.singleton entityKey (entityVal, (eId, eName))
+    mkOccMap (Entity{..}, E.Value eId, E.Value eName) = encrypt entityKey <&> (\ceoId -> Map.singleton entityKey (entityVal, ceoId, (eId, eName)))
 
 mkExamOccurrenceOptions :: ExamOccurrenceMap -> OptionList ExamOccurrenceId
 mkExamOccurrenceOptions = mkOptionListGrouped . groupSort . map mkEOOption . Map.toList
   where
-    mkEOOption :: (ExamOccurrenceId, (ExamOccurrence, (ExamId, ExamName))) -> (Text, [Option ExamOccurrenceId])
+    mkEOOption :: (ExamOccurrenceId, (ExamOccurrence, CryptoUUIDExamOccurrence, (ExamId, ExamName))) -> (Text, [Option ExamOccurrenceId])
-    mkEOOption (eid, (ExamOccurrence{..}, (_,eName))) = (ciOriginal eName, [Option{..}])
+    mkEOOption (eid, (ExamOccurrence{examOccurrenceName}, ceoId, (_,eName))) = (ciOriginal eName, [Option{..}])
       where
         optionDisplay       = ciOriginal examOccurrenceName
-        optionExternalValue = toPathPiece $ eName <> ":" <> examOccurrenceName
+        optionExternalValue = toPathPiece ceoId
         optionInternalValue = eid
+
+convertExamOccurrenceMap :: ExamOccurrenceMap -> ExamToOccurrencesMap
+convertExamOccurrenceMap eom = Map.fromListWith (<>) $ map aux $ Map.toList eom
+  where
+    aux :: (ExamOccurrenceId, (ExamOccurrence, CryptoUUIDExamOccurrence, (ExamId, ExamName))) -> (ExamId, (Set CryptoUUIDExamOccurrence, Set ExamOccurrenceForm))
+    aux (_, (ExamOccurrence{..}, cueoId, (eid,_))) = (eid, (Set.singleton cueoId, Set.singleton ExamOccurrenceForm
+            { eofId          = Just cueoId
+            , eofName        = examOccurrenceName
+            , eofExaminer    = examOccurrenceExaminer
+            , eofRoom        = examOccurrenceRoom
+            , eofRoomHidden  = examOccurrenceRoomHidden
+            , eofCapacity    = examOccurrenceCapacity
+            , eofStart       = examOccurrenceStart
+            , eofEnd         = examOccurrenceEnd
+            , eofDescription = examOccurrenceDescription
+            }
+          ))

src/Utils/Form.hs

@@ -116,6 +116,10 @@ commentField msg = Field {..}
     fieldView  _ _ _ _ _  = msg2widget msg
     fieldEnctype          = UrlEncoded
 
+-- | Fields of sets are only allowed indirectly
+mkSetField :: (Ord a, Functor m) => Field m [a] -> Field m (Set a)
+mkSetField = convertField Set.fromList Set.toList
+
 --------------------
 -- Field Settings --
 --------------------