Course member list stub working, after daylong painful birth throes

messages/uniworx/de.msg

@@ -67,7 +67,7 @@ TermSchoolCourseListTitle tid@TermId school@SchoolName: Kurse #{display tid} fü
 CourseNewHeading: Neuen Kurs anlegen
 CourseEditHeading tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{csh} editieren
 CourseEditTitle: Kurs editieren/anlegen
-CourseMember: Teilnehmer
+CourseMembers: Teilnehmer
 CourseMembersCount num@Int64: #{display num}
 CourseMembersCountLimited num@Int64 max@Int64: #{display num}/#{display max}
 CourseName: Name
@@ -591,6 +591,7 @@ MenuProfile: Anpassen
 MenuLogin: Login
 MenuLogout: Logout
 MenuCourseList: Kurse
+MenuCourseMembers: Kursteilnehmer
 MenuTermShow: Semester
 MenuSubmissionDelete: Abgabe löschen
 MenuUsers: Benutzer

src/Foundation.hs

@@ -1403,6 +1403,14 @@ pageActions (CourseR tid ssh csh CShowR) =
       }
   ] ++ pageActions (CourseR tid ssh csh SheetListR) ++
   [ MenuItem
+      { menuItemType = PageActionSecondary
+      , menuItemLabel = MsgMenuCourseMembers
+      , menuItemIcon  = Just "user-graduate"
+      , menuItemRoute = SomeRoute $ CourseR tid ssh csh CUsersR
+      , menuItemModal = False
+      , menuItemAccessCallback' = return True
+      }
+  , MenuItem
       { menuItemType = PageActionSecondary
       , menuItemLabel = MsgMenuCourseEdit
       , menuItemIcon  = Nothing

src/Handler/Course.hs

@@ -92,7 +92,7 @@ colRegTo = sortable (Just "register-to") (i18nCell MsgRegisterTo)
             maybe mempty timeCell courseRegisterTo
 
 colMembers :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
-colMembers = sortable (Just "members") (i18nCell MsgCourseMember)
+colMembers = sortable (Just "members") (i18nCell MsgCourseMembers)
           $ \DBRow{ dbrOutput=(Entity _ Course{..}, currentParticipants, _, _) } -> i18nCell $ case courseCapacity of
               Nothing -> MsgCourseMembersCount currentParticipants
               Just limit -> MsgCourseMembersCountLimited currentParticipants limit
@@ -621,22 +621,25 @@ validateCourse CourseForm{..} =
   ] ]
 
 
-
+--------------------
 -- CourseUserTable
 
-type UserTableExpr  = (E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) `E.LeftOuterJoin` E.SqlExpr (Entity CourseUserNote)
+type UserTableExpr   = (E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseUserNote))
-type UserTableWhere = UserTableExpr -> E.SqlExpr (E.Value Bool)
+type UserTableWhere  = UserTableExpr -> E.SqlExpr (E.Value Bool)
-type UserTableData  = DBRow (Entity User, Entity CourseParticipant, Maybe (Key CourseUserNote))
+type UserTableData   = DBRow (Entity User, E.Value UTCTime, E.Value (Maybe CourseUserNoteId))
 
-userTableQuery :: UserTableWhere -> (UserTableExpr -> v) -> UserTableExpr -> E.SqlQuery v
+forceUserTableType :: (UserTableExpr -> a) -> (UserTableExpr -> a)
-userTableQuery whereClause returnStatement t@((user `E.InnerJoin` participant) `E.LeftOuterJoin` note) = do
+forceUserTableType = id
-  E.on $ participant E.^. CourseParticipantUser E.==. note E.^. CourseUserNoteUser
+
-  E.on $ participant E.^. CourseParticipantUser E.==. user E.^. UserId
+userTableQuery :: UserTableWhere -> UserTableExpr
+   -> E.SqlQuery  ( E.SqlExpr (Entity User)
+                  , E.SqlExpr (E.Value UTCTime)
+                  , E.SqlExpr (E.Value (Maybe CourseUserNoteId)))
+userTableQuery whereClause t@((user `E.InnerJoin` participant) `E.LeftOuterJoin` note) = do
+  E.on $ (E.just $ participant E.^. CourseParticipantUser) E.==. note E.?. CourseUserNoteUser
+  E.on $           participant E.^. CourseParticipantUser  E.==. user E.^. UserId
   E.where_ $ whereClause t
-  return $ returnStatement t
+  return (user, participant E.^. CourseParticipantRegistration, note E.?. CourseUserNoteId)
-
-instance HasEntity UserTableData CourseParticipant where
-  hasEntity = _dbrOutput . _2
 
 instance HasEntity UserTableData User where
   hasEntity = _dbrOutput . _1
@@ -645,59 +648,71 @@ instance HasUser UserTableData where
   -- hasUser = _entityVal
   hasUser = _dbrOutput . _1 . _entityVal
 
+_userTableRegistration :: Lens' UserTableData UTCTime
+_userTableRegistration = _dbrOutput . _2 . _unValue
 
+-- FIXME: I am a prism due to maybe
+_userTableNote :: Lens' UserTableData (Maybe CourseUserNoteId)
+_userTableNote = _dbrOutput . _3 . _unValue
+
+-- default Where-Clause
 courseIs :: CourseId -> UserTableWhere
 courseIs cid ((_user `E.InnerJoin` participant) `E.LeftOuterJoin` _note) = participant E.^. CourseParticipantCourse E.==. E.val cid
 
--- TODO: delete commented function
--- colUserParticipant' :: IsDBTable m a => Colonnade _ UserTableData (DBCell m a)
--- colUserParticipant' = sortable (Just "participant") (i18nCell MsgCourseMember)
---     $ \DBRow { dbrOutput=(Entity _ user,_,_) } -> userCell (userDisplayName user) (userSurname user)
 
-
+colUserComment :: IsDBTable m a => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m a)
-colUserParticipant :: IsDBTable m a => Colonnade _ UserTableData (DBCell m a)
-colUserParticipant = sortable (Just "participant") (i18nCell MsgCourseMember) cellHasUser
-
-colUserParticipantLink :: IsDBTable m a => TermId -> SchoolId -> CourseShorthand -> Colonnade _ UserTableData (DBCell m a)
-colUserParticipantLink tid ssh csh = sortable (Just "participant") (i18nCell MsgCourseMember) (cellHasUserLink courseLink)
-  where
-    courseLink = CourseR tid ssh csh . CUserR
-
-colUserMatriclenr :: IsDBTable m a => Colonnade _ UserTableData (DBCell m a)
-colUserMatriclenr = sortable (Just "matriclenumber") (i18nCell MsgMatrikelNr) cellHasMatrikelnummer
-
-colUserComment :: IsDBTable m a => TermId -> SchoolId -> CourseShorthand -> Colonnade _ UserTableData (DBCell m a)
 colUserComment tid ssh csh =
     sortable (Just "course-user-note") (i18nCell MsgCourseUserNote)
-      $ \DBRow{ dbrOutput=(Entity uid _, _, mbNoteKey) } ->
+      $ \DBRow{ dbrOutput=(Entity uid _, _, E.Value mbNoteKey) } ->
         maybeEmpty mbNoteKey $ const $
           anchorCellM (courseLink <$> encrypt uid) (toWidget $ hasComment True)
   where
     courseLink = CourseR tid ssh csh . CUserR
 
-makeUserTable :: UserTableWhere -> _ -> _ -> DB Widget
+    --  makeCourseUserTable :: (ToSortable h, Functor h) =>
-makeUserTable _whereClause _colChoices _psValidator =
+    --                          UserTableWhere
-  -- do
+    --                          -> Colonnade
-  --   dbTable psValidator DBTable
+    --                               h
-  --     { userTableQUery whereClause
+    --                               (DBRow
-  --     ,
+    --                                  (Entity User, E.Value UTCTime,
-  return [whamlet| Course user table not yet implemented |]
+    --                                   E.Value (Maybe CourseUserNoteId)))
+    --                               (DBCell (HandlerT UniWorX IO) ())
+    --                          -> PSValidator (HandlerT UniWorX IO) ()
+    --                          -> ReaderT SqlBackend (HandlerT UniWorX IO) Widget
+
+makeCourseUserTable :: UserTableWhere -> _ -> _ -> DB Widget
+makeCourseUserTable whereClause colChoices psValidator =
+  -- return [whamlet|TODO|] -- TODO
+  -- -- psValidator has default sorting and filtering
+  let dbtIdent     = "courseUsers" :: Text
+      dbtStyle     = def
+      dbtSQLQuery  = userTableQuery whereClause
+      dbtRowKey    = (\((user `E.InnerJoin` _participant) `E.LeftOuterJoin` _note) -> user E.^. UserId)
+      dbtProj      = return -- . dbrOutput -- NOT SURE
+      dbtColonnade = colChoices
+      dbtSorting   = Map.fromList [] -- TODO
+      dbtFilter    = Map.fromList [] -- TODO
+      dbtFilterUI  = mempty -- TODO
+      dbtParams    = def
+  in dbTableWidget' psValidator DBTable{..}
 
 
 getCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 getCUsersR tid ssh csh = do
-  Entity _cid course <- runDB $ getBy404 $ TermSchoolCourseShort tid ssh csh
+  Entity cid course <- runDB $ getBy404 $ TermSchoolCourseShort tid ssh csh
-  let heading = [whamlet|_{MsgCourseMember} #{courseName course} #{display tid}|]
+  let heading = [whamlet|_{MsgMenuCourseMembers} #{courseName course} #{display tid}|]
-  --     whereClause = courseIs cid
+      whereClause = courseIs cid
-  --     colChoices  = [colUserParticipant,colUserMatriclenr,colUserComment tid ssh csh]
+      colChoices  = mconcat
-  --     psValidator = def
+        [ colUserParticipantLink tid ssh csh
-  -- tableWidget <- runDB $ makeUserTable whereClause colChoices psValidator
+        , colUserMatriclenr
+        -- ,colUserComment tid ssh csh
+        ]
+      psValidator = def
+  tableWidget <- runDB $ makeCourseUserTable whereClause colChoices psValidator
   siteLayout heading $ do
     setTitle [shamlet| #{toPathPiece tid} - #{csh}|]
-    [whamlet|
+    -- TODO: creat hamlet wrapper
-      User table not yet implemented
+    tableWidget
-      $# ^{tableWidget}
-     |]
 
 
 

src/Handler/Profile.hs

@@ -244,9 +244,9 @@ getProfileDataR = do
            <*> mkCorrectionsTable uid -- Tabelle mit allen Korrektor-Aufgaben
 
 
-  let examTable = [whamlet| Klausuren werden momentan leider noch nicht unterstützt.|]
+  let examTable        = [whamlet|Klausuren werden momentan leider noch nicht unterstützt.|]
   let ownTutorialTable = [whamlet|Übungsgruppen werden momentan leider noch nicht unterstützt.|]
-  let tutorialTable = [whamlet|Übungsgruppen werden momentan leider noch nicht unterstützt.|]
+  let tutorialTable    = [whamlet|Übungsgruppen werden momentan leider noch nicht unterstützt.|]
 
   -- Delete Button
   (btnWdgt, btnEnctype) <- generateFormPost (buttonForm :: Form ButtonDelete)

src/Handler/Utils/Table/Cells.hs

@@ -55,10 +55,10 @@ timeCell t = cell $ formatTime SelFormatDateTime t >>= toWidget
 userCell :: IsDBTable m a => Text -> Text -> DBCell m a
 userCell displayName surname = cell $ nameWidget displayName surname
 
-cellHasUser :: (IsDBTable m a, HasUser c) => c -> DBCell m a
+cellHasUser :: (IsDBTable m c, HasUser a) => a -> DBCell m c
 cellHasUser = liftA2 userCell (view _userDisplayName) (view _userSurname)
 
-cellHasUserLink :: (IsDBTable m a, HasEntity u User) => (CryptoUUIDUser -> Route UniWorX) -> u -> DBCell m a
+cellHasUserLink :: (IsDBTable m c, HasEntity u User) => (CryptoUUIDUser -> Route UniWorX) -> u -> DBCell m c
 -- cellHasUserLink toLink user =
 --   let uid   = user ^. hasEntityUser . _entityKey
 --       nWdgt = nameWidget (user ^. hasEntityUser . _entityVal . _userDisplayName) (user ^. hasEntityUser .  _entityVal . _userSurname)
@@ -149,3 +149,28 @@ correctorStateCell sc =
 correctorLoadCell :: IsDBTable m a => SheetCorrector -> DBCell m a
 correctorLoadCell sc =
   i18nCell $ sheetCorrectorLoad sc
+
+
+--------------------------------
+-- Generic Columns
+-- reuse encourages consistency
+--
+-- if it works out, turn into its own module
+-- together with filters and sorters
+
+
+-- | Does not work, since we have now show Instance for RenderMesage UniWorX msg
+colUser :: (IsDBTable m c, HasUser a, RenderMessage UniWorX msg, Show msg) => msg -> Colonnade Sortable a  (DBCell m c)
+colUser msg = sortable (Just $ fromString $ show msg) (i18nCell msg) cellHasUser
+
+colUserParticipant :: (IsDBTable m c, HasUser a) => Colonnade Sortable a  (DBCell m c)
+colUserParticipant = sortable (Just "participant") (i18nCell MsgCourseMembers) cellHasUser
+
+colUserMatriclenr ::  (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c)
+colUserMatriclenr = sortable (Just "matriclenumber") (i18nCell MsgMatrikelNr) cellHasMatrikelnummer
+
+colUserParticipantLink :: (IsDBTable m c, HasEntity a User) => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable a (DBCell m c)
+colUserParticipantLink tid ssh csh = sortable (Just "participant") (i18nCell MsgCourseMembers) (cellHasUserLink courseLink)
+  where
+    -- courseLink :: CryptoUUIDUser -> Route UniWorX
+    courseLink = CourseR tid ssh csh . CUserR