fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

refactor(performance): disable modalAccess use for known admins

Browse Source 
modalAccess displays a link to modal only
if the user has the rights to follow that link.
However, for large dbTables this checking takes
too long. So we use a conventional modal instead again.
Worst-case: some non-admins are shown links that they cannot follow
This commit is contained in:
Steffen Jost 2023-11-28 15:32:33 +01:00
parent 0a06efd76c
commit 92aca1b830
12 changed files with 74 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
src/Handler/Admin/Avs.hs
View File

@ -548,7 +548,7 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
[ dbSelect (applying _2) id $ return . view (resultUserAvs . _userAvsPersonId)
-- (\DBRow{dbrOutput=(_,_,apid,_)} -> return apid -- return . view resultAvsPID) -- does not type due to traversal
, colUserNameLink AdminUserR
, sortable (Just "avspersonno") (i18nCell MsgAvsPersonNo) $ \(view resultUserAvs -> a) -> avsPersonNoLinkedCell a
, sortable (Just "avspersonno") (i18nCell MsgAvsPersonNo) $ \(view resultUserAvs -> a) -> avsPersonNoLinkedCellAdmin a
-- , colUserCompany
, sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \(view (resultUser . _entityKey) -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX"
companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
@ -752,7 +752,7 @@ getProblemAvsErrorR = do
dbtRowKey = qerryUsrAvs >>> (E.^. UserAvsId)
dbtProj = dbtProjId
dbtColonnade = dbColonnade $ mconcat
[ colUserNameModalHdr MsgLmsUser AdminUserR
[ colUserNameModalHdrAdmin MsgLmsUser AdminUserR
, sortable (Just "avs-nr") (i18nCell MsgAvsPersonNo)
$ avsPersonNoLinkedCell . view reserrUsrAvs
, sortable Nothing (i18nCell MsgAvsPersonId)

2
src/Handler/Course/Users.hs
View File

@ -660,7 +660,7 @@ postCUsersR tid ssh csh = do
, pure . cap' $ colUserNameLink (CourseR tid ssh csh . CUserR)
, guardOn showSex . cap' $ colUserSex'
, pure . cap' $ colUserEmail
, pure . cap' $ colUserMatriclenr
, pure . cap' $ colUserMatriclenr False
, pure . cap' $ colUserQualifications nowaday
, guardOn hasSubmissionGroups $ cap' colUserSubmissionGroup
, guardOn hasTutorials . cap' $ colUserTutorials tid ssh csh

2
src/Handler/Exam/Users.hs
View File

@ -484,7 +484,7 @@ postEUsersR tid ssh csh examn = do
dbtColonnade = mconcat $ catMaybes
[ pure $ dbSelect (_2 . applying _2) _1 $ return . view (resultExamRegistration . _entityKey)
, pure $ colUserNameLink (CourseR tid ssh csh . CUserR)
, pure colUserMatriclenr
, pure $ colUserMatriclenr False
, pure $ colStudyFeatures resultStudyFeatures
, pure $ sortable (Just "occurrence") (i18nCell MsgTableExamOccurrence) $ maybe mempty (anchorCell' (\n -> CExamR tid ssh csh examn EShowR :#: [st|exam-occurrence__#{n}|]) id . examOccurrenceName . entityVal) . view _userTableOccurrence
, guardOn showPasses $ sortable Nothing (i18nCell MsgAchievedPasses) $ \(view $ resultUser . _entityKey -> uid) ->

7
src/Handler/Firm.hs
View File

@ -215,8 +215,7 @@ runFirmActionFormPost cid route isAdmin acts = do
return [whamlet|
<section>
<h2 .show-hide__toggle uw-show-hide data-show-hide-collapsed>
_{MsgFirmAction}
$
_{MsgFirmAction}
<div>
<p>
_{MsgFirmActionInfo}
@ -744,7 +743,7 @@ mkFirmUserTable isAdmin cid = do
dbtColonnade = formColonnade $ mconcat
[ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUserUser . _entityKey))
, colUserNameModalHdr MsgTableCompanyUser ForProfileDataR
, sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \(view resultUserUser -> entUsr ) -> cellHasMatrikelnummerLinked entUsr
, guardMonoid isAdmin $ sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \(view resultUserUser -> entUsr ) -> cellHasMatrikelnummerLinkedAdmin entUsr
, sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \(view $ resultUserUser . _userCompanyPersonalNumber -> t) -> foldMap textCell t
, sortable (Just "supervisors") (i18nCell MsgTableCompanyNrSupers ) $ \(view resultUserCompanySupervisors -> nr) -> wgtCell $ word2widget nr
, sortable (Just "reroutes") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultUserCompanyReroutes -> nr) -> wgtCell $ word2widget nr
@ -1022,7 +1021,7 @@ mkFirmSuperTable isAdmin cid = do
dbtColonnade = formColonnade $ mconcat
[ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultSuperUser . _entityKey))
, colUserNameModalHdr MsgTableSupervisor ForProfileDataR
, sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \(view resultSuperUser -> entUsr) -> cellHasMatrikelnummerLinked entUsr
, guardMonoid isAdmin $ sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \(view resultSuperUser -> entUsr) -> cellHasMatrikelnummerLinkedAdmin entUsr
, sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultSuperCompanies -> cmps) ->
intercalate semicolonCell [companyCell cmpShort cmpName isSuper | (E.Value cmpName, E.Value cmpShort, E.Value isSuper) <- cmps]
, sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \(view $ resultSuperUser . _userCompanyPersonalNumber -> t) -> foldMap textCell t

4
src/Handler/LMS.hs
View File

@ -632,7 +632,7 @@ postLmsR sid qsh = do
]
colChoices cmpMap = mconcat
[ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUser . _entityKey))
, colUserNameModalHdr MsgLmsUser AdminUserR
, colUserNameModalHdrAdmin MsgLmsUser AdminUserR
, colUserEmail
, sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) ->
let cs = [ companyCell (unCompanyKey cmpId) cmpName cmpSpr
@ -640,7 +640,7 @@ postLmsR sid qsh = do
, let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap
]
in intercalate spacerCell cs
, colUserMatriclenr
, colUserMatriclenr isAdmin
-- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser)
, sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d
, sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d

2
src/Handler/Qualification.hs
View File

@ -591,7 +591,7 @@ postQualificationR sid qsh = do
, let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap
]
in intercalate spacerCell cs
, guardMonoid isAdmin colUserMatriclenr
, guardMonoid isAdmin $ colUserMatriclenr isAdmin
-- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser)
, sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d
, sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d

4
src/Handler/Tutorial/Users.hs
View File

@ -71,8 +71,8 @@ postTUsersR tid ssh csh tutn = do
colChoices = mconcat $ catMaybes
[ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
, pure $ colUserNameModalHdr MsgTableCourseMembers ForProfileDataR
, pure colUserEmail
, pure colUserMatriclenr
, pure colUserEmail
, pure $ colUserMatriclenr isAdmin
, pure $ colUserQualifications nowaday
, pure $ colUserQualificationBlocked isAdmin nowaday
]

2
src/Handler/Users.hs
View File

@ -100,7 +100,7 @@ postUsersR = do
, sortable (Just "name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
(AdminUserR <$> encrypt uid)
(nameWidget userDisplayName userSurname)
, sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \DBRow{ dbrOutput = entUsr } -> cellHasMatrikelnummerLinked entUsr
, sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \DBRow{ dbrOutput = entUsr } -> cellHasMatrikelnummerLinkedAdmin entUsr
, sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX"
companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId

62
src/Handler/Utils/Table/Cells.hs
View File

@ -218,7 +218,7 @@ cellHasUserLink toLink user =
nWdgt = nameWidget (userEntity ^. _entityVal . _userDisplayName) (userEntity ^. _entityVal . _userSurname)
in anchorCellM (toLink <$> encrypt uid) nWdgt
-- | like `cellHasUserLink` but opens the user in a modal instead
-- | like `cellHasUserLink` but opens the user in a modal instead; link is only displayed if the user has sufficient rights
cellHasUserModal :: (IsDBTable m c, HasEntity u User) => (CryptoUUIDUser -> Route UniWorX) -> u -> DBCell m c
cellHasUserModal toLink user =
let userEntity = user ^. hasEntityUser
@ -226,10 +226,21 @@ cellHasUserModal toLink user =
nWdgt = nameWidget (userEntity ^. _entityVal . _userDisplayName) (userEntity ^. _entityVal . _userSurname)
lWdgt = do
uuid <- liftHandler $ encrypt uid
modalAccess False nWdgt nWdgt $ toLink uuid
modalAccess nWdgt nWdgt False $ toLink uuid
in cell lWdgt
-- | like `cellHasUserModal` but with fixed route and showing an edit icon instead
-- | like `cellHasUserModal` but but always display link without prior access rights checks
cellHasUserModalAdmin :: (IsDBTable m c, HasEntity u User) => (CryptoUUIDUser -> Route UniWorX) -> u -> DBCell m c
cellHasUserModalAdmin toLink user =
let userEntity = user ^. hasEntityUser
uid = userEntity ^. _entityKey
nWdgt = nameWidget (userEntity ^. _entityVal . _userDisplayName) (userEntity ^. _entityVal . _userSurname)
lWdgt = do
uuid <- liftHandler $ encrypt uid
modal nWdgt $ Left $ SomeRoute $ toLink uuid
in cell lWdgt
-- | like `cellHasUserModal` but with fixed route and showing an edit icon instead; link is only displayed if the user has sufficient rights
cellEditUserModal :: (IsDBTable m c, HasEntity u User) => u -> DBCell m c
cellEditUserModal user =
let userEntity = user ^. hasEntityUser
@ -237,16 +248,39 @@ cellEditUserModal user =
nWdgt = toWidget $ icon IconUserEdit
lWdgt = do
uuid <- liftHandler $ encrypt uid
modalAccess True nWdgt mempty $ ForProfileR uuid
modalAccess mempty nWdgt True $ ForProfileR uuid
in cell lWdgt
-- | like `cellEditUserModal` but always displays the link without prior access rights checks
cellEditUserModalAdmin :: (IsDBTable m c, HasEntity u User) => u -> DBCell m c
cellEditUserModalAdmin user =
let userEntity = user ^. hasEntityUser
uid = userEntity ^. _entityKey
nWdgt = toWidget $ icon IconUserEdit
lWdgt = do
uuid <- liftHandler $ encrypt uid
modal nWdgt (Left $ SomeRoute $ ForProfileR uuid)
in cell lWdgt
cellHasMatrikelnummer :: (IsDBTable m a, HasUser u) => u -> DBCell m a
cellHasMatrikelnummer = maybe mempty textCell . view _userMatrikelnummer
cellHasMatrikelnummerLinked :: (IsDBTable m a, HasEntity u User) => u -> DBCell m a
cellHasMatrikelnummerLinked usr
cellHasMatrikelnummerLinked :: (IsDBTable m a, HasEntity u User) => Bool -> u -> DBCell m a
cellHasMatrikelnummerLinked isAdmin usr
| Just matNr <- usrEntity ^. _userMatrikelnummer = cell $ do
uuid <- liftHandler $ encrypt $ usrEntity ^. _entityKey
modalAccess False (text2widget matNr) mempty (AdminAvsUserR uuid)
if isAdmin
then modal (text2widget matNr) (Left $ SomeRoute $ AdminAvsUserR uuid)
else modalAccess mempty (text2widget matNr) False (AdminAvsUserR uuid)
| otherwise = mempty
where
usrEntity = usr ^. hasEntityUser
cellHasMatrikelnummerLinkedAdmin :: (IsDBTable m a, HasEntity u User) => u -> DBCell m a
cellHasMatrikelnummerLinkedAdmin usr
| Just matNr <- usrEntity ^. _userMatrikelnummer = cell $ do
uuid <- liftHandler $ encrypt $ usrEntity ^. _entityKey
modal (text2widget matNr) (Left $ SomeRoute $ AdminAvsUserR uuid)
| otherwise = mempty
where
usrEntity = usr ^. hasEntityUser
@ -364,7 +398,7 @@ qualificationValidUntilCell' mbToLink d qb qu = cell $ case mbToLink of
Nothing -> headWgt <> dateWgt
Just toLink -> do
uuid <- liftHandler $ encrypt $ qu ^. hasQualificationUser . _qualificationUserUser
let modalWgt = modalAccess False dateWgt dateWgt $ toLink uuid
let modalWgt = modalAccess dateWgt dateWgt False $ toLink uuid
headWgt <> modalWgt
where
dateWgt = formatTimeW SelFormatDate (qu ^. hasQualificationUser . _qualificationUserValidUntil)
@ -386,7 +420,7 @@ qualificationValidReasonCell' mbToLink showReason d qb qu = ic <> foldMap blc qb
| Just toLink <- mbToLink = cell $ do
uuid <- liftHandler $ encrypt uid
let dWgt = formatTimeW SelFormatDate tstamp
modalAccess False dWgt dWgt $ toLink uuid
modalAccess dWgt dWgt False $ toLink uuid
-- anchorCellM (toLink <$> encrypt uid)
| otherwise = dateCell tstamp
uid = qu ^. hasQualificationUser . _qualificationUserUser
@ -405,7 +439,7 @@ qualificationValidReasonCell'' mbToLink showReason d qb qu extValid = ic <> icEr
| Just toLink <- mbToLink = cell $ do
uuid <- liftHandler $ encrypt uid
let dWgt = formatTimeW SelFormatDate tstamp
modalAccess False dWgt dWgt $ toLink uuid
modalAccess dWgt dWgt False $ toLink uuid
-- anchorCellM (toLink <$> encrypt uid)
| otherwise = dateCell tstamp
uid = qu ^. hasQualificationUser . _qualificationUserUser
@ -466,7 +500,13 @@ avsPersonNoLinkedCell :: (IsDBTable m c, HasUserAvs a) => a -> DBCell m c
avsPersonNoLinkedCell a = cell $ do
uuid <- liftHandler $ encrypt $ a ^. _userAvsUser
let nWgt = toWgt $ toMessage $ a ^. _userAvsNoPerson
modalAccess False nWgt nWgt $ AdminAvsUserR uuid
modalAccess nWgt nWgt False $ AdminAvsUserR uuid
avsPersonNoLinkedCellAdmin :: (IsDBTable m c, HasUserAvs a) => a -> DBCell m c
avsPersonNoLinkedCellAdmin a = cell $ do
uuid <- liftHandler $ encrypt $ a ^. _userAvsUser
let nWgt = toWgt $ toMessage $ a ^. _userAvsNoPerson
modal nWgt (Left $ SomeRoute $ AdminAvsUserR uuid)
avsPersonCardCell :: (IsDBTable m c) => Set AvsDataPersonCard -> DBCell m c
avsPersonCardCell cards = wgtCell

8
src/Handler/Utils/Table/Columns.hs
View File

@ -336,6 +336,10 @@ colUserNameLinkHdr colHeader userLink = sortable (Just "user-name") (i18nCell co
colUserNameModalHdr :: (IsDBTable m c, HasEntity a User, RenderMessage UniWorX msg) => msg -> (CryptoUUIDUser -> Route UniWorX) -> Colonnade Sortable a (DBCell m c)
colUserNameModalHdr colHeader userLink = sortable (Just "user-name") (i18nCell colHeader) (cellHasUserModal userLink)
-- | like `colUserNameModalHdr` but without checking access rights before displaying the link (no risk, but non-admins may see links that are unusable for them)
colUserNameModalHdrAdmin :: (IsDBTable m c, HasEntity a User, RenderMessage UniWorX msg) => msg -> (CryptoUUIDUser -> Route UniWorX) -> Colonnade Sortable a (DBCell m c)
colUserNameModalHdrAdmin colHeader userLink = sortable (Just "user-name") (i18nCell colHeader) (cellHasUserModalAdmin userLink)
-- | Intended to work with @nameWidget@, showing highlighter Surname within Displayname
sortUserName :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t r')
sortUserName = ("user-name",) . sortUserNameBare
@ -442,8 +446,8 @@ fltrUserMatriculationUI :: DBFilterUI
fltrUserMatriculationUI mPrev = prismAForm (singletonFilter "user-matriculation") mPrev $ aopt textField (fslI MsgTableUserMatriculation)
colUserMatriclenr :: (IsDBTable m c, HasEntity a User) => Colonnade Sortable a (DBCell m c)
colUserMatriclenr = sortable (Just "user-matriclenumber") (i18nCell MsgTableMatrikelNr) cellHasMatrikelnummerLinked
colUserMatriclenr :: (IsDBTable m c, HasEntity a User) => Bool -> Colonnade Sortable a (DBCell m c)
colUserMatriclenr isAdmin = sortable (Just "user-matriclenumber") (i18nCell MsgTableMatrikelNr) $ cellHasMatrikelnummerLinked isAdmin
sortUserMatriclenr :: IsString d => (t -> E.SqlExpr (Entity User)) -> (d, SortColumn t r')
sortUserMatriclenr queryUser = ("user-matriclenumber", SortColumn $ queryUser >>> (E.^. UserMatrikelnummer))

7
src/Handler/Utils/Widgets.hs
View File

@ -123,15 +123,14 @@ editedByW fmt tm usr = do
[whamlet|_{MsgUtilEditedBy usr ft}|]
-- | like `modal`, but checks access rights to the link
modalAccess :: Bool -> Widget -> Widget -> Route UniWorX -> Widget
modalAccess writeAccess wdgtYes wdgtNo route = do
-- | like `modal`, but only conditionally displays the modal link only after checking access rights. WARNING: this might be too slow for large dbTable. Use `modalAccessCheckOnClick` instead
modalAccess :: Widget -> Widget -> Bool -> Route UniWorX -> Widget
modalAccess wdgtNo wdgtYes writeAccess route = do
authOk <- liftHandler $ bool hasReadAccessTo hasWriteAccessTo writeAccess route
if authOk
then modal wdgtYes (Left $ SomeRoute route)
else wdgtNo
----------
-- HEAT --
----------

2
src/Utils/Frontend/Modal.hs
View File

@ -40,7 +40,7 @@ customModal Modal{..} = do
-- | Create a link to a modal, does not check link, see `Handler.Utils.Widget.modalAccess` for a checking variant
modal :: WidgetFor site () -- ^ Widget that represents the link
-> Either (SomeRoute site) (WidgetFor site ()) -- ^ Modal contant: either dynamic link or static widget
-> Either (SomeRoute site) (WidgetFor site ()) -- ^ Modal content: either dynamic link or static widget
-> WidgetFor site () -- ^ result widget
modal modalTrigger' modalContent = customModal Modal{..}
where