From 3f40dd890e27de7f82945c1bcb2a0a0f4829df2b Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 31 Jan 2025 12:18:34 +0100 Subject: [PATCH] fix(tutorial): fix #2696 template choice respects school, course, term, etc. --- .../categories/qualification/de-de-formal.msg | 2 +- .../categories/qualification/en-eu.msg | 2 +- .../uniworx/utils/navigation/menu/en-eu.msg | 2 +- src/Database/Esqueleto/Utils.hs | 7 +++- src/Handler/Course/ParticipantInvite.hs | 42 ++++++++++++++----- 5 files changed, 39 insertions(+), 16 deletions(-) diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index f72efb50b..3696a51e4 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -157,4 +157,4 @@ QualificationCreated qsh@Text: Qualifikation #{qsh} wurde angelegt. QualificationEdit qsh@Text: Qualifikation #{qsh} wurde geändert. QualFormErrorDuplShort qsh@Text: Es gibt bereits eine Qualifikation mit Kürzel #{qsh}! QualFormErrorDuplName qname@Text: Es gibt bereits eine Qualifikation mit Namen #{qname}! -QualFormErrorSshMismatch: Qualifikationänderungsformular enthält unglültige Institutsangabe. Bitte versuchen Sie erneut, nachdem Sie Seite neu geladen haben. \ No newline at end of file +QualFormErrorSshMismatch: Qualifikationänderungsformular enthält unglültige Bereichsangabe. Bitte versuchen Sie erneut, nachdem Sie Seite neu geladen haben. \ No newline at end of file diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index d5121b735..430b8e44f 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -157,4 +157,4 @@ QualificationCreated qsh@Text: Qualification #{qsh} created. QualificationEdit qsh@Text: Qualification #{qsh} edited. QualFormErrorDuplShort qsh@Text: There already exists a qualification with shorthand #{qsh}! QualFormErrorDuplName qname@Text: There already exists a qualification with name #{qname}! -QualFormErrorSshMismatch: Qualification edit form data mismatch on institute detected. Please try again after reloading the page. \ No newline at end of file +QualFormErrorSshMismatch: Qualification edit form department mismatch. Please try again after reloading the page. \ No newline at end of file diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index e739e6981..86a7e25f4 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -127,7 +127,7 @@ MenuQualificationEdit: Edit MenuQualificationNew: Create new qualification MenuLms: E‑learning MenuLmsUser: User Qualifications -MenuLmsUserSchool: Institute User Qualifications +MenuLmsUserSchool: Department User Qualifications MenuLmsUserAll: All User Qualifications MenuLmsUsers: Legacy download e‑learning users MenuLmsUpload: Upload diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index ab55d406b..6e523eb3f 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -517,10 +517,13 @@ allFilter fltrs needle criterias = F.foldr aux true fltrs where aux fltr acc = fltr needle criterias E.&&. acc --- | Descending order of this field or SqlExpression, but with NULLS at the end. +-- | Ascending order of this field or SqlExpression, but with NULLS at the end. +-- For bool, just use ASC, since false < true < null ascNullsFirst :: PersistField a => E.SqlExpr (E.Value a) -> E.SqlExpr E.OrderBy ascNullsFirst = E.orderByExpr " ASC NULLS FIRST" +-- | Descending order of this field or SqlExpression, but with NULLS at the end. +-- Use this if you want the order to be true, false, null descNullsLast :: PersistField a => E.SqlExpr (E.Value a) -> E.SqlExpr E.OrderBy descNullsLast = E.orderByExpr " DESC NULLS LAST" @@ -748,7 +751,7 @@ selectCountDistinct q = do -> error "E.countDistinct did not return exactly one result" -- DEPRECATED: use Database.Esqueleto.selectOne instead --- selectMaybe :: (E.SqlSelect a r, MonadIO m) => E.SqlQuery a -> E.SqlReadT m (Maybe r) +-- selectMaybe :: (E.SqlSelect a r, MonadIO m) => E.SqlQuery a -> E.SqlReadT m (Maybe r) -- aka selectFirst -- selectMaybe = fmap listToMaybe . E.select . (<* E.limit 1) -- | convert something that is like a text to text diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index 665d83627..c7ef4d8a8 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -29,7 +29,7 @@ import Control.Monad.Except (MonadError(..)) import Generics.Deriving.Monoid (memptydefault, mappenddefault) --- import Database.Esqueleto.Experimental ((:&)(..)) +import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma import qualified Database.Esqueleto.Utils as E @@ -165,9 +165,9 @@ postTAddUserR tid ssh csh tutn = handleAddUserR tid ssh csh (Left tutn) Nothing handleAddUserR :: TermId -> SchoolId -> CourseShorthand -> Either TutorialName Day -> Maybe TutorialType -> Handler Html handleAddUserR tid ssh csh tdesc ttyp = do - (cid, tutTypes, tutNameSuggestions) <- runDB $ do + (cEnt@Entity{entityKey=cid}, tutTypes, tutNameSuggestions) <- runDB $ do let plainTemplates = tutorialTemplateNames Nothing - cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh + cEnt@Entity{entityKey=cid} <- getBy404 $ TermSchoolCourseShort tid ssh csh tutTypes <- E.select $ E.distinct $ do tutorial <- E.from $ E.table @Tutorial let tuTyp = tutorial E.^. TutorialType @@ -185,11 +185,12 @@ handleAddUserR tid ssh csh tdesc ttyp = do E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid E.&&. E.isJust (tutorial E.^. TutorialFirstDay) E.&&. E.not_ (E.any (E.hasPrefix_ (tutorial E.^. TutorialType) . E.val) plainTemplates) - E.orderBy [E.desc $ tutorial E.^. TutorialFirstDay, E.asc tuName] + E.orderBy $ [E.asc $ tutorial E.^. TutorialName `E.hasInfix` E.val tn | tn <- tutorialTemplateNames Nothing] -- avoid template names, if possible + ++ [E.desc $ tutorial E.^. TutorialFirstDay, E.asc tuName] E.limit 7 return tuName let tutNameSuggestions = return $ mkOptionList [Option tno tn tno | etn <- tutNames, let tn = E.unValue etn, let tno = CI.original tn] - return (cid, Set.toAscList typeSet, tutNameSuggestions) -- Set in order to remove duplicates and sort ascending at once + return (cEnt, Set.toAscList typeSet, tutNameSuggestions) -- Set in order to remove duplicates and sort ascending at once currentRoute <- fromMaybe (error "postCAddUserR called from 404-handler") <$> getCurrentRoute @@ -213,7 +214,7 @@ handleAddUserR tid ssh csh tdesc ttyp = do registeredUsers <- registerUsers cid users whenIsJust actTutorial $ \(tutName,tutType,tutDay) -> do whenIsJust (tutName <|> fmap (tutorialDefaultName tutType) tutDay) $ \tName -> do - tutId <- upsertNewTutorial cid tName tutType tutDay + tutId <- upsertNewTutorial cEnt tName tutType tutDay registerTutorialMembers tutId registeredUsers -- when (Set.size tutActs == Set.size confirmedActs) $ -- not sure how this condition might be false at this point redirect $ CTutorialR tid ssh csh tName TUsersR @@ -344,16 +345,35 @@ registerUser cid (_avsIdent, Just uid) = exceptT return return $ do return $ mempty { aurRegisterSuccess = Set.singleton uid } -upsertNewTutorial :: CourseId -> TutorialName -> Maybe TutorialType -> Maybe Day -> Handler TutorialId -upsertNewTutorial cid newTutorialName newTutorialType newFirstDay = runDB $ do +upsertNewTutorial :: Entity Course -> TutorialName -> Maybe TutorialType -> Maybe Day -> Handler TutorialId +upsertNewTutorial Entity{entityKey=cid, entityVal=crse} newTutorialName newTutorialType newFirstDay = runDB $ do now <- liftIO getCurrentTime existingTut <- getBy $ UniqueTutorial cid newTutorialName - templateEnt <- selectFirst [TutorialType <-. tutorialTemplateNames newTutorialType] [Desc TutorialType, Asc TutorialName] + -- templateEnt <- selectFirst [TutorialType <-. tutorialTemplateNames newTutorialType] [Desc TutorialType, Asc TutorialName] -- current prod as of 02/2025 + templateEnt <- E.selectOne $ do + (tut :& crs :& trm) <- E.from $ E.table @Tutorial + `E.innerJoin` E.table @Course + `E.on` (\(tut :& crs) -> tut E.^. TutorialCourse E.==. crs E.^. CourseId) + `E.innerJoin` E.table @Term + `E.on` (\(_ :& crs :& trm) -> trm E.^. TermId E.==. crs E.^. CourseTerm) + E.where_ $ crs E.^. CourseSchool E.==. E.val (crse & courseSchool) -- filter by School + -- E.&&. tut E.^. TutorialName `E.in_` E.vals (tutorialTemplateNames newTutorialType) -- filter TutorialName being a template + E.orderBy $ -- NOTE: E.desc to have true before false, only works for non-nullable columns! + (:) (E.desc $ tut E.^. TutorialName `E.in_` E.vals (tutorialTemplateNames newTutorialType)) $ -- prefer template names above all else + mcons ((\ttyp -> E.desc $ tut E.^. TutorialName `E.hasInfix` E.val ttyp) <$> newTutorialType) -- prefer ttype, if given. + [ E.desc $ tut E.^. TutorialCourse E.==. E.val cid -- prefer current course + , E.desc $ crs E.^. CourseName E.==. E.val (crse & courseName) -- prefer courses with identical name + , E.desc $ crs E.^. CourseShorthand E.==. E.val (crse & courseShorthand) -- prefer courses with identical shortcut + , E.desc $ crs E.^. CourseTerm E.==. E.val (crse & courseTerm) -- prefer courses from current term + , E.desc $ trm E.^. TermStart -- prefer most recently started term + -- , E.desc $ tut E.^. tutorialRegisterFrom + , E.asc $ tut E.^. TutorialName -- prefer tutorial name in alpahbetical order + ] + return tut case (existingTut, newFirstDay, templateEnt) of (Just Entity{entityKey=tid},_,_) -> return tid -- no need to update, we ignore the anchor day (Nothing, Just moveDay, Just Entity{entityVal=Tutorial{..}}) -> do - Course{..} <- get404 cid - term <- get404 courseTerm + term <- get404 $ courseTerm crse let oldFirstDay = fromMaybe moveDay $ tutorialFirstDay <|> fst (occurrencesBounds term $ unJSONB tutorialTime) newTime = normalizeOccurrences $ occurrencesAddBusinessDays term (oldFirstDay, moveDay) $ unJSONB tutorialTime dayDiff = maybe 0 (diffDays moveDay) tutorialFirstDay