chore(tutorial): build model for #90

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

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/School/DayTasks.hs

@@ -42,7 +42,7 @@ instance Finite DailyTableAction
 nullaryPathPiece ''DailyTableAction $ camelToPathPiece' 2
 embedRenderMessage ''UniWorX ''DailyTableAction id
 
-data DailyTableActionData  = DailyActDummyData
+data DailyTableActionData = DailyActDummyData
   deriving (Eq, Ord, Read, Show, Generic)
 
 -- | partial JSON object to be used for filtering with "@>"
@@ -240,9 +240,9 @@ mkDailyTable isAdmin ssh nd = do
           in anchorCell (CTutorialR tid cssh csh tutName TUsersR) $ citext2widget tutName
       , sortable Nothing (i18nCell MsgTableTutorialOccurrence) $ \(view $ resultTutorial . _entityKey -> tutId) -> cellMaybe (lessonTimesCell False) $ Map.lookup tutId tutLessons
       , sortable Nothing (i18nCell MsgTableTutorialRoom) $ \(view $ resultTutorial . _entityKey -> tutId) ->
-          -- listInlineCell (foldMap (fmap lessonRoom) $ Map.lookup tutId tutLessons) $ cellMaybe roomReferenceCell
-          -- listInlineCell (concat $ mapMM lessonRoom $ Map.lookup tutId tutLessons) roomReferenceCell
-          cellMaybe (`listInlineCell` roomReferenceCell) $ mapMM lessonRoom $ Map.lookup tutId tutLessons
+          -- listInlineCell (nubOrd . concat $ mapMM lessonRoom $ Map.lookup tutId tutLessons) roomReferenceCell
+          cellMaybe ((`listInlineCell` roomReferenceCell) . nubOrd) $ mapMM lessonRoom $ Map.lookup tutId tutLessons
+      -- , sortable Nothing (i18nCell MsgTableTutorialRoom) $ \(view $ resultTutorial . _entityKey -> _) -> listCell ["A","D","C","B"] textCell -- DEMO: listCell reverses the order, for list-types! listInlineCell is fixed now
       , sortable Nothing (i18nCell $ MsgCourseQualifications 3) $ \(preview resultCourseQualis -> cqs) -> maybeCell cqs $ flip listInlineCell qualificationIdShortCell
       , sortable (Just "user-company") (i18nCell MsgTablePrimeCompany) $ \(preview resultCompanyId -> mcid) -> cellMaybe companyIdCell mcid
       , sortable (Just "booking-company") (i18nCell MsgTableBookingCompany) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantCompany -> mcid) -> cellMaybe companyIdCell mcid

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/Table/Pagination.hs

@@ -1854,19 +1854,19 @@ maybeLinkEitherCellCM' mCache xM x2route (x2widgetAuth,x2widgetUnauth) = cell $
       toWidget $ x2widgetUnauth Nothing
 
 
-listInlineCell :: (IsDBTable m a, MonoFoldable mono) => mono -> (Element mono -> DBCell m a) -> DBCell m a
+listInlineCell :: (IsDBTable m a, MonoFoldable mono, SemiSequence mono) => mono -> (Element mono -> DBCell m a) -> DBCell m a
 listInlineCell = listInlineCell' . return
 
-listInlineCell' :: (IsDBTable m a, MonoFoldable mono) => WriterT a m mono -> (Element mono -> DBCell m a) -> DBCell m a
+listInlineCell' :: (IsDBTable m a, MonoFoldable mono, SemiSequence mono) => WriterT a m mono -> (Element mono -> DBCell m a) -> DBCell m a
 listInlineCell' mkXS mkCell = ilistInlineCell' (otoList <$> mkXS) $ const mkCell
 
-ilistInlineCell :: (IsDBTable m a, MonoFoldableWithKey mono) => mono -> (MonoKey mono -> Element mono -> DBCell m a) -> DBCell m a
+ilistInlineCell :: (IsDBTable m a, MonoFoldableWithKey mono, SemiSequence mono) => mono -> (MonoKey mono -> Element mono -> DBCell m a) -> DBCell m a
 ilistInlineCell = ilistInlineCell' . return
 
-ilistInlineCell' :: (IsDBTable m a, MonoFoldableWithKey mono) => WriterT a m mono -> (MonoKey mono -> Element mono -> DBCell m a) -> DBCell m a
+ilistInlineCell' :: (IsDBTable m a, MonoFoldableWithKey mono, SemiSequence mono) => WriterT a m mono -> (MonoKey mono -> Element mono -> DBCell m a) -> DBCell m a
 ilistInlineCell' mkXS mkCell = review dbCell . ([], ) $ do
   xs <- mkXS
-  cells <- forM (otoKeyedList xs) $
+  cells <- forM (otoKeyedList $ reverse xs) $ -- Do we need to reverse for all MonoFoldableWithKey, or is only the List-Instance flawed?
     \(view dbCell . uncurry mkCell -> (attrs, mkWidget)) -> (attrs, ) <$> mkWidget
   return $(widgetFile "table/cell/listInline")
 

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

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

@@ -1084,6 +1084,12 @@ fillDb = do
                     , scheduleEnd       = TimeOfDay 14 44 0
                     , scheduleRoom      = Just $ RoomReferenceSimple "A320neo"
                     }
+                , ScheduleWeekly
+                    { scheduleDayOfWeek = Friday
+                    , scheduleStart     = TimeOfDay 15 55 0
+                    , scheduleEnd       = TimeOfDay 16 16 0
+                    , scheduleRoom      = Just $ RoomReferenceSimple "A340"
+                    }
                 , ScheduleWeekly
                     { scheduleDayOfWeek = Sunday
                     , scheduleStart     = TimeOfDay 15 55 0
@@ -1094,8 +1100,8 @@ fillDb = do
             , occurrencesExceptions = Set.fromList
                 [ ExceptOccur
                     { exceptDay   = nTimes 7 succ firstDay
-                    , exceptStart = TimeOfDay  8 30  0
-                    , exceptEnd   = TimeOfDay 16  0  0
+                    , exceptStart = TimeOfDay  8 30  30
+                    , exceptEnd   = TimeOfDay 16  0  30
                     , exceptRoom  = Just $ RoomReferenceSimple "A380"
                     }
                 , ExceptOccur
@@ -1107,7 +1113,13 @@ fillDb = do
                 , ExceptOccur
                     { exceptDay   = nowaday
                     , exceptStart = TimeOfDay  9  10  0
-                    , exceptEnd   = TimeOfDay 16  10  0
+                    , exceptEnd   = TimeOfDay 12  10  0
+                    , exceptRoom  = Just $ RoomReferenceSimple "B747"
+                    }
+                , ExceptOccur
+                    { exceptDay   = nowaday
+                    , exceptStart = TimeOfDay 13  11  0
+                    , exceptEnd   = TimeOfDay 16  11  0
                     , exceptRoom  = Just $ RoomReferenceSimple "B747"
                     }
                 ]
@@ -1152,7 +1164,7 @@ fillDb = do
                     { exceptDay   = nowaday
                     , exceptStart = TimeOfDay 17  10  0
                     , exceptEnd   = TimeOfDay 18  10  0
-                    , exceptRoom  = Nothing
+                    , exceptRoom  = Just $ RoomReferenceSimple "A380"
                     }
                 ]
             }
@@ -1205,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