diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 944e8321e..db45e0f11 100644 --- 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 diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 0b16e8d5e..7defa02c9 100644 --- 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 diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 93bb5048e..91a105146 100644 --- 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 diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 912e614ac..5b3701cf2 100644 --- 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 diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index faf9df267..917a27e2c 100644 --- 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) \ No newline at end of file +-- updateAutomatic = iconTooltip [whamlet|_{MsgNoAutomaticUpdateTip}|] (Just IconLocked) +updateAutomatic True = mempty +updateAutomatic False = do + msg <- messageIconI Warning IconLocked MsgNoAutomaticUpdateTip + messageTooltip msg + \ No newline at end of file diff --git a/src/Handler/Utils/Company.hs b/src/Handler/Utils/Company.hs index a5d90c0cb..634bf6143 100644 --- 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 +

+ ^{c} + $forall c <- otherCmp +

+ #{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 diff --git a/templates/profileData.hamlet b/templates/profileData.hamlet index 8a97391f9..29c852786 100644 --- 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

- _{MsgAdminUserPostAddress} -
- #{addr} # + _{MsgAdminUserPostAddress} # ^{updateAutomatic postalAutomatic} +
+ #{addr} $if (not postalAutomatic) $maybe postUpdate <- userPostLastUpdate
@@ -67,12 +67,11 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
^{formatTimeW SelFormatDateTime postUpdate}
- _{MsgUserDisplayEmail} -
+ _{MsgUserDisplayEmail} # + ^{updateAutomatic emailAutomatic} +
$maybe primaryEmail <- actualDisplayEmail -

- #{mailtoHtml primaryEmail} # - ^{updateAutomatic emailAutomatic} + #{mailtoHtml primaryEmail} $nothing ^{messageTooltip tooltipInvalidEmail} # #{mailtoHtml userDisplayEmail} @@ -110,11 +109,11 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later _{MsgCompanyPersonalNumber}

#{companyPersonalNumber} - $if not $ null companies + $maybe compWgt <- companies
_{MsgCompany}
- ^{mconcat companies} + ^{compWgt} $if numSupervisors > 0
_{MsgProfileSupervisor} $if numSupervisors > 3