Course member list stub working, after daylong painful birth throes
This commit is contained in:
SJost
parent
d1c0b67627
commit
8dae9eb1d4
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user