Cleanup AdminHijackUserR

messages/uniworx/de.msg

@@ -153,6 +153,7 @@ UnauthorizedAnd l@Text r@Text: (#{l} UND #{r})
 UnauthorizedOr  l@Text r@Text: (#{l} ODER #{r})
 UnauthorizedSiteAdmin: Sie sind kein System-weiter Administrator.
 UnauthorizedSchoolAdmin: Sie sind nicht als Administrator für dieses Institut eingetragen.
+UnauthorizedAdminEscalation: Sie sind nicht Administrator für alle Institute, für die dieser Nutzer Administrator oder Veranstalter ist.
 UnauthorizedSchoolLecturer: Sie sind nicht als Veranstalter für dieses Institut eingetragen.
 UnauthorizedLecturer: Sie sind nicht als Veranstalter für diese Veranstaltung eingetragen.
 UnauthorizedCorrector: Sie sind nicht als Korrektor für diese Veranstaltung eingetragen.
@@ -556,6 +557,7 @@ AuthPredsActive: Aktive Authorisierungsprädikate
 AuthPredsActiveChanged: Authorisierungseinstellungen für aktuelle Sitzung gespeichert
 AuthTagFree: Seite ist generell zugänglich
 AuthTagAdmin: Nutzer ist Administrator
+AuthTagNoEscalation: Nutzer-Rechte werden nicht erweitert
 AuthTagDeprecated: Seite ist nicht überholt
 AuthTagDevelopment: Seite ist nicht in Entwicklung
 AuthTagLecturer: Nutzer ist Dozent

routes

@@ -36,7 +36,7 @@
 /users                      UsersR            GET             -- no tags, i.e. admins only
 /admin/test                 AdminTestR        GET POST
 /admin/user/#CryptoUUIDUser AdminUserR        GET             !development
-/admin/user/#CryptoUUIDUser/hijack AdminHijackUserR POST
+/admin/user/#CryptoUUIDUser/hijack AdminHijackUserR POST      !adminANDno-escalation
 /admin/errMsg               AdminErrMsgR      GET POST
 /info                       VersionR          GET             !free
 /help                       HelpR             GET POST        !free

src/Foundation.hs

@@ -362,6 +362,16 @@ tagAccessPredicate AuthAdmin = APDB $ \route _ -> case route of
     adrights <- lift $ selectFirst [UserAdminUser ==. authId] []
     guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin)
     return Authorized
+tagAccessPredicate AuthNoEscalation = APDB $ \route _ -> case route of
+  AdminHijackUserR cID -> exceptT return return $ do
+    myUid <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
+    uid <- decrypt cID
+    otherSchoolsAdmin <- lift $ Set.fromList . map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. uid] []
+    otherSchoolsLecturer <- lift $ Set.fromList . map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. uid] []
+    mySchools <- lift $ Set.fromList . map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. myUid] []
+    guardMExceptT ((otherSchoolsAdmin `Set.union` otherSchoolsLecturer) `Set.isSubsetOf` mySchools) (unauthorizedI MsgUnauthorizedAdminEscalation)
+    return Authorized
+  r -> $unsupportedAuthPredicate AuthNoEscalation r
 tagAccessPredicate AuthDeprecated = APHandler $ \r _ -> do
   $logWarnS "AccessControl" ("deprecated route: " <> tshow r)
   addMessageI Error MsgDeprecatedRoute

src/Handler/Users.hs

@@ -9,18 +9,16 @@ import Utils.Lens
 import qualified Data.CaseInsensitive as CI
 
 import qualified Data.Map as Map
-import qualified Data.Set as Set
 
 import qualified Database.Esqueleto as E
 
 
-hijackUserForm :: UserId -> Form UserId
+hijackUserForm :: CryptoUUIDUser -> Form ()
-hijackUserForm uid csrf = do
+hijackUserForm cID csrf = do
-  cID <- encrypt uid
   (uidResult, uidView) <- mforced hiddenField "" (cID :: CryptoUUIDUser)
   (btnResult, btnView) <- mreq (buttonField BtnHijack) "" Nothing 
 
-  return (uid <$ uidResult <* btnResult, mconcat [toWidget csrf, fvInput uidView, fvInput btnView])
+  return (() <$ uidResult <* btnResult, mconcat [toWidget csrf, fvInput uidView, fvInput btnView])
 
 getUsersR :: Handler Html
 getUsersR = do
@@ -59,12 +57,15 @@ getUsersR = do
                 <li>#{sh}
             |]
       , sortable Nothing mempty $ \DBRow{ dbrOutput = Entity uid _ } -> cell $ do
-          (hijackView, hijackEnctype) <- liftHandlerT . generateFormPost $ hijackUserForm uid
           cID <- encrypt uid
-          [whamlet|
+          mayHijack <- (== Authorized) <$> evalAccess (AdminHijackUserR cID) True
-            <form method=POST action=@{AdminHijackUserR cID} enctype=#{hijackEnctype}>
+          myUid <- liftHandlerT maybeAuthId
-              ^{hijackView}
+          when (mayHijack && Just uid /= myUid) $ do
-          |]
+            (hijackView, hijackEnctype) <- liftHandlerT . generateFormPost $ hijackUserForm cID
+            [whamlet|
+              <form method=POST action=@{AdminHijackUserR cID} enctype=#{hijackEnctype}>
+                ^{hijackView}
+            |]
       ]
     psValidator = def
       & defaultSorting [SortAscBy "name", SortAscBy "display-name"]
@@ -99,21 +100,10 @@ getUsersR = do
 postAdminHijackUserR :: CryptoUUIDUser -> Handler TypedContent
 postAdminHijackUserR cID = do
   uid <- decrypt cID
-  ((hijackRes, _), _) <- runFormPost $ hijackUserForm uid
+  ((hijackRes, _), _) <- runFormPost $ hijackUserForm cID
 
-  case hijackRes of
+  ret <- formResultMaybe hijackRes $ \() -> Just <$> do
-    FormSuccess uid'
+    User{userIdent} <- runDB $ get404 uid
-      | uid' == uid -> do
+    setCredsRedirect $ Creds "dummy" (CI.original userIdent) []
-          myUid <- requireAuthId
-          User{..} <- runDB $ do
-            otherSchoolsAdmin <- Set.fromList . map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. uid] []
-            otherSchoolsLecturer <- Set.fromList . map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. uid] []
-            mySchools <- Set.fromList . map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. myUid] []
-            unless ((otherSchoolsAdmin `Set.union` otherSchoolsLecturer) `Set.isSubsetOf` mySchools) $
-              permissionDenied "Cannot escalate admin status to additional schools"
 
-            get404 uid
+  maybe (redirect UsersR) return ret
-          setCredsRedirect $ Creds "dummy" (CI.original userIdent) []
-      | otherwise -> error "This should be impossible by definition of `hijackUserForm`"
-    FormFailure errs -> toTypedContent <$> mapM_ (addMessage Error . toHtml) errs
-    FormMissing -> return $ toTypedContent ()

src/Model/Types.hs

@@ -702,6 +702,7 @@ pseudonymFragments = folding
 data AuthTag
   = AuthFree
   | AuthAdmin
+  | AuthNoEscalation
   | AuthDeprecated
   | AuthDevelopment
   | AuthLecturer