diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 5c690fd29..37d611034 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -4,6 +4,9 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity and HasUser instances +{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} -- TODO, only for develop +{-# OPTIONS_GHC -fno-warn-unused-local-binds #-} -- TODO, only for develop + module Handler.Profile ( getProfileR, postProfileR , getForProfileR, postForProfileR @@ -38,6 +41,7 @@ import qualified Database.Esqueleto.Experimental as E import qualified Database.Esqueleto.Legacy as EL (on,from) import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.PostgreSQL as E +import Database.Esqueleto.Utils.TH import qualified Data.Text as Text import Data.List (inits) @@ -1042,6 +1046,71 @@ mkCorrectionsTable = in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in (_1 %~ getAny) <$> dbTableWidget validator DBTable{..} +type TblExamsExpr = ( E.SqlExpr ( Entity Course) + `E.InnerJoin` E.SqlExpr ( Entity Exam) + `E.InnerJoin` E.SqlExpr ( Entity ExamRegistration) + `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamOccurrence)) + `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) + ) +-- due to GHC staging restrictions, we use the preprocessor instead +#define TABLE_EXAMS_JOIN "IILL" + +type TblExamsData = DBRow (Entity Course, Entity Exam, Entity ExamRegistration, Maybe (Entity ExamOccurrence), Maybe (Entity User)) + +-- | Table listing all exams that the given user is enrolled in +mkExamsTable :: UserId -> DB (Bool, Widget) +mkExamsTable = + let dbtIdent = "exams-user" :: Text + dbtStyle = def + dbtSQLQuery' uid (crs `E.InnerJoin` exm `E.InnerJoin` reg `E.LeftOuterJoin` occ `E.LeftOuterJoin` xmr) = do + EL.on $ xmr E.?. UserId E.==. E.joinV (occ E.?. ExamOccurrenceExaminer) + EL.on $ reg E.^. ExamRegistrationOccurrence E.==. occ E.?. ExamOccurrenceId + EL.on $ reg E.^. ExamRegistrationExam E.==. exm E.^. ExamId + EL.on $ crs E.^. CourseId E.==. exm E.^. ExamCourse + E.where_ $ reg E.^. ExamRegistrationUser E.==. E.val uid + return (crs,exm,reg,occ,xmr) + queryCourse :: TblExamsExpr -> E.SqlExpr (Entity Course) + queryCourse = $(sqlMIXproj TABLE_EXAMS_JOIN 1) + queryExam :: TblExamsExpr -> E.SqlExpr (Entity Exam) + queryExam = $(sqlMIXproj TABLE_EXAMS_JOIN 2) + queryRegistration :: TblExamsExpr -> E.SqlExpr (Entity ExamRegistration) + queryRegistration = $(sqlMIXproj TABLE_EXAMS_JOIN 3) + queryOccurrence :: TblExamsExpr -> E.SqlExpr (Maybe (Entity ExamOccurrence)) + queryOccurrence = $(sqlMIXproj TABLE_EXAMS_JOIN 4) + queryExaminer :: TblExamsExpr -> E.SqlExpr (Maybe (Entity User)) + queryExaminer = $(sqlMIXproj TABLE_EXAMS_JOIN 5) + resultCourse :: Lens' TblExamsData (Entity Course) + resultCourse = _dbrOutput . _1 + resultExam :: Lens' TblExamsData (Entity Exam) + resultExam = _dbrOutput . _2 + resultRegistration :: Lens' TblExamsData (Entity ExamRegistration) + resultRegistration = _dbrOutput . _3 + resultOccurrence :: Traversal' TblExamsData (Entity ExamOccurrence) + resultOccurrence = _dbrOutput . _4 . _Just + resultExaminer :: Traversal' TblExamsData (Entity User) + resultExaminer = _dbrOutput . _5 . _Just + dbtRowKey = queryRegistration >>> (E.^. ExamRegistrationId) + dbtProj = dbtProjId + dbtColonnade = mconcat + [ sortable (Just "course") (i18nCell MsgTableCourse) $ fmap addIndicatorCell courseCell <$> view (resultCourse . _entityVal) + , sortable (Just "exam") (i18nCell MsgCourseExam) $ \row -> examCell (row ^. resultCourse . _entityVal) (row ^. resultExam . _entityVal) + ] + validator = def + dbtSorting = Map.fromList + [ ( "course", SortColumn $ queryCourse >>> (E.^. CourseName)) + , ( "exam" , SortColumn $ queryExam >>> (E.^. ExamName)) + -- TODO: continue here + ] + dbtFilter = mempty + dbtFilterUI = mempty + dbtParams = def + dbtCsvEncode = noCsvEncode + dbtCsvDecode = Nothing + dbtExtraReps = [] + in \uid -> let dbtSQLQuery = dbtSQLQuery' uid + in (_1 %~ getAny) <$> dbTableWidget validator DBTable{..} + + -- | Table listing all qualifications that the given user is enrolled in mkQualificationsTable :: UTCTime -> UserId -> DB Widget diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index ae036174b..4545c88ea 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -389,6 +389,19 @@ courseCell Course{..} = anchorCell link name `mappend` desc ^{modal "Beschreibung" (Right $ toWidget descr)} |] +examCell :: IsDBTable m a => Course -> Exam -> DBCell m a +examCell Course{..} Exam{..} = anchorCell link name `mappend` desc + where + link = CExamR courseTerm courseSchool courseShorthand examName EShowR + name = citext2widget examName + desc = case examDescription of + Nothing -> mempty + (Just descr) -> cell [whamlet| + $newline never +
+ ^{modal "Beschreibung" (Right $ toWidget descr)} + |] + -- also see Handler.Utils.Widgets.companyWidget companyCell :: IsDBTable m a => CompanyShorthand -> CompanyName -> Bool -> DBCell m a companyCell csh cname isSupervisor = anchorCell curl name