diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index d161e3257..080cb2d22 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -633,7 +633,14 @@ userTableQuery whereClause returnStatement t@((user `E.InnerJoin` participant) ` return $ returnStatement t instance HasUser UserTableData where - hasUser = _dbrOutput . _1 . _entityVal + hasUser = _entityVal + +instance HasEntity UserTableData User where + hasEntity = _dbrOutput . _1 + +-- -- there can be only one -- FunctionalDependency violation +-- instance HasEntity UserTableData CourseParticipant where +-- hasEntity = _dbrOutput . _2 courseIs :: CourseId -> UserTableWhere courseIs cid ((_user `E.InnerJoin` participant) `E.LeftOuterJoin` _note) = participant E.^. CourseParticipantCourse E.==. E.val cid @@ -646,6 +653,11 @@ courseIs cid ((_user `E.InnerJoin` participant) `E.LeftOuterJoin` _note) = parti 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 diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 335150037..7196055a9 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -21,6 +21,11 @@ hijackUserForm cID csrf = do (btnResult, btnView) <- mreq (buttonField BtnHijack) "" Nothing return (() <$ uidResult <* btnResult, mconcat [toWidget csrf, fvInput uidView, fvInput btnView]) +-- In case of refactoring, use this: +-- instance HasEntity (DBRow (Entity User)) User where +-- hasEntity = _dbrOutput +-- instance HasUser (DBRow (Entity USer)) where +-- hasUser = _entityVal getUsersR :: Handler Html getUsersR = do diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 5406aeccd..453c04d9e 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -37,6 +37,12 @@ userCell displayName surname = cell $ nameWidget displayName surname cellHasUser :: (IsDBTable m a, HasUser c) => c -> DBCell m a cellHasUser = liftA2 userCell (view _userDisplayName) (view _userSurname) +cellHasUserLink :: (IsDBTable m a, HasEntity u User) => (CryptoUUIDUser -> Route UniWorX) -> u -> DBCell m a +cellHasUserLink toLink user = + let uid = user ^. _entityKey + nWdgt = nameWidget (user ^. _entityVal . _userDisplayName) (user ^. _entityVal . _userSurname) + in anchorCellM (toLink <$> encrypt uid) nWdgt + cellHasMatrikelnummer :: (IsDBTable m a, HasUser c) => c -> DBCell m a cellHasMatrikelnummer = maybe mempty textCell . view _userMatrikelnummer diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 1ef9e7f57..3fea6ff14 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -26,30 +26,35 @@ _InnerJoinRight :: Lens' (E.InnerJoin l r) r _InnerJoinRight f (E.InnerJoin l r) = (l `E.InnerJoin`) <$> f r -makeLenses_ ''Entity +-- makeLenses_ ''Entity +makeClassyFor_ "HasEntity" "hasEntity" ''Entity +-- class HasEntity c record | c -> record where +-- hasEntity :: Lens' c (Entity record) -- makeLenses_ ''Course makeClassyFor_ "HasCourse" "hasCourse" ''Course +-- class HasCourse c where +-- hasCourse :: Lens' c Course + +instance (HasCourse a) => HasCourse (Entity a) where + hasCourse = _entityVal . hasCourse makeClassyFor_ "HasUser" "hasUser" ''User -- > :info HasUser --- class HasUser c where --- {-# MINIMAL 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 +-- _user... +-- + +-- TODO: Is this instance needed? +instance (HasUser a) => HasUser (Entity a) where + hasUser = _entityVal . hasUser +-- This is what we would want instead: +-- instance (HasEntity a User) => HasUser a where +-- hasUser = _entityVal + makeLenses_ ''SheetCorrector