chore(tutorial): build model for #90
This commit is contained in:
parent
d4d511a02f
commit
06fa34c938
@ -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
|
||||
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
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
||||
-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- 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
|
||||
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user