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,46 +110,55 @@ postAdminHijackUserR cID = do
   maybe (redirect UsersR) return ret
 
 
-userRightsForm :: UserId -> Form [(School, Bool, Bool)]
-userRightsForm uid csrf = do
-  let f = Set.fromList . map (userAdminSchool . entityVal)
-  (f -> adminSchools, userRights) <- liftHandlerT $ do
-    adminId <- requireAuthId
-    runDB $ (,)
-      <$> 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
-                  E.where_ $ userAdmin    E.^. UserAdminUser      E.==. E.val uid
-            let schLecturer = E.exists $ E.from $ \userLecturer -> do
-                  E.where_ $ userLecturer E.^. UserLecturerSchool E.==. school E.^. SchoolId
-                  E.where_ $ userLecturer E.^. UserLecturerUser   E.==. E.val uid
-            return (school,schAdmin,schLecturer)
-          )
-
-  boxRights <- forM userRights $ \(Entity sid school, E.Value isAdmin, E.Value isLecturer) ->
-    if  | Set.member sid adminSchools -> do
-            cbAdmin    <- mreq checkBoxField "" $ Just isAdmin
-            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 =
-        forM boxRights $ \(school, (resAdmin,_), (resLecturer, _)) ->
-          (,,) <$> pure school <*> resAdmin <*> resLecturer
-  return (result,$(widgetFile "widgets/user-rights-form"))
-
 getAdminUserR, postAdminUserR :: CryptoUUIDUser -> Handler Html
 getAdminUserR = postAdminUserR
 postAdminUserR uuid = do
+    adminId <- requireAuthId
     uid <- decrypt uuid
-    User{..} <- runDB $ get404 uid
-    ((result, formWidget),formEnctype) <- runFormPost $ userRightsForm uid
-    formResult result actions
+    let fromSchoolList = Set.fromList . map (userAdminSchool . entityVal)
+    (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
+                    E.where_ $ userAdmin    E.^. UserAdminUser      E.==. E.val uid
+              let schLecturer = E.exists $ E.from $ \userLecturer -> do
+                    E.where_ $ userLecturer E.^. UserLecturerSchool E.==. school E.^. SchoolId
+                    E.where_ $ userLecturer E.^. UserLecturerUser   E.==. E.val uid
+              return (school,schAdmin,schLecturer)
+            )
+    -- above data is needed for both form generation and result evaluation
+    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)
+                    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 = forM boxRights $ \(Entity sid _, (resAdmin,_), (resLecturer, _)) ->
+                        (,,) <$> pure sid <*> resAdmin <*> resLecturer
+          return (result,$(widgetFile "widgets/user-rights-form"))
+    let userRightsAction changes = do
+          void . runDB $
+            forM changes $ \(sid, userAdmin, userLecturer) ->
+              if Set.notMember sid adminSchools
+                then return ()
+                else do
+                  if userAdmin
+                    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}