diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index f6ab783b9..039498fe8 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/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 diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index 594f9c320..13a3dd6fe 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/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 diff --git a/routes b/routes index c6aa0743e..469524dbb 100644 --- a/routes +++ b/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 diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 367fe7a21..cca5a0290 100644 --- a/src/Foundation/Navigation.hs +++ b/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 diff --git a/src/Handler/Exam/Edit.hs b/src/Handler/Exam/Edit.hs index 80ef0123d..67e700ac0 100644 --- a/src/Handler/Exam/Edit.hs +++ b/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 diff --git a/src/Handler/Exam/Form.hs b/src/Handler/Exam/Form.hs index 1a597e33c..cd9004489 100644 --- a/src/Handler/Exam/Form.hs +++ b/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 - , PersistQueryRead backend, PersistUniqueRead backend, PersistStoreWrite backend +upsertExamOccurrences :: ( HandlerSite m ~ UniWorX, MonadHandler m, MonadThrow m + , PersistQueryRead backend, PersistUniqueWrite backend , BaseBackend backend ~ SqlBackend, BackendCompatible SqlBackend backend) - => Key Exam -> mono -> ReaderT backend m () -upsertExamOccurrences eId = mapM_ $ \case + => Key Exam -> [ExamOccurrenceForm] -> ReaderT backend m Int +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 diff --git a/src/Handler/Exam/New.hs b/src/Handler/Exam/New.hs index 479002ce9..3c09f207a 100644 --- a/src/Handler/Exam/New.hs +++ b/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 ] diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index 508edd33f..9962b7390 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/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| +
+

#{CI.original exmName} +

#{examDescription exm} +

+ ^{eofForm} + |] diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 55027a7f6..1972685ac 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -328,7 +328,7 @@ data FormIdentifier | FIDAddSupervisor | FIDFirmUserChangeRequest | FIDFirmAction - | FIDGeneralTutorialAction + | FIDTutorialExamOccurrences | FIDUnreachableUsersAction deriving (Eq, Ord, Read, Show)