From 39a4ebef2a484927d3169f0ab98b4c39f5b142f3 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 6 Feb 2025 19:02:04 +0100 Subject: [PATCH] chore(mail): add modal computing actual receivers at postal pref columns --- .../uniworx/categories/print/de-de-formal.msg | 2 +- .../uniworx/categories/user/de-de-formal.msg | 1 + messages/uniworx/categories/user/en-eu.msg | 1 + messages/uniworx/misc/de-de-formal.msg | 4 +- messages/uniworx/misc/en-eu.msg | 4 +- .../navigation/breadcrumbs/de-de-formal.msg | 1 + .../utils/navigation/breadcrumbs/en-eu.msg | 1 + routes | 1 + src/Foundation/Navigation.hs | 1 + src/Handler/Profile.hs | 150 +++++++++++++++++- src/Handler/Users.hs | 2 + src/Handler/Utils/Company.hs | 20 ++- src/Handler/Utils/Table/Cells.hs | 25 ++- src/Handler/Utils/Table/Columns.hs | 2 +- src/Handler/Utils/Users.hs | 3 +- src/Handler/Utils/Widgets.hs | 9 ++ test/Database/Fill.hs | 14 +- 17 files changed, 215 insertions(+), 26 deletions(-) diff --git a/messages/uniworx/categories/print/de-de-formal.msg b/messages/uniworx/categories/print/de-de-formal.msg index f14def9d8..0a6f96a23 100644 --- a/messages/uniworx/categories/print/de-de-formal.msg +++ b/messages/uniworx/categories/print/de-de-formal.msg @@ -17,7 +17,7 @@ PrintJobReprint n@Int m@Int: #{n}/#{m} #{pluralDE n "Druckauftrag" "Druckaufräg PrintJobAcknowledgeFailed: Keine Druckaufträge bestätigt aufgrund zwischenzeitlicher Änderungen. Bitte die Seite im Browser aktualisieren! PrintJobAcknowledgeQuestion n@Int d@Text: #{n} #{pluralDE n "Druckauftrag" "Druckaufräge"} vom #{d} als gedruckt und versendet bestätigen? PrintJobAcknowledgements: Versanddatum von Briefen an -PrintRecipient: Empfänger +PrintRecipient: Empfänger:innen PrintAffected: Betroffener PrintSender !ident-ok: Sender PrintCourse: Kursarten diff --git a/messages/uniworx/categories/user/de-de-formal.msg b/messages/uniworx/categories/user/de-de-formal.msg index 737e627bf..7d93442d5 100644 --- a/messages/uniworx/categories/user/de-de-formal.msg +++ b/messages/uniworx/categories/user/de-de-formal.msg @@ -43,6 +43,7 @@ SynchroniseAvsAllUsersQueued n@Int64: AVS-Synchronisation von allen #{n} #{plura SynchroniseLdapUserQueued n@Int: LDAP-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen, die Ausführung wird mehrere Minuten benötigen! SynchroniseLdapAllUsersQueued: LDAP-Synchronisation von allen Benutzer:innen angestoßen, die Ausführung kann eine Weile brauchen! UserListTitle: Komprehensive Benutzerliste +UserRecipientsTitle name@Text: Benachrichtigungsempfänger für #{name} AccessRightsSaved: Berechtigungen erfolgreich verändert AccessRightsNotChanged: Berechtigungen wurden nicht verändert AuthLDAPLookupFailed: Nutzer:in konnte aufgrund eines LDAP-Fehlers nicht nachgeschlagen werden diff --git a/messages/uniworx/categories/user/en-eu.msg b/messages/uniworx/categories/user/en-eu.msg index 67ae441d8..61efbbb6d 100644 --- a/messages/uniworx/categories/user/en-eu.msg +++ b/messages/uniworx/categories/user/en-eu.msg @@ -43,6 +43,7 @@ SynchroniseAvsAllUsersQueued n: Triggered AVS synchronisation of all #{n} #{plur SynchroniseLdapUserQueued n: Triggered LDAP synchronisation of #{n} #{pluralEN n "user" "users"}, which may take several minutes to complete. SynchroniseLdapAllUsersQueued: Triggered LDAP synchronisation of all users, which may take quite a while to complete. UserListTitle: Comprehensive list of users +UserRecipientsTitle name: Notificationrecipients for #{name} AccessRightsSaved: Successfully updated permissions AccessRightsNotChanged: Permissions left unchanged AuthLDAPLookupFailed: User could not be looked up due to a LDAP error diff --git a/messages/uniworx/misc/de-de-formal.msg b/messages/uniworx/misc/de-de-formal.msg index c243c42f9..e4bc92fa3 100644 --- a/messages/uniworx/misc/de-de-formal.msg +++ b/messages/uniworx/misc/de-de-formal.msg @@ -39,4 +39,6 @@ Unknown: ist unbekannt UnknownOrNotAllowed: ist unbekannt oder hier nicht erlaubt Ambiguous: ist uneindeutig Action: Aktion -For: für \ No newline at end of file +For: für +Address: Adresse +NoContactAddress: Keinerlei Kontaktdaten bekannt! \ No newline at end of file diff --git a/messages/uniworx/misc/en-eu.msg b/messages/uniworx/misc/en-eu.msg index f12710a69..3d13cc994 100644 --- a/messages/uniworx/misc/en-eu.msg +++ b/messages/uniworx/misc/en-eu.msg @@ -39,4 +39,6 @@ Unknown: is unknown UnknownOrNotAllowed: is unknown or not allowed here Ambiguous: is ambiguous Action: Action -For: for \ No newline at end of file +For: for +Address: Address +NoContactAddress: No contact details known! \ No newline at end of file diff --git a/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg b/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg index 9087f1ca0..649db00c6 100644 --- a/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg @@ -71,6 +71,7 @@ BreadcrumbError: Fehler BreadcrumbUpload !ident-ok: Upload BreadcrumbUserAdd: Benutzer:in anlegen BreadcrumbUserNotifications: Benachrichtigungs-Einstellungen +BreadcrumbUserRecipients: Benachrichtigungs-Empfänger BreadcrumbUserPassword: Passwort BreadcrumbAdminHeading !ident-ok: Administration BreadcrumbAdminFeaturesHeading: Studiengänge diff --git a/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg b/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg index 5a473fe1e..920bb3624 100644 --- a/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg +++ b/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg @@ -71,6 +71,7 @@ BreadcrumbError: Error BreadcrumbUpload: Upload BreadcrumbUserAdd: Add user BreadcrumbUserNotifications: Notification settings +BreadcrumbUserRecipients: Notification recipients BreadcrumbUserPassword: Password BreadcrumbAdminHeading: Administration BreadcrumbAdminFeaturesHeading: Features of study diff --git a/routes b/routes index e1edeb0a2..678c11c49 100644 --- a/routes +++ b/routes @@ -58,6 +58,7 @@ /users/#CryptoUUIDUser/hijack AdminHijackUserR GET POST !adminANDno-escalation /users/#CryptoUUIDUser/notifications UserNotificationR GET POST !self /users/#CryptoUUIDUser/password UserPasswordR GET POST !selfANDis-pw-hash +/users/#CryptoUUIDUser/recipients UserRecipientsR GET !self !/users/functionary-invite/new AdminNewFunctionaryInviteR GET POST !/users/functionary-invite AdminFunctionaryInviteR GET POST !/users/add AdminUserAddR GET POST diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 1f310ec3b..f1eb8b462 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -103,6 +103,7 @@ breadcrumb (UserPasswordR cID) = useRunDB $ do -> i18nCrumb MsgMenuUserPassword . Just $ AdminUserR cID | otherwise -> i18nCrumb MsgMenuUserPassword $ Just ProfileR +breadcrumb (UserRecipientsR cID) = i18nCrumb MsgBreadcrumbUserRecipients . Just $ AdminUserR cID breadcrumb AdminNewFunctionaryInviteR = i18nCrumb MsgMenuLecturerInvite $ Just UsersR breadcrumb AdminFunctionaryInviteR = i18nCrumb MsgBreadcrumbFunctionaryInvite Nothing diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index a538160af..833b8564c 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -14,11 +14,13 @@ module Handler.Profile , getSetDisplayEmailR, postSetDisplayEmailR , getCsvOptionsR, postCsvOptionsR , postLangR + , getUserRecipientsR ) where import Import import Handler.Utils +import Handler.Utils.Avs import Handler.Utils.AvsUpdate import Handler.Utils.Profile import Handler.Utils.Users @@ -1125,9 +1127,8 @@ mkSupervisorsTable uid = dbTableWidget' validator DBTable{..} -- , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b , sortable (Just "reroute") (i18nCell MsgTableRerouteActive) $ \row -> let isReroute = row ^. resultUserSupervisor . _entityVal ._userSupervisorRerouteNotifications - isLetter = row ^. resultUser . _userPrefersPostal in if isReroute - then iconCell IconReroute <> spacerCell <> iconFixedCell (iconLetterOrEmail isLetter) + 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 "reason") (i18nCell MsgTableReason) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorReason -> mr) -> maybeCell mr textCell @@ -1205,6 +1206,102 @@ mkSuperviseesTable userPrefersPostal uid = dbTableWidget' validator DBTable{..} dbtExtraReps = [] +type TblReceiverData = DBRow (Entity User, Maybe (Entity UserSupervisor)) +instance HasEntity TblReceiverData User where + hasEntity = _dbrOutput . _1 +instance HasUser TblReceiverData where + hasUser = _dbrOutput . _1 . _entityVal + +-- | Table listing all supervisor of the given user +mkReceiversTable :: UserId -> [Entity User] -> DB Widget +mkReceiversTable uid receivers = dbTableDB' validator DBTable{..} + where + dbtIdent = "receivers" :: Text + dbtStyle = def + + queryReceiver :: E.SqlExpr (Entity User) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity UserSupervisor)) -> E.SqlExpr (Entity User) + queryReceiver = $(E.sqlLOJproj 2 1) + queryReceiverSupervisor :: E.SqlExpr (Entity User) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity UserSupervisor)) -> E.SqlExpr (Maybe (Entity UserSupervisor)) + queryReceiverSupervisor = $(E.sqlLOJproj 2 2) + + resultReceiver :: Lens' TblReceiverData (Entity User) + resultReceiver = _dbrOutput . _1 + resultReceiverSupervisor :: Traversal' TblReceiverData (Entity UserSupervisor) + resultReceiverSupervisor = _dbrOutput . _2 . _Just + + dbtSQLQuery (usr `E.LeftOuterJoin` spr) = do + EL.on $ spr E.?. UserSupervisorSupervisor E.?=. usr E.^. UserId + E.&&. spr E.?. UserSupervisorUser E.?=. E.val uid + E.where_ $ usr E.^. UserId `E.in_` E.vals (entityKey <$> receivers) + return (usr, spr) + dbtRowKey (usr `E.LeftOuterJoin` _) = usr E.^. UserId + dbtProj = dbtProjId + + dbtColonnade = mconcat + [ colUserNameModalHdr MsgCommRecipients ForProfileDataR + -- , colUserEmail + , sortable Nothing (i18nCell MsgAddress) $ \(view resultReceiver -> rcvr) -> sqlCell $ -- recall: requires dbTableDB' above! + getPostalPreferenceAndAddress' rcvr >>= \case + (False, _, (Just eml, auto)) -> do -- email + return [whamlet| +

+ ^{widgetMailPrefPin rcvr} # + ^{updateAutomatic auto} # +

+ #{mailtoHtml eml} + |] + (True, (Just postal, auto), _) -> do -- postal + return [whamlet| +

+ ^{widgetMailPrefPin rcvr} # + ^{updateAutomatic auto} +

+ #{postal} + |] + _ -> return $ msg2widget MsgNoContactAddress + , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \(view $ resultReceiver . _entityKey -> ruid) -> sqlCell + (maybeMonoid <$> wgtCompanies ruid) -- TODO: user wgtCompanies' to check mismatch in companies + -- , colUserLetterEmailPin + -- , sortable (Just "rerouted") (i18nCell MsgTableRerouteActive) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorRerouteNotifications -> b) -> indicatorCell <> ifIconCell b IconReroute + -- , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b + -- , sortable (Just "reroute") (i18nCell MsgTableRerouteActive) $ \row -> + -- let isReroute = row ^. resultUserSupervisor . _entityVal ._userSupervisorRerouteNotifications + -- in if isReroute + -- then iconCell IconReroute <> blankCell <> cellMailPrefPin (row ^. resultUser) + -- else mempty + , sortable (Just "cshort") (i18nCell MsgTableCompany) $ \(preview $ resultReceiverSupervisor . _entityVal . _userSupervisorCompany . _Just -> mc) -> maybeCell mc (\(unCompanyKey -> c) -> anchorCell (FirmUsersR c) $ citext2widget c) + , sortable (Just "reason") (i18nCell MsgTableReason) $ \(preview $ resultReceiverSupervisor . _entityVal . _userSupervisorReason . _Just -> mr) -> maybeCell mr textCell + ] + validator = def -- & defaultSorting [ SortAscBy "cshort", SortAscBy "user-name" ] + dbtSorting = Map.fromList + [ sortUserNameLink queryReceiver + -- , sortUserLetterEmailPin 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)) + ] + dbtFilter = mconcat + [ singletonMap & uncurry $ fltrUserNameEmail queryReceiver + ] + dbtFilterUI = mempty + dbtParams = def + dbtCsvEncode = noCsvEncode + dbtCsvDecode = Nothing + dbtExtraReps = [] + getAuthPredsR, postAuthPredsR :: Handler Html getAuthPredsR = postAuthPredsR postAuthPredsR = do @@ -1356,3 +1453,52 @@ postLangR = do addMessage Success . toHtml $ mr MsgLanguageChanged redirect . fromMaybe NewsR =<< lookupGlobalGetParam GetReferer + + +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 + mrtbl <- case receivers of + [] -> return Nothing -- no receivers + [_] | usrReceives -> return Nothing -- only user receives for themself + _ -> Just <$> runDB (mkReceiversTable uid receivers) + let heading = MsgUserRecipientsTitle $ usr ^. _userDisplayName + usrWgt = userWidget usr + hasPwd = isJust $ usr ^. _userPinPassword + siteLayoutMsg heading $ do + setTitleI heading -- TODO: translate to i18nWidgetFile + [whamlet| +

+

+ Benachrichtigungen für ^{usrWgt} ^{widgetMailPrefPin usr} # + $if usrReceives + gehen # + $maybe _ <- mrtbl + ebenfalls an die unten aufgeführten Personen: + $nothing + nur an diese Person selbst. + $else + $maybe _ <- mrtbl + gehen tatsächlich nur an die unten aufgeführten Personen: + $nothing + werden momentan an niemanden zugestellt! + $maybe tbl <- mrtbl +

+ ^{tbl} +

+

+ Hinweise: + Mit welchem Passwort PDF Anhänge geschützt werden, hängt von der Nachricht ab. # + + Zum Beispiel werden Pin Briefe für ablaufende Qualifikationen # + $if hasPwd + mit dem Passwort von ^{usrWgt} geschützt. # + $else + nicht geschützt, da kein Pin Passwort gesetzt ist. # + + Für andere Benachrichtigungen wird meist das Passwort des tatsächlichen Empfängers gewählt, sofern eins gesetzt wurde. + + Die Voreinstellung für das PDF Passwort ist die Hauptausweisnummer, inklusive Punkt. + |] + diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 76e1a2507..aafdacd02 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -132,6 +132,7 @@ postUsersR = do , sortable (Just "last-login") (i18nCell MsgLastLogin) $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastAuthentication , sortable (Just "auth-ldap") (i18nCell MsgAuthMode) $ \DBRow{ dbrOutput = Entity _ User{..} } -> i18nCell userAuthentication , colUserEmail + , colUserLetterEmailPin , sortable (Just "ldap-sync") (i18nCell MsgLdapSynced) $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastLdapSynchronisation , flip foldMap universeF $ \function -> sortable (Just $ SortingKey $ CI.mk $ toPathPiece function) (i18nCell function) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do @@ -223,6 +224,7 @@ postUsersR = do ) | function <- universeF ] ++ [ sortUserEmail id + , sortUserLetterEmailPin id , ( "name" , SortColumn (E.^. UserSurname) ) diff --git a/src/Handler/Utils/Company.hs b/src/Handler/Utils/Company.hs index 792119e63..21f9a4ef8 100644 --- a/src/Handler/Utils/Company.hs +++ b/src/Handler/Utils/Company.hs @@ -38,14 +38,18 @@ company2msg :: CompanyId -> SomeMessage UniWorX company2msg = text2message . ciOriginal . unCompanyKey wgtCompanies :: UserId -> DB (Maybe Widget) -wgtCompanies = \uid -> do +wgtCompanies = (fst <<$>>) . wgtCompanies' + +-- | Given a UserId, create widgets showing top-companies (with internal link) and associated companies (unlinked) +wgtCompanies' :: UserId -> DB (Maybe (Widget, [CompanyShorthand])) +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 + let (mPri, topCmp, otherCmp, topIds) = procCmp mPri companies resWgt = [whamlet| $forall c <- topCmp @@ -55,14 +59,18 @@ wgtCompanies = \uid -> do

^{c} |] - return $ toMaybe (notNull topCmp) resWgt + return $ toMaybe (notNull topCmp) (resWgt, topIds) where - procCmp _ [] = (0, [], []) + procCmp _ [] = (0, [], [], []) procCmp maxPri ((E.Value cmpSh, E.Value cmpName, E.Value cmpSpr, E.Value cmpPrio) : cs) = let isTop = cmpPrio >= maxPri cmpWgt = companyWidget isTop (cmpSh, cmpName, cmpSpr) - (accPri,accTop,accRem) = procCmp maxPri cs - in (max cmpPrio accPri, bool accTop (cmpWgt : accTop) isTop, bool (cmpWgt : accRem) accRem isTop) -- lazy evaluation after repmin example, don't factor out the bool! + (accPri,accTop,accRem,accTopId) = 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) diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 652e58936..a4d0480f7 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -32,6 +32,9 @@ spacerCell = cell [whamlet| |] semicolonCell :: IsDBTable m a => DBCell m a semicolonCell = cell [whamlet|; |] +blankCell :: IsDBTable m a => DBCell m a +blankCell = textCell " " + -- | Contribute to DBResult. BEWARE: only shown cells are executed; pagination makes tellCell useless for rowcounts; instead use dbtProj for computations on all rows regardless of pagination tellCell :: IsDBTable m a => a -> DBCell m a -> DBCell m a tellCell = flip mappend . writerCell . tell @@ -116,7 +119,7 @@ iconBoolCell :: IsDBTable m a => Bool -> DBCell m a iconBoolCell = cell . toWidget . boolSymbol ifIconCell :: IsDBTable m a => Bool -> Icon -> DBCell m a -ifIconCell True = iconCell +ifIconCell True = iconFixedCell . icon ifIconCell False = const iconSpacerCell addIconFixedWidth :: IsDBTable m a => DBCell m a -> DBCell m a @@ -218,12 +221,22 @@ emailCell :: IsDBTable m a => CI Text -> DBCell m a emailCell email = cell $(widgetFile "widgets/link-email") where linkText= toWgt email -cellMailPrefPin :: (IsDBTable m a, HasUser u) => u -> DBCell m a + +cellMailPrefPin :: (IsDBTable m a, HasEntity u User) => u -> DBCell m a cellMailPrefPin usr = - iconFixedCell (iconLetterOrEmail prefPost) <> ifIconCell (not prefPost && hasPin) IconPinProtect - where - prefPost = usr ^. _userPrefersPostal - hasPin = isJust (usr ^. _userPinPassword) + let userEntity = usr ^. hasEntityUser + uid = userEntity ^. _entityKey + rwgt = do + uuid <- liftHandler $ encrypt uid + modal (widgetMailPrefPin userEntity) (Left $ SomeRoute $ UserRecipientsR uuid) + in cell rwgt -- addIconFixedWidth + +-- cellMailPrefPin :: (IsDBTable m a, HasUser u) => u -> DBCell m a +-- cellMailPrefPin usr = +-- iconFixedCell (iconLetterOrEmail prefPost) <> blankCell <> ifIconCell (not prefPost && hasPin) IconPinProtect +-- where +-- prefPost = usr ^. _userPrefersPostal +-- hasPin = isJust (usr ^. _userPinPassword) cellHasUser :: (IsDBTable m c, HasUser a) => a -> DBCell m c cellHasUser = liftA2 userCell (view _userDisplayName) (view _userSurname) diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index 54dbd304e..3f10b313e 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -495,7 +495,7 @@ fltrUserEmailUI mPrev = -- | Icon column showing whether the user prefers emails, and if so, whether a pdf password is set -colUserLetterEmailPin :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c) +colUserLetterEmailPin :: (IsDBTable m c, HasEntity a User) => Colonnade Sortable a (DBCell m c) colUserLetterEmailPin = sortable (Just "user-mail-pref-pin") (i18nCell MsgPrefersPostal) cellMailPrefPin sortUserLetterEmailPin :: IsString d => (t -> E.SqlExpr (Entity User)) -> (d, SortColumn t r') diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index 6e62c4aa6..7fbb3ee0d 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -91,7 +91,8 @@ getUserPrimaryCompanyAddress uid prj = runMaybeT $ do MaybeT $ pure $ prj company --- | result (True, Nothing, Nothing) indicates that neither userEmail nor userPostAddress is known +-- | Compute actual address for user; returning True for Postal preference, as well as address (user or company) and primary e-mail +-- result (True, Nothing, Nothing) indicates that neither userEmail nor userPostAddress is known getPostalPreferenceAndAddress :: Entity User -> DB (Bool, Maybe [Text], Maybe UserEmail) getPostalPreferenceAndAddress usr = do pa <- getPostalAddress usr diff --git a/src/Handler/Utils/Widgets.hs b/src/Handler/Utils/Widgets.hs index fe93cc9c8..c19ae4393 100644 --- a/src/Handler/Utils/Widgets.hs +++ b/src/Handler/Utils/Widgets.hs @@ -172,6 +172,15 @@ companyWidget isPrimary (csh, cname, isSupervisor) | isSupervisor = text2markup (corg <> " ") | otherwise = text2markup corg +widgetMailPrefPin :: HasUser u => u -> Widget -- TODO: move to appropriate module +widgetMailPrefPin usr = if not prefPost && hasPin + then [whamlet|^{modWgt} ^{pinWgt}|] + else modWgt + where + prefPost :: Bool = usr ^. _userPrefersPostal + hasPin :: Bool = isJust (usr ^. _userPinPassword) + modWgt :: Widget = toWidget $ iconLetterOrEmail prefPost + pinWgt :: Widget = toWidget iconPinProtect --------------------- -- Status Tooltips -- diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 676ced98a..b4bfb264d 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -645,13 +645,13 @@ fillDb = do I am aware that violations in the form plagiarism or collaboration with third parties will lead to expulsion from the course. |] } - fraportAg <- insert' $ Company "Fraport AG" "Fraport" 1 True (Just $ markdownToStoredMarkup ("Frankfurt Airport Services Worldwide\n60547 Frankfurt am Main"::Text)) (Just "fraport@fraport.de") - fraGround <- insert' $ Company "Fraport Ground Handling Professionals GmbH" "FraGround" 2 True (Just $ markdownToStoredMarkup ("Sauerbierstraße 772 \nBürokomplex 80/C/1\n112233 Nieder-Tupfing-Hohen-Kreisingen\nTöpferbezirk"::Text)) Nothing - nice <- insert' $ Company "N*ICE Aircraft Services & Support GmbH" "N*ICE" 33 False (Just $ markdownToStoredMarkup ("69 Nevermore Blvd.\nHarlaemn\nNew York\nUSA"::Text)) (Just "badguy@nice.com") - ffacil <- insert' $ Company "Fraport Facility Services GmbH" "GCS" 44 False Nothing $ Just "gcs@gcs.com" - bpol <- insert' $ Company "Bundespolizeidirektion Flughafen Frankfurt am Main" "BPol" 5555 False Nothing Nothing - _noone <- insert' $ Company "Vollautomaten GmbH" "NoOne" 3 True Nothing Nothing - randComps <- insertMany [Company rcName rcShort n neven Nothing Nothing | n <- [1001..2002] + fraportAg <- insert' $ Company "Fraport AG" "Fraport" 1 True (Just $ markdownToStoredMarkup ("Frankfurt Airport Services Worldwide\n60547 Frankfurt am Main"::Text)) (Just "fraport@fraport.de") False + fraGround <- insert' $ Company "Fraport Ground Handling Professionals GmbH" "FraGround" 2 True (Just $ markdownToStoredMarkup ("Sauerbierstraße 772 \nBürokomplex 80/C/1\n112233 Nieder-Tupfing-Hohen-Kreisingen\nTöpferbezirk"::Text)) Nothing True + nice <- insert' $ Company "N*ICE Aircraft Services & Support GmbH" "N*ICE" 33 False (Just $ markdownToStoredMarkup ("69 Nevermore Blvd.\nHarlaemn\nNew York\nUSA"::Text)) (Just "badguy@nice.com") False + ffacil <- insert' $ Company "Fraport Facility Services GmbH" "GCS" 44 False Nothing(Just "gcs@gcs.com") True + bpol <- insert' $ Company "Bundespolizeidirektion Flughafen Frankfurt am Main" "BPol" 5555 False Nothing Nothing False + _noone <- insert' $ Company "Vollautomaten GmbH" "NoOne" 3 True Nothing Nothing True + randComps <- insertMany [Company rcName rcShort n neven Nothing Nothing True | n <- [1001..2002] , let neven = even n , let rcName = CI.mk $ "Random Corp " <> tshow n <> bool "" " GmbH" (even n) , let rcShort = CI.mk $ "RC" <> tshow n