chore(tutorial): add separate exam occurrence edit page (WIP)

messages/uniworx/utils/navigation/menu/de-de-formal.msg

@@ -33,6 +33,7 @@ MenuCourseIcon: Kurse
 MenuCourseMembers: Kursartteilnehmer:innen
 MenuCourseAddMembers: Kursartteilnehmer:innen hinzufügen
 MenuTutorialAddMembers: Kursteilnehmer:innen hinzufügen
+MenuTutorialExam exn@ExamName: Kursprüfung #{exn} bearbeiten
 MenuCourseCommunication: Kursartmitteilung (E‑Mail)
 MenuCourseExamOffice: Prüfungsbeauftragte
 MenuTermShow: Jahr

messages/uniworx/utils/navigation/menu/en-eu.msg

@@ -33,6 +33,7 @@ MenuCourseIcon: Courses
 MenuCourseMembers: Participants
 MenuCourseAddMembers: Add course type participants
 MenuTutorialAddMembers: Add course participants
+MenuTutorialExam exn@ExamName: Edit course exam #{exn}
 MenuCourseCommunication: Course type message (email)
 MenuCourseExamOffice: Exam offices
 MenuTermShow: Semesters

routes

@@ -228,6 +228,7 @@
     /delete                   TDeleteR         GET POST
     /participants             TUsersR          GET POST        !tutor
     /participants/add         TAddUserR        GET POST        !tutor
+    /participants/exam/#ExamName  TExamR       GET POST        !tutor
     /register                 TRegisterR           POST        !timeANDcapacityANDcourse-registeredANDregister-group !timeANDtutorial-registered
     /communication            TCommR           GET POST        !tutor
     /tutor-invite             TInviteR         GET POST        !tutorANDtutor-control

src/Foundation/Navigation.hs

@@ -306,6 +306,7 @@ breadcrumb (CourseR tid ssh csh (TutorialR tutn sRoute)) = case sRoute of
     guardM . lift . hasReadAccessTo $ CTutorialR tid ssh csh tutn TUsersR
     return (CI.original tutn, Just $ CourseR tid ssh csh CTutorialListR)
   TAddUserR   -> i18nCrumb MsgMenuTutorialAddMembers      . Just $ CTutorialR tid ssh csh tutn TUsersR
+  TExamR exn  -> i18nCrumb (MsgMenuTutorialExam exn)      . Just $ CTutorialR tid ssh csh tutn TUsersR
   TEditR      -> i18nCrumb MsgMenuTutorialEdit            . Just $ CTutorialR tid ssh csh tutn TUsersR
   TDeleteR    -> i18nCrumb MsgMenuTutorialDelete          . Just $ CTutorialR tid ssh csh tutn TUsersR
   TCommR      -> i18nCrumb MsgMenuTutorialComm            . Just $ CTutorialR tid ssh csh tutn TUsersR

src/Handler/Exam/Edit.hs

@@ -75,7 +75,7 @@ postEEditR tid ssh csh examn = do
 
         occIds <- fmap catMaybes . forM (Set.toList efOccurrences) $ traverse decrypt . eofId
         deleteWhere [ ExamOccurrenceExam ==. eId, ExamOccurrenceId /<-. occIds ]
-        upsertExamOccurrences eId $ Set.toList efOccurrences
+        void $ upsertExamOccurrences eId $ Set.toList efOccurrences
 
         pIds <- fmap catMaybes . forM (Set.toList efExamParts) $ traverse decrypt . epfId
 

src/Handler/Exam/Form.hs

@@ -350,6 +350,7 @@ copyExamOccurrences eId dfrom dto = do
               _examOccurrenceEnd . _Just . _utctDay %~ shiftDay $ eo
     newName <- maybeM (guessExamOccurrenceName eId $ examOccurrenceTemplate eo') return $ return (fmap CI.mk $ textReplaceFirst drepl $ CI.original oldName)
     insertUnique_ (eo'{examOccurrenceName=newName})
+  memcachedInvalidateClass MemcachedKeyClassExamOccurrences
   return $ length $ catMaybes res
 
 -- | generate an exam-unique occurrence name from data
@@ -402,15 +403,15 @@ guessExamOccurrenceName eId ExamOccurrenceForm{..} = do
 
 
 -- upsertExamOccurrences :: (MonoFoldable mono, Element mono ~ ExamOccurrenceForm) => ExamId -> mono -> DB ()     -- too specific
-upsertExamOccurrences :: ( MonoFoldable mono, Element mono ~ ExamOccurrenceForm, HandlerSite m ~ UniWorX, MonadHandler m, MonadThrow m
+upsertExamOccurrences :: ( HandlerSite m ~ UniWorX, MonadHandler m, MonadThrow m
-                         , PersistQueryRead backend, PersistUniqueRead backend, PersistStoreWrite backend
+                         , PersistQueryRead backend, PersistUniqueWrite backend
                          , BaseBackend backend ~ SqlBackend, BackendCompatible SqlBackend backend)
-  => Key Exam -> mono -> ReaderT backend m ()
+  => Key Exam -> [ExamOccurrenceForm] -> ReaderT backend m Int
-upsertExamOccurrences eId = mapM_ $ \case
+upsertExamOccurrences eId = fmap (length . catMaybes) . mapM (\case
     eof@ExamOccurrenceForm{ eofId = Nothing, eofName = eofNameMb, .. } -> do
       eofName <- fromMaybeM (guessExamOccurrenceName eId eof) (pure eofNameMb)
       $logInfoS "ExamOccurrenceForm" [st|New Exam Occurrence: #{eofName}|]
-      insert_ ExamOccurrence
+      insertUnique_ ExamOccurrence
           { examOccurrenceExam = eId
           , examOccurrenceName = eofName
           , examOccurrenceExaminer = eofExaminer
@@ -421,14 +422,14 @@ upsertExamOccurrences eId = mapM_ $ \case
           , examOccurrenceEnd = eofEnd
           , examOccurrenceDescription = eofDescription
           }
-    eof@ExamOccurrenceForm{eofName = eofNameMb, .. } -> void . runMaybeT $ do
+    eof@ExamOccurrenceForm{eofName = eofNameMb, .. } -> fmap join $ runMaybeT $ do
       cID <- hoistMaybe eofId
       eofId' <- decrypt cID
       oldOcc <- MaybeT $ get eofId'
       guard $ examOccurrenceExam oldOcc == eId
       lift $ do
         eofName <- fromMaybeM (guessExamOccurrenceName eId eof) (pure eofNameMb)
-        replace eofId' ExamOccurrence
+        res <- replaceUnique eofId' ExamOccurrence
           { examOccurrenceExam = eId
           , examOccurrenceName = eofName
           , examOccurrenceExaminer = eofExaminer
@@ -439,6 +440,9 @@ upsertExamOccurrences eId = mapM_ $ \case
           , examOccurrenceEnd = eofEnd
           , examOccurrenceDescription = eofDescription
           }
+        memcachedInvalidateClass MemcachedKeyClassExamOccurrences
+        return $ flipMaybe () res
+    )
 
 examPartsForm :: Maybe (Set ExamPartForm) -> AForm Handler (Set ExamPartForm)
 examPartsForm prev = wFormToAForm $ do

src/Handler/Exam/New.hs

@@ -70,7 +70,7 @@ postCExamNewR tid ssh csh = do
                 examPartWeight    = epfWeight
           ]
 
-        upsertExamOccurrences examid efOccurrences
+        void $ upsertExamOccurrences examid $ Set.toList efOccurrences
 
         insertMany_ [ ExamOfficeSchool ssh' examid | ssh' <- Set.toList efOfficeSchools ]
 

src/Handler/Tutorial/Users.hs

@@ -4,8 +4,11 @@
 
 {-# LANGUAGE TypeApplications, BlockArguments #-}
 
+{-# OPTIONS_GHC -Wno-error=unused-local-binds -Wno-error=unused-matches #-}
+
 module Handler.Tutorial.Users
   ( getTUsersR, postTUsersR
+  , getTExamR, postTExamR
   ) where
 
 import Import
@@ -238,7 +241,7 @@ postTUsersR tid ssh csh tutn = do
         then return $(i18nWidgetFile "exam-missing")
         else do
           openExamsUUIDs <- forM openExams $ \ent@Entity{entityKey=k, entityVal=Exam{examName}} -> (ent,,) <$> encrypt k <*> pure (mkExamEditBtn examName)
-          ((gtaRes, gtaWgt), gtaEnctype) <- runFormPost . identifyForm FIDGeneralTutorialAction $ mkExamOccurrenceForm openExamsUUIDs exOccs -- TODO also TODO: occurrence name auto generation
+          ((gtaRes, gtaWgt), gtaEnctype) <- runFormPost . identifyForm ("FIDGeneralTutorialAction"::Text) $ mkExamOccurrenceForm openExamsUUIDs exOccs -- TODO also TODO: occurrence name auto generation
           let gtaAnchor  = "general-tutorial-action-form" :: Text
               gtaRoute   = croute :#: gtaAnchor
               gtaForm    = wrapForm gtaWgt FormSettings
@@ -257,10 +260,57 @@ postTUsersR tid ssh csh tutn = do
             $logInfoS "ExamOccurrenceEdit" [st|Exam-Edit: #{length cEOIds} old occurrences, #{length eoIdsDelete} to delete, #{length $ Set.filter (isNothing . eofId) occs} to insert, #{length $ Set.filter (isJust . eofId) occs} to edit|]
             runDB do
               deleteWhere [ExamOccurrenceExam ==. eId, ExamOccurrenceId <-. eoIdsDelete]
-              upsertExamOccurrences eId $ Set.toList occs
+              void $ upsertExamOccurrences eId $ Set.toList occs
           return gtaForm
       let heading = prependCourseTitle tid ssh csh $ CI.original tutorialName
       html <- siteLayoutMsg heading do
         setTitleI heading
         $(widgetFile "tutorial-participants")
       return $ toTypedContent html
+
+
+getTExamR, postTExamR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> ExamName -> Handler Html
+getTExamR = postTExamR
+postTExamR tid ssh csh tutn exmName = do
+  let baseroute  = CTutorialR tid ssh csh tutn
+  (cid,tutEnt,Entity{entityKey=eId,entityVal=exm},exOccs) <- runDB do
+    trm <- get404 tid
+    (cid, tutEnt) <- fetchCourseIdTutorial tid ssh csh tutn
+    exm <- getBy404 $ UniqueExam cid exmName
+    let lessons  = occurringLessons trm $ tutEnt ^. _entityVal . _tutorialTime . _Wrapped'
+        timespan = lessonTimesSpan lessons
+        -- (fmap (toMidnight . succ) -> tbegin, fmap toMidnight -> tend) = munzip timespan
+    -- exms <- selectList ([ExamCourse ==. cid, ExamStart <=. tend] ++ ([ExamEnd >=. tbegin] ||. [ExamEnd ==. Nothing])) [Asc ExamName]
+    exOccs <- flip foldMapM timespan $ getDayExamOccurrences False ssh $ Just cid
+    return (cid,tutEnt,exm,exOccs)
+  cueId :: CryptoUUIDExam <- encrypt eId
+  let eid2eos = convertExamOccurrenceMap exOccs
+      (cuEoIds, eos) = munzip $ Map.lookup eId eid2eos
+      exOcForm = (,,)
+        <$> areq             hiddenField  "" (Just cueId)
+        <*> areq (mkSetField hiddenField) "" cuEoIds
+        <*> examOccurrenceMultiForm eos
+  ((eofRes, eofWgt), eofEnctype) <- runFormPost $ identifyForm FIDTutorialExamOccurrences $ renderAForm FormStandard exOcForm
+  let eofForm = wrapForm eofWgt def{formEncoding = eofEnctype}
+  formResult eofRes $ \(edCEId, edCEOIds, edOccs) -> do
+    let ceoidsDelete = edCEOIds `Set.difference` setMapMaybe eofId edOccs
+    $logInfoS "ExamOccurrenceEdit" [st|Exam-Edit: #{length edCEOIds} old occurrences, #{length ceoidsDelete} to delete, #{length $ Set.filter (isNothing . eofId) edOccs} to insert, #{length $ Set.filter (isJust . eofId) edOccs} to edit|]
+    reId <- decrypt edCEId
+    eoIdsDelete <- mapM decrypt $ Set.toList ceoidsDelete
+    when (reId == eId) $ runDB do
+      nrDel <- deleteWhereCount [ExamOccurrenceExam ==. reId, ExamOccurrenceId <-. eoIdsDelete]
+      nrUps <- upsertExamOccurrences eId $ Set.toList edOccs
+      --TODO status message
+      reload $ baseroute $ TExamR exmName
+
+  let heading = prependCourseTitle tid ssh csh $ CI.original $ tutorialName $ entityVal tutEnt
+  -- let heading = prependCourseTitle tid ssh csh $ tutEnt ^. _entityVal . _tutorialName . _CI
+  siteLayoutMsg (MsgMenuTutorialExam exmName) do
+    setTitle $ citext2Html exmName
+    [whamlet|
+      <section>
+        <h2>#{CI.original exmName}
+        <p>#{examDescription exm}
+      <section>
+        ^{eofForm}
+    |]

src/Utils/Form.hs

@@ -328,7 +328,7 @@ data FormIdentifier
   | FIDAddSupervisor
   | FIDFirmUserChangeRequest
   | FIDFirmAction
-  | FIDGeneralTutorialAction
+  | FIDTutorialExamOccurrences
   | FIDUnreachableUsersAction
   deriving (Eq, Ord, Read, Show)