chore(firm): only show/link primary company for a user in several places

contributes to #164
2024-06-10 18:40:58 +02:00 · 2024-06-10 18:40:58 +02:00 · e6c57035f9
commit e6c57035f9
parent bb101dee7b
7 changed files with 55 additions and 36 deletions
--- a/src/Handler/LMS.hs
+++ b/src/Handler/LMS.hs
@ -440,7 +440,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
    dbtSQLQuery = lmsTableQuery now qid
    dbtRowKey = queryUser >>> (E.^. UserId)
    dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, qUsrBlock, printAcks, validQ) -> do
-      cmpUsr <- selectList [UserCompanyUser ==. entityKey usr] [Asc UserCompanyCompany]
+      cmpUsr <- selectList [UserCompanyUser ==. entityKey usr] [Desc UserCompanyPriority, Asc UserCompanyCompany, LimitTo 1]
      return (qualUsr, usr, lmsUsr, qUsrBlock, printAcks, cmpUsr, validQ)
    dbtColonnade = cols cmpMap
    dbtSorting = mconcat
@ -619,7 +619,7 @@ postLmsR sid qsh = do
          [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUser . _entityKey))
          , colUserNameModalHdrAdmin MsgLmsUser AdminUserR
          , colUserEmail
-          , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) ->
+          , sortable (Just "user-company") (i18nCell MsgTableCompany) $ \( view resultCompanyUser -> cmps) ->
              let cs =  [ companyCell (unCompanyKey cmpId) cmpName cmpSpr
                        | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps
                        , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap                        
--- a/src/Handler/Profile.hs
+++ b/src/Handler/Profile.hs
@ -21,6 +21,7 @@ import Import
 import Handler.Utils
 import Handler.Utils.Profile
 import Handler.Utils.Users
+import Handler.Utils.Company

 import Utils.Print (validCmdArgument)

@ -599,12 +600,7 @@ makeProfileData usrEnt@(Entity uid User{..}) = do
      E.on $ studyfeat E.^. StudyFeaturesDegree   E.==. studydegree E.^. StudyDegreeId
      E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
      return  (studyfeat, studydegree, studyterms)
-  companies' <- E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
-      E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
-      E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid            
-      E.orderBy [E.asc (comp E.^. CompanyName)] -- E.desc (usrComp E.^. UserCompanySupervisor), 
-      return (comp E.^. CompanyShorthand, comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor)
-  let companies = intersperse (text2widget ", ") $ companyWidget . $(E.unValueN 3) <$> companies'
+  companies <- wgtCompanies uid
  supervisors' <- E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
      E.on $ spvr E.^. UserSupervisorSupervisor E.==. usrSpvr E.^. UserId
      E.where_ $ spvr E.^. UserSupervisorUser E.==. E.val uid      
--- a/src/Handler/Qualification.hs
+++ b/src/Handler/Qualification.hs
@ -378,7 +378,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
      --   E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val (entityKey usr)
      --   E.orderBy [E.asc (comp E.^. CompanyName)]
      --   return (comp E.^. CompanyName, comp E.^. CompanyAvsId, usrComp E.^. UserCompanySupervisor)
-      cmpUsr <- selectList [UserCompanyUser ==. entityKey usr] [Asc UserCompanyCompany]
+      cmpUsr <- selectList [UserCompanyUser ==. entityKey usr] [Desc UserCompanyPriority, Asc UserCompanyCompany, LimitTo 1]
      return (qualUsr, usr, lmsUsr, qUsrBlock, cmpUsr)
    dbtColonnade = cols cmpMap
    dbtSorting = mconcat
@ -578,7 +578,7 @@ postQualificationR sid qsh = do
          [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
          , colUserNameModalHdr MsgLmsUser linkUserName
          , colUserEmail          
-          , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) ->
+          , sortable (Just "user-company") (i18nCell MsgTableCompany) $ \( view resultCompanyUser -> cmps) ->
              let cs =  [ companyCell (unCompanyKey cmpId) cmpName cmpSpr
                        | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps
                        , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap                        
--- a/src/Handler/Users.hs
+++ b/src/Handler/Users.hs
@ -17,6 +17,7 @@ import Handler.Utils
 import Handler.Utils.Users
 import Handler.Utils.Invitations
 import Handler.Utils.Avs
+import Handler.Utils.Company

 import qualified Auth.LDAP as Auth

@ -107,19 +108,11 @@ postUsersR = do
          (AdminUserR <$> encrypt uid)
          (nameWidget userDisplayName userSurname)
      , 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
-              E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
-              E.orderBy [E.asc (comp E.^. CompanyName)]
-              return (comp E.^. CompanyShorthand, comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor)            
-            let icnSuper  = toWidget $ text2markup " " <> icon IconSupervisor
-                companies = 
-                  (\(E.Value cmpSh, E.Value cmpName, E.Value cmpSpr) -> simpleLink (citext2widget cmpName) (FirmUsersR cmpSh) <> bool mempty icnSuper cmpSpr) <$> companies'
-            pure $ intercalate (text2widget "; ") companies
-      -- , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
-      --     (AdminUserR <$> encrypt uid)
-      --     (toWgt userCompanyPersonalNumber)
+      , sortable (Just "user-company") (i18nCell MsgTableCompanies)   $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ liftHandler $ runDB $ -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX"
+          maybeMonoid <$> wgtCompanies uid
+      , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
+          (AdminUserR <$> encrypt uid)
+          (toWgt userCompanyPersonalNumber)
      , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \DBRow{ dbrOutput = Entity _uid User{..} } -> cellMaybe textCell userCompanyPersonalNumber
      , sortable (Just "company-department") (i18nCell MsgCompanyDepartment)  $ \DBRow{ dbrOutput = Entity _uid User{..} } -> cellMaybe textCell userCompanyDepartment
 --       , sortable (Just "last-name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
--- a/src/Handler/Utils.hs
+++ b/src/Handler/Utils.hs
@ -193,4 +193,9 @@ msgAdminProblem AdminProblemUnknown{adminProblemText=err} = return $
  someMessages ["Problem: ", err]  

 updateAutomatic :: Bool -> Widget
-updateAutomatic = iconTooltip [whamlet|_{MsgNoAutomaticUpdateTip}|] (Just IconLocked)
+-- updateAutomatic = iconTooltip [whamlet|_{MsgNoAutomaticUpdateTip}|] (Just IconLocked)
+updateAutomatic True  = mempty
+updateAutomatic False = do
+  msg <- messageIconI Warning IconLocked MsgNoAutomaticUpdateTip
+  messageTooltip msg
+  
--- a/src/Handler/Utils/Company.hs
+++ b/src/Handler/Utils/Company.hs
@ -13,17 +13,43 @@ import Import
 -- import qualified Data.Text as Text
 import Database.Persist.Postgresql

-- import           Database.Esqueleto.Experimental ((:&)(..))
+import           Database.Esqueleto.Experimental ((:&)(..))
 import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
 import qualified Database.Esqueleto.Utils        as E
 import qualified Database.Esqueleto.PostgreSQL   as E

 import Handler.Utils.Users
-
+import Handler.Utils.Widgets

 company2msg :: CompanyId -> SomeMessage UniWorX
 company2msg = text2message . ciOriginal . unCompanyKey

+wgtCompanies :: UserId -> DB (Maybe Widget)
+wgtCompanies = \uid -> do
+    companies <- E.select $ do 
+      (usrComp :& comp) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @Company
+        `E.on` (\(usrComp :& comp) -> usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId)
+      E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
+      E.orderBy [E.asc (comp E.^. CompanyName)]
+      return (comp E.^. CompanyShorthand, comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor, usrComp E.^. UserCompanyPriority)
+    let (mPri, topCmp, otherCmp) = procCmp mPri companies
+        resWgt = 
+          [whamlet|
+            $forall c <- topCmp
+              <p>
+                ^{c}
+            $forall c <- otherCmp
+              <p>
+                #{c}
+          |]
+    return $ toMaybe (notNull topCmp) resWgt
+  where 
+    procCmp _ [] = (0, [],[])
+    procCmp maxPri ((E.Value cmpSh, E.Value cmpName, E.Value cmpSpr, E.Value cmpPrio) : cs) =
+      let cmpWgt = companyWidget (cmpSh, cmpName, cmpSpr)
+          isTop  = cmpPrio >= maxPri
+          (accPri,accTop,accRem) = procCmp maxPri cs
+      in (max cmpPrio accPri, bool accTop (cmpWgt : accTop) isTop, bool (cmpName : accRem) accRem isTop) -- lazy evaluation after repmin example

 -- TODO: use this function in company view Handler.Firm #157
 -- | add all company supervisors for a given users
--- a/templates/profileData.hamlet
+++ b/templates/profileData.hamlet
@ -56,10 +56,10 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
        #{iconLetterOrEmail userPrefersPostal}
      $maybe addr <- actualPostAddress
        <dt .deflist__dt>
-          _{MsgAdminUserPostAddress}
-        <dd .deflist__dd>            
-          #{addr} #
+          _{MsgAdminUserPostAddress} #
          ^{updateAutomatic postalAutomatic}
+        <dd .deflist__dd>            
+          #{addr}
        $if (not postalAutomatic)
          $maybe postUpdate <- userPostLastUpdate
            <dt .deflist__dt>
@ -67,12 +67,11 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
            <dd .deflist__dd>
              ^{formatTimeW SelFormatDateTime postUpdate}
      <dt .deflist__dt>
-        _{MsgUserDisplayEmail}
-      <dd .deflist__dd>
+        _{MsgUserDisplayEmail} #
+        ^{updateAutomatic emailAutomatic}
+      <dd .deflist__dd .email>
        $maybe primaryEmail <- actualDisplayEmail          
-          <p .email>
-            #{mailtoHtml primaryEmail} #
-          ^{updateAutomatic emailAutomatic}
+          #{mailtoHtml primaryEmail}          
        $nothing
          ^{messageTooltip tooltipInvalidEmail} #
          #{mailtoHtml userDisplayEmail}          
@ -110,11 +109,11 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
          _{MsgCompanyPersonalNumber}
        <dd .deflist__dd>
          #{companyPersonalNumber}          
-      $if not $ null companies
+      $maybe compWgt <- companies
        <dt .deflist__dt>
          _{MsgCompany}
        <dd .deflist__dd>
-          ^{mconcat companies}
+          ^{compWgt}
      $if numSupervisors > 0
        <dt .deflist__dt>_{MsgProfileSupervisor}
          $if numSupervisors > 3