diff --git a/routes b/routes index aca3c5735..2720c7259 100644 --- a/routes +++ b/routes @@ -10,22 +10,23 @@ -- Admins always have access to entities within their assigned schools. -- -- Access Tags: --- !free -- free for all --- !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) --- !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) --- !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 --- !empty -- course this route is associated with has no participants whatsoever +-- !free -- free for all +-- !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) +-- !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) +-- !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 +-- !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) --- !time -- access depends on time somehow --- !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) +-- !materials -- only if course allows all materials to be free (no meaning outside of courses) +-- !time -- access depends on time somehow +-- !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) -- --- !deprecated -- like free, but logs and gives a warning; entirely disabled in production --- !development -- like free, but only for development builds +-- !no-escalation -- +-- !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 diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index f1d1e575b..403ad0131 100644 --- a/src/Handler/Users.hs +++ b/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 diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 68a1ba2a8..5163d834c 100644 --- a/src/Utils/Lens.hs +++ b/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 diff --git a/src/Utils/Lens/TH.hs b/src/Utils/Lens/TH.hs index 6f5bf4c14..dffbf10c0 100644 --- a/src/Utils/Lens/TH.hs +++ b/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) \ No newline at end of file