feat(course): associate qualifications with courses

models/courses.model

@@ -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

src/Handler/Tutorial/Users.hs

@@ -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
+      acts = Map.fromList $
-        [ ( TutorialUserRenewQualification
+        (if null qualifications then mempty else
-          , TutorialUserRenewQualificationData
+          [ ( TutorialUserRenewQualification
-            <$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing            
+            , TutorialUserRenewQualificationData
-          )
+              <$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing            
-        , ( TutorialUserGrantQualification
+            )
-          , TutorialUserGrantQualificationData
+          , ( TutorialUserGrantQualification
-            <$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing
+            , TutorialUserGrantQualificationData
-            <*> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry
+              <$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing
-          )
+              <*> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry
-        , ( TutorialUserSendMail, pure TutorialUserSendMailData )
+            )
+          ] 
+        ) ++
+        [ ( 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 $
+  tutors <- runDB $ E.select $ do
-    E.select $ E.from $ \(tutor `E.InnerJoin` user) -> do
+    (tutor :& user) <- E.from $ E.table @Tutor `E.innerJoin` E.table @User
-      E.on $ tutor E.^. TutorUser E.==. user E.^. UserId
+      `E.on` (\(tutor :& user) -> tutor E.^. TutorUser E.==. user E.^. UserId)
-      E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid
+    E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid
-      return user
+    return user
 
   let heading = prependCourseTitle tid ssh csh $ CI.original tutorialName
   siteLayoutMsg heading $ do

test/Database/Fill.hs

@@ -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 $ utctDay now
-    -- (currentYear, currentMonth, currentDay) = toGregorian $ getTermDay currentTerm
+    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
@@ -818,6 +819,9 @@ fillDb = do
           , 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"