Steps towards #126, compiling but incomplete

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.

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
       }

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

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

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|<i .fas .fa-eye-slash>|]
+
+commentWidget :: Bool -> Widget
+-- ^ @commentWidget True@ is an icon that denotes that something™ has a comment
+commentWidget True  = [whamlet|<i .fas .fa-comment-alt>|]
+commentWidget False = mempty

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

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

src/index.md

@@ -1,3 +1,5 @@
+# Datei Index
+
 Database,Esqueleto.*
   : Hilfsdefinitionen, welche Esqueleto anbieten könnte