diff --git a/models/tutorials.model b/models/tutorials.model index 72dc8676a..c1e237344 100644 --- a/models/tutorials.model +++ b/models/tutorials.model @@ -24,9 +24,19 @@ Tutor UniqueTutor tutorial user deriving Generic TutorialParticipant - tutorial TutorialId OnDeleteCascade OnUpdateCascade - user UserId - company CompanyId Maybe + tutorial TutorialId OnDeleteCascade OnUpdateCascade + user UserId + company CompanyId Maybe + drivingPermit UserDrivingPermit Maybe + eyeExam UserEyeExam Maybe + note Text Maybe UniqueTutorialParticipant tutorial user - deriving Eq Ord Show - deriving Generic \ No newline at end of file + deriving Eq Ord Show Generic +TutorialParticipantDay + tutorial TutorialId OnDeleteCascade OnUpdateCascade + user UserId OnDeleteCascade OnUpdateCascade + day Day + attendance Bool default=true + note Text Maybe + UniqueTutorialParticipantDay tutorial user day + deriving Show Generic \ No newline at end of file diff --git a/models/users.model b/models/users.model index beb1d8e0c..96761a200 100644 --- a/models/users.model +++ b/models/users.model @@ -104,4 +104,9 @@ UserSupervisor reason Text Maybe -- miscellaneous reason, e.g. Winterservice supervisision UniqueUserSupervisor supervisor user -- each supervisor/user combination is unique (same supervisor can superviser the same user only once) deriving Generic Show - +UserDay + user UserId OnDeleteCascade OnUpdateCascade + day Day + parkingToken Bool default=false + UniqueUserDay user day + deriving Generic Show diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index dfb456147..665d83627 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -402,6 +402,9 @@ registerTutorialMembers tutId (Set.toList -> users) = runDB $ do prevParticipants <- Set.fromList . fmap entityKey <$> selectList [TutorialParticipantUser <-. users, TutorialParticipantTutorial ==. tutId] [] participants <- fmap Set.fromList . for users $ \tutorialParticipantUser -> do tutorialParticipantCompany <- selectCompanyUserPrime' tutorialParticipantUser + let tutorialParticipantDrivingPermit = Nothing + tutorialParticipantEyeExam = Nothing + tutorialParticipantNote = Nothing Entity tutPartId _ <- upsert TutorialParticipant { tutorialParticipantTutorial = tutId, .. } [] audit $ TransactionTutorialParticipantEdit tutId tutPartId tutorialParticipantUser return tutPartId diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index 3d66e30c7..b5fe6ca51 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -736,7 +736,7 @@ postCUsersR tid ssh csh = do (CourseUserRegisterTutorialData{..}, selectedUsers) -> do Sum nrOk <- runDB $ flip foldMapM selectedUsers $ \uid -> do fsh <- selectCompanyUserPrime' uid - mbKey <- insertUnique $ TutorialParticipant registerTutorial uid fsh + mbKey <- insertUnique $ TutorialParticipant registerTutorial uid fsh Nothing Nothing Nothing return $ Sum $ length mbKey let mStatus = bool Success Warning $ nrOk < Set.size selectedUsers addMessageI mStatus $ MsgCourseUsersTutorialRegistered $ fromIntegral nrOk diff --git a/src/Handler/Tutorial/Register.hs b/src/Handler/Tutorial/Register.hs index 0377aae60..1db091e07 100644 --- a/src/Handler/Tutorial/Register.hs +++ b/src/Handler/Tutorial/Register.hs @@ -24,7 +24,7 @@ postTRegisterR tid ssh csh tutn = do BtnRegister -> do ok <- runDB $ do fsh <- selectCompanyUserPrime' uid - insertUnique $ TutorialParticipant tutid uid fsh + insertUnique $ TutorialParticipant tutid uid fsh Nothing Nothing Nothing if isJust ok then addMessageI Success $ MsgTutorialRegisteredSuccess tutorialName else addMessageI Error $ MsgTutorialRegisteredFail tutorialName -- cannot happen, but it is nonetheless better to be safe than crashing diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index 1760d37fe..86d3f40df 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -871,9 +871,30 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.<# (tutorialParticipant E.^. TutorialParticipantTutorial) E.<&> E.val newUserId E.<&> (tutorialParticipant E.^. TutorialParticipantCompany) + E.<&> (tutorialParticipant E.^. TutorialParticipantDrivingPermit) + E.<&> (tutorialParticipant E.^. TutorialParticipantEyeExam) + E.<&> (tutorialParticipant E.^. TutorialParticipantNote) ) (\_current _excluded -> []) - deleteWhere [ TutorialParticipantUser ==. oldUserId ] + E.insertSelectWithConflict + UniqueTutorialParticipantDay + (EL.from $ \tutorialParticipantDay -> do + E.where_ $ tutorialParticipantDay E.^. TutorialParticipantDayUser E.==. E.val oldUserId + return $ TutorialParticipantDay + E.<# (tutorialParticipantDay E.^. TutorialParticipantDayTutorial) + E.<&> E.val newUserId + E.<&> (tutorialParticipantDay E.^. TutorialParticipantDayDay) + E.<&> (tutorialParticipantDay E.^. TutorialParticipantDayAttendance) + E.<&> (tutorialParticipantDay E.^. TutorialParticipantDayNote) + ) + (\current excluded -> + [ TutorialParticipantDayAttendance E.=. (current E.^. TutorialParticipantDayAttendance E.||. excluded E.^. TutorialParticipantDayAttendance) + , TutorialParticipantDayNote E.=. E.coalesce [current E.^. TutorialParticipantDayNote, excluded E.^. TutorialParticipantDayNote] + ] + ) + deleteWhere [ TutorialParticipantDayUser ==. oldUserId ] + deleteWhere [ TutorialParticipantUser ==. oldUserId ] + E.insertSelectWithConflict UniqueSystemMessageHidden @@ -1012,6 +1033,21 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do ) deleteWhere [ UserCompanyUser ==. oldUserId] + E.insertSelectWithConflict + UniqueUserDay + (EL.from $ \userDay -> do + E.where_ $ userDay E.^. UserDayUser E.==. E.val oldUserId + return $ UserDay + E.<# E.val newUserId + E.<&> (userDay E.^. UserDayDay) + E.<&> (userDay E.^. UserDayParkingToken) + ) + (\current excluded -> + [ UserDayParkingToken E.=. (current E.^. UserDayParkingToken E.||. excluded E.^. UserDayParkingToken) + ] + ) + deleteWhere [ UserDayUser ==. oldUserId] + mbOldAvsId <- getBy $ UniqueUserAvsUser oldUserId mbNewAvsId <- getBy $ UniqueUserAvsUser newUserId case (mbOldAvsId,mbNewAvsId) of diff --git a/src/Model/Types/User.hs b/src/Model/Types/User.hs index 64cb539d9..d2143636c 100644 --- a/src/Model/Types/User.hs +++ b/src/Model/Types/User.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -15,7 +15,7 @@ data SystemFunction = SystemExamOffice | SystemFaculty | SystemStudent - | SystemPrinter + | SystemPrinter deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic) deriving anyclass (Universe, Finite, Hashable, NFData) @@ -24,3 +24,37 @@ pathPieceJSON ''SystemFunction pathPieceJSONKey ''SystemFunction derivePersistFieldPathPiece ''SystemFunction pathPieceBinary ''SystemFunction + + + +-------------------------------------------------------------------------------------- +-- User related dataypes which are not stored in User itself, but in various places + +data UserDrivingPermit = UserDrivingPermitB + | UserDrivingPermitB01 + deriving (Eq, Ord, Enum, Bounded, Generic, Universe, Finite, Hashable, NFData) + +instance Show UserDrivingPermit where + show UserDrivingPermitB = "B" + show UserDrivingPermitB01 = "B01" + +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 3 + } ''UserDrivingPermit +derivePersistFieldJSON ''UserDrivingPermit + + +data UserEyeExam = UserEyeExamSX + | UserEyeExamS01 + deriving (Eq, Ord, Enum, Bounded, Generic, Universe, Finite, Hashable, NFData) + +instance Show UserEyeExam where + show UserEyeExamSX = "SX" + show UserEyeExamS01 = "S01" + +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 3 + } ''UserEyeExam +derivePersistFieldJSON ''UserEyeExam + + diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 7ab25710a..46f8d5000 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -136,6 +136,7 @@ makeClassyFor_ ''LmsUser makeClassyFor_ ''LmsReport makeClassyFor_ ''UserAvs +makeLenses_ ''UserDay makeLenses_ ''UserCompany makeLenses_ ''Company @@ -286,6 +287,7 @@ makeLenses_ ''CourseNewsFile makeLenses_ ''Tutorial makeLenses_ ''TutorialParticipant +makeLenses_ ''TutorialParticipantDay makeLenses_ ''SessionFile diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 1ea12d27e..5f95fbab1 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -1217,12 +1217,15 @@ fillDb = do insert_ $ CourseParticipant c gkleen now $ CourseParticipantInactive True insert_ $ CourseParticipant c fhamann now $ CourseParticipantInactive False insert_ $ CourseParticipant c svaupel now CourseParticipantActive - insert_ $ TutorialParticipant tut1 svaupel Nothing - insert_ $ TutorialParticipant tut2 svaupel $ Just fraGround - when (odd tyear) $ insert_ $ TutorialParticipant tut3 svaupel $ Just fraGround - insert_ $ TutorialParticipant tut1 gkleen $ Just nice - insert_ $ TutorialParticipant tut2 fhamann $ Just bpol - when (even tyear) $ insert_ $ TutorialParticipant tut3 jost $ Just fraportAg + insert_ $ TutorialParticipant tut1 svaupel Nothing Nothing Nothing Nothing + insert_ $ TutorialParticipant tut2 svaupel (Just fraGround) (Just UserDrivingPermitB01) (Just UserEyeExamS01) (Just "Testnote") + when (odd tyear) $ insert_ $ TutorialParticipant tut3 svaupel (Just fraGround) Nothing Nothing Nothing + insert_ $ TutorialParticipant tut1 gkleen (Just nice) (Just UserDrivingPermitB) (Just UserEyeExamSX) (Just "Note test") + insert_ $ TutorialParticipant tut2 fhamann (Just bpol) (Just UserDrivingPermitB) (Just UserEyeExamSX) (Just "All ok") + when (even tyear) $ insert_ $ TutorialParticipant tut3 jost (Just fraportAg) (Just UserDrivingPermitB01) (Just UserEyeExamSX) (Just "Eye test suspicious") + insert_ $ TutorialParticipantDay tut2 svaupel nowaday True $ Just "Was on time" + insert_ $ TutorialParticipantDay tut2 fhamann nowaday False $ Just "Missing" + when (odd tyear) $ void . insert' $ Exam { examCourse = c