First steps towards editable User Rights

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

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

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
         <form method=post action=@{AdminTestR} enctype=#{emailEnctype}>
           ^{emailWidget}
       |]
-  
+
   defaultLayout $
     -- setTitle "Uni2work Admin Testpage"
     $(widgetFile "adminTest")
 
 
-getAdminUserR :: CryptoUUIDUser -> Handler Html
-getAdminUserR uuid = do
-  uid <- decrypt uuid
-  User{..} <- runDB $ get404 uid
-  defaultLayout
-    [whamlet|
-      <h1>TODO
-      <h2>Admin Page for User ^{nameWidget userDisplayName userSurname}
-    |]
-
 getAdminErrMsgR, postAdminErrMsgR :: Handler Html
 getAdminErrMsgR = postAdminErrMsgR
 postAdminErrMsgR = do

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

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"

src/Handler/Utils/Form.hs

@@ -135,7 +135,6 @@ buttonForm csrf = do
      |])
 
 
-
 ------------
 -- Fields --
 ------------

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

templates/adminUser.hamlet

@@ -0,0 +1,6 @@
+<h2>
+  _{MsgAccessRightsFor}
+  ^{nameWidget userDisplayName userSurname}
+<form method=post action=@{AdminUserR uuid} enctype=#{formEnctype}>
+  ^{formWidget}
+  ^{submitButtonView}

templates/widgets/user-rights-form.hamlet

@@ -0,0 +1,14 @@
+$newline never
+#{csrf}
+<div .scrolltable>
+  <table .table .table--striped .table--hover>
+    <tr .table__row .table__row--head>
+      <th>
+        $# empty cell
+      <th .table__th>_{MsgAdminFor}
+      <th .table__th>_{MsgLecturerFor}
+    $forall (School name _, (_,cbAdmin), (_,cbLecturer)) <- boxRights
+      <tr .table__row>
+        <th .table__th>#{name}
+        <td .table__td>^{fvInput cbAdmin}
+        <td .table__td>^{fvInput cbLecturer}