fix: inherit authorization of CAddUserR in more places

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"}

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)

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

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)))
+                    -> Colonnade h UserTableData (DBCell (MForm Handler) (FormResult (First (Element acts), DBFormResult UserId Bool UserTableData)))
-                    -> PSValidator (MForm Handler) (FormResult (First act, DBFormResult UserId Bool UserTableData))
+                    -> PSValidator (MForm Handler) (FormResult (First (Element acts), DBFormResult UserId Bool UserTableData))
-                    -> DB (FormResult (act, Set UserId), Widget)
+                    -> DB (FormResult (Element acts, Set UserId), Widget)
-makeCourseUserTable cid restrict colChoices psValidator = do
+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

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

templates/course-user.hamlet

@@ -12,12 +12,13 @@
         $maybe date <- mRegAt
           <dt .deflist__dt>_{MsgRegisteredSince}
           <dd .deflist__dd>#{date}
-        <dt .deflist__dt>
+        $if mayRegister
-        <dd .deflist__dd>
+          <dt .deflist__dt>
-          ^{regButtonWidget}
+          <dd .deflist__dd>
-          $maybe _ <- mRegistration
+            ^{regButtonWidget}
-            <p>
+            $maybe _ <- mRegistration
-              _{MsgCourseDeregisterLecturerTip}
+              <p>
+                _{MsgCourseDeregisterLecturerTip}
         <dt .deflist__dt>_{MsgStudyTerms}
         <dd .deflist__dd>
           $if null studies