chore(mail): view page for receivers working now and polished

messages/uniworx/categories/courses/courses/de-de-formal.msg

@@ -70,9 +70,9 @@ CourseInvalidInput: Eingaben bitte korrigieren.
 CourseEditTitle: Kursart editieren/anlegen
 CourseEditOk       tid@TermId ssh@SchoolId csh@CourseShorthand: Kursart #{tid}-#{ssh}-#{csh} wurde erfolgreich geändert.
 CourseEditDupShort tid@TermId ssh@SchoolId csh@CourseShorthand: Kursart #{tid}-#{ssh}-#{csh} konnte nicht geändert werden: Es gibt bereits einen andere Kursart mit dem selben Kürzel oder Titel in diesem Jahr und Bereich.
-CourseEditQualificationFail: Eine Qualifikation konnte uas unbekanntem Grund nicht mit diesem Kurs assoziert werden.
+CourseEditQualificationFail: Eine Qualifikation konnte uas unbekanntem Grund nicht mit diesem Kurs assoziiert werden.
-CourseEditQualificationFailRights qsh@QualificationShorthand ssh@SchoolId: Qualifikation #{qsh} konnte nicht mit diesem Kurs assoziert werden, da Ihre Berechtigungen für Bereich #{ssh} dazu nicht ausreichen.
+CourseEditQualificationFailRights qsh@QualificationShorthand ssh@SchoolId: Qualifikation #{qsh} konnte nicht mit diesem Kurs assoziiert werden, da Ihre Berechtigungen für Bereich #{ssh} dazu nicht ausreichen.
-CourseEditQualificationFailExists: Diese Qualifikation ist bereits assoziert
+CourseEditQualificationFailExists: Diese Qualifikation ist bereits assoziiert
 CourseEditQualificationFailOrder: Diese Sortierpriorität existiert bereits
 CourseLecturer: Kursverwalter:in
 MailSubjectParticipantInvitation tid@TermId ssh@SchoolId csh@CourseShorthand: [#{tid}-#{ssh}-#{csh}] Einladung zur Kursartteilnahme

messages/uniworx/categories/courses/exam/exam/de-de-formal.msg

@@ -223,7 +223,7 @@ ExamRegisteredCountOf num@Int64 count@Int64 !ident-ok: #{num}/#{count}
 ExamOccurrences: Termine
 ExamOccurrencesCopied num@Int: #{pluralDEeN num "Prüfungstermin"} kopiert 
 ExamOccurrencesEdited num@Int del@Int: #{pluralENsN num "Prüfungstermin"} geändert #{guardMonoid (del > 0) ("und " <> pluralENsN num "Prüfungstermin" <> " gelöscht")}
-ExamOccurrenceCopyNoStartDate: Dieser Kurs hat noch keine eigene Termine um Prüfungstermine zeitlich damit zu assozieren
+ExamOccurrenceCopyNoStartDate: Dieser Kurs hat noch keine eigene Termine um Prüfungstermine zeitlich damit zu assoziieren
 ExamOccurrenceCopyFail: Keine passenden Prüfungstermine zum Kopieren gefunden
 GradingFrom: Ab
 ExamNoShow: Nicht erschienen

messages/uniworx/categories/firm/de-de-formal.msg

@@ -81,3 +81,5 @@ CompanyUserPriorityTip: Firmenpriorität ist lediglich relativ zu anderen Firmen
 CompanyUserUseCompanyAddress: Verwendet Firmenkontaktaddresse
 CompanyUserUseCompanyAddressTip: sofern im Benutzer keine Postanschrift hinterlegt ist
 CompanyUserUseCompanyPostalError: Postalische Adresse muss leer bleiben, damit die Firmenanschrift genutzt wird!
+CompanySupervisorCompanyMissing fsh@CompanyShorthand: Empfänger ist nicht mit Firma #{fsh} aus Ansprechpartnerbeziehung assoziiert
+CompanySuperviseeCompanyMissing fsh@CompanyShorthand: Betroffener ist nicht mit Firma #{fsh} aus Ansprechpartnerbeziehung assoziiert

messages/uniworx/categories/firm/en-eu.msg

@@ -81,3 +81,5 @@ CompanyUserPriorityTip: Company priority is relative to other company associatio
 CompanyUserUseCompanyAddress: Use company postal address
 CompanyUserUseCompanyAddressTip: if and only if the postal address of the user is empty
 CompanyUserUseCompanyPostalError: Individual postal address must left empty for the company address to be used!
+CompanySupervisorCompanyMissing fsh: Reciver is not associated with #{fsh} given as reroute reason
+CompanySuperviseeCompanyMissing fsh: Supervisee is not associated with #{fsh} detailed as supervisonship reason

messages/uniworx/categories/settings/personal_settings/en-eu.msg

@@ -36,7 +36,7 @@ ProfileSuperviseeRemark n m: This person supervises #{pluralENsN n "person"}#{no
 
 UserTelephone: Phone
 UserMobile: Mobile
-Company: Company affilitaion
+Company: Company affiliation
 CompanyPersonalNumber: Personnel number
 CompanyPersonalNumberFraport: Personnel number (Fraport AG only)
 CompanyDepartment: Department

messages/uniworx/categories/user/de-de-formal.msg

@@ -117,4 +117,5 @@ UserCompanyReason: Begründung der Firmenassoziation
 UserCompanyReasonTooltip: Optionale Notiz für besondere Fälle. Kann ggf. autmatische Entfernung bei AVS Firmenwechsel verhindern.
 UserSupervisorReason: Begründung Ansprechpartner
 UserSupervisorReasonTooltip: Optionale Notiz für besondere Fälle. Kann ggf. autmatische Entfernung bei AVS Firmenwechsel verhindern.
+UserSupervisorCompany: Ansprechpartner wegen Firma
 AdminUserAllNotifications: Alle Benachrichtigungen and diesen Benutzer

messages/uniworx/categories/user/en-eu.msg

@@ -117,4 +117,5 @@ UserCompanyReason: Reason for company association
 UserCompanyReasonTooltip: Optional note for special cases. In some case this may prevent automatic removel upon AVS user company changes.
 UserSupervisorReason: Reason for supervision
 UserSupervisorReasonTooltip: Optional note for special cases. In some case this may prevent automatic removel upon AVS user company changes.
+UserSupervisorCompany: Supervisor for company
 AdminUserAllNotifications: All notification sent to this user

src/Handler/Profile.hs

@@ -1130,7 +1130,7 @@ mkSupervisorsTable uid = dbTableWidget' validator DBTable{..}
             in  if isReroute
                   then iconCell IconReroute <> blankCell <> cellMailPrefPin (row ^. resultUser)
                   else mempty
-        , sortable (Just "cshort")      (i18nCell MsgTableCompany) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorCompany -> mc) -> maybeCell mc (\(unCompanyKey -> c) -> anchorCell (FirmUsersR c) $ citext2widget c)
+        , sortable (Just "cshort")      (i18nCell MsgTableCompany) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorCompany -> mc) -> maybeCell mc companyIdCell
         , sortable (Just "reason")      (i18nCell MsgTableReason)  $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorReason  -> mr) -> maybeCell mr textCell
         ]
     validator = def & defaultSorting [ SortAscBy "cshort", SortAscBy "user-name" ]
@@ -1180,7 +1180,7 @@ mkSuperviseesTable userPrefersPostal uid = dbTableWidget' validator DBTable{..}
         , sortable (Just "reroute") (i18nCell MsgTableRerouteActive) $ \row ->
             let isReroute = row ^. resultUserSupervisor . _entityVal ._userSupervisorRerouteNotifications
             in  boolCell isReroute $ iconCell IconReroute <> iconCellLetterOrEmail
-        , sortable (Just "cshort")      (i18nCell MsgTableCompany)  $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorCompany -> mc) -> maybeCell mc (\(unCompanyKey -> c) -> anchorCell (FirmUsersR c) $ citext2widget c)
+        , sortable (Just "cshort")      (i18nCell MsgTableCompany)  $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorCompany -> mc) -> maybeCell mc companyIdCell
         , sortable (Just "reason")      (i18nCell MsgTableReason)   $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorReason  -> mr) -> maybeCell mr textCell
         ]
     validator = def & defaultSorting [ SortAscBy "cshort", SortAscBy "user-name" ]
@@ -1213,8 +1213,8 @@ instance HasUser TblReceiverData where
   hasUser = _dbrOutput . _1 . _entityVal
 
 -- | Table listing all supervisor of the given user
-mkReceiversTable :: UserId -> [Entity User] -> DB Widget
+mkReceiversTable :: UserId -> [CompanyShorthand] -> [Entity User] -> DB Widget
-mkReceiversTable uid receivers = dbTableDB' validator DBTable{..}
+mkReceiversTable uid usrCmps receivers = dbTableDB' validator DBTable{..}
   where
     dbtIdent = "receivers" :: Text
     dbtStyle = def
@@ -1240,6 +1240,7 @@ mkReceiversTable uid receivers = dbTableDB' validator DBTable{..}
     dbtColonnade = mconcat
         [ colUserNameModalHdr MsgCommRecipients ForProfileDataR
         -- , colUserEmail
+        -- , colUserLetterEmailPin
         , sortable Nothing (i18nCell MsgAddress) $ \(view resultReceiver -> rcvr) -> sqlCell $ -- recall: requires dbTableDB' above!
             getPostalPreferenceAndAddress' rcvr >>= \case
               (False, _, (Just eml, auto)) -> do -- email
@@ -1259,39 +1260,49 @@ mkReceiversTable uid receivers = dbTableDB' validator DBTable{..}
                       #{postal}
                   |]
               _ -> return $ msg2widget MsgNoContactAddress
-        , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \(view $ resultReceiver . _entityKey -> ruid) -> sqlCell
+        , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \row -> sqlCell $ do
-            (maybeMonoid <$> wgtCompanies ruid) -- TODO: user wgtCompanies' to check mismatch in companies
+            let ruid = row ^. resultReceiver . _entityKey
-        -- , colUserLetterEmailPin
+                rcmp = row ^? resultReceiverSupervisor . _entityVal . _userSupervisorCompany . _Just . to unCompanyKey
-        -- , sortable (Just "rerouted")    (i18nCell MsgTableRerouteActive)  $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorRerouteNotifications -> b) -> indicatorCell <> ifIconCell b IconReroute
+                errWgt fsh = let emsg = MsgCompanySupervisorCompanyMissing fsh
-        -- , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal)       $ \(view $ resultUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b
+                             in [whamlet|^{messageTooltip =<< messageI Error emsg} _{emsg}|]
-        -- , sortable (Just "reroute") (i18nCell MsgTableRerouteActive) $ \row ->
+            cmps <- wgtCompanies' ruid
-        --     let isReroute = row ^. resultUserSupervisor . _entityVal ._userSupervisorRerouteNotifications
+            return $ case (cmps, rcmp) of
-        --     in  if isReroute
+              (Just (cwgt, cmpsData), Just svcsh)
-        --           then iconCell IconReroute <> blankCell <> cellMailPrefPin (row ^. resultUser)
+                | svcsh `notElem` (cmpsData ^.. traverse . _1) ->
-        --           else mempty
+                    [whamlet|$newline never
-        , sortable (Just "cshort")      (i18nCell MsgTableCompany) $ \(preview $ resultReceiverSupervisor . _entityVal . _userSupervisorCompany . _Just -> mc) -> maybeCell mc (\(unCompanyKey -> c) -> anchorCell (FirmUsersR c) $ citext2widget c)
+                      <ul .list--iconless>
-        , sortable (Just "reason")      (i18nCell MsgTableReason)  $ \(preview $ resultReceiverSupervisor . _entityVal . _userSupervisorReason  . _Just -> mr) -> maybeCell mr textCell
+                        ^{cwgt}
+                      <p>
+                        ^{errWgt svcsh}
+                    |]
+              (Just (cwgt,_),_) -> [whamlet|<ul .list--iconless>^{cwgt}|]
+              (Nothing, Just svcsh) -> errWgt svcsh
+              (Nothing, Nothing) -> mempty
+        , sortable (Just "reason")      (i18nCell MsgUserSupervisorReason)  $ \(preview $ resultReceiverSupervisor . _entityVal . _userSupervisorReason  . _Just -> mr) -> maybeCell mr textCell
+        , sortable (Just "cshort")      (i18nCell MsgUserSupervisorCompany) $ \row ->
+            let mc = row ^? resultReceiverSupervisor . _entityVal . _userSupervisorCompany . _Just
+                errWgt fsh = let emsg = MsgCompanySuperviseeCompanyMissing fsh
+                             in [whamlet|<p>^{messageTooltip =<< messageI Error emsg} _{emsg}|]
+            in case mc of
+                Nothing -> mempty
+                (Just sfid@(unCompanyKey -> sfsh))
+                  | notNull usrCmps
+                  , sfsh `notElem` usrCmps -> companyIdCell sfid <> wgtCell (errWgt sfsh)
+                  | otherwise ->              companyIdCell sfid
         ]
     validator = def -- & defaultSorting [ SortAscBy "cshort", SortAscBy "user-name" ]
     dbtSorting = Map.fromList
         [ sortUserNameLink        queryReceiver
         -- , sortUserLetterEmailPin  queryReceiver
-        , sortUserEmail           queryReceiver
+        -- , sortUserEmail           queryReceiver
         , ("user-company"     , SortColumn (\row -> E.subSelect $ do
               (cmp :& usrCmp) <- E.from $ E.table @Company `E.innerJoin` E.table @UserCompany `E.on` (\(cmp :& usrCmp) -> cmp E.^. CompanyId E.==. usrCmp E.^. UserCompanyCompany)
               E.where_ $ usrCmp E.^. UserCompanyUser E.==. queryReceiver row E.^. UserId
               E.orderBy [E.asc $ cmp E.^. CompanyName]
               return (cmp E.^. CompanyName)
             ))
-        -- , singletonMap "postal-pref"  $ SortColumn $ queryUser            >>> (E.^. UserPrefersPostal)
-        -- , singletonMap "rerouted"     $ SortColumn $ queryUserSupervisor  >>> (E.^. UserSupervisorRerouteNotifications)
-        -- -- , singletonMap "reroute"      $ SortColumn $ queryUserSupervisor &&& queryUser >>> (\(spr,usr) ->  mTuple (spr E.^. UserSupervisorRerouteNotifications) (usr E.^. UserPrefersPostal))
-        -- , singletonMap "reroute"      $ SortColumns  $ \row ->
-        --     [ SomeExprValue $ queryUserSupervisor row E.^. UserSupervisorRerouteNotifications
-        --     , SomeExprValue $ queryUser           row E.^. UserPrefersPostal
-        --     ]
-        , ("cshort", SortColumn $ queryReceiverSupervisor  >>> (E.?. UserSupervisorCompany))
         , ("reason", SortColumn $ queryReceiverSupervisor  >>> (E.?. UserSupervisorReason))
+        , ("cshort", SortColumn $ queryReceiverSupervisor  >>> (E.?. UserSupervisorCompany))
         ]
     dbtFilter  = mconcat
         [ singletonMap & uncurry $ fltrUserNameEmail queryReceiver
@@ -1458,16 +1469,18 @@ postLangR = do
 getUserRecipientsR :: CryptoUUIDUser -> Handler Html
 getUserRecipientsR uuid = do
   uid <- decrypt uuid
-  (usr, receivers, usrReceives) <- updateReceivers uid -- if this is two due to the AVS queries, try Handler.Utils.getReceivers instead
+  (usr, receivers, usrReceives) <- updateReceivers uid    -- use Handler.Utils.getReceivers instead to avoid AVS queries
   mrtbl <- case receivers of
             []                -> return Nothing -- no receivers
             [_] | usrReceives -> return Nothing -- only user receives for themself
-            _ -> Just <$> runDB (mkReceiversTable uid receivers)
+            _ -> runDB $ do
+              usrCmps <- wgtCompanies' uid
+              let fshs :: [CompanyShorthand] = usrCmps ^.. _Just . _2 . traverse . _1
+              rtbl <- mkReceiversTable uid fshs receivers
+              return $ Just (rtbl, fst <$> usrCmps)
   let heading = MsgUserRecipientsTitle $ usr ^. _userDisplayName
-      usrWgt = userWidget usr
+      usrWgt  = userWidget usr
-      hasPwd = isJust $ usr ^. _userPinPassword
+      hasPwd  = isJust $ usr ^. _userPinPassword
   siteLayoutMsg heading $ do
     setTitleI heading
     $(i18nWidgetFile "user-receivers")
-    
-

src/Handler/Utils/Company.hs

@@ -2,6 +2,7 @@
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
+{-# LANGUAGE BlockArguments #-}         -- do starts is own block
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Handler.Utils.Company where
@@ -38,38 +39,40 @@ company2msg :: CompanyId -> SomeMessage UniWorX
 company2msg = text2message . ciOriginal . unCompanyKey
 
 wgtCompanies :: UserId -> DB (Maybe Widget)
-wgtCompanies = (fst <<$>>) . wgtCompanies'
+wgtCompanies = (wrapUL . fst <<$>>) . wgtCompanies'
+  where
+    wrapUL wgt = [whamlet|<ul .list--iconless>^{wgt}|]
 
--- | Given a UserId, create widgets showing top-companies (with internal link) and associated companies (unlinked)
+-- | Given a UserId, create widget showing top-companies (with internal link) and associated companies (unlinked)
-wgtCompanies' :: UserId -> DB (Maybe (Widget, [CompanyShorthand]))
+--   NOTE: The widget must be wrapped with <ul>
+wgtCompanies' :: UserId -> DB (Maybe (Widget, [(CompanyShorthand,CompanyName,Bool,Int)]))
 wgtCompanies' uid = do
-    companies <- E.select $ do
+    companies <- $(E.unValueN 4) <<$>> 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, topIds) = procCmp mPri companies
+    let (mPri, topCmp, otherCmp) = procCmp mPri companies
         resWgt =
           [whamlet|
             $forall c <- topCmp
-              <p>
+              <li>
                 ^{c}
             $forall c <- otherCmp
-              <p>
+              <li>
                 ^{c}
           |]
-    return $ toMaybe (notNull topCmp) (resWgt, topIds)
+    return $ toMaybe (notNull companies) (resWgt, companies)
   where
-    procCmp _ [] = (0, [], [], [])
+    procCmp _ [] = (0, [], [])
-    procCmp maxPri ((E.Value cmpSh, E.Value cmpName, E.Value cmpSpr, E.Value cmpPrio) : cs) =
+    procCmp maxPri ((cmpSh, cmpName, cmpSpr, cmpPrio) : cs) =
       let isTop  = cmpPrio >= maxPri
           cmpWgt = companyWidget isTop (cmpSh, cmpName, cmpSpr)
-          (accPri,accTop,accRem,accTopId) = procCmp maxPri cs
+          (accPri,accTop,accRem) = procCmp maxPri cs
       in  ( max cmpPrio accPri
           , bool           accTop  (cmpWgt : accTop)    isTop -- lazy evaluation after repmin example, don't factor out the bool!
           , bool (cmpWgt : accRem)           accRem     isTop
-          , bool           accTopId (cmpSh : accTopId)  isTop
           )
 
 type AnySuperReason = Either SupervisorReason (Maybe Text)

src/Handler/Utils/Table/Cells.hs

@@ -229,7 +229,7 @@ cellMailPrefPin usr =
       rwgt = do
               uuid <- liftHandler $ encrypt uid
               modal (widgetMailPrefPin userEntity) (Left $ SomeRoute $ UserRecipientsR uuid)
-  in cell rwgt -- addIconFixedWidth
+  in cell rwgt
 
 -- cellMailPrefPin :: (IsDBTable m a, HasUser u) => u -> DBCell m a
 -- cellMailPrefPin usr =

src/Handler/Utils/Widgets.hs

@@ -172,7 +172,7 @@ companyWidget isPrimary (csh, cname, isSupervisor)
       | isSupervisor = text2markup (corg <> " ")
       | otherwise    = text2markup  corg
 
-widgetMailPrefPin :: HasUser u => u -> Widget   -- TODO: move to appropriate module
+widgetMailPrefPin :: HasUser u => u -> Widget
 widgetMailPrefPin usr = if not prefPost && hasPin
     then [whamlet|^{modWgt} ^{pinWgt}|]
     else modWgt

src/Utils.hs

@@ -862,6 +862,11 @@ listBracket b@(s,e) (h:t)
       | e == h1   = Just $ reverse l1
       | otherwise = listUntil (h1:l1) t1
 
+-- Test whether two lists are disjoint. Not efficient due to lack of Ord instance.
+-- disjoint :: Eq a => [a] -> [a] -> Bool
+-- disjoint [] _ = True
+-- disjoint (x:xs) ys = x `notElem` ys && disjoint xs ys
+
 
 ----------
 -- Sets --

templates/i18n/user-receivers/de-de-formal.hamlet

@@ -19,9 +19,17 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
             gehen tatsächlich nur an die unten aufgeführten Personen:
         $nothing
             werden momentan an niemanden zugestellt!
-$maybe tbl <- mrtbl
+$maybe (tbl, mbUsrCmps) <- mrtbl
     <p>
         ^{tbl}
+    <p>        
+        $maybe usrCmps <- mbUsrCmps
+            <h4>
+                _{MsgCompany} ^{usrWgt}:
+            <ul .list--inline .list--comma-separated>
+                ^{usrCmps}
+        $nothing
+            Für ^{usrWgt} ist momentan keine Firmenzugehörigkeit bekannt.
     <p>
         <h4>
             Hinweis:

templates/i18n/user-receivers/en-eu.hamlet

@@ -18,9 +18,17 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
             are only sent to the following persons instead: 
         $nothing
             are currently not delivered to anyone! 
-$maybe tbl <- mrtbl
+$maybe (tbl, mbUsrCmps) <- mrtbl
     <p>
         ^{tbl}
+    <p>        
+        $maybe usrCmps <- mbUsrCmps
+            <h4>
+                _{MsgCompany} ^{usrWgt}:
+            <ul .list--inline .list--comma-separated>
+                ^{usrCmps}
+        $nothing
+            ^{usrWgt} is currently not affiliated with any company.
     <p> 
         <h4>
             Note:

test/Database/Fill.hs

@@ -695,7 +695,7 @@ fillDb = do
               , UserSupervisor jost jost              True  (Just fraportAg)  (Just "Staff")
               , UserSupervisor svaupel gkleen         False (Just nice)       (Just "Staff")
               , UserSupervisor svaupel fhamann        True  (Just nice)       (Just "Staff")
-              , UserSupervisor sbarth tinaTester      True  (Just nice)       (Just $ tshow SupervisorReasonAvsSuperior)
+              , UserSupervisor sbarth tinaTester      True  (Just fraportAg)  (Just $ tshow SupervisorReasonAvsSuperior)
               , UserSupervisor gkleen fhamann         False (Just fraGround)  (Just "Staff")
               , UserSupervisor gkleen gkleen          True  (Just fraGround)  (Just "Staff")
               , UserSupervisor tinaTester tinaTester  False Nothing           (Just "Staff")