diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 3ec217f11..0e902650f 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 -CourseMembers: Teilnehmer +CourseMember: Teilnehmer CourseMembersCount num@Int64: #{display num} CourseMembersCountLimited num@Int64 max@Int64: #{display num}/#{display max} CourseName: Name @@ -88,6 +88,7 @@ CourseFilterSearch: Volltext-Suche CourseFilterRegistered: Registriert CourseDeleteQuestion: Wollen Sie den unten aufgeführten Kurs wirklich löschen? CourseDeleted: Kurs gelöscht +CourseUserNote: Notiz NoSuchTerm tid@TermId: Semester #{display tid} gibt es nicht. NoSuchSchool ssh@SchoolId: Institut #{display ssh} gibt es nicht. diff --git a/src/Foundation.hs b/src/Foundation.hs index 05f50b22c..b328221be 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1161,17 +1161,17 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the } , return MenuItem { menuItemType = NavbarAside - , menuItemLabel = MsgMenuCourseList - , menuItemIcon = Just "graduation-cap" - , menuItemRoute = SomeRoute CourseListR + , menuItemLabel = MsgMenuTermShow + , menuItemIcon = Just "calendar-alt" -- SJ wrote: calendar icon, since Term will be repleaced with TimeTable in the future; arguably Term is more calendar-like than courses anyway!!! + , menuItemRoute = SomeRoute TermShowR , menuItemModal = False , menuItemAccessCallback' = return True } , return MenuItem { menuItemType = NavbarAside - , menuItemLabel = MsgMenuTermShow - , menuItemIcon = Just "calendar-alt" -- SJ wrote: calendar icon, since Term will be repleaced with TimeTable in the future; arguably Term is more calendar-like than courses anyway!!! - , menuItemRoute = SomeRoute TermShowR + , menuItemLabel = MsgMenuCourseList + , menuItemIcon = Just "graduation-cap" + , menuItemRoute = SomeRoute CourseListR , menuItemModal = False , menuItemAccessCallback' = return True } diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 3401cf4de..d161e3257 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + module Handler.Course where import Import @@ -89,8 +91,8 @@ colRegTo = sortable (Just "register-to") (i18nCell MsgRegisterTo) $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } -> maybe mempty timeCell courseRegisterTo -colParticipants :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) -colParticipants = sortable (Just "participants") (i18nCell MsgCourseMembers) +colMembers :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) +colMembers = sortable (Just "members") (i18nCell MsgCourseMember) $ \DBRow{ dbrOutput=(Entity _ Course{..}, currentParticipants, _, _) } -> i18nCell $ case courseCapacity of Nothing -> MsgCourseMembersCount currentParticipants Just limit -> MsgCourseMembersCountLimited currentParticipants limit @@ -137,7 +139,7 @@ makeCourseTable whereClause colChoices psValidator = do , ( "schoolshort", SortColumn $ \(_course `E.InnerJoin` school) -> school E.^. SchoolShorthand) , ( "register-from", SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseRegisterFrom) , ( "register-to", SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseRegisterTo) - , ( "participants", SortColumn course2Participants ) + , ( "members", SortColumn course2Participants ) , ( "registered", SortColumn $ course2Registered muid) ] , dbtFilter = Map.fromList -- OverloadedLists does not work with the templates here @@ -221,7 +223,7 @@ getTermSchoolCourseListR tid ssh = do , colCShortDescr , colRegFrom , colRegTo - , colParticipants + , colMembers , maybe mempty (const colRegistered) muid ] whereClause (course, _, _) = @@ -245,7 +247,7 @@ getTermCourseListR tid = do , colSchoolShort , colRegFrom , colRegTo - , colParticipants + , colMembers , maybe mempty (const colRegistered) muid ] whereClause (course, _, _) = course E.^. CourseTerm E.==. E.val tid @@ -617,8 +619,69 @@ 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)) + +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 + E.where_ $ whereClause t + return $ returnStatement t + +instance HasUser UserTableData where + hasUser = _dbrOutput . _1 . _entityVal + +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 + +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) } -> + maybeEmpty mbNoteKey $ const $ + anchorCellM (encrypt uid >>= return . courseLink) (commentWidget 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 |] + + getCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html -getCUsersR = error "CUsersR: Not implemented" +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 + siteLayout heading $ do + setTitle [shamlet| #{toPathPiece tid} - #{csh}|] + [whamlet| + User table not yet implemented + $# ^{tableWidget} + |] + getCUserR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDUser -> Handler Html diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 403ad0131..335150037 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -22,14 +22,6 @@ hijackUserForm cID csrf = do return (() <$ uidResult <* btnResult, mconcat [toWidget csrf, fvInput uidView, fvInput btnView]) -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)) - --- 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 - getUsersR :: Handler Html getUsersR = do let diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 3ecc4b932..f899f2991 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -74,3 +74,8 @@ visibleWidget :: Bool -> Widget -- ^ @visibleWidget False@ is an icon that denotes that something™ is not visible visibleWidget True = mempty visibleWidget False = [whamlet||] + +commentWidget :: Bool -> Widget +-- ^ @commentWidget True@ is an icon that denotes that something™ has a comment +commentWidget True = [whamlet||] +commentWidget False = mempty diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index a164e9f96..5406aeccd 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -34,6 +34,12 @@ 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 = liftA2 userCell (view _userDisplayName) (view _userSurname) + +cellHasMatrikelnummer :: (IsDBTable m a, HasUser c) => c -> DBCell m a +cellHasMatrikelnummer = maybe mempty textCell . view _userMatrikelnummer + -- Just for documentation purposes; inline this code instead: maybeTimeCell :: IsDBTable m a => Maybe UTCTime -> DBCell m a maybeTimeCell = maybe mempty timeCell @@ -110,3 +116,10 @@ correctorStateCell sc = correctorLoadCell :: IsDBTable m a => SheetCorrector -> DBCell m a correctorLoadCell sc = i18nCell $ sheetCorrectorLoad sc + + +commentCell :: IsDBTable m a => Maybe (Route UniWorX) -> DBCell m a +commentCell Nothing = mempty +commentCell (Just link) = anchorCell link icon + where + icon = commentWidget True diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 5163d834c..1ef9e7f57 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -29,9 +29,28 @@ _InnerJoinRight f (E.InnerJoin l r) = (l `E.InnerJoin`) <$> f r makeLenses_ ''Entity -- makeLenses_ ''Course --- makeClassy_ ''Course makeClassyFor_ "HasCourse" "hasCourse" ''Course +makeClassyFor_ "HasUser" "hasUser" ''User +-- > :info HasUser +-- class HasUser c where +-- {-# MINIMAL hasUser #-}-- +-- hasUser :: Lens' c User +-- _userAuthentication :: Lens' c AuthenticationMode +-- _userDateFormat :: Lens' c DateTimeFormat +-- _userDateTimeFormat :: Lens' c DateTimeFormat +-- _userDisplayName :: Lens' c Text +-- _userDownloadFiles :: Lens' c Bool +-- _userEmail :: Lens' c (CI.Text) +-- _userIdent :: Lens' c (CI.Text) +-- _userMailLanguages :: Lens' c MailLanguages +-- _userMatrikelnummer :: Lens' c (Maybe Text) +-- _userMaxFavourites :: Lens' c Int +-- _userNotificationSettings :: Lens' c NotificationSettings +-- _userSurname :: Lens' c Text +-- _userTheme :: Lens' c Theme +-- _userTimeFormat :: Lens' c DateTimeFormat + makeLenses_ ''SheetCorrector makeLenses_ ''SubmissionGroup diff --git a/src/index.md b/src/index.md index f2b0b8adf..17798d0df 100644 --- a/src/index.md +++ b/src/index.md @@ -1,3 +1,5 @@ +# Datei Index + Database,Esqueleto.* : Hilfsdefinitionen, welche Esqueleto anbieten könnte