refactor(performance): disable modalAccess use for known admins

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

src/Handler/Admin/Avs.hs

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

src/Handler/Course/Users.hs

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

src/Handler/Exam/Users.hs

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

src/Handler/Firm.hs

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

src/Handler/LMS.hs

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

src/Handler/Qualification.hs

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

src/Handler/Tutorial/Users.hs

@@ -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   colUserEmail
-          , pure  colUserMatriclenr
+          , pure $ colUserMatriclenr isAdmin
           , pure $ colUserQualifications nowaday
           , pure $ colUserQualificationBlocked isAdmin nowaday
           ]

src/Handler/Users.hs

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

src/Handler/Utils/Table/Cells.hs

@@ -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 :: (IsDBTable m a, HasEntity u User) => Bool -> u -> DBCell m a
-cellHasMatrikelnummerLinked usr 
+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 

src/Handler/Utils/Table/Columns.hs

@@ -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 ::  (IsDBTable m c, HasEntity a User) => Bool -> Colonnade Sortable a (DBCell m c)
-colUserMatriclenr = sortable (Just "user-matriclenumber") (i18nCell MsgTableMatrikelNr) cellHasMatrikelnummerLinked
+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))

src/Handler/Utils/Widgets.hs

@@ -123,15 +123,14 @@ editedByW fmt tm usr  = do
   [whamlet|_{MsgUtilEditedBy usr ft}|]
 
 
--- | like `modal`, but checks access rights to the link
+-- | 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 :: Bool -> Widget -> Widget -> Route UniWorX -> Widget
+modalAccess :: Widget -> Widget -> Bool -> Route UniWorX -> Widget
-modalAccess writeAccess wdgtYes wdgtNo route = do
+modalAccess wdgtNo wdgtYes writeAccess route = do
   authOk <- liftHandler $ bool hasReadAccessTo hasWriteAccessTo writeAccess route
   if authOk
     then modal wdgtYes (Left $ SomeRoute route)
     else       wdgtNo
 
-
 ----------
 -- HEAT --
 ----------

src/Utils/Frontend/Modal.hs

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