diff --git a/messages/uniworx/categories/courses/courses/de-de-formal.msg b/messages/uniworx/categories/courses/courses/de-de-formal.msg index 377fc616e..a6ec9bc28 100644 --- a/messages/uniworx/categories/courses/courses/de-de-formal.msg +++ b/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 diff --git a/messages/uniworx/categories/courses/courses/en-eu.msg b/messages/uniworx/categories/courses/courses/en-eu.msg index a699a7256..2d99467a3 100644 --- a/messages/uniworx/categories/courses/courses/en-eu.msg +++ b/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 diff --git a/messages/uniworx/categories/courses/exam/exam/de-de-formal.msg b/messages/uniworx/categories/courses/exam/exam/de-de-formal.msg index 7fc318be8..43e4bf4ed 100644 --- a/messages/uniworx/categories/courses/exam/exam/de-de-formal.msg +++ b/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 diff --git a/messages/uniworx/categories/courses/exam/exam/en-eu.msg b/messages/uniworx/categories/courses/exam/exam/en-eu.msg index db97592de..773d9bd47 100644 --- a/messages/uniworx/categories/courses/exam/exam/en-eu.msg +++ b/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 diff --git a/messages/uniworx/categories/courses/tutorial/de-de-formal.msg b/messages/uniworx/categories/courses/tutorial/de-de-formal.msg index 51d63a9cf..9ed2c42cd 100644 --- a/messages/uniworx/categories/courses/tutorial/de-de-formal.msg +++ b/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 diff --git a/messages/uniworx/categories/courses/tutorial/en-eu.msg b/messages/uniworx/categories/courses/tutorial/en-eu.msg index 96c044f5d..9ba136306 100644 --- a/messages/uniworx/categories/courses/tutorial/en-eu.msg +++ b/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 diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 3ee7284c9..ab55d406b 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/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 diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index 56db6f364..dd9557920 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/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' -- TODO: export and show on page, since it is already computed! - _timespan = lessonTimesSpan lessons - - -- 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 + lessons = occurringLessons trm $ tutEnt ^. _entityVal . _tutorialTime . _Wrapped' + timespan = lessonTimesSpan lessons + $logDebugS "Occurrences" $ tshow timespan + exOccs <- flip foldMapM timespan $ getDayExamOccurrences True ssh $ Just cid 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 - (TutorialUserSendMailData{}, selectedUsers) -> do + reloadKeepGetParams croute + (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 diff --git a/src/Handler/Utils/Course/Cache.hs b/src/Handler/Utils/Course/Cache.hs index aae1b1bc6..8347cb2c7 100644 --- a/src/Handler/Utils/Course/Cache.hs +++ b/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 d = Aeson.object - [ "exceptions" Aeson..= - [ Aeson.object - [ "exception" Aeson..= ("occur"::Text) - , "day" Aeson..= d - ] ] ] +-- occurrenceDayValue :: Day -> Value +-- occurrenceDayValue d = Aeson.object +-- [ "exceptions" Aeson..= +-- [ Aeson.object +-- [ "exception" Aeson..= ("occur"::Text) +-- , "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)) -getDayExamOccurrences ssh mbcid dlimit@(dstart, dend ) +-- if a CourseId is specified, only exams from that course are returned +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.val ssh E.==. crs E.^. CourseSchool - 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) - ) - return (exm, occ) + E.where_ $ E.and $ catMaybes + [ toMaybe onlyOpen $ E.justVal now E.>=. exm E.^. ExamRegisterFrom -- fail on null + E.&&. E.val now E.<~. exm E.^. ExamRegisterTo -- success on null + , mbcid <&> ((E.==. (crs E.^. CourseId)) . E.val) + , Just $ crs E.^. CourseSchool E.==. E.val ssh + , 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 (entityVal -> exm, Entity{..}) = Map.singleton entityKey (exm ^. _examCourse, exm ^. _examName, entityVal) + mkOccMap :: (Entity ExamOccurrence, E.Value ExamId, E.Value ExamName) -> ExamOccurrenceMap + 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 diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs index 22c0f4e66..d51e23d2b 100644 --- a/src/Model/Migration/Definitions.hs +++ b/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_course_event_time" ,"CREATE INDEX idx_course_event_time ON \"course_event\" 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 @>. ] where addIndex :: Text -> Sql -> Migration diff --git a/src/Model/Types/Exam.hs b/src/Model/Types/Exam.hs index 986aa3871..f88c67351 100644 --- a/src/Model/Types/Exam.hs +++ b/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) diff --git a/src/Utils.hs b/src/Utils.hs index adc247a67..63aa34f7e 100644 --- a/src/Utils.hs +++ b/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