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

contributes to #164

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                        

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
+  companies <- wgtCompanies uid
-      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'
   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      

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                        

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"
+      , 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"
-            companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
+          maybeMonoid <$> wgtCompanies uid
-              E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
+      , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
-              E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
+          (AdminUserR <$> encrypt uid)
-              E.orderBy [E.asc (comp E.^. CompanyName)]
+          (toWgt userCompanyPersonalNumber)
-              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 "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

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
+  

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

templates/profileData.hamlet

@@ -56,10 +56,10 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
         #{iconLetterOrEmail userPrefersPostal}
       $maybe addr <- actualPostAddress
         <dt .deflist__dt>
-          _{MsgAdminUserPostAddress}
+          _{MsgAdminUserPostAddress} #
-        <dd .deflist__dd>            
-          #{addr} #
           ^{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}
+        _{MsgUserDisplayEmail} #
-      <dd .deflist__dd>
+        ^{updateAutomatic emailAutomatic}
+      <dd .deflist__dd .email>
         $maybe primaryEmail <- actualDisplayEmail          
-          <p .email>
+          #{mailtoHtml primaryEmail}          
-            #{mailtoHtml primaryEmail} #
-          ^{updateAutomatic emailAutomatic}
         $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