chore(tutorial): build model for #90

models/tutorials.model

@@ -24,9 +24,19 @@ Tutor
     UniqueTutor tutorial user
     deriving Generic
 TutorialParticipant
-    tutorial    TutorialId OnDeleteCascade OnUpdateCascade
+    tutorial        TutorialId OnDeleteCascade OnUpdateCascade
-    user        UserId
+    user            UserId
-    company     CompanyId Maybe
+    company         CompanyId Maybe
+    drivingPermit   UserDrivingPermit Maybe
+    eyeExam         UserEyeExam Maybe
+    note            Text Maybe
     UniqueTutorialParticipant tutorial user
-    deriving Eq Ord Show
+    deriving Eq Ord Show Generic
-    deriving 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

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

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

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

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

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

src/Model/Types/User.hs

@@ -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
 
@@ -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
+
+

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
 

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 tut1 svaupel Nothing Nothing Nothing Nothing
-        insert_ $ TutorialParticipant tut2 svaupel $ Just fraGround
+        insert_ $ TutorialParticipant tut2 svaupel (Just fraGround) (Just UserDrivingPermitB01) (Just UserEyeExamS01) (Just "Testnote")
-        when (odd  tyear) $ insert_ $ TutorialParticipant tut3 svaupel $ Just fraGround
+        when (odd  tyear) $ insert_ $ TutorialParticipant tut3 svaupel (Just fraGround) Nothing Nothing Nothing
-        insert_ $ TutorialParticipant tut1 gkleen   $ Just nice
+        insert_ $ TutorialParticipant tut1 gkleen  (Just nice) (Just UserDrivingPermitB) (Just UserEyeExamSX) (Just "Note test")
-        insert_ $ TutorialParticipant tut2 fhamann $ Just bpol
+        insert_ $ TutorialParticipant tut2 fhamann (Just bpol) (Just UserDrivingPermitB) (Just UserEyeExamSX) (Just "All ok")
-        when (even tyear) $ insert_ $ TutorialParticipant tut3 jost $ Just fraportAg
+        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