feat(course): associate qualifications with courses
This commit is contained in:
parent
a9cccef1a5
commit
ffaaf9c86d
@ -90,3 +90,10 @@ CourseUserExamOfficeOptOut
|
||||
school SchoolId
|
||||
UniqueCourseUserExamOfficeOptOut course user school
|
||||
deriving Generic
|
||||
|
||||
CourseQualification
|
||||
course CourseId
|
||||
qualification QualificationId
|
||||
sortOrder Int default=0
|
||||
UniqueCourseQualification course qualification
|
||||
deriving Generic
|
||||
@ -2,6 +2,8 @@
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module Handler.Tutorial.Users
|
||||
( getTUsersR, postTUsersR
|
||||
) where
|
||||
@ -20,7 +22,8 @@ import qualified Data.Map as Map
|
||||
|
||||
-- import qualified Data.Time.Zones as TZ
|
||||
|
||||
import qualified Database.Esqueleto.Legacy as E
|
||||
import Database.Esqueleto.Experimental ((:&)(..))
|
||||
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
|
||||
|
||||
import Handler.Course.Users
|
||||
|
||||
@ -54,8 +57,17 @@ getTUsersR = postTUsersR
|
||||
postTUsersR tid ssh csh tutn = do
|
||||
showSex <- getShowSex
|
||||
(Entity tutid Tutorial{..}, (participantRes, participantTable)) <- runDB $ do
|
||||
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
tut@(Entity tutid _) <- fetchTutorial tid ssh csh tutn
|
||||
qualifications <- selectList [QualificationSchool ==. ssh] [Asc QualificationShorthand]
|
||||
-- qualifications <- selectList [QualificationSchool ==. ssh] [Asc QualificationShorthand]
|
||||
qualifications <- E.select $ do
|
||||
(qual :& courseQual) <-
|
||||
E.from $ E.table @Qualification
|
||||
`E.innerJoin` E.table @CourseQualification
|
||||
`E.on` (\(qual :& courseQual) -> qual E.^. QualificationId E.==. courseQual E.^. CourseQualificationQualification)
|
||||
E.where_ $ courseQual E.^. CourseQualificationCourse E.==. E.val cid
|
||||
E.orderBy [E.asc $ courseQual E.^. CourseQualificationSortOrder]
|
||||
pure qual
|
||||
now <- liftIO getCurrentTime
|
||||
let minDur :: Maybe Int = minimumMaybe $ catMaybes (view _qualificationValidDuration <$> qualifications) -- no instance Ord CalendarDiffDays
|
||||
dayExpiry = flip addGregorianDurationClip (utctDay now) . fromMonths <$> minDur
|
||||
@ -71,12 +83,12 @@ postTUsersR tid ssh csh tutn = do
|
||||
& defaultSortingByName
|
||||
& restrictSorting (\name _ -> none (== name) ["note", "registration", "tutorials", "exams", "submission-group", "state"]) -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
|
||||
& restrictFilter (\name _ -> none (== name) ["tutorial", "exam", "submission-group", "active", "has-personalised-sheet-files"])
|
||||
isInTut q = E.exists . E.from $ \tutorialParticipant ->
|
||||
isInTut q = E.exists $ do
|
||||
tutorialParticipant <- E.from $ E.table @TutorialParticipant
|
||||
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"]
|
||||
|
||||
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
|
||||
let
|
||||
qualOpt :: Entity Qualification -> Handler (Option QualificationId)
|
||||
qualOpt (Entity qualId qual) = do
|
||||
@ -87,17 +99,20 @@ postTUsersR tid ssh csh tutn = do
|
||||
, optionExternalValue = tshow cQualId
|
||||
}
|
||||
acts :: Map TutorialUserAction (AForm Handler TutorialUserActionData)
|
||||
acts = Map.fromList
|
||||
[ ( TutorialUserRenewQualification
|
||||
, TutorialUserRenewQualificationData
|
||||
<$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing
|
||||
)
|
||||
, ( TutorialUserGrantQualification
|
||||
, TutorialUserGrantQualificationData
|
||||
<$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing
|
||||
<*> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry
|
||||
)
|
||||
, ( TutorialUserSendMail, pure TutorialUserSendMailData )
|
||||
acts = Map.fromList $
|
||||
(if null qualifications then mempty else
|
||||
[ ( TutorialUserRenewQualification
|
||||
, TutorialUserRenewQualificationData
|
||||
<$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing
|
||||
)
|
||||
, ( TutorialUserGrantQualification
|
||||
, TutorialUserGrantQualificationData
|
||||
<$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing
|
||||
<*> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry
|
||||
)
|
||||
]
|
||||
) ++
|
||||
[ ( TutorialUserSendMail, pure TutorialUserSendMailData )
|
||||
, ( TutorialUserDeregister, pure TutorialUserDeregisterData )
|
||||
]
|
||||
table <- makeCourseUserTable cid acts isInTut colChoices psValidator (Just csvColChoices)
|
||||
@ -125,11 +140,11 @@ postTUsersR tid ssh csh tutn = do
|
||||
addMessageI Success $ MsgTutorialUsersDeregistered nrDel
|
||||
redirect $ CTutorialR tid ssh csh tutn TUsersR
|
||||
|
||||
tutors <- runDB $
|
||||
E.select $ E.from $ \(tutor `E.InnerJoin` user) -> do
|
||||
E.on $ tutor E.^. TutorUser E.==. user E.^. UserId
|
||||
E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid
|
||||
return user
|
||||
tutors <- runDB $ E.select $ do
|
||||
(tutor :& user) <- E.from $ E.table @Tutor `E.innerJoin` E.table @User
|
||||
`E.on` (\(tutor :& user) -> tutor E.^. TutorUser E.==. user E.^. UserId)
|
||||
E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid
|
||||
return user
|
||||
|
||||
let heading = prependCourseTitle tid ssh csh $ CI.original tutorialName
|
||||
siteLayoutMsg heading $ do
|
||||
|
||||
@ -57,8 +57,8 @@ fillDb = do
|
||||
addBDays = addBusinessDays Fraport -- holiday area to use
|
||||
n_day n = addBDays n $ utctDay now
|
||||
n_day' n = now { utctDay = n_day n }
|
||||
currentTerm = TermIdentifier . fst3 . toGregorian $ utctDay now
|
||||
-- (currentYear, currentMonth, currentDay) = toGregorian $ getTermDay currentTerm
|
||||
(currentYear, _currentMonth, _currentDay) = toGregorian $ utctDay now
|
||||
currentTerm = TermIdentifier currentYear
|
||||
nextTerm n = toEnum . (+n) $ fromEnum currentTerm
|
||||
|
||||
termTime :: TermIdentifier -- ^ Term
|
||||
@ -172,7 +172,7 @@ fillDb = do
|
||||
, userTitle = Just "Dr."
|
||||
, userMaxFavourites = 14
|
||||
, userMaxFavouriteTerms = 4
|
||||
, userTheme = userDefaultTheme
|
||||
, userTheme = ThemeSkyLove
|
||||
, userDateTimeFormat = userDefaultDateTimeFormat
|
||||
, userDateFormat = userDefaultDateFormat
|
||||
, userTimeFormat = userDefaultTimeFormat
|
||||
@ -402,7 +402,7 @@ fillDb = do
|
||||
, userTitle = Nothing
|
||||
, userMaxFavourites = userDefaultMaxFavourites
|
||||
, userMaxFavouriteTerms = userDefaultMaxFavourites
|
||||
, userTheme = userDefaultTheme
|
||||
, userTheme = ThemeAberdeenReds
|
||||
, userDateTimeFormat = userDefaultDateTimeFormat
|
||||
, userDateFormat = userDefaultDateFormat
|
||||
, userTimeFormat = userDefaultTimeFormat
|
||||
@ -786,6 +786,7 @@ fillDb = do
|
||||
jtt = (((Just .) .) .) . termTime tid
|
||||
firstDay = utctDay $ termTime tid TermDayLectureStart 0 Nothing toMidnight
|
||||
secondDay = utctDay $ termTime tid TermDayLectureStart 1 Nothing toMidnight
|
||||
tyear = year tid
|
||||
weekDay = dayOfWeek firstDay
|
||||
-- thirdDay = utctDay $ termTime tid TermDayLectureStart 2 Nothing toMidnight
|
||||
capacity = Just 8
|
||||
@ -816,8 +817,11 @@ fillDb = do
|
||||
, courseDeregisterUntil = jtt TermDayLectureStart (-5) (Just Monday) toMidnight
|
||||
, courseRegisterSecret = Nothing
|
||||
, courseMaterialFree = True
|
||||
}
|
||||
}
|
||||
insert_ $ CourseEdit jost now c
|
||||
when (tyear >= currentYear) $ insert_ $ CourseQualification c qid_f 2
|
||||
when (tyear >= succ currentYear) $ insert_ $ CourseQualification c qid_r 3
|
||||
when (tyear >= succ (succ currentYear)) $ insert_ $ CourseQualification c qid_l 1
|
||||
insert_ Sheet
|
||||
{ sheetCourse = c
|
||||
, sheetName = mkName "Sehtest"
|
||||
|
||||
Loading…
Reference in New Issue
Block a user