From 5cd8827b99cf1183f71a65c83aba18f91d3862d8 Mon Sep 17 00:00:00 2001 From: SJost Date: Thu, 21 Feb 2019 12:22:29 +0100 Subject: [PATCH 01/12] No change, just trying to build --- routes | 1 - 1 file changed, 1 deletion(-) diff --git a/routes b/routes index 994822a7b..1a9f35659 100644 --- a/routes +++ b/routes @@ -47,7 +47,6 @@ /impressum ImpressumR GET !free /version VersionR GET !free - /help HelpR GET POST !free /user ProfileR GET POST !free From 479f109447169ed056793e8a95e3c16c5cb11940 Mon Sep 17 00:00:00 2001 From: SJost Date: Thu, 21 Feb 2019 14:07:03 +0100 Subject: [PATCH 02/12] Trying to fix unusual and new haddock --- src/Database/Esqueleto/Utils.hs | 10 +++++----- src/Utils/Lens/TH.hs | 5 +++-- templates/adminUser.hamlet | 2 ++ templates/data-protection-de.hamlet | 4 ++-- 4 files changed, 12 insertions(+), 9 deletions(-) diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 9e78f9fd0..41464cc00 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -5,11 +5,11 @@ import Data.Foldable as F import Database.Esqueleto as E -{-| - Description : Convenience for using @Esqueleto@, - intended to be imported qualified - just like Esqueleto --} +-- +-- Description : Convenience for using @Esqueleto@, +-- intended to be imported qualified +-- just like Esqueleto + -- ezero = E.val (0 :: Int64) diff --git a/src/Utils/Lens/TH.hs b/src/Utils/Lens/TH.hs index dffbf10c0..d65e58672 100644 --- a/src/Utils/Lens/TH.hs +++ b/src/Utils/Lens/TH.hs @@ -6,7 +6,8 @@ import Control.Lens.Internal.FieldTH import Language.Haskell.TH -- import Control.Lens.Misc -{- NOTE: The code for lensRules_ and makeLenses_ was stolen from package lens-misc-0.0.2.0, +{- + NOTE: The code for lensRules_ and makeLenses_ was stolen from package lens-misc-0.0.2.0, which was currently unavailable in our stack snapshot. See https://github.com/louispan/lens-misc -} @@ -59,5 +60,5 @@ makeClassyFor_ :: String -> String -> Name -> DecsQ makeClassyFor_ clsName funName = makeFieldOptics (classyRulesFor_ clNamer) where clNamer :: ClassyNamer - -- clNamer _ = Just (clsName, funName) -- for newer versions >= 4.17 + -- clNamer _ = Just (clsName, funName) {- for newer versions >= 4.17 =} clNamer _ = Just (mkName clsName, mkName funName) \ No newline at end of file diff --git a/templates/adminUser.hamlet b/templates/adminUser.hamlet index 30d7961f5..5909795a5 100644 --- a/templates/adminUser.hamlet +++ b/templates/adminUser.hamlet @@ -1,3 +1,5 @@ +

+ #{userEmail}

^{formWidget} ^{submitButtonView} diff --git a/templates/data-protection-de.hamlet b/templates/data-protection-de.hamlet index 04e775a99..73fae7c7b 100644 --- a/templates/data-protection-de.hamlet +++ b/templates/data-protection-de.hamlet @@ -1,7 +1,7 @@
-

Stand -

Version 0.91 vom 22.5.2018 +$#

Stand +$#

Version 0.91 vom 22.5.2018

Die LMU unterliegt als Körperschaft des öffentlichen Rechts dem bayerischen Datenschutzgesetz, in einigen Bereichen dem Bundesdatenschutzgesetz, From 2550f7405618a7ef8df16ab149cbff2447963d3c Mon Sep 17 00:00:00 2001 From: SJost Date: Thu, 21 Feb 2019 14:53:45 +0100 Subject: [PATCH 03/12] TEST: removing makeCLassyFor maybe build works then? --- src/Handler/Course.hs | 28 +++++++++++++++------------- src/Handler/Utils/Table/Cells.hs | 19 ++++++++++--------- src/Utils/Lens.hs | 25 +++++++++++++------------ src/Utils/Lens/TH.hs | 4 ++-- 4 files changed, 40 insertions(+), 36 deletions(-) diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index e7cf7276b..bfa554762 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -632,11 +632,12 @@ userTableQuery whereClause returnStatement t@((user `E.InnerJoin` participant) ` E.where_ $ whereClause t return $ returnStatement t -instance HasUser UserTableData where - hasUser = _entityVal - -instance HasEntity UserTableData User where - hasEntity = _dbrOutput . _1 +-- TEST HADDOCK +-- instance HasUser UserTableData where +-- hasUser = _entityVal +-- +-- instance HasEntity UserTableData User where +-- hasEntity = _dbrOutput . _1 -- -- there can be only one -- FunctionalDependency violation -- instance HasEntity UserTableData CourseParticipant where @@ -650,16 +651,17 @@ courseIs cid ((_user `E.InnerJoin` participant) `E.LeftOuterJoin` _note) = parti -- 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 +-- TEST HADDOCK +-- 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 +-- 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 +-- 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 = diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 453c04d9e..a2b4ec387 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -34,17 +34,18 @@ 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) +-- TEST HADDOCK +-- 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 +-- 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 +-- 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 diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 3fea6ff14..42b844180 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -25,32 +25,33 @@ _InnerJoinLeft f (E.InnerJoin l r) = (`E.InnerJoin` r) <$> f l _InnerJoinRight :: Lens' (E.InnerJoin l r) r _InnerJoinRight f (E.InnerJoin l r) = (l `E.InnerJoin`) <$> f r - --- makeLenses_ ''Entity -makeClassyFor_ "HasEntity" "hasEntity" ''Entity +-- TEST HADDOCK +makeLenses_ ''Entity +-- makeClassyFor_ "HasEntity" "hasEntity" ''Entity -- class HasEntity c record | c -> record where -- hasEntity :: Lens' c (Entity record) --- makeLenses_ ''Course -makeClassyFor_ "HasCourse" "hasCourse" ''Course +makeLenses_ ''Course +-- makeClassyFor_ "HasCourse" "hasCourse" ''Course -- class HasCourse c where -- hasCourse :: Lens' c Course -instance (HasCourse a) => HasCourse (Entity a) where - hasCourse = _entityVal . hasCourse +-- instance (HasCourse a) => HasCourse (Entity a) where + -- hasCourse = _entityVal . hasCourse -makeClassyFor_ "HasUser" "hasUser" ''User +makeLenses_ ''User +-- makeClassyFor_ "HasUser" "hasUser" ''User -- > :info HasUser --- class HasUser c where {-# MINIMAL hasUser #-} --- hasUser :: Lens' c User +-- class HasUser c where +-- hasUser :: Lens' c User -- MINIMAL -- _userDisplayName :: Lens' c Text -- _userSurname :: Lens' c Text -- _user... -- -- TODO: Is this instance needed? -instance (HasUser a) => HasUser (Entity a) where - hasUser = _entityVal . hasUser +-- 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 diff --git a/src/Utils/Lens/TH.hs b/src/Utils/Lens/TH.hs index d65e58672..b8d8857a7 100644 --- a/src/Utils/Lens/TH.hs +++ b/src/Utils/Lens/TH.hs @@ -17,7 +17,7 @@ lensRules_ :: LensRules lensRules_ = lensRules & lensField .~ \_ _ n -> [TopName (mkName ('_':nameBase n))] --- | Like lensRules_, but different class and function name +-- | Like @lensRules_@, but different class and function name classyRulesFor_ :: ClassyNamer -> LensRules classyRulesFor_ clsNamer = classyRules & lensClass .~ clsNamer @@ -60,5 +60,5 @@ makeClassyFor_ :: String -> String -> Name -> DecsQ makeClassyFor_ clsName funName = makeFieldOptics (classyRulesFor_ clNamer) where clNamer :: ClassyNamer - -- clNamer _ = Just (clsName, funName) {- for newer versions >= 4.17 =} + -- clNamer _ = Just (clsName, funName) -- for newer versions >= 4.17 clNamer _ = Just (mkName clsName, mkName funName) \ No newline at end of file From 29189bf8f80ce6ef8d2e05949470a05bd64100a7 Mon Sep 17 00:00:00 2001 From: SJost Date: Thu, 21 Feb 2019 15:27:39 +0100 Subject: [PATCH 04/12] Partial revert of commit 2550f740 to determine error source --- src/Utils/Lens.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 42b844180..2d94ac57b 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -25,22 +25,22 @@ _InnerJoinLeft f (E.InnerJoin l r) = (`E.InnerJoin` r) <$> f l _InnerJoinRight :: Lens' (E.InnerJoin l r) r _InnerJoinRight f (E.InnerJoin l r) = (l `E.InnerJoin`) <$> f r --- TEST HADDOCK -makeLenses_ ''Entity --- makeClassyFor_ "HasEntity" "hasEntity" ''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 +-- makeLenses_ ''Course +makeClassyFor_ "HasCourse" "hasCourse" ''Course -- class HasCourse c where -- hasCourse :: Lens' c Course -- instance (HasCourse a) => HasCourse (Entity a) where -- hasCourse = _entityVal . hasCourse -makeLenses_ ''User --- makeClassyFor_ "HasUser" "hasUser" ''User +-- makeLenses_ ''User +makeClassyFor_ "HasUser" "hasUser" ''User -- > :info HasUser -- class HasUser c where -- hasUser :: Lens' c User -- MINIMAL From e58e33e47ff7d1dd027cfb429139d1e7636472c9 Mon Sep 17 00:00:00 2001 From: SJost Date: Thu, 21 Feb 2019 15:37:40 +0100 Subject: [PATCH 05/12] Minor bugfix: QueueNotfication for UserRightsUpdate --- src/Jobs/Handler/QueueNotification.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Jobs/Handler/QueueNotification.hs b/src/Jobs/Handler/QueueNotification.hs index 5dfdc20fa..3d226f72a 100644 --- a/src/Jobs/Handler/QueueNotification.hs +++ b/src/Jobs/Handler/QueueNotification.hs @@ -4,7 +4,7 @@ module Jobs.Handler.QueueNotification import Import hiding ((\\)) -import Data.List ((\\)) +import Data.List (nub, (\\)) import Jobs.Types @@ -67,7 +67,7 @@ determineNotificationCandidates NotificationUserRightsUpdate{..} E.on $ admin E.^. UserAdminUser E.==. user E.^. UserId E.where_ $ admin E.^. UserAdminSchool `E.in_` E.valList newAdminSchools return user - return $ affectedUser <> affectedAdmins + return $ nub $ affectedUser <> affectedAdmins classifyNotification :: Notification -> DB NotificationTrigger From b1231978cc20324f65f9df94427f61f02458f57d Mon Sep 17 00:00:00 2001 From: SJost Date: Thu, 21 Feb 2019 15:41:38 +0100 Subject: [PATCH 06/12] Test Problem with makeClassy: just using one now --- src/Utils/Lens.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 2d94ac57b..500f6329f 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -26,13 +26,13 @@ _InnerJoinRight :: Lens' (E.InnerJoin l r) r _InnerJoinRight f (E.InnerJoin l r) = (l `E.InnerJoin`) <$> f r --- makeLenses_ ''Entity -makeClassyFor_ "HasEntity" "hasEntity" ''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 +makeLenses_ ''Course +-- makeClassyFor_ "HasCourse" "hasCourse" ''Course -- class HasCourse c where -- hasCourse :: Lens' c Course From e74555c40b1e857122826d888d91fa23bbdafb13 Mon Sep 17 00:00:00 2001 From: SJost Date: Thu, 21 Feb 2019 15:55:12 +0100 Subject: [PATCH 07/12] TEST Build-Error: one more makeClassy --- src/Utils/Lens.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 500f6329f..b8924a19a 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -26,8 +26,8 @@ _InnerJoinRight :: Lens' (E.InnerJoin l r) r _InnerJoinRight f (E.InnerJoin l r) = (l `E.InnerJoin`) <$> f r -makeLenses_ ''Entity --- makeClassyFor_ "HasEntity" "hasEntity" ''Entity +-- makeLenses_ ''Entity +makeClassyFor_ "HasEntity" "hasEntity" ''Entity -- class HasEntity c record | c -> record where -- hasEntity :: Lens' c (Entity record) From bb552c472f97a4de5b4b396f3851fa41c2c2cb21 Mon Sep 17 00:00:00 2001 From: SJost Date: Thu, 21 Feb 2019 16:11:04 +0100 Subject: [PATCH 08/12] TEST: Does ist build with everything except for `makeClassy ''Entity`? Probably the functional dependency is to blame?! --- src/Handler/Course.hs | 19 ++++++++++--------- src/Handler/Utils/Table/Cells.hs | 9 ++++----- src/Utils/Lens.hs | 4 ++-- 3 files changed, 16 insertions(+), 16 deletions(-) diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index bfa554762..fe31596d1 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -632,10 +632,11 @@ userTableQuery whereClause returnStatement t@((user `E.InnerJoin` participant) ` E.where_ $ whereClause t return $ returnStatement t --- TEST HADDOCK --- instance HasUser UserTableData where --- hasUser = _entityVal --- +instance HasUser UserTableData where + -- hasUser = _entityVal + hasUser = _dbrOutput . _1 . _entityVal + + -- TEST HADDOCK -- instance HasEntity UserTableData User where -- hasEntity = _dbrOutput . _1 @@ -651,17 +652,17 @@ courseIs cid ((_user `E.InnerJoin` participant) `E.LeftOuterJoin` _note) = parti -- colUserParticipant' = sortable (Just "participant") (i18nCell MsgCourseMember) -- $ \DBRow { dbrOutput=(Entity _ user,_,_) } -> userCell (userDisplayName user) (userSurname user) --- TEST HADDOCK --- colUserParticipant :: IsDBTable m a => Colonnade _ UserTableData (DBCell m a) --- colUserParticipant = sortable (Just "participant") (i18nCell MsgCourseMember) cellHasUser + +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 +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 = diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index a2b4ec387..e4de18458 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -34,9 +34,8 @@ timeCell t = cell $ formatTime SelFormatDateTime t >>= toWidget userCell :: IsDBTable m a => Text -> Text -> DBCell m a userCell displayName surname = cell $ nameWidget displayName surname --- TEST HADDOCK --- cellHasUser :: (IsDBTable m a, HasUser c) => c -> DBCell m a --- cellHasUser = liftA2 userCell (view _userDisplayName) (view _userSurname) +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 = @@ -44,8 +43,8 @@ userCell displayName surname = cell $ nameWidget displayName surname -- 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 +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 diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index b8924a19a..500f6329f 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -26,8 +26,8 @@ _InnerJoinRight :: Lens' (E.InnerJoin l r) r _InnerJoinRight f (E.InnerJoin l r) = (l `E.InnerJoin`) <$> f r --- makeLenses_ ''Entity -makeClassyFor_ "HasEntity" "hasEntity" ''Entity +makeLenses_ ''Entity +-- makeClassyFor_ "HasEntity" "hasEntity" ''Entity -- class HasEntity c record | c -> record where -- hasEntity :: Lens' c (Entity record) From 89e6b171078135932714883a44c5a7e769a432f6 Mon Sep 17 00:00:00 2001 From: SJost Date: Thu, 21 Feb 2019 16:47:42 +0100 Subject: [PATCH 09/12] Build problem determined: crashes Haddock. Added similar Class manually. --- src/Handler/Course.hs | 11 +++++------ src/Handler/Utils/Table/Cells.hs | 13 ++++++++----- src/Utils/Lens.hs | 9 +++++++-- 3 files changed, 20 insertions(+), 13 deletions(-) diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index fe31596d1..76d2d6a11 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -636,13 +636,12 @@ instance HasUser UserTableData where -- hasUser = _entityVal hasUser = _dbrOutput . _1 . _entityVal - -- TEST HADDOCK --- instance HasEntity UserTableData User where --- hasEntity = _dbrOutput . _1 +instance HasEntity UserTableData User where + hasEntity = _dbrOutput . _1 --- -- there can be only one -- FunctionalDependency violation --- instance HasEntity UserTableData CourseParticipant where --- hasEntity = _dbrOutput . _2 +-- there can be only one due to FunctionalDependency violation if we use MakeClassy on Entity +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 diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index e4de18458..0074ce3cc 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -37,11 +37,14 @@ 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 +cellHasUserLink :: (IsDBTable m a, HasEntity u User) => (CryptoUUIDUser -> Route UniWorX) -> u -> DBCell m a +cellHasUserLink toLink user = + let userEntity :: Entity User -- needed without the functional dependency + userEntity = user ^. hasEntity + uid = userEntity ^. _entityKey + nWdgt = nameWidget (userEntity ^. _entityVal . _userDisplayName) (userEntity ^. _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 500f6329f..514679daf 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -27,12 +27,17 @@ _InnerJoinRight f (E.InnerJoin l r) = (l `E.InnerJoin`) <$> f r makeLenses_ ''Entity +-- BUILD SERVER FAILS TO MAKE HADDOCK FOR THE ONE BELOW: -- makeClassyFor_ "HasEntity" "hasEntity" ''Entity -- class HasEntity c record | c -> record where -- hasEntity :: Lens' c (Entity record) +-- +-- Manual attempt, leaving out the unwanted functional dependency +class HasEntity c record where + hasEntity :: Lens' c (Entity record) -makeLenses_ ''Course --- makeClassyFor_ "HasCourse" "hasCourse" ''Course +-- makeLenses_ ''Course +makeClassyFor_ "HasCourse" "hasCourse" ''Course -- class HasCourse c where -- hasCourse :: Lens' c Course From 7d72086fd9fff80a0687b0b6fc33923d8ad3fe9a Mon Sep 17 00:00:00 2001 From: SJost Date: Thu, 21 Feb 2019 19:55:38 +0100 Subject: [PATCH 10/12] minor refactor --- src/Handler/Course.hs | 20 ++++++++-------- src/Handler/Utils/Table/Cells.hs | 7 ++++-- src/Utils/Lens.hs | 40 +++++++++++++++++++------------- 3 files changed, 39 insertions(+), 28 deletions(-) diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 76d2d6a11..2c2690b23 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -632,16 +632,16 @@ userTableQuery whereClause returnStatement t@((user `E.InnerJoin` participant) ` E.where_ $ whereClause t return $ returnStatement t -instance HasUser UserTableData where - -- hasUser = _entityVal - hasUser = _dbrOutput . _1 . _entityVal +instance HasEntity UserTableData CourseParticipant where + hasEntity = _dbrOutput . _2 instance HasEntity UserTableData User where hasEntity = _dbrOutput . _1 --- there can be only one due to FunctionalDependency violation if we use MakeClassy on Entity -instance HasEntity UserTableData CourseParticipant where - hasEntity = _dbrOutput . _2 +instance HasUser UserTableData where + -- hasUser = _entityVal + hasUser = _dbrOutput . _1 . _entityVal + courseIs :: CourseId -> UserTableWhere courseIs cid ((_user `E.InnerJoin` participant) `E.LeftOuterJoin` _note) = participant E.^. CourseParticipantCourse E.==. E.val cid @@ -655,10 +655,10 @@ 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 +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/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 0074ce3cc..802ae21a2 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -38,9 +38,12 @@ 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 ^. hasEntityUser . _entityKey +-- nWdgt = nameWidget (user ^. hasEntityUser . _entityVal . _userDisplayName) (user ^. hasEntityUser . _entityVal . _userSurname) +-- in anchorCellM (toLink <$> encrypt uid) nWdgt cellHasUserLink toLink user = - let userEntity :: Entity User -- needed without the functional dependency - userEntity = user ^. hasEntity + let userEntity = user ^. hasEntityUser uid = userEntity ^. _entityKey nWdgt = nameWidget (userEntity ^. _entityVal . _userDisplayName) (userEntity ^. _entityVal . _userSurname) in anchorCellM (toLink <$> encrypt uid) nWdgt diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 514679daf..b8ac05e63 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -26,23 +26,15 @@ _InnerJoinRight :: Lens' (E.InnerJoin l r) r _InnerJoinRight f (E.InnerJoin l r) = (l `E.InnerJoin`) <$> f r -makeLenses_ ''Entity --- BUILD SERVER FAILS TO MAKE HADDOCK FOR THE ONE BELOW: --- makeClassyFor_ "HasEntity" "hasEntity" ''Entity --- class HasEntity c record | c -> record where --- hasEntity :: Lens' c (Entity record) --- --- Manual attempt, leaving out the unwanted functional dependency -class HasEntity c record where - hasEntity :: Lens' c (Entity record) +----------------------------------- +-- Lens Definitions for our Types + -- makeLenses_ ''Course makeClassyFor_ "HasCourse" "hasCourse" ''Course -- class HasCourse c where -- hasCourse :: Lens' c Course --- instance (HasCourse a) => HasCourse (Entity a) where - -- hasCourse = _entityVal . hasCourse -- makeLenses_ ''User makeClassyFor_ "HasUser" "hasUser" ''User @@ -54,12 +46,28 @@ makeClassyFor_ "HasUser" "hasUser" ''User -- _user... -- --- TODO: Is this instance needed? --- instance (HasUser a) => HasUser (Entity a) where - -- hasUser = _entityVal . hasUser --- This is what we would want instead: + +makeLenses_ ''Entity +-- BUILD SERVER FAILS TO MAKE HADDOCK FOR THE ONE BELOW: +-- makeClassyFor_ "HasEntity" "hasEntity" ''Entity +-- class HasEntity c record | c -> record where +-- hasEntity :: Lens' c (Entity record) +-- +-- Manual definition, explicitely leaving out the unwanted Functional Dependency, since we want Instances differing on the result-type +class HasEntity c record where + hasEntity :: Lens' c (Entity record) + +-- Typed convenience to avoid type signatures, due to the missing FunctionalDepenency that we do not want. +hasEntityUser :: (HasEntity a User) => Lens' a (Entity User) +hasEntityUser = hasEntity + +-- This is what we would want, but is an UndecidableInstance since the type is not reduced: -- instance (HasEntity a User) => HasUser a where --- hasUser = _entityVal +-- hasUser = hasEntityUser +-- +-- Possible, but rather useless: +-- instance (HasUser a) => HasUser (Entity a) where +-- hasUser = _entityVal . hasUser makeLenses_ ''SheetCorrector From f869876e1211f85e099ec35cf391766dce30ad46 Mon Sep 17 00:00:00 2001 From: SJost Date: Thu, 21 Feb 2019 22:08:49 +0100 Subject: [PATCH 11/12] Towards #303 --- src/Handler/Course.hs | 7 ++++--- src/Handler/Utils.hs | 6 ++++++ test/Database.hs | 4 ++-- 3 files changed, 12 insertions(+), 5 deletions(-) diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 2c2690b23..99c242802 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -40,11 +40,11 @@ colCourseDescr = sortable (Just "course") (i18nCell MsgCourse) $ do return $ courseCell course colDescription :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) -colDescription = sortable Nothing (i18nCell MsgCourseDescription) +colDescription = sortable Nothing mempty $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } -> case courseDescription of Nothing -> mempty - (Just descr) -> cell $ modal "Beschreibung" (Right $ toWidget descr) + (Just descr) -> cell $ modal (commentWidget True) (Right $ toWidget descr) colCShort :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colCShort = sortable (Just "cshort") (i18nCell MsgCourseShort) @@ -190,7 +190,8 @@ getCourseListR :: Handler Html getCourseListR = do muid <- maybeAuthId let colonnade = widgetColonnade $ mconcat - [ colCourseDescr + [ colCourse -- colCourseDescr + , colDescription , colSchoolShort , colTerm , colCShort diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index f899f2991..e45890f58 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -75,6 +75,12 @@ visibleWidget :: Bool -> Widget visibleWidget True = mempty visibleWidget False = [whamlet||] +isVisibleWidget :: Bool -> Widget +-- ^ @visibleWidget True@ is an icon that denotes that something™ is visible +isVisibleWidget True = [whamlet||] +isVisibleWidget False = mempty + + commentWidget :: Bool -> Widget -- ^ @commentWidget True@ is an icon that denotes that something™ has a comment commentWidget True = [whamlet||] diff --git a/test/Database.hs b/test/Database.hs index 2fc8a7dc5..8cecdb70e 100755 --- a/test/Database.hs +++ b/test/Database.hs @@ -220,7 +220,7 @@ fillDb = do -- FFP ffp <- insert' Course { courseName = "Fortgeschrittene Funktionale Programmierung" - , courseDescription = Nothing + , courseDescription = Just "

It is fun!

Come to where the functional is!" , courseLinkExternal = Nothing , courseShorthand = "FFP" , courseTerm = TermKey summer2018 @@ -354,7 +354,7 @@ fillDb = do -- datenbanksysteme dbs <- insert' Course { courseName = "Datenbanksysteme" - , courseDescription = Nothing + , courseDescription = Just "Datenbanken banken Daten damit die Daten nicht wanken. Die Datenschützer danken!" , courseLinkExternal = Nothing , courseShorthand = "DBS" , courseTerm = TermKey summer2018 From 68d36b2fe0687faf7a3bbf1c76cecf65fda5455b Mon Sep 17 00:00:00 2001 From: SJost Date: Fri, 22 Feb 2019 07:47:20 +0100 Subject: [PATCH 12/12] Course description as icon complete --- src/Handler/Course.hs | 40 +++++++++++++++++++++------------------- test/Database.hs | 15 ++++++++++++++- 2 files changed, 35 insertions(+), 20 deletions(-) diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 99c242802..eb0936540 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -34,10 +34,10 @@ colCourse = sortable (Just "course") (i18nCell MsgCourse) anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseName}|] -colCourseDescr :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) -colCourseDescr = sortable (Just "course") (i18nCell MsgCourse) $ do - course <- view $ _dbrOutput . _1 . _entityVal - return $ courseCell course +-- colCourseDescr :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) +-- colCourseDescr = sortable (Just "course") (i18nCell MsgCourse) $ do +-- course <- view $ _dbrOutput . _1 . _entityVal +-- return $ courseCell course colDescription :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) colDescription = sortable Nothing mempty @@ -51,19 +51,19 @@ colCShort = sortable (Just "cshort") (i18nCell MsgCourseShort) $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } -> anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseShorthand}|] -colCShortDescr :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) -colCShortDescr = sortable (Just "cshort") (i18nCell MsgCourseShort) - $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } -> mappend - ( anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseShorthand}|] ) - ( case courseDescription of - Nothing -> mempty - (Just descr) -> cell - [whamlet| - $newline never -
- ^{modal "Beschreibung" (Right $ toWidget descr)} - |] - ) +-- colCShortDescr :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) +-- colCShortDescr = sortable (Just "cshort") (i18nCell MsgCourseShort) +-- $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } -> mappend +-- ( anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseShorthand}|] ) +-- ( case courseDescription of +-- Nothing -> mempty +-- (Just descr) -> cell +-- [whamlet| +-- $newline never +--
+-- ^{modal "Beschreibung" (Right $ toWidget descr)} +-- |] +-- ) colTerm :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colTerm = sortable (Just "term") (i18nCell MsgTerm) @@ -221,7 +221,8 @@ getTermSchoolCourseListR tid ssh = do muid <- maybeAuthId let colonnade = widgetColonnade $ mconcat [ dbRow - , colCShortDescr + , colCShort + , colDescription , colRegFrom , colRegTo , colMembers @@ -244,7 +245,8 @@ getTermCourseListR tid = do muid <- maybeAuthId let colonnade = widgetColonnade $ mconcat [ dbRow - , colCShortDescr + , colCShort + , colDescription , colSchoolShort , colRegFrom , colRegTo diff --git a/test/Database.hs b/test/Database.hs index 8cecdb70e..69ef0a541 100755 --- a/test/Database.hs +++ b/test/Database.hs @@ -218,9 +218,22 @@ fillDb = do repsert sdInf $ StudyTerms 79 (Just "IfI") (Just "Institut für Informatik") repsert sdMath $ StudyTerms 105 (Just "MI" ) (Just "Mathematisches Institut") -- FFP + let nbrs :: [Int] + nbrs = [1,2,3,27,7,1] ffp <- insert' Course { courseName = "Fortgeschrittene Funktionale Programmierung" - , courseDescription = Just "

It is fun!

Come to where the functional is!" + , courseDescription = Just [shamlet| +

It is fun! +

Come to where the functional is! +

+

Functional programming can be done in Haskell! +

This is not a joke, this is serious! +

+

Consider some numbers +
    + $forall n <- nbrs +
  • Number #{n} + |] , courseLinkExternal = Nothing , courseShorthand = "FFP" , courseTerm = TermKey summer2018