chore(profile): towards exam table in profile data (WIP)

towards #2347

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

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
+              <div>
+                ^{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