From 8dae9eb1d4101436b8b4eef29a9747a1d320314c Mon Sep 17 00:00:00 2001 From: SJost Date: Fri, 22 Feb 2019 18:24:21 +0100 Subject: [PATCH] Course member list stub working, after daylong painful birth throes --- messages/uniworx/de.msg | 3 +- src/Foundation.hs | 8 +++ src/Handler/Course.hs | 111 ++++++++++++++++++------------- src/Handler/Profile.hs | 4 +- src/Handler/Utils/Table/Cells.hs | 29 +++++++- 5 files changed, 102 insertions(+), 53 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 59e81077f..e9f008c79 100644 --- a/messages/uniworx/de.msg +++ b/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 diff --git a/src/Foundation.hs b/src/Foundation.hs index ac281aee2..84766c47e 100644 --- a/src/Foundation.hs +++ b/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 diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index cca75abd3..4c2de9249 100644 --- a/src/Handler/Course.hs +++ b/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 UserTableWhere = UserTableExpr -> E.SqlExpr (E.Value Bool) -type UserTableData = DBRow (Entity User, Entity CourseParticipant, Maybe (Key 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 UserTableData = DBRow (Entity User, E.Value UTCTime, E.Value (Maybe CourseUserNoteId)) -userTableQuery :: UserTableWhere -> (UserTableExpr -> v) -> UserTableExpr -> E.SqlQuery v -userTableQuery whereClause returnStatement t@((user `E.InnerJoin` participant) `E.LeftOuterJoin` note) = do - E.on $ participant E.^. CourseParticipantUser E.==. note E.^. CourseUserNoteUser - E.on $ participant E.^. CourseParticipantUser E.==. user E.^. UserId +forceUserTableType :: (UserTableExpr -> a) -> (UserTableExpr -> a) +forceUserTableType = id + +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 - -instance HasEntity UserTableData CourseParticipant where - hasEntity = _dbrOutput . _2 + return (user, participant E.^. CourseParticipantRegistration, note E.?. CourseUserNoteId) 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) - -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 :: IsDBTable m a => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable 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 -makeUserTable _whereClause _colChoices _psValidator = - -- do - -- dbTable psValidator DBTable - -- { userTableQUery whereClause - -- , - return [whamlet| Course user table not yet implemented |] + -- makeCourseUserTable :: (ToSortable h, Functor h) => + -- UserTableWhere + -- -> Colonnade + -- h + -- (DBRow + -- (Entity User, E.Value UTCTime, + -- 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 - let heading = [whamlet|_{MsgCourseMember} #{courseName course} #{display tid}|] - -- whereClause = courseIs cid - -- colChoices = [colUserParticipant,colUserMatriclenr,colUserComment tid ssh csh] - -- psValidator = def - -- tableWidget <- runDB $ makeUserTable whereClause colChoices psValidator + Entity cid course <- runDB $ getBy404 $ TermSchoolCourseShort tid ssh csh + let heading = [whamlet|_{MsgMenuCourseMembers} #{courseName course} #{display tid}|] + whereClause = courseIs cid + colChoices = mconcat + [ colUserParticipantLink tid ssh csh + , colUserMatriclenr + -- ,colUserComment tid ssh csh + ] + psValidator = def + tableWidget <- runDB $ makeCourseUserTable whereClause colChoices psValidator siteLayout heading $ do setTitle [shamlet| #{toPathPiece tid} - #{csh}|] - [whamlet| - User table not yet implemented - $# ^{tableWidget} - |] + -- TODO: creat hamlet wrapper + tableWidget diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 567c20a9d..6b5a7e237 100644 --- a/src/Handler/Profile.hs +++ b/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) diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index a8be16abf..c57adcdc3 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/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