Admins can change user access rights now

messages/uniworx/de.msg

@@ -333,11 +333,13 @@ MultiSinkException name@Text error@Text: In Abgabe #{name} ist ein Fehler aufget
 NoTableContent: Kein Tabelleninhalt
 NoUpcomingSheetDeadlines: Keine anstehenden Übungsblätter
 
+AdminUserHeading: Benutzeradministration
 AccessRightsFor: Berechtigungen für
 AdminFor: Administrator
 LecturerFor: Dozent
 LecturersFor: Dozenten
 UserListTitle: Komprehensive Benutzerliste
+AccessRightsSaved: Berechtigungsänderungen wurden gespeichert.
 
 DateTimeFormat: Datums- und Uhrzeitformat
 DateFormat: Datumsformat

src/Foundation.hs

@@ -888,6 +888,7 @@ instance Yesod UniWorX where
     makeLogger = readTVarIO . snd . appLogger
 
 
+
 siteLayout :: Maybe Html -- ^ Optionally override `pageHeading`
            -> Widget -> Handler Html
 siteLayout headingOverride widget = do
@@ -1609,7 +1610,7 @@ pageHeading UsersR
 pageHeading (AdminTestR)
   = Just $ [whamlet|Internal Code Demonstration Page|]
 pageHeading (AdminUserR _)
-  = Just $ [whamlet|User Display for Admin|]
+  = Just $ i18nHeading MsgAdminUserHeading
 pageHeading (AdminErrMsgR)
   = Just $ i18nHeading MsgErrMsgHeading
 pageHeading (VersionR)

src/Handler/Users.hs

@@ -110,14 +110,16 @@ postAdminHijackUserR cID = do
   maybe (redirect UsersR) return ret
 
 
-userRightsForm :: UserId -> Form [(School, Bool, Bool)]
+getAdminUserR, postAdminUserR :: CryptoUUIDUser -> Handler Html
-userRightsForm uid csrf = do
+getAdminUserR = postAdminUserR
-  let f = Set.fromList . map (userAdminSchool . entityVal)
+postAdminUserR uuid = do
-  (f -> adminSchools, userRights) <- liftHandlerT $ do
     adminId <- requireAuthId
-    runDB $ (,)
+    uid <- decrypt uuid
-      <$> selectList [UserAdminUser ==. adminId] []
+    let fromSchoolList = Set.fromList . map (userAdminSchool . entityVal)
-      <*> (E.select $ E.from $ \school -> do
+    (User{..}, fromSchoolList -> adminSchools, userRights) <- runDB $ (,,)
+        <$> get404 uid
+        <*> selectList [UserAdminUser ==. adminId] []
+        <*> E.select ( E.from $ \school -> do
               E.orderBy [E.asc $ school E.^. SchoolName]
               let schAdmin    = E.exists $ E.from $ \userAdmin    -> do
                     E.where_ $ userAdmin    E.^. UserAdminSchool    E.==. school E.^. SchoolId
@@ -127,29 +129,36 @@ userRightsForm uid csrf = do
                     E.where_ $ userLecturer E.^. UserLecturerUser   E.==. E.val uid
               return (school,schAdmin,schLecturer)
             )
-
+    -- above data is needed for both form generation and result evaluation
-  boxRights <- forM userRights $ \(Entity sid school, E.Value isAdmin, E.Value isLecturer) ->
+    let userRightsForm :: Form [(SchoolId, Bool, Bool)]
+        userRightsForm csrf = do
+          boxRights <- forM userRights $ \(school@(Entity sid _), E.Value isAdmin, E.Value isLecturer) ->
             if  | Set.member sid adminSchools -> do
-            cbAdmin    <- mreq checkBoxField "" $ Just isAdmin
+                    cbAdmin    <- mreq    checkBoxField "" (Just isAdmin)
-            cbLecturer <- mreq checkBoxField "" $ Just isLecturer
+                    cbLecturer <- mreq    checkBoxField "" (Just isLecturer)
                     return (school, cbAdmin, cbLecturer)
                 | otherwise -> do
                     cbAdmin    <- mforced checkBoxField ""       isAdmin
                     cbLecturer <- mforced checkBoxField ""       isLecturer
                     return (school, cbAdmin, cbLecturer)
-  let result =
+          let result = forM boxRights $ \(Entity sid _, (resAdmin,_), (resLecturer, _)) ->
-        forM boxRights $ \(school, (resAdmin,_), (resLecturer, _)) ->
+                        (,,) <$> pure sid <*> resAdmin <*> resLecturer
-          (,,) <$> pure school <*> resAdmin <*> resLecturer
           return (result,$(widgetFile "widgets/user-rights-form"))
-
+    let userRightsAction changes = do
-getAdminUserR, postAdminUserR :: CryptoUUIDUser -> Handler Html
+          void . runDB $
-getAdminUserR = postAdminUserR
+            forM changes $ \(sid, userAdmin, userLecturer) ->
-postAdminUserR uuid = do
+              if Set.notMember sid adminSchools
-    uid <- decrypt uuid
+                then return ()
-    User{..} <- runDB $ get404 uid
+                else do
-    ((result, formWidget),formEnctype) <- runFormPost $ userRightsForm uid
+                  if userAdmin
-    formResult result actions
+                    then void . insertUnique $ UserAdmin uid sid
+                    else deleteBy $ UniqueUserAdmin uid sid
+                  if userLecturer
+                    then void . insertUnique $ UserLecturer uid sid
+                    else deleteBy $ UniqueSchoolLecturer uid sid
+                -- Note: deleteWhere would not work well here since we filter by adminSchools
+          addMessageI Info MsgAccessRightsSaved
+    ((result, formWidget),formEnctype) <- runFormPost userRightsForm
+    formResult result userRightsAction
     defaultLayout
       $(widgetFile "adminUser")
-  where
-    actions _result = error "TODO"

templates/widgets/user-rights-form.hamlet

@@ -7,7 +7,7 @@ $newline never
         $# empty cell
       <th .table__th>_{MsgAdminFor}
       <th .table__th>_{MsgLecturerFor}
-    $forall (School name _, (_,cbAdmin), (_,cbLecturer)) <- boxRights
+    $forall (Entity _ (School name _), (_,cbAdmin), (_,cbLecturer)) <- boxRights
       <tr .table__row>
         <th .table__th>#{name}
         <td .table__td>^{fvInput cbAdmin}