From 3391904cff75cf9646d647ee15d907a8080d00ce Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 9 Sep 2019 15:39:57 +0200 Subject: [PATCH] fix: inherit authorization of CAddUserR in more places --- messages/uniworx/de.msg | 3 ++- src/Foundation.hs | 5 ++++- src/Handler/Course/User.hs | 10 ++++++++-- src/Handler/Course/Users.hs | 24 ++++++++++++++++-------- src/Handler/Tutorial/Users.hs | 3 ++- templates/course-user.hamlet | 13 +++++++------ 6 files changed, 39 insertions(+), 19 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 62214863b..cae00655d 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -116,7 +116,8 @@ CourseNewHeading: Neuen Kurs anlegen CourseEditHeading tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{tid}-#{ssh}-#{csh} editieren CourseEditTitle: Kurs editieren/anlegen CourseMembers: Teilnehmer -CourseMemberOf: Teilnehmer +CourseMemberOf: Teilnehmer von +CourseAssociatedWith: assoziiert mit CourseMembersCount n@Int: #{n} CourseMembersCountLimited n@Int max@Int: #{n}/#{max} CourseMembersCountOf n@Int mbNum@IntMaybe: #{n} Kursanmeldungen #{maybeToMessage " von " mbNum " möglichen"} diff --git a/src/Foundation.hs b/src/Foundation.hs index 60143db44..740fc2f45 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1803,7 +1803,10 @@ instance YesodBreadcrumbs UniWorX where breadcrumb (CourseR tid ssh csh CUsersR) = return ("Anmeldungen", Just $ CourseR tid ssh csh CShowR) breadcrumb (CourseR tid ssh csh CAddUserR) = return ("Kursteilnehmer hinzufügen", Just $ CourseR tid ssh csh CUsersR) breadcrumb (CourseR tid ssh csh CInviteR) = return ("Einladung", Just $ CourseR tid ssh csh CShowR) - breadcrumb (CourseR tid ssh csh (CUserR _)) = return ("Teilnehmer" , Just $ CourseR tid ssh csh CUsersR) + breadcrumb (CourseR tid ssh csh (CUserR cID)) = do + uid <- decrypt cID + User{userDisplayName} <- runDB $ get404 uid + return (userDisplayName, Just $ CourseR tid ssh csh CShowR) breadcrumb (CourseR tid ssh csh CCorrectionsR) = return ("Abgaben" , Just $ CourseR tid ssh csh CShowR) breadcrumb (CourseR tid ssh csh CAssignR) = return ("Zuteilung Korrekturen" , Just $ CourseR tid ssh csh CCorrectionsR) breadcrumb (CourseR tid ssh csh SheetListR) = return ("Übungen" , Just $ CourseR tid ssh csh CShowR) diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs index 81ac54d5b..7e8cc7cfd 100644 --- a/src/Handler/Course/User.hs +++ b/src/Handler/Course/User.hs @@ -114,8 +114,9 @@ postCUserR tid ssh csh uCId = do addMessageI Success MsgCourseStudyFeatureUpdated redirect $ currentRoute :#: registrationFieldFrag + mayRegister <- hasWriteAccessTo $ CourseR tid ssh csh CAddUserR let regButton - | Just _ <- mRegistration = BtnCourseDeregister + | is _Just mRegistration = BtnCourseDeregister | otherwise = BtnCourseRegister ((regButtonRes, regButtonView), regButtonEnctype) <- runFormPost . identifyForm FIDcRegButton $ buttonForm' [regButton] @@ -130,6 +131,9 @@ postCUserR tid ssh csh uCId = do , formAnchor = Just registrationButtonFrag } formResult regButtonRes $ \case + _ + | not mayRegister + -> permissionDenied "User may not be registered" BtnCourseDeregister | Just (Entity pId _) <- mRegistration -> do @@ -160,7 +164,9 @@ postCUserR tid ssh csh uCId = do mRegAt <- for (courseParticipantRegistration . entityVal <$> mRegistration) $ formatTime SelFormatDateTime -- generate output - let headingLong = [whamlet|^{nameWidget userDisplayName userSurname} - _{MsgCourseMemberOf} #{csh} #{tid}|] + let headingLong + | is _Just mRegistration = [whamlet|^{nameWidget userDisplayName userSurname}, _{MsgCourseMemberOf} #{csh} #{tid}|] + | otherwise = [whamlet|^{nameWidget userDisplayName userSurname}, _{MsgCourseAssociatedWith} #{csh} #{tid}|] headingShort = prependCourseTitle tid ssh csh $ SomeMessage userDisplayName siteLayout headingLong $ do setTitleI headingShort diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index fc7b82a36..ab74991a1 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -130,15 +130,18 @@ nullaryPathPiece ''CourseUserAction $ camelToPathPiece' 2 embedRenderMessage ''UniWorX ''CourseUserAction id -makeCourseUserTable :: forall h act. +makeCourseUserTable :: forall h acts. ( Functor h, ToSortable h - , RenderMessage UniWorX act, Eq act, PathPiece act, Finite act) + , MonoFoldable acts + , RenderMessage UniWorX (Element acts), Eq (Element acts), PathPiece (Element acts) + ) => CourseId + -> acts -> (UserTableExpr -> E.SqlExpr (E.Value Bool)) - -> Colonnade h UserTableData (DBCell (MForm Handler) (FormResult (First act, DBFormResult UserId Bool UserTableData))) - -> PSValidator (MForm Handler) (FormResult (First act, DBFormResult UserId Bool UserTableData)) - -> DB (FormResult (act, Set UserId), Widget) -makeCourseUserTable cid restrict colChoices psValidator = do + -> Colonnade h UserTableData (DBCell (MForm Handler) (FormResult (First (Element acts), DBFormResult UserId Bool UserTableData))) + -> PSValidator (MForm Handler) (FormResult (First (Element acts), DBFormResult UserId Bool UserTableData)) + -> DB (FormResult (Element acts, Set UserId), Widget) +makeCourseUserTable cid acts restrict colChoices psValidator = do Just currentRoute <- liftHandlerT getCurrentRoute -- -- psValidator has default sorting and filtering let dbtIdent = "courseUsers" :: Text @@ -209,7 +212,7 @@ makeCourseUserTable cid restrict colChoices psValidator = do , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just - <$> areq (selectField optionsFinite) (fslI MsgAction) Nothing + <$> areq (selectField $ optionsF acts) (fslI MsgAction) Nothing , dbParamsFormEvaluate = liftHandlerT . runFormPost , dbParamsFormResult = id , dbParamsFormIdent = def @@ -228,6 +231,7 @@ getCUsersR, postCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCUsersR = postCUsersR postCUsersR tid ssh csh = do (Entity cid course, numParticipants, (participantRes,participantTable)) <- runDB $ do + mayRegister <- hasWriteAccessTo $ CourseR tid ssh csh CAddUserR let colChoices = mconcat [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) , colUserNameLink (CourseR tid ssh csh . CUserR) @@ -240,9 +244,13 @@ postCUsersR tid ssh csh = do , colUserComment tid ssh csh ] psValidator = def & defaultSortingByName + acts = catMaybes + [ Just CourseUserSendMail + , guardOn mayRegister CourseUserDeregister + ] ent@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh numParticipants <- count [CourseParticipantCourse ==. cid] - table <- makeCourseUserTable cid (const E.true) colChoices psValidator + table <- makeCourseUserTable cid acts (const E.true) colChoices psValidator return (ent, numParticipants, table) formResult participantRes $ \case (CourseUserSendMail, selectedUsers) -> do diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index 34046f452..a5441c01d 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -50,8 +50,9 @@ postTUsersR tid ssh csh tutn = do isInTut q = E.exists . E.from $ \tutorialParticipant -> E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser q E.^. UserId E.&&. tutorialParticipant E.^. TutorialParticipantTutorial E.==. E.val tutid + cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh - table <- makeCourseUserTable cid isInTut colChoices psValidator + table <- makeCourseUserTable cid universeF isInTut colChoices psValidator return (tut, table) formResult participantRes $ \case diff --git a/templates/course-user.hamlet b/templates/course-user.hamlet index 338bb52c2..d4d057f4a 100644 --- a/templates/course-user.hamlet +++ b/templates/course-user.hamlet @@ -12,12 +12,13 @@ $maybe date <- mRegAt
_{MsgRegisteredSince}
#{date} -
-
- ^{regButtonWidget} - $maybe _ <- mRegistration -

- _{MsgCourseDeregisterLecturerTip} + $if mayRegister +

+
+ ^{regButtonWidget} + $maybe _ <- mRegistration +

+ _{MsgCourseDeregisterLecturerTip}

_{MsgStudyTerms}
$if null studies