fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore(profile): show user courses among enrolled course type list

Browse Source 
(Recall: course = tutorial, course type = course)
This commit is contained in:
Steffen Jost 2024-07-31 17:51:13 +02:00
parent 507a7e02fc
commit 0fde59c19a
2 changed files with 75 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

107
src/Handler/Profile.hs
View File

@ -31,9 +31,11 @@ import Utils.Print (validCmdArgument)
import Data.Map ((!))
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Database.Esqueleto.Legacy as E
import Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Experimental as E
import qualified Database.Esqueleto.Legacy as EL (on,from)
import qualified Database.Esqueleto.Utils as E
-- import Database.Esqueleto ((^.))
import qualified Data.Text as Text
import Data.List (inits)
@ -192,28 +194,28 @@ notificationForm template = wFormToAForm $ do
-> return False
NTKCourseParticipant
| Just uid <- mbUid
-> fmap not . E.selectExists . E.from $ \courseParticipant ->
-> fmap not . E.selectExists . EL.from $ \courseParticipant ->
E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val uid
E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
NTKSubmissionUser
| Just uid <- mbUid
-> fmap not . E.selectExists . E.from $ \submissionUser ->
-> fmap not . E.selectExists . EL.from $ \submissionUser ->
E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val uid
NTKExamParticipant
| Just uid <- mbUid
-> fmap not . E.selectExists . E.from $ \examRegistration ->
-> fmap not . E.selectExists . EL.from $ \examRegistration ->
E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val uid
NTKCorrector
| Just uid <- mbUid
-> fmap not . E.selectExists . E.from $ \sheetCorrector ->
-> fmap not . E.selectExists . EL.from $ \sheetCorrector ->
E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid
NTKCourseLecturer
| Just uid <- mbUid
-> fmap not . E.selectExists . E.from $ \lecturer ->
-> fmap not . E.selectExists . EL.from $ \lecturer ->
E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid
NTKFunctionary f
| Just uid <- mbUid
-> fmap not . E.selectExists . E.from $ \userFunction ->
-> fmap not . E.selectExists . EL.from $ \userFunction ->
E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val uid
E.&&. userFunction E.^. UserFunctionFunction E.==. E.val f
_ | Nothing <- mbUid -> return False -- Show everything for not-logged-in users (e.g. if they presented a token)
@ -428,8 +430,8 @@ serveProfileR :: (UserId, User) -> Handler Html
serveProfileR (uid, user@User{..}) = do
currentRoute <- fromMaybe ProfileR <$> getCurrentRoute
(userSchools, userExamOfficeLabels) <- runDB $ do
userSchools <- fmap (setOf $ folded . _Value) . E.select . E.from $ \school -> do
E.where_ . E.exists . E.from $ \userSchool ->
userSchools <- fmap (setOf $ folded . _Value) . E.select . EL.from $ \school -> do
E.where_ . E.exists . EL.from $ \userSchool ->
E.where_ $ E.not_ (userSchool E.^. UserSchoolIsOptOut)
E.&&. userSchool E.^. UserSchoolUser E.==. E.val uid
E.&&. userSchool E.^. UserSchoolSchool E.==. school E.^. SchoolId
@ -519,8 +521,8 @@ serveProfileR (uid, user@User{..}) = do
oldExamLabels = userExamOfficeLabels
newExamLabels = stgExamOfficeSettings & eosettingsLabels
forM_ oldExamLabels $ \(Entity eolid ExamOfficeLabel{..}) -> unless (Right eolid `Map.member` newExamLabels || Left examOfficeLabelName `Map.member` newExamLabels) $ do
E.delete . E.from $ \examOfficeExternalExamLabel -> E.where_ $ examOfficeExternalExamLabel E.^. ExamOfficeExternalExamLabelLabel E.==. E.val eolid
E.delete . E.from $ \examOfficeExamLabel -> E.where_ $ examOfficeExamLabel E.^. ExamOfficeExamLabelLabel E.==. E.val eolid
E.delete . EL.from $ \examOfficeExternalExamLabel -> E.where_ $ examOfficeExternalExamLabel E.^. ExamOfficeExternalExamLabelLabel E.==. E.val eolid
E.delete . EL.from $ \examOfficeExamLabel -> E.where_ $ examOfficeExamLabel E.^. ExamOfficeExamLabelLabel E.==. E.val eolid
when (csvExportLabel userCsvOptions == Just examOfficeLabelName) $
update uid [ UserCsvOptions =. userCsvOptions { csvExportLabel = Nothing } ]
delete eolid
@ -633,19 +635,19 @@ makeProfileData usrEnt@(Entity uid usrVal@User{..}) = do
addressLinkdIcon <- messageTooltip <$> messageIconI Info IconLink MsgAddressIsLinkedTip
(actualPrefersPostal, (actualPostAddress, postalAutomatic), (actualDisplayEmail, emailAutomatic)) <- getPostalPreferenceAndAddress' usrEnt
functions <- Map.fromListWith Set.union . map (\(Entity _ UserFunction{..}) -> (userFunctionFunction, Set.singleton userFunctionSchool)) <$> selectList [UserFunctionUser ==. uid] []
lecture_corrector <- E.select $ E.distinct $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
lecture_corrector <- E.select $ E.distinct $ EL.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do
EL.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
EL.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid
return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand)
studies <- E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do
E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId
E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId
studies <- E.select $ EL.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do
EL.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId
EL.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId
E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
return (studyfeat, studydegree, studyterms)
companies <- wgtCompanies uid
-- supervisors' <- E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
-- E.on $ spvr E.^. UserSupervisorSupervisor E.==. usrSpvr E.^. UserId
-- supervisors' <- E.select $ EL.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
-- EL.on $ spvr E.^. UserSupervisorSupervisor E.==. usrSpvr E.^. UserId
-- E.where_ $ spvr E.^. UserSupervisorUser E.==. E.val uid
-- E.orderBy [E.asc (usrSpvr E.^. UserDisplayName)]
-- return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications)
@ -653,8 +655,8 @@ makeProfileData usrEnt@(Entity uid usrVal@User{..}) = do
-- supervisors = intersperse (text2widget ", ") $
-- (\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisors'
-- icnReroute = text2widget " " <> toWgt (icon IconReroute)
-- supervisees' <- E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
-- E.on $ spvr E.^. UserSupervisorUser E.==. usrSpvr E.^. UserId
-- supervisees' <- E.select $ EL.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
-- EL.on $ spvr E.^. UserSupervisorUser E.==. usrSpvr E.^. UserId
-- E.where_ $ spvr E.^. UserSupervisorSupervisor E.==. E.val uid
-- return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications)
-- let numSupervisees = length supervisees'
@ -681,7 +683,7 @@ makeProfileData usrEnt@(Entity uid usrVal@User{..}) = do
-- let examTable, ownTutorialTable, tutorialTable :: Widget
-- examTable = i18n MsgPersonalInfoExamAchievementsWip
-- ownTutorialTable = i18n MsgPersonalInfoOwnTutorialsWip
-- tutorialTable = i18n MsgPersonalInfoTutorialsWip
-- tutorialTable = i18n MsgPersonalInfoTutorialsWip -- note that tutorials are linked in enrolledCoursesTable
cID <- encrypt uid
mCRoute <- getCurrentRoute
@ -705,7 +707,7 @@ mkOwnedCoursesTable =
withType = id
dbtSQLQuery' uid (course `E.InnerJoin` lecturer) = do
E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
EL.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid
return ( course E.^. CourseTerm
, course E.^. CourseSchool
@ -747,18 +749,28 @@ mkOwnedCoursesTable =
-- | Table listing all courses that the given user is enrolled in
mkEnrolledCoursesTable :: UserId -> DB (Bool, Widget)
mkEnrolledCoursesTable =
let withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a)
mkEnrolledCoursesTable uid = do
usrTuts <- E.select $ do
(tpar :& tut) <- E.from $ E.table @TutorialParticipant `E.innerJoin` E.table @Tutorial
`E.on` (\(tpar :& tut) -> tut E.^. TutorialId E.==. tpar E.^. TutorialParticipantTutorial)
E.where_ $ tpar E.^. TutorialParticipantUser E.==. E.val uid
E.orderBy [E.asc $ tut E.^. TutorialCourse, E.desc $ tut E.^. TutorialName] -- Data.Map.fromAscListWith reverses tutorials, hence E.desc
return (tut E.^. TutorialCourse, tut E.^. TutorialName)
let usrTutMap :: Map CourseId [TutorialName]
usrTutMap = Map.fromAscListWith (++) [(tcid, [tnm]) | (E.Value tcid, E.Value tnm) <- usrTuts]
withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a)
-> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a)
withType = id
validator = def & defaultSorting [SortDescBy "time"]
in \uid -> (_1 %~ getAny) <$> dbTableWidget validator
(_1 %~ getAny) <$> dbTableWidget validator
DBTable
{ dbtIdent = "courseMembership" :: Text
, dbtSQLQuery = \(course `E.InnerJoin` participant) -> do
E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse
EL.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse
E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid
E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
return (course, participant E.^. CourseParticipantRegistration)
@ -775,7 +787,14 @@ mkEnrolledCoursesTable =
, sortable (Just "time") (i18nCell MsgProfileRegistered) $ do
regTime <- view $ _dbrOutput . _2
return $ dateTimeCell regTime
]
, sortable Nothing (i18nCell MsgCourseTutorials) $ \(view $ _dbrOutput . _1 -> Entity{entityKey=cid, entityVal=Course{..}}) ->
cell [whamlet|
<ul .list--iconless>
$forall tutName <- maybeMonoid (Map.lookup cid usrTutMap)
<li>
^{simpleLink (citext2widget tutName) (CTutorialR courseTerm courseSchool courseShorthand tutName TUsersR)}
|]
]
, dbtSorting = Map.fromList
[ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseName )
, ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseTerm )
@ -808,9 +827,9 @@ mkSubmissionTable =
withType = id
dbtSQLQuery' uid (course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` subUser) = do
E.on $ submission E.^. SubmissionId E.==. subUser E.^. SubmissionUserSubmission
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
EL.on $ submission E.^. SubmissionId E.==. subUser E.^. SubmissionUserSubmission
EL.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
EL.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
E.where_ $ subUser E.^. SubmissionUserUser E.==. E.val uid
let crse = ( course E.^. CourseTerm
, course E.^. CourseSchool
@ -821,7 +840,7 @@ mkSubmissionTable =
dbtRowKey (_ `E.InnerJoin` _ `E.InnerJoin` submission `E.InnerJoin` _) = submission E.^. SubmissionId
lastSubEdit uid submission = -- latest Edit-Time of this user for submission
E.subSelectMaybe . E.from $ \subEdit -> do
E.subSelectMaybe . EL.from $ \subEdit -> do
E.where_ $ subEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId
E.&&. subEdit E.^. SubmissionEditUser E.==. E.val (Just uid)
return . E.max_ $ subEdit E.^. SubmissionEditTime
@ -888,8 +907,8 @@ mkSubmissionGroupTable =
withType = id
dbtSQLQuery' uid (course `E.InnerJoin` sgroup `E.InnerJoin` sguser) = do
E.on $ sguser E.^. SubmissionGroupUserSubmissionGroup E.==. sgroup E.^. SubmissionGroupId
E.on $ sgroup E.^. SubmissionGroupCourse E.==. course E.^. CourseId
EL.on $ sguser E.^. SubmissionGroupUserSubmissionGroup E.==. sgroup E.^. SubmissionGroupId
EL.on $ sgroup E.^. SubmissionGroupCourse E.==. course E.^. CourseId
E.where_ $ sguser E.^. SubmissionGroupUserUser E.==. E.val uid
let crse = ( course E.^. CourseTerm
, course E.^. CourseSchool
@ -942,18 +961,18 @@ mkCorrectionsTable =
-> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity SheetCorrector))->a)
withType = id
corrsAssigned uid sheet = E.subSelectCount . E.from $ \submission ->
corrsAssigned uid sheet = E.subSelectCount . EL.from $ \submission ->
E.where_ $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
E.&&. submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
corrsCorrected uid sheet = E.subSelectCount . E.from $ \submission ->
corrsCorrected uid sheet = E.subSelectCount . EL.from $ \submission ->
E.where_ $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
E.&&. submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
E.&&. E.not_ (E.isNothing $ submission E.^. SubmissionRatingTime)
dbtSQLQuery' uid (course `E.InnerJoin` sheet `E.InnerJoin` corrector) = do
E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
EL.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
EL.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid
let crse = ( course E.^. CourseTerm
, course E.^. CourseSchool
@ -1018,9 +1037,9 @@ mkQualificationsTable =
DBTable
{ dbtIdent = "userQualifications" :: Text
, dbtSQLQuery = \(quali `E.InnerJoin` quser `E.LeftOuterJoin` qblock) -> do
E.on $ quser E.^. QualificationUserId E.=?. qblock E.?. QualificationUserBlockQualificationUser
EL.on $ quser E.^. QualificationUserId E.=?. qblock E.?. QualificationUserBlockQualificationUser
E.&&. qblock `isLatestBlockBefore` E.val now
E.on $ quser E.^. QualificationUserQualification E.==. quali E.^. QualificationId
EL.on $ quser E.^. QualificationUserQualification E.==. quali E.^. QualificationId
E.where_ $ quser E.^. QualificationUserUser E.==. E.val uid
return (quali, quser, qblock)
, dbtRowKey = \(_quali `E.InnerJoin` quser `E.LeftOuterJoin` _qblock) -> quser E.^. QualificationUserId
@ -1078,7 +1097,7 @@ mkSupervisorsTable uid = dbTableWidget validator DBTable{..}
dbtStyle = def
dbtSQLQuery (usr `E.InnerJoin` spr) = do
E.on $ spr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId
EL.on $ spr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId
E.where_ $ spr E.^. UserSupervisorUser E.==. E.val uid
return (usr, spr)
dbtRowKey (_ `E.InnerJoin` spr) = spr E.^. UserSupervisorId
@ -1131,7 +1150,7 @@ mkSuperviseesTable userPrefersPostal uid = dbTableWidget validator DBTable{..}
dbtStyle = def
dbtSQLQuery (usr `E.InnerJoin` spr) = do
E.on $ spr E.^. UserSupervisorUser E.==. usr E.^. UserId
EL.on $ spr E.^. UserSupervisorUser E.==. usr E.^. UserId
E.where_ $ spr E.^. UserSupervisorSupervisor E.==. E.val uid
return (usr, spr)
dbtRowKey (_ `E.InnerJoin` spr) = spr E.^. UserSupervisorId
@ -1290,7 +1309,7 @@ postCsvOptionsR = do
Entity uid User{userCsvOptions} <- requireAuth
userIsExamOffice <- hasReadAccessTo $ ExamOfficeR EOExamsR
examOfficeLabels <- if not userIsExamOffice then return mempty else runDB . E.select . E.from $ \examOfficeLabel -> do
examOfficeLabels <- if not userIsExamOffice then return mempty else runDB . E.select . EL.from $ \examOfficeLabel -> do
E.where_ $ examOfficeLabel E.^. ExamOfficeLabelUser E.==. E.val uid
E.orderBy [ E.asc (examOfficeLabel E.^. ExamOfficeLabelName) ]
return $ examOfficeLabel E.^. ExamOfficeLabelName

14
test/Database/Fill.hs
View File

@ -1098,7 +1098,7 @@ fillDb = do
, tutorialFirstDay = Just firstDay
}
insert_ $ Tutor tut1 jost
insert_ Tutorial
tut2 <- insert Tutorial
{ tutorialName = mkName "Vorlage"
, tutorialCourse = c
, tutorialType = "Vorlage"
@ -1138,7 +1138,7 @@ fillDb = do
, tutorialTutorControlled = True
, tutorialFirstDay = Just firstDay
}
insert_ Tutorial
tut3 <- insert Tutorial
{ tutorialName = mkName "Sondertutoriumsvorlage"
, tutorialCourse = c
, tutorialType = "Vorlage_Sondertutorium"
@ -1178,6 +1178,16 @@ fillDb = do
, tutorialTutorControlled = True
, tutorialFirstDay = Just $ succ $ succ firstDay
}
insert_ $ CourseParticipant c jost now CourseParticipantActive
insert_ $ CourseParticipant c gkleen now $ CourseParticipantInactive True
insert_ $ CourseParticipant c fhamann now $ CourseParticipantInactive False
insert_ $ CourseParticipant c svaupel now CourseParticipantActive
insert_ $ TutorialParticipant tut1 svaupel
insert_ $ TutorialParticipant tut2 svaupel
when (odd tyear) $ insert_ $ TutorialParticipant tut3 svaupel
insert_ $ TutorialParticipant tut1 gkleen
insert_ $ TutorialParticipant tut2 fhamann
when (even tyear) $ insert_ $ TutorialParticipant tut3 jost
when (odd tyear) $
void . insert' $ Exam
{ examCourse = c