Courses are Classy now "HasCourse" with "hasCourse"

routes

@@ -10,22 +10,23 @@
 --  Admins always have access to entities within their assigned schools.
 --
 --  Access Tags:
---    !free        -- free for all
+--    !free           -- free for all
---    !lecturer    -- lecturer    for this course (or for any school, if route is not connected to a course)
+--    !lecturer       -- lecturer    for this course (or for any school, if route is not connected to a course)
---    !corrector   -- corrector   for this sheet  (or the submission, if route is connected to a submission, or the course, if route is not connected to a sheet, or any course, if route is not connected to a course)
+--    !corrector      -- corrector   for this sheet  (or the submission, if route is connected to a submission, or the course, if route is not connected to a sheet, or any course, if route is not connected to a course)
---    !registered  -- participant for this course (no effect outside of courses)
+--    !registered     -- participant for this course (no effect outside of courses)
---    !participant -- connected with a given course (not necessarily registered), i.e. has a submission, is a corrector, etc. (no effect outside of courses)
+--    !participant    -- connected with a given course (not necessarily registered), i.e. has a submission, is a corrector, etc. (no effect outside of courses)
---    !owner       -- part of the group of owners of this submission
+--    !owner          -- part of the group of owners of this submission
---    !capacity    -- course this route is associated with has at least one unit of participant capacity
+--    !capacity       -- course this route is associated with has at least one unit of participant capacity
---    !empty       -- course this route is associated with has no participants whatsoever
+--    !empty          -- course this route is associated with has no participants whatsoever
 --
---    !materials   -- only if course allows all materials to be free (no meaning outside of courses)
+--    !materials      -- only if course allows all materials to be free (no meaning outside of courses)
---    !time        -- access depends on time somehow
+--    !time           -- access depends on time somehow
---    !read        -- only if it is read-only access (i.e. GET but not POST)
+--    !read           -- only if it is read-only access (i.e. GET but not POST)
---    !write       -- only if it is write access     (i.e. POST only, included for completeness)
+--    !write          -- only if it is write access     (i.e. POST only, included for completeness)
 --
---    !deprecated  -- like free, but logs and gives a warning; entirely disabled in production
+--    !no-escalation  --
---    !development -- like free, but only for development builds
+--    !deprecated     -- like free, but logs and gives a warning; entirely disabled in production
+--    !development    -- like free, but only for development builds
 
 /static StaticR EmbeddedStatic appStatic                      !free
 /auth   AuthR   Auth   getAuth                                !free

src/Handler/Users.hs

@@ -19,9 +19,17 @@ hijackUserForm :: CryptoUUIDUser -> Form ()
 hijackUserForm cID csrf = do
   (uidResult, uidView) <- mforced hiddenField "" (cID :: CryptoUUIDUser)
   (btnResult, btnView) <- mreq (buttonField BtnHijack) "" Nothing
-
   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/Utils/Lens.hs

@@ -3,7 +3,7 @@ module Utils.Lens ( module Utils.Lens ) where
 import Import.NoFoundation
 import Control.Lens as Utils.Lens hiding ((<.>))
 import Control.Lens.Extras as Utils.Lens (is)
-import Utils.Lens.TH as Utils.Lens (makeLenses_)
+import Utils.Lens.TH as Utils.Lens (makeLenses_, makeClassyFor_)
 
 import qualified Database.Esqueleto as E (Value(..),InnerJoin(..))
 
@@ -28,7 +28,9 @@ _InnerJoinRight f (E.InnerJoin l r) = (l `E.InnerJoin`) <$> f r
 
 makeLenses_ ''Entity
 
-makeLenses_ ''Course
+-- makeLenses_ ''Course
+-- makeClassy_ ''Course
+makeClassyFor_ "HasCourse" "hasCourse" ''Course
 
 makeLenses_ ''SheetCorrector
 

src/Utils/Lens/TH.hs

@@ -1,5 +1,6 @@
 module Utils.Lens.TH where
 
+import ClassyPrelude (String, Maybe(..))
 import Control.Lens
 import Control.Lens.Internal.FieldTH
 import Language.Haskell.TH
@@ -15,6 +16,13 @@ lensRules_ :: LensRules
 lensRules_ = lensRules
     & lensField .~ \_ _ n -> [TopName (mkName ('_':nameBase n))]
 
+-- | Like lensRules_, but different class and function name
+classyRulesFor_ :: ClassyNamer -> LensRules
+classyRulesFor_ clsNamer = classyRules
+    & lensClass .~ clsNamer
+    & lensField .~ \_ _ n -> [TopName (mkName ('_':nameBase n))]
+
+
 -- | Build lenses (and traversals) with a sensible default configuration.
 -- Works the same as 'makeLenses' except that
 -- the resulting lens is also prefixed with an underscore.
@@ -42,6 +50,14 @@ lensRules_ = lensRules
 -- @
 -- 'makeLenses_' = 'makeLensesWith' 'lensRules_'
 -- @
-
 makeLenses_ :: Name -> DecsQ
 makeLenses_ = makeFieldOptics lensRules_
+
+-- | like makeClassyFor but only specifies names for class and its function,
+--   otherwise lenses are created with underscore like `makeLenses_`
+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 (mkName clsName, mkName funName)