From ba45bc5883dd7d3c80fc07920a25d7a016d00129 Mon Sep 17 00:00:00 2001 From: SJost Date: Thu, 14 Feb 2019 18:34:26 +0100 Subject: [PATCH] Admins can change user access rights now --- messages/uniworx/de.msg | 2 + src/Foundation.hs | 3 +- src/Handler/Users.hs | 83 +++++++++++++---------- templates/widgets/user-rights-form.hamlet | 2 +- 4 files changed, 51 insertions(+), 39 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 39f5d6f1c..b00fd3be1 100644 --- a/messages/uniworx/de.msg +++ b/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 diff --git a/src/Foundation.hs b/src/Foundation.hs index 28eb1c33a..7e729cc8f 100644 --- a/src/Foundation.hs +++ b/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) diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 84e37c36d..0dd2ec483 100644 --- a/src/Handler/Users.hs +++ b/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" \ No newline at end of file diff --git a/templates/widgets/user-rights-form.hamlet b/templates/widgets/user-rights-form.hamlet index 54db4cf1c..a77f054fe 100644 --- a/templates/widgets/user-rights-form.hamlet +++ b/templates/widgets/user-rights-form.hamlet @@ -7,7 +7,7 @@ $newline never $# empty cell _{MsgAdminFor} _{MsgLecturerFor} - $forall (School name _, (_,cbAdmin), (_,cbLecturer)) <- boxRights + $forall (Entity _ (School name _), (_,cbAdmin), (_,cbLecturer)) <- boxRights #{name} ^{fvInput cbAdmin}