chore(tutorial): assign exam rooms for tutorial users ad hoc

messages/uniworx/categories/courses/courses/de-de-formal.msg

@@ -136,6 +136,7 @@ CourseUserNoTutorialsDeregistered: Teilnehmer:in ist zu keinem der gewählten Ku
 CourseUserTutorials: Angemeldete Kurse
 CourseUserExams: Angemeldete Prüfungen
 CourseUserExamOccurrences: Prüfungstermin
+CourseUserExamOccurrenceOverride: Ggf. vorhanden Prüfungstermin überschreiben
 CourseUserSheets: Übungsblätter
 CsvColumnUserName: Voller Name des/der Teilnehmers/Teilnehmerin
 CsvColumnUserMatriculation: AVS Nummer des/der Teilnehmers/Teilnehmerin

messages/uniworx/categories/courses/courses/en-eu.msg

@@ -136,6 +136,7 @@ CourseUserNoTutorialsDeregistered: Participant is not registered for any of the
 CourseUserTutorials: Registered courses
 CourseUserExams: Registered exams
 CourseUserExamOccurrences: Exam occurrence
+CourseUserExamOccurrenceOverride: Override other registrations for this exam, if any
 CourseUserSheets: Exercise sheets
 CsvColumnUserName: Participant's full name
 CsvColumnUserMatriculation: Participant's AVS number

messages/uniworx/categories/courses/exam/exam/de-de-formal.msg

@@ -86,6 +86,7 @@ ExamRoomAlreadyExists: Prüfung ist bereits eingetragen
 ExamRoomName: Interne Bezeichnung
 ExamRoomCapacity: Kapazität
 ExamRoomCapacityNegative: Kapazität darf nicht negativ sein
+ExamRommCapacityInsufficient n@Int: Kapazität reicht nicht aus, nur noch #{n} Plätze verfügbar
 ExamRoomTime: Termin
 ExamRoomStart: Beginn
 ExamRoomEnd: Ende

messages/uniworx/categories/courses/exam/exam/en-eu.msg

@@ -86,6 +86,7 @@ ExamRoomAlreadyExists: Occurrence already configured
 ExamRoomName: Internal name
 ExamRoomCapacity: Capacity
 ExamRoomCapacityNegative: Capacity may not be negative
+ExamRommCapacityInsufficient n@Int: Insufficient capacity, only #{n} remaining
 ExamRoomTime: Time
 ExamRoomStart: Start
 ExamRoomEnd: End

messages/uniworx/categories/courses/tutorial/de-de-formal.msg

@@ -50,6 +50,8 @@ TutorialUserGrantQualification: Qualifikation vergeben
 TutorialUserRenewQualification: Qualifikation regulär verlängern
 TutorialUserRenewedQualification n@Int: Qualifikation für #{tshow n} Kurs-#{pluralDE n "Teilnehmer:in" "Teilnehmer:innen"} regulär verlängert
 TutorialUserGrantedQualification n@Int: Qualifikation erfolgreich an #{tshow n} Kurs-#{pluralDE n "Teilnehmer:in" "Teilnehmer:innen"} vergeben
+TutorialUserAssignExam: Zur Prüfung einteilen
+TutorialUserExamAssignedFor n@Int m@Int p@Text: #{n}/#{m} zur Prüfung #{p} eingeteilt
 CommTutorial: Kursmitteilung
 TutorialDrivingPermit: Führerschein
 TutorialEyeExam: Sehtest

messages/uniworx/categories/courses/tutorial/en-eu.msg

@@ -51,6 +51,8 @@ TutorialUserGrantQualification: Grant qualification
 TutorialUserRenewQualification: Renew qualification
 TutorialUserRenewedQualification n@Int: Successfully renewed qualification #{tshow n} course #{pluralEN n "user" "users"}
 TutorialUserGrantedQualification n: Successfully granted qualification #{tshow n} course #{pluralEN n "user" "users"}
+TutorialUserAssignExam: Register for examination
+TutorialUserExamAssignedFor n@Int m@Int p@Text: #{n}/#{m} enrolled for exam #{p}
 CommTutorial: Course message
 TutorialDrivingPermit: Driving permit
 TutorialEyeExam: Eye exam

src/Database/Esqueleto/Utils.hs

@@ -53,6 +53,7 @@ module Database.Esqueleto.Utils
   , str2citext
   , num2text --, text2num
   , day, day', dayMaybe, interval, diffDays, diffTimes
+  , withinPeriod
   , exprLift
   , explicitUnsafeCoerceSqlExprValue
   , psqlVersion_
@@ -151,21 +152,25 @@ infixl 4 ?=.
 -- | like (=?.) but also succeeds if the right-hand side is NULL. Can often be avoided by moving from where- to join-condition!
 infixl 4 =~.
 (=~.) ::  PersistField typ => E.SqlExpr (E.Value typ) ->  E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool)
-(=~.) a b = E.isNothing b E.||. (E.just a E.==. b)
+-- (=~.) a b = E.isNothing b E.||. (E.just a E.==. b) -- avoid expensive E.||.
+(=~.) a b = a E.==. E.coalesceDefault [b] a
 
 infixl 4 ~=.
 (~=.) ::  PersistField typ => E.SqlExpr (E.Value (Maybe typ)) ->  E.SqlExpr (E.Value typ) -> E.SqlExpr (E.Value Bool)
-(~=.) a b = E.isNothing a E.||. (a E.==. E.just b)
+-- (~=.) a b = E.isNothing a E.||. (a E.==. E.just b) -- avoid expensive E.||.
+(~=.) a b = b E.==. E.coalesceDefault [a] b
 
--- | like (>.), but also succeeds if the right-hand side is NULL
+-- | like (>=.), but also succeeds if the right-hand side is NULL
 infixl 4 >~.
 (>~.) ::  PersistField typ => E.SqlExpr (E.Value typ) -> E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool)
-(>~.) a b = E.isNothing b E.||. (E.just a E.>. b)
+-- (>~.) a b = E.isNothing b E.||. (E.just a E.>. b)
+(>~.) a b = a E.>=. E.coalesceDefault [b] a
 
--- | like (<.), but also succeeds if the right-hand side is NULL
+-- | like (<=.), but also succeeds if the right-hand side is NULL
 infixl 4 <~.
 (<~.) ::  PersistField typ => E.SqlExpr (E.Value typ) -> E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool)
-(<~.) a b = E.isNothing b E.||. (E.just a E.<. b)
+-- (<~.) a b = E.isNothing b E.||. (E.just a E.<. b)
+(<~.) a b = a E.<=. E.coalesceDefault [b] a
 
 infixr 2 ~., ~*., !~., !~*.
 
@@ -774,6 +779,19 @@ day' = E.unsafeSqlCastAs "date"
 dayMaybe :: E.SqlExpr (E.Value (Maybe UTCTime)) -> E.SqlExpr (E.Value (Maybe Day))
 dayMaybe = E.unsafeSqlCastAs "date"
 
+-- | Given an occurrence with start-time and maybe an end-time, does it overlap with a given day interval?
+--   If there is no end-time, then the start-time must be in between.
+withinPeriod :: (Day, Day) -> E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value (Maybe UTCTime)) -> E.SqlExpr (E.Value Bool)
+withinPeriod (dbegin, dend) tfrom tto = day      tfrom  E.<=. E.val dend
+              E.&&. E.coalesceDefault  [dayMaybe tto]
+                                       (day      tfrom) E.>=. E.val dbegin
+-- Alternative variant which SJ expected to be more efficient, if there is an index on the first argument available,
+-- but FraportGPT thinks otherwise: "OR conditions may prevent the efficient use of an index. OR conditions can sometimes lead to a full table scan, whereas COALESCE is quite cheap"
+-- withinPeriod (dstart, dend) tfrom tto = day      tfrom E.<=.   E.val dend
+--             E.&&. (                     day      tfrom E.>=.   E.val dstart
+--               E.||. (isJust tto E.&&.   dayMaybe tto   E.>=. justVal dstart ))
+
+
 interval :: CalendarDiffDays -> E.SqlExpr (E.Value Day) -- E.+=.  requires both types to be the same, so we use Day
 -- interval _ = E.unsafeSqlCastAs "interval" $ E.unsafeSqlValue "'P2Y'" -- tested working example
 interval = E.unsafeSqlCastAs "interval". E.unsafeSqlValue . wrapSqlString . Text.Builder.fromString . iso8601Show

src/Handler/Tutorial/Users.hs

@@ -14,7 +14,7 @@ import Utils.Form
 import Utils.Print
 import Handler.Utils
 import Handler.Utils.Course
--- import Handler.Utils.Course.Cache
+import Handler.Utils.Course.Cache
 import Handler.Utils.Tutorial
 import Database.Persist.Sql (deleteWhereCount)
 
@@ -32,7 +32,8 @@ import Handler.Course.Users
 
 
 data TutorialUserAction
-  = TutorialUserPrintQualification
+  = TutorialUserAssignExam
+  | TutorialUserPrintQualification
   | TutorialUserRenewQualification
   | TutorialUserGrantQualification
   | TutorialUserSendMail
@@ -53,21 +54,26 @@ data TutorialUserActionData
     , tuValidUntil    :: Day
     }
   | TutorialUserSendMailData
-  | TutorialUserDeregisterData{}
+  | TutorialUserDeregisterData
+  | TutorialUserAssignExamData
+    { tuOccurrenceId :: ExamOccurrenceId
+    , tuReassign   :: Bool
+    }
   deriving (Eq, Ord, Read, Show, Generic)
 
 
 getTUsersR, postTUsersR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler TypedContent
 getTUsersR = postTUsersR
 postTUsersR tid ssh csh tutn = do
+  let croute  = CTutorialR tid ssh csh tutn TUsersR
+  now <- liftIO getCurrentTime
   isAdmin <- hasReadAccessTo AdminR
-  (Entity tutid tut@Tutorial{..}, (participantRes, participantTable), qualifications) <- runDB $ do
+  (Entity tutid tut@Tutorial{..}, (participantRes, participantTable), qualifications, exOccs) <- runDB $ do
     trm <- get404 tid
     -- cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
     -- tutEnt@(Entity tutid _) <- fetchTutorial tid ssh csh tutn
     (cid, tutEnt@(Entity tutid _)) <- fetchCourseIdTutorial tid ssh csh tutn
     qualifications <- getCourseQualifications cid
-    now <- liftIO getCurrentTime
     let nowaday = utctDay now
         minDur :: Maybe Int = minimumMaybe $ mapMaybe (view _qualificationValidDuration) qualifications  -- no instance Ord CalendarDiffDays
         dayExpiry = flip addGregorianDurationClip nowaday . fromMonths <$> minDur
@@ -90,34 +96,20 @@ postTUsersR tid ssh csh tutn = do
           E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser q E.^. UserId
                E.&&. tutorialParticipant E.^. TutorialParticipantTutorial E.==. E.val tutid
         csvColChoices = flip elem ["name", "matriculation", "email", "qualifications"]
-
         qualOptions = qualificationsOptionList qualifications
-
+        lessons  = occurringLessons trm $ tutEnt ^. _entityVal . _tutorialTime . _Wrapped'
-        lessons = occurringLessons trm $ tutEnt ^. _entityVal . _tutorialTime . _Wrapped' -- TODO: export and show on page, since it is already computed!
+        timespan = lessonTimesSpan lessons
-        _timespan = lessonTimesSpan lessons
+    $logDebugS "Occurrences" $ tshow timespan
-
+    exOccs <- flip foldMapM timespan $ getDayExamOccurrences True ssh $ Just cid
-    -- for purposes of table actions, pick all currently open associated exams
-    _exams <- selectList
-      (-- ([ExamRegisterTo >=. Just now] ||. [ExamRegisterTo ==. Nothing]) ++ -- Reconsider: only allow exams with open registration?
-       ([ExamEnd        >=. Just now] ||. [ExamEnd        ==. Nothing]) ++
-        [ ExamStart <=. Just now --  , ExamRegisterFrom <=. Just now
-        , ExamCourse ==. cid, ExamClosed ==. Nothing, ExamFinished ==. Nothing -- Reconsider: ExamFinished prevents publication of results - do we want this?
-      ]) [Asc ExamRegisterFrom, Asc ExamStart, Asc ExamRegisterTo, Asc ExamName, LimitTo 7] -- earliest still open exam
-    -- tutorialTime
-    -- pick exam occurrences and tutors
-    -- TODO: !!!continue here!!!
-    -- _examOccs <- forM timespan $ \(dstart,dend) -> E.select $ do
-    --   occ <- E.from $ E.table @ExamOccurrence
-    --   E.where_ $ (occ E.^. ExamOccurrenceId `E.in_` E.valList (entityKey <$> exams))
-    --     E.&&.  ( E.day      (occ E.^. ExamOccurrenceStart) `E.between` (E.val     dstart, E.val     dend)
-    --       E.||.  E.dayMaybe (occ E.^. ExamOccurrenceEnd)   `E.between` (E.justVal dstart, E.justVal dend)
-    --       )
-    --   E.orderBy [E.asc $ occ E.^. ExamOccurrenceName]
-
-    -- multiActionAOpts or similar, see FirmAction for another example
     let
       acts :: Map TutorialUserAction (AForm Handler TutorialUserActionData)
       acts = Map.fromList $
+        bcons (not $ null exOccs)
+            ( TutorialUserAssignExam
+            , TutorialUserAssignExamData
+                <$> apopt (selectField $ pure $ mkExamOccurrenceOptions exOccs) (fslI MsgCourseUserExamOccurrences) Nothing
+                <*> apopt checkBoxField (fslI MsgCourseUserExamOccurrenceOverride) (Just False)
+            ) $
         (if null qualifications then mempty else
           [ ( TutorialUserRenewQualification
             , TutorialUserRenewQualificationData
@@ -135,7 +127,7 @@ postTUsersR tid ssh csh tutn = do
         , ( TutorialUserPrintQualification, pure TutorialUserPrintQualificationData )
         ]
     table <- makeCourseUserTable cid acts isInTut colChoices psValidator (Just csvColChoices)
-    return (tutEnt, table, qualifications)
+    return (tutEnt, table, qualifications, exOccs)
 
   let courseQids = Set.fromList (entityKey <$> qualifications)
   tcontent <- formResultMaybe participantRes $ \case
@@ -147,7 +139,6 @@ postTUsersR tid ssh csh tutn = do
         case mbAletter of
           Nothing -> addMessageI Error MsgErrorUnknownFormAction >> return Nothing -- TODO: better error message
           Just aletter -> do
-            now <- liftIO getCurrentTime
             apcIdent <- letterApcIdent aletter encRcvr now
             let fName = letterFileName aletter
             renderLetters rcvr letters apcIdent >>= \case
@@ -164,22 +155,39 @@ postTUsersR tid ssh csh tutn = do
         let reason = "Kurs " <> CI.original (unSchoolKey ssh) <> "-" <> CI.original csh <> "-" <> CI.original tutn
         runDB . forM_ selectedUsers $ upsertQualificationUser tuQualification today tuValidUntil Nothing reason
         addMessageI  (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
-        redirect $ CTutorialR tid ssh csh tutn TUsersR
+        reloadKeepGetParams croute
     (TutorialUserRenewQualificationData{..}, selectedUsers)
       | tuQualification `Set.member` courseQids -> do
         noks <- runDB $ renewValidQualificationUsers tuQualification Nothing Nothing $ Set.toList selectedUsers
         addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks
-        redirect $ CTutorialR tid ssh csh tutn TUsersR
+        reloadKeepGetParams croute
-    (TutorialUserSendMailData{}, selectedUsers) -> do
+    (TutorialUserSendMailData, selectedUsers) -> do
         cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser]
         redirect (CTutorialR tid ssh csh tutn TCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cids])
-    (TutorialUserDeregisterData{},selectedUsers) -> do
+    (TutorialUserDeregisterData, selectedUsers) -> do
         nrDel <- runDB $ deleteWhereCount
           [ TutorialParticipantTutorial ==. tutid
           , TutorialParticipantUser <-. Set.toList selectedUsers
           ]
         addMessageI Success $ MsgTutorialUsersDeregistered nrDel
-        redirect $ CTutorialR tid ssh csh tutn TUsersR
+        reloadKeepGetParams croute
+    (TutorialUserAssignExamData{..}, selectedUsers)
+      | (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]
+              let ok = totalCap - usedCap >= n
+              unless ok $ addMessageI Error $ MsgExamRommCapacityInsufficient $ totalCap - usedCap
+              pure ok
+            when capOk $ do
+              let regTemplate uid = ExamRegistration eid uid (Just tuOccurrenceId) now
+              nrOk <- runDB $ if tuReassign
+                      then putMany [regTemplate uid | uid <- Set.toList selectedUsers] >> pure n
+                      else forM (Set.toList selectedUsers) (insertUnique . regTemplate) <&> (length . catMaybes)
+              let allok = bool Warning Success $ nrOk == n
+              addMessageI allok $ MsgTutorialUserExamAssignedFor nrOk n $ ciOriginal examOccurrenceName
+              reloadKeepGetParams croute
+            return Nothing
     _other -> addMessageI Error MsgErrorUnknownFormAction >> return Nothing
 
   case tcontent of

src/Handler/Utils/Course/Cache.hs

@@ -11,7 +11,7 @@ import Handler.Utils
 
 import qualified Data.Set as Set
 import qualified Data.Map as Map
-import qualified Data.Aeson  as Aeson
+-- import qualified Data.Aeson  as Aeson
 
 
 -- import Database.Persist.Sql (updateWhereCount)
@@ -23,15 +23,15 @@ import qualified Database.Esqueleto.Utils as E
 
 
 
--- | partial JSON object to be used for filtering with "@>"
+--   partial JSON object to be used for filtering with "@>"
 --   ensure that a GIN index for the jsonb column is created in Model.Migration.Definitions
-occurrenceDayValue :: Day -> Value
+-- occurrenceDayValue :: Day -> Value
-occurrenceDayValue d = Aeson.object
+-- occurrenceDayValue d = Aeson.object
-  [ "exceptions" Aeson..=
+--   [ "exceptions" Aeson..=
-    [ Aeson.object
+--     [ Aeson.object
-      [ "exception" Aeson..= ("occur"::Text)
+--       [ "exception" Aeson..= ("occur"::Text)
-      , "day"       Aeson..= d
+--       , "day"       Aeson..= d
-  ] ] ]
+--   ] ] ]
 
 {- More efficient DB-only version, but ignores regular schedules
 getDayTutorials :: SchoolId -> Day -> DB [TutorialId]
@@ -131,22 +131,38 @@ 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))
+
 -- | retrieve all exam occurrences for a school in a given time period, ignoring term times; uses caching
-getDayExamOccurrences :: SchoolId -> Maybe CourseId -> (Day,Day) -> DB (Map ExamOccurrenceId (CourseId, ExamName, ExamOccurrence))
+--   if a CourseId is specified, only exams from that course are returned
-getDayExamOccurrences ssh mbcid dlimit@(dstart, dend )
+getDayExamOccurrences :: Bool -> SchoolId -> Maybe CourseId -> (Day,Day) -> DB ExamOccurrenceMap
+getDayExamOccurrences onlyOpen ssh mbcid dlimit@(dstart, dend)
   | dstart > dend = return mempty
   | otherwise = memcachedByClass MemcachedKeyClassExamOccurrences (Just . Right $ 12 * diffDay) (CacheKeyExamOccurrences ssh dlimit mbcid) $ do
+    now <- liftIO getCurrentTime
     candidates <- E.select $ do
       (crs :& exm :& occ) <- E.from $ E.table @Course
           `E.innerJoin` E.table @Exam            `E.on` (\(crs :& exm)        -> crs E.^. CourseId   E.==. exm E.^. ExamCourse)
           `E.innerJoin` E.table @ExamOccurrence  `E.on` (\(_   :& exm :& occ) -> exm E.^. ExamId     E.==. occ E.^. ExamOccurrenceExam)
-      E.where_ $ ifNothing mbcid id (\cid -> ((crs E.^. CourseId E.==. E.val cid) E.&&.)) $
+      E.where_ $ E.and $ catMaybes
-                E.val ssh E.==. crs E.^. CourseSchool
+        [ toMaybe onlyOpen $ E.justVal now E.>=. exm E.^. ExamRegisterFrom -- fail on null
-        E.&&. ( E.day      (occ E.^. ExamOccurrenceStart) `E.between` (E.val     dstart, E.val     dend)
+                      E.&&.  E.val     now E.<~. exm E.^. ExamRegisterTo   -- success on null
-          E.||. E.dayMaybe (occ E.^. ExamOccurrenceEnd)   `E.between` (E.justVal dstart, E.justVal dend)
+        , mbcid <&> ((E.==. (crs E.^. CourseId)) . E.val)
-          )
+        , Just $ crs E.^. CourseSchool E.==. E.val ssh
-      return (exm, occ)
+        , 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
   where
-    mkOccMap :: (Entity Exam, Entity ExamOccurrence) -> Map ExamOccurrenceId (CourseId, ExamName, ExamOccurrence)
+    mkOccMap :: (Entity ExamOccurrence, E.Value ExamId, E.Value ExamName) -> ExamOccurrenceMap
-    mkOccMap (entityVal -> exm, Entity{..}) = Map.singleton entityKey (exm ^. _examCourse, exm ^. _examName, entityVal)
+    mkOccMap (Entity{..}, E.Value eId, E.Value eName) = Map.singleton entityKey (entityVal, (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{..}])
+      where
+        optionDisplay       = ciOriginal examOccurrenceName
+        optionExternalValue = toPathPiece $ eName <> ":" <> examOccurrenceName
+        optionInternalValue = eid

src/Model/Migration/Definitions.hs

@@ -92,6 +92,7 @@ migrateManual = do
     , ("study_features_relevance_cached",     "CREATE INDEX study_features_relevance_cached ON \"study_features\" (relevance_cached)")
     , ("submission_rating_by",                "CREATE INDEX submission_rating_by ON submission (rating_by) WHERE rating_by IS NOT NULL"  )
     , ("exam_corrector_user",                 "CREATE INDEX exam_corrector_user ON exam_corrector (\"user\")"                            )
+    , ("exam_occurrence_start",               "CREATE INDEX exam_occurrence_start ON exam_occurrence (\"start\")"                        )
     , ("submission_rating_time",              "CREATE INDEX submission_rating_time ON submission (rating_time)"                          )
     , ("idx_qualification_user_first_held"   ,"CREATE INDEX idx_qualification_user_first_held ON \"qualification_user\" (\"first_held\")")
     , ("idx_qualification_user_valid_until"  ,"CREATE INDEX idx_qualification_user_valid_until ON \"qualification_user\" (\"valid_until\")")
@@ -102,8 +103,8 @@ migrateManual = do
     , ("idx_lms_report_log_q_ident_time"     ,"CREATE INDEX idx_lms_report_log_q_ident_time ON \"lms_report_log\" (\"qualification\",\"ident\",\"timestamp\")")
     , ("idx_user_company_company"            ,"CREATE INDEX idx_user_company_company ON \"user_company\" (\"company\")") -- composed index from unique cannot be used for frequently used filters on company
     , ("idx_user_supervisor_user"            ,"CREATE INDEX idx_user_supervisor_user ON \"user_supervisor\" (\"user\")") -- composed index from unique cannot be used for frequently used filters on user
-    , ("idx_tutorial_time"                   ,"CREATE INDEX idx_tutorial_time ON \"tutorial\" USING GIN (\"time\")")            -- GIN Index to speed up filtering with @>.
+    -- , ("idx_tutorial_time"                   ,"CREATE INDEX idx_tutorial_time ON \"tutorial\" USING GIN (\"time\")")            -- GIN Index to speed up filtering with @>.
-    , ("idx_course_event_time"               ,"CREATE INDEX idx_course_event_time ON \"course_event\" USING GIN (\"time\")")    -- GIN Index to speed up filtering with @>.
+    -- , ("idx_course_event_time"               ,"CREATE INDEX idx_course_event_time ON \"course_event\" USING GIN (\"time\")")    -- GIN Index to speed up filtering with @>.
     ]
   where
     addIndex :: Text -> Sql -> Migration

src/Model/Types/Exam.hs

@@ -238,7 +238,7 @@ traverseExamOccurrenceMapping :: Ord roomId'
 traverseExamOccurrenceMapping = _examOccurrenceMappingMapping . iso Map.toList (Map.fromListWith Set.union) . traverse . _1
 
 -- | Natural extended by representation for Infinity.
--- 
+--
 -- Maybe doesn't work, because the 'Ord' instance puts 'Nothing' below 0
 -- instead of above every other number.
 newtype ExamOccurrenceCapacity = EOCapacity (Maybe Natural)

src/Utils.hs

@@ -769,6 +769,10 @@ adjustAssoc upd key = aux
       where
         v' = upd v
 
+-- | Merge all duplicate keys of an association list over a semigroup and sort the association list
+groupSort :: (Ord k, Semigroup v) => [(k,v)] -> [(k,v)]
+groupSort = Map.toAscList . Map.fromListWith (<>)
+
 -- | Copied form Util from package ghc
 partitionWith :: (a -> Either b c) -> [a] -> ([b], [c])
 -- ^ Uses a function to determine which of two output lists an input element should join