diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 8e9213360..39f5d6f1c 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -333,6 +333,7 @@ MultiSinkException name@Text error@Text: In Abgabe #{name} ist ein Fehler aufget NoTableContent: Kein Tabelleninhalt NoUpcomingSheetDeadlines: Keine anstehenden Übungsblätter +AccessRightsFor: Berechtigungen für AdminFor: Administrator LecturerFor: Dozent LecturersFor: Dozenten diff --git a/routes b/routes index 99a2bf3d0..09fbbdf3d 100644 --- a/routes +++ b/routes @@ -35,7 +35,7 @@ / HomeR GET !free /users UsersR GET -- no tags, i.e. admins only -/users/#CryptoUUIDUser AdminUserR GET !development +/users/#CryptoUUIDUser AdminUserR GET POST !development /users/#CryptoUUIDUser/hijack AdminHijackUserR POST !adminANDno-escalation /admin/test AdminTestR GET POST /admin/errMsg AdminErrMsgR GET POST diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 17bc943b9..a159489fe 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -66,7 +66,7 @@ postAdminTestR = do _other -> addMessage Warning "KEIN Knopf erkannt" ((emailResult, emailWidget), emailEnctype) <- runFormPost . identifyForm "email" $ renderAForm FormStandard emailTestForm - case emailResult of + case emailResult of (FormSuccess (email, ls)) -> do jId <- runDB $ do jId <- queueJob $ JobSendTestEmail email ls @@ -80,22 +80,12 @@ postAdminTestR = do
^{emailWidget} |] - + defaultLayout $ -- setTitle "Uni2work Admin Testpage" $(widgetFile "adminTest") -getAdminUserR :: CryptoUUIDUser -> Handler Html -getAdminUserR uuid = do - uid <- decrypt uuid - User{..} <- runDB $ get404 uid - defaultLayout - [whamlet| -

TODO -

Admin Page for User ^{nameWidget userDisplayName userSurname} - |] - getAdminErrMsgR, postAdminErrMsgR :: Handler Html getAdminErrMsgR = postAdminErrMsgR postAdminErrMsgR = do diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 38f064dd8..7bd81f775 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -88,7 +88,8 @@ postProfileR = do let formText = Nothing :: Maybe UniWorXMessage actionUrl = ProfileR defaultLayout $ do - setTitle . toHtml $ userIdent <> "'s User page" + setTitle . toHtml $ "Profil " <> userIdent + [whamlet| Benutzereinstellungen für ^{nameWidget userDisplayName userSurname} |] $(widgetFile "formPageI18n") postProfileDataR :: Handler Html @@ -160,9 +161,6 @@ deleteUser duid = do - - - getProfileDataR :: Handler Html getProfileDataR = do (uid, User{..}) <- requireAuthPair diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index a2c21ec9f..84e37c36d 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -8,6 +8,7 @@ import Utils.Lens import qualified Data.CaseInsensitive as CI +import qualified Data.Set as Set import qualified Data.Map as Map import qualified Database.Esqueleto as E @@ -16,7 +17,7 @@ import qualified Database.Esqueleto as E hijackUserForm :: CryptoUUIDUser -> Form () hijackUserForm cID csrf = do (uidResult, uidView) <- mforced hiddenField "" (cID :: CryptoUUIDUser) - (btnResult, btnView) <- mreq (buttonField BtnHijack) "" Nothing + (btnResult, btnView) <- mreq (buttonField BtnHijack) "" Nothing return (() <$ uidResult <* btnResult, mconcat [toWidget csrf, fvInput uidView, fvInput btnView]) @@ -69,7 +70,7 @@ getUsersR = do ] psValidator = def & defaultSorting [SortAscBy "name", SortAscBy "display-name"] - + ((), userList) <- runDB $ dbTable psValidator DBTable { dbtSQLQuery = return :: E.SqlExpr (Entity User) -> E.SqlQuery (E.SqlExpr (Entity User)) , dbtRowKey = (E.^. UserId) @@ -92,7 +93,7 @@ getUsersR = do , dbtParams = def , dbtIdent = "users" :: Text } - + defaultLayout $ do setTitleI MsgUserListTitle $(widgetFile "users") @@ -107,3 +108,48 @@ postAdminHijackUserR cID = do setCredsRedirect $ Creds "dummy" (CI.original userIdent) [] 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 + uid <- decrypt uuid + User{..} <- runDB $ get404 uid + ((result, formWidget),formEnctype) <- runFormPost $ userRightsForm uid + formResult result actions + defaultLayout + $(widgetFile "adminUser") + where + actions _result = error "TODO" \ No newline at end of file diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 152d53186..1fcc4b11c 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -135,7 +135,6 @@ buttonForm csrf = do |]) - ------------ -- Fields -- ------------ diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 6fab13a32..c4fe43f80 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -303,12 +303,22 @@ combinedButtonFieldF_ :: forall m a p. ) => p a -> FieldSettings (HandlerSite m) -> AForm m () combinedButtonFieldF_ _ = void . combinedButtonFieldF @m @a +-- | Submit-Button as AForm, also see submitButtonView below submitButton :: (Button (HandlerSite m) ButtonSubmit, MonadHandler m) => AForm m () submitButton = combinedButtonFieldF_ (Proxy @ButtonSubmit) "" autosubmitButton :: (Button (HandlerSite m) ButtonSubmit, MonadHandler m) => AForm m () autosubmitButton = combinedButtonFieldF_ (Proxy @ButtonSubmit) $ "" & addAutosubmit +-- | just Html for a Submit-Button +submitButtonView :: forall site . Button site ButtonSubmit => WidgetT site IO () +submitButtonView = do + let bField :: Field (HandlerT site IO) ButtonSubmit + bField = buttonField BtnSubmit + btnId <- newIdent + fieldView bField btnId "" mempty (Right BtnSubmit) False + + ------------------- -- Custom Fields -- ------------------- diff --git a/templates/adminUser.hamlet b/templates/adminUser.hamlet new file mode 100644 index 000000000..31f816412 --- /dev/null +++ b/templates/adminUser.hamlet @@ -0,0 +1,6 @@ +

+ _{MsgAccessRightsFor} + ^{nameWidget userDisplayName userSurname} + + ^{formWidget} + ^{submitButtonView} diff --git a/templates/widgets/user-rights-form.hamlet b/templates/widgets/user-rights-form.hamlet new file mode 100644 index 000000000..54db4cf1c --- /dev/null +++ b/templates/widgets/user-rights-form.hamlet @@ -0,0 +1,14 @@ +$newline never +#{csrf} +
+ + + +
+ $# empty cell + _{MsgAdminFor} + _{MsgLecturerFor} + $forall (School name _, (_,cbAdmin), (_,cbLecturer)) <- boxRights +
#{name} + ^{fvInput cbAdmin} + ^{fvInput cbLecturer} \ No newline at end of file