diff --git a/messages/uniworx/categories/courses/tutorial/de-de-formal.msg b/messages/uniworx/categories/courses/tutorial/de-de-formal.msg index 82cd5c5ba..4e7522146 100644 --- a/messages/uniworx/categories/courses/tutorial/de-de-formal.msg +++ b/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 \ No newline at end of file diff --git a/messages/uniworx/categories/courses/tutorial/en-eu.msg b/messages/uniworx/categories/courses/tutorial/en-eu.msg index 686b01f58..600da8712 100644 --- a/messages/uniworx/categories/courses/tutorial/en-eu.msg +++ b/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 \ No newline at end of file diff --git a/models/exams.model b/models/exams.model index 8dd6f3ad5..610bac4df 100644 --- a/models/exams.model +++ b/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 diff --git a/src/Handler/Exam/Edit.hs b/src/Handler/Exam/Edit.hs index ed7d56100..80ef0123d 100644 --- a/src/Handler/Exam/Edit.hs +++ b/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 - 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 - } + 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 ba98c1e19..a447f4870 100644 --- a/src/Handler/Exam/Form.hs +++ b/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 diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index 31a4167b7..ed1e45832 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/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 - GenTutActNoneData -> return () - GenTutActOccAddData{} -> error "not yet implemended" -- TODO - - GenTutActOccEditData{} -> error "not yet implemended" -- TODO - - ----------------------------------------------- - -- !!!!!TODO: evaluate form result !!!!!!!!! -- - ----------------------------------------------- + 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|

diff --git a/src/Handler/Utils/Course/Cache.hs b/src/Handler/Utils/Course/Cache.hs index 8347cb2c7..f16a6d9c0 100644 --- a/src/Handler/Utils/Course/Cache.hs +++ b/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{..}, E.Value eId, E.Value eName) = Map.singleton entityKey (entityVal, (eId, eName)) + mkOccMap :: (Entity ExamOccurrence, E.Value ExamId, E.Value ExamName) -> DB ExamOccurrenceMap + 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 (eid, (ExamOccurrence{..}, (_,eName))) = (ciOriginal eName, [Option{..}]) + mkEOOption :: (ExamOccurrenceId, (ExamOccurrence, CryptoUUIDExamOccurrence, (ExamId, ExamName))) -> (Text, [Option ExamOccurrenceId]) + 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 + } + )) \ No newline at end of file diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index cc72f86cb..716718928 100644 --- a/src/Utils/Form.hs +++ b/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 -- --------------------