fix(tutorial): fix #2696 template choice respects school, course, term, etc.
This commit is contained in:
parent
7a1732507f
commit
3f40dd890e
@ -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.
|
||||
QualFormErrorSshMismatch: Qualifikationänderungsformular enthält unglültige Bereichsangabe. Bitte versuchen Sie erneut, nachdem Sie Seite neu geladen haben.
|
||||
@ -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.
|
||||
QualFormErrorSshMismatch: Qualification edit form department mismatch. Please try again after reloading the page.
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user