From 09d10e1ba2a935cc85658201cc6dff54e67a30d9 Mon Sep 17 00:00:00 2001 From: Steffen Date: Fri, 8 Mar 2024 18:06:52 +0100 Subject: [PATCH] refactor(user): empty postal uses high priority company address instead working --- models/company.model | 2 +- models/users.model | 2 +- src/Handler/Admin.hs | 4 +- src/Handler/Admin/Test.hs | 2 +- src/Handler/Firm.hs | 7 +++- src/Handler/Profile.hs | 8 +++- src/Handler/Utils/Avs.hs | 2 + src/Handler/Utils/Users.hs | 55 +++++++++++++++++++------ src/Utils/DB.hs | 3 +- src/Utils/Icon.hs | 9 +++- src/Utils/Mail.hs | 2 +- src/Utils/Print.hs | 80 +++++++++++++++--------------------- templates/profileData.hamlet | 33 +++++++++------ test/Database/Fill.hs | 24 +++++------ 14 files changed, 136 insertions(+), 97 deletions(-) diff --git a/models/company.model b/models/company.model index 6986b1af6..7cf61bb5e 100644 --- a/models/company.model +++ b/models/company.model @@ -10,7 +10,7 @@ Company avsId Int default=0 -- primary key from avs, use negative numbers for non-AVS companies prefersPostal Bool default=false -- new company users prefers letters by post instead of email postAddress StoredMarkup Maybe -- default company postal address, including company name - email UserEmail Maybe -- Case-insensitive generic company eMail address + email UserEmail Maybe -- Case-insensitive generic company eMail address UniqueCompanyName name -- UniqueCompanyShorthand shorthand -- unnecessary, since it is the primary key already UniqueCompanyAvsId avsId diff --git a/models/users.model b/models/users.model index 9b19db75f..a2b03cc67 100644 --- a/models/users.model +++ b/models/users.model @@ -46,7 +46,7 @@ User json -- Each Uni2work user has a corresponding row in this table; create companyDepartment Text Maybe -- thus we store such information for ease of reference directly, if available pinPassword Text Maybe -- used to encrypt pins within emails postAddress StoredMarkup Maybe -- including company name, if any, but excluding username; leave empty for using auto-update CompanyPostAddress via UserCompany - postLastUpdate UTCTime Maybe -- record postal address updates + postLastUpdate UTCTime Maybe -- record postal address updates prefersPostal Bool default=false -- user prefers letters by post instead of email examOfficeGetSynced Bool default=true -- whether synced status should be displayed for exam results by default examOfficeGetLabels Bool default=true -- whether labels should be displayed for exam results by default diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index fd001c768..6d011bc68 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -168,9 +168,9 @@ retrieveUnreachableUsers = do E.where_ $ E.isNothing (user E.^. UserPostAddress) E.&&. (E.isNothing (user E.^. UserCompanyDepartment) E.||. user E.^. UserCompanyPersonalNumber `E.ilike` E.justVal "E%") return user - return $ filter hasInvalidEmail emailOnlyUsers + filterM hasInvalidEmail emailOnlyUsers where - hasInvalidEmail = isNothing . getEmailAddress . entityVal + hasInvalidEmail = fmap isNothing . getEmailAddress allDriversHaveAvsId :: UTCTime -> DB Bool diff --git a/src/Handler/Admin/Test.hs b/src/Handler/Admin/Test.hs index 1969f8717..50b670d2e 100644 --- a/src/Handler/Admin/Test.hs +++ b/src/Handler/Admin/Test.hs @@ -354,7 +354,7 @@ getAdminTestPdfR = do , isReminder = False } apcIdent <- letterApcIdent letter encRecipient now - renderLetterPDF usr letter apcIdent >>= \case + renderLetterPDF usr letter apcIdent Nothing >>= \case Left err -> sendResponseStatus internalServerError500 $ "PDF generation failed: \n" <> err Right pdf -> do liftIO $ LBS.writeFile "/tmp/generated.pdf" pdf diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 8c25f0572..32655b867 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -28,7 +28,8 @@ import qualified Data.Map as Map -- import qualified Data.Text as T import qualified Data.CaseInsensitive as CI -- import qualified Data.Conduit.List as C -import Database.Persist.Sql (deleteWhereCount, updateWhereCount) +-- import Database.Persist.Sql (deleteWhereCount, updateWhereCount) +import Database.Persist.Postgresql import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma import qualified Database.Esqueleto.Legacy as EL (on) @@ -161,7 +162,9 @@ firmActionHandler route isAdmin = flip formResult faHandler addMessageI Warning MsgFirmActAddSupersEmpty reloadKeepGetParams route runDB $ do - putMany [UserCompany uid cid True firmActAddSupervisorReroute | uid <- usersFound] + -- putMany [UserCompany uid cid True firmActAddSupervisorReroute 0 False | uid <- usersFound] -- putMany always overwrites existing records, which would destroy priority and useCompanyAddress here + -- upsertManyWhere [UserCompany uid cid True firmActAddSupervisorReroute 0 False | uid <- usersFound] [copyField UserCompanySupervisor, copyField UserCompanySupervisorReroute] [] [] -- overwrite Supervisor and SupervisorReroute, keep priority and useCompanyAddress + upsertManyWhere [UserCompany uid cid True firmActAddSupervisorReroute 0 False | uid <- usersFound] [] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. firmActAddSupervisorReroute] [] -- identical to previous line, but perhaps more clear? whenIsJust firmActAddSupervisorPostal $ \prefPostal -> updateWhere [UserId <-. usersFound] [UserPrefersPostal =. prefPostal] addMessageI Success $ MsgFirmActAddSupersSet (fromIntegral $ length usersFound) firmActAddSupervisorPostal diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 85a6a2a52..8429c04c7 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -20,6 +20,7 @@ import Import import Handler.Utils import Handler.Utils.Profile +import Handler.Utils.Users import Utils.Print (validCmdArgument) @@ -583,9 +584,12 @@ getForProfileDataR cID = do dataWidget makeProfileData :: Entity User -> DB Widget -makeProfileData (Entity uid User{..}) = do +makeProfileData usrEnt@(Entity uid User{..}) = do now <- liftIO getCurrentTime - avsId <- entityVal <<$>> getBy (UniqueUserAvsUser uid) + avsId <- entityVal <<$>> getBy (UniqueUserAvsUser uid) + (actualPrefersPostal, actualPostAddress, actualDisplayEmail) <- getPostalPreferenceAndAddress' usrEnt + let postalAutomatic = isJust actualPostAddress && isNothing userPostAddress -- address is either from company or department + emailAutomatic = isJust actualDisplayEmail && not (validEmail' userDisplayEmail) functions <- Map.fromListWith Set.union . map (\(Entity _ UserFunction{..}) -> (userFunctionFunction, Set.singleton userFunctionSchool)) <$> selectList [UserFunctionUser ==. uid] [] lecture_corrector <- E.select $ E.distinct $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index bdf1a3fd5..3f57a9f51 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -494,9 +494,11 @@ updateAvsUserByIds apids = do eml_new = (newAvsFirmInfo ^. _avsFirmPrimaryEmail) <|> (newAvsPersonInfo ^. _avsInfoPersonEMail) in mkUpdate usr eml_new eml_old $ CheckAvsUpdate UserDisplayEmail $ to (fromMaybe mempty) . from _CI -- Maybe nicht im User, aber im AvsInfo PROBLEM: Hängt auch von der FirmenEmail ab und muss daher im Verbund betrachtet werden. + -- TODO: company address no longer stored with each individual user frm_ups = maybeEmpty oldAvsFirmInfo $ \oldAvsFirmInfo' -> mapMaybe (mkUpdate usr newAvsFirmInfo oldAvsFirmInfo') [ CheckAvsUpdate UserPostAddress _avsFirmPostAddress ] + usr_ups = mcons eml_up $ frm_ups <> per_ups avs_ups = ((UserAvsNoPerson =.) <$> readMay (avsInfoPersonNo newAvsPersonInfo)) `mcons` [ UserAvsLastSynch =. now diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index 73541a394..24cd181c5 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -16,7 +16,8 @@ module Handler.Utils.Users , UserAssimilateException(..), UserAssimilateExceptionReason(..) , assimilateUser , getEmailAddress - , getPostalAddress, getPostalPreferenceAndAddress + , getPostalAddress, getPostalAddress' + , getPostalPreferenceAndAddress, getPostalPreferenceAndAddress' , abbrvName , getReceivers, getReceiversFor , getSupervisees @@ -66,6 +67,16 @@ abbrvName User{userDisplayName, userFirstName, userSurname} = assemble = Text.intercalate "." +getUserCompanyAddress :: UserId -> (Company -> Maybe a) -> DB (Maybe a) +getUserCompanyAddress uid prj = runMaybeT $ do + Entity{entityVal=UserCompany{userCompanyCompany=cid}} <- MaybeT $ + selectFirst [UserCompanyUser ==. uid, UserCompanyUseCompanyAddress ==. True] + [Desc UserCompanyPriority, Desc UserCompanySupervisorReroute, Desc UserCompanySupervisor, Asc UserCompanyCompany] + company <- MaybeT $ get cid + -- hoistMaybe $ prj company + MaybeT $ pure $ prj company + + -- | result (True, Nothing, Nothing) indicates that neither userEmail nor userPostAddress is known getPostalPreferenceAndAddress :: Entity User -> DB (Bool, Maybe [Text], Maybe UserEmail) getPostalPreferenceAndAddress usr = do @@ -75,6 +86,17 @@ getPostalPreferenceAndAddress usr = do finalPref = (usrPrefPost && isJust pa) || isNothing em -- finalPref = isJust pa && (usrPrefPost || isNothing em) return (finalPref, pa, em) + +-- | result (True, Nothing, Nothing) indicates that neither userEmail nor userPostAddress is known +-- primed variant returns storedMarkup without prefixed userDisplayName +getPostalPreferenceAndAddress' :: Entity User -> DB (Bool, Maybe StoredMarkup, Maybe UserEmail) +getPostalPreferenceAndAddress' usr = do + pa <- getPostalAddress' usr + em <- getEmailAddress usr + let usrPrefPost = usr ^. _entityVal . _userPrefersPostal + finalPref = (usrPrefPost && isJust pa) || isNothing em + -- finalPref = isJust pa && (usrPrefPost || isNothing em) + return (finalPref, pa, em) getEmailAddress :: Entity User -> DB (Maybe UserEmail) @@ -83,26 +105,19 @@ getEmailAddress Entity{entityKey=uid, entityVal=User{userDisplayEmail, userEmail = return $ Just userDisplayEmail | otherwise = do - compEmailMb <- runMaybeT $ do - Entity{entityVal=UserCompany{userCompanyCompany=cid}} <- MaybeT $ selectFirst [UserCompanyUser ==. uid, UserCompanyUseCompanyAddress ==. True] [Desc UserCompanyPriority] - Company{companyEmail} <- MaybeT $ get cid - MaybeT $ return companyEmail + compEmailMb <- getUserCompanyAddress uid companyEmail return $ pickValidEmail' $ mcons compEmailMb [userEmail] - +-- address is prefixed with userDisplayName getPostalAddress :: Entity User -> DB (Maybe [Text]) getPostalAddress Entity{entityKey=uid, entityVal=User{..}} | Just pa <- userPostAddress = prefixMarkupName pa | otherwise = do - compAddrMb <- runMaybeT $ do - Entity{entityVal=UserCompany{userCompanyCompany=cid}} <- MaybeT $ selectFirst [UserCompanyUser ==. uid, UserCompanyUseCompanyAddress ==. True] [Desc UserCompanyPriority] - Company{companyPostAddress} <- MaybeT $ get cid - MaybeT $ return companyPostAddress - case compAddrMb of + getUserCompanyAddress uid companyPostAddress >>= \case (Just pa) - -> prefixMarkupName pa + -> prefixMarkupName pa Nothing | Just abt <- userCompanyDepartment -> return $ Just $ if | "BVD" `isPrefixOf` abt -> [userDisplayName, abt, "Bodenverkehrsdienste"] @@ -111,6 +126,22 @@ getPostalAddress Entity{entityKey=uid, entityVal=User{..}} where prefixMarkupName = return . Just . (userDisplayName :) . html2textlines +-- primed variant returns storedMarkup without prefixed userDisplayName +getPostalAddress' :: Entity User -> DB (Maybe StoredMarkup) +getPostalAddress' Entity{entityKey=uid, entityVal=User{..}} + | res@(Just _) <- userPostAddress + = return res + | otherwise + = do + getUserCompanyAddress uid companyPostAddress >>= \case + res@(Just _) + -> return res + Nothing + | Just abt <- userCompanyDepartment + -> return $ Just $ plaintextToStoredMarkup $ textUnlines $ + if | "BVD" `isPrefixOf` abt -> [userDisplayName, abt, "Bodenverkehrsdienste"] + | otherwise -> [userDisplayName, abt, "Hausbriefkasten" ] + | otherwise -> return Nothing -- | Consider using Handler.Utils.Avs.updateReceivers instead -- Return Entity User and all Supervisors with rerouteNotifications as well as diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs index d6dc8493e..9730b0678 100644 --- a/src/Utils/DB.hs +++ b/src/Utils/DB.hs @@ -44,7 +44,8 @@ fieldLensVal f = entityLens . fieldLens f getVal :: record -> Entity record getVal = Entity (error "fieldLensVal unexpectectly required an entity key") -- this is safe, since the lens is only used locally setVal :: record -> Entity record -> record - setVal _ = entityVal + -- setVal _ = entityVal + setVal = const -- TODO verify emptyOrIn :: PersistField typ diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index 07804c015..0ec91a144 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -118,6 +118,7 @@ data Icon | IconCompany | IconEdit | IconUserEdit + | IconMagic -- indicates automatic updates deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic) deriving anyclass (Universe, Finite, NFData) @@ -214,6 +215,7 @@ iconText = \case IconCompany -> "building" IconEdit -> "edit" IconUserEdit -> "user-edit" + IconMagic -> "wand-magic" nullaryPathPiece ''Icon $ camelToPathPiece' 1 deriveLift ''Icon @@ -291,11 +293,16 @@ isBad :: Bool -> Markup isBad True = icon IconProblem isBad False = mempty --- ^ Maybe display an icon that denotes that something™ is bad +-- ^ Maybe display an icon that denotes that something™ is new isNew :: Bool -> Markup isNew True = icon IconNew isNew False = mempty +-- ^ Maybe display an icon that denotes that something™ is automagically updated or derived +isAutomatic :: Bool -> Markup +isAutomatic True = icon IconMagic +isAutomatic False = mempty + boolSymbol :: Bool -> Markup boolSymbol True = icon IconOK boolSymbol False = icon IconNotOK diff --git a/src/Utils/Mail.hs b/src/Utils/Mail.hs index 487048f84..2e34c69b1 100644 --- a/src/Utils/Mail.hs +++ b/src/Utils/Mail.hs @@ -19,7 +19,7 @@ validEmail email = validRFC5322 && not invalidFraport where validRFC5322 = Email.isValid $ encodeUtf8 email invalidFraport = case Text.stripSuffix "@fraport.de" (foldCase email) of - Just fralogin -> Text.all Char.isDigit $ Text.drop 1 fralogin + Just fralogin -> Text.all Char.isDigit $ Text.drop 1 fralogin -- Emails like E1234@fraport.de or 012345!fraport.de are not read Nothing -> False validEmail' :: CI Text -> Bool -- UserEmail = CI Text diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index 104be74e6..e52eb7670 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -145,58 +145,41 @@ pdfLaTeX lk doc = do let writerOpts = def { P.writerExtensions = P.pandocExtensions , P.writerTemplate = Just tmpl } makePDF writerOpts $ appMeta setIsDeFromLang doc - -renderLetterPDF :: (MDLetter l) => Entity User -> l -> Text -> Handler (Either Text LBS.ByteString) -renderLetterPDF rcvrEnt@Entity{entityVal=rcvr} mdl apcIdent = do - rcvrPostal <- runDB $ getPostalAddress rcvrEnt - -- (_,rcvrPostal, rcvrEmail) <- runDB $ getPostalPreferenceAndAddress - renderLetterPDFto $ fromMaybe [rcvr & userDisplayName] rcvrPostal -renderLetterPDFto :: (MDLetter l) => [Text] -> Entity User -> l -> Text -> Handler (Either Text LBS.ByteString) -renderLetterPDFto rcvrPostal rcvrEnt@Entity{entityVal=rcvr} mdl apcIdent = do +letterTemplate :: (MDLetter l) => Entity User -> l -> Text -> Maybe [Text] -> Handler (Either Text P.Pandoc) +letterTemplate rcvrEnt@Entity{entityVal=rcvr} mdl apcIdent rcvrPostalRaw = do now <- liftIO getCurrentTime - formatter@DateTimeFormatter{ format } <- getDateTimeFormatterUser' rcvr - let lang = selectDeEn $ rcvr & userLanguages -- select either German or English only, default de; see Utils.Lang - kind = getLetterKind mdl - tmpl = getTemplate mdl + formatter@DateTimeFormatter{ format } <- getDateTimeFormatterUser' rcvr + rcvrPostal <- altM (return rcvrPostalRaw) $ runDB $ getPostalAddress rcvrEnt + -- (_,rcvrPostal, rcvrEmail) <- runDB $ getPostalPreferenceAndAddress + let lang = selectDeEn $ rcvr & userLanguages -- select either German or English only, default de; see Utils.Lang + tmpl = getTemplate mdl meta = addApcIdent apcIdent <> letterMeta mdl formatter lang rcvrEnt <> mkMeta [ -- toMeta "lang" lang -- receiver language is decided in MDLetter instance, since some letters have fixed languages toMeta "date" $ format SelFormatDate now , toMeta "rcvr-name" $ rcvr & userDisplayName - , toMeta "address" $ rcvrPostal + , toMeta "address" $ fromMaybe [rcvr & userDisplayName] $ canonical rcvrPostal + --, toMeta "rcvr-email" $ fromMaybe [rcvr & userDisplayEmail] rcvrEmail -- note that some templates use "email" already otherwise ] - e_md <- mdTemplating tmpl meta - actRight e_md $ pdfLaTeX kind + mdTemplating tmpl meta +renderLetterPDF :: (MDLetter l) => Entity User -> l -> Text -> Maybe [Text] -> Handler (Either Text LBS.ByteString) +renderLetterPDF rcvrEnt mdl apcIdent rcvrPostal = do + e_md <- letterTemplate rcvrEnt mdl apcIdent rcvrPostal + actRight e_md $ pdfLaTeX $ getLetterKind mdl -renderLetterHtml :: (MDLetter l) => Entity User -> l -> Text -> Handler (Either Text Html) -renderLetterHtml rcvrEnt@Entity{entityVal=rcvr} mdl apcIdent = do - now <- liftIO getCurrentTime - formatter@DateTimeFormatter{ format } <- getDateTimeFormatterUser' rcvr - rcvrPostal <- runDB $ getPostalAddress rcvrEnt - -- (_,rcvrPostal, rcvrEmail) <- runDB $ getPostalPreferenceAndAddress - let lang = selectDeEn $ rcvr & userLanguages -- select either German or English only, default de; see Utils.Lang - kind = getLetterKind mdl - tmpl = getTemplate mdl - meta = addApcIdent apcIdent - <> letterMeta mdl formatter lang rcvrEnt - <> mkMeta - [ -- toMeta "lang" lang -- receiver language is decided in MDLetter instance, since some letters have fixed languages - toMeta "date" $ format SelFormatDate now - , toMeta "rcvr-name" $ rcvr & userDisplayName - , toMeta "address" $ fromMaybe [rcvr & userDisplayName] rcvrPostal - --, toMeta "rcvr-email" $ fromMaybe [rcvr & userDisplayEmail] rcvrEmail -- note that some templates use "email" already otherwise - ] - e_md <- mdTemplating tmpl meta - actRight e_md $ \md -> pure . over _Left P.renderError . P.runPure $ do - html_tmpl <- compileTemplate $ templateHtml kind - -- html_tmpl <- ExceptT $ memcachedBy (Just . Right $ 6 * diffHour) ("LetterKind-Html: \n" <> tshow lk) (pure . over _Left P.renderError . P.runPure $ compileTemplate $ templateHtml lk) - let writerOpts = def { P.writerExtensions = P.pandocExtensions - , P.writerTemplate = Just html_tmpl } - P.writeHtml5 writerOpts $ appMeta setIsDeFromLang md +renderLetterHtml :: (MDLetter l) => Entity User -> l -> Text -> Maybe [Text] -> Handler (Either Text Html) +renderLetterHtml rcvrEnt mdl apcIdent rcvrPostal = do + e_md <- letterTemplate rcvrEnt mdl apcIdent rcvrPostal + actRight e_md $ \md -> pure . over _Left P.renderError . P.runPure $ do + html_tmpl <- compileTemplate $ templateHtml $ getLetterKind mdl + -- html_tmpl <- ExceptT $ memcachedBy (Just . Right $ 6 * diffHour) ("LetterKind-Html: \n" <> tshow lk) (pure . over _Left P.renderError . P.runPure $ compileTemplate $ templateHtml lk) + let writerOpts = def { P.writerExtensions = P.pandocExtensions + , P.writerTemplate = Just html_tmpl } + P.writeHtml5 writerOpts $ appMeta setIsDeFromLang md -- TODO: apcIdent does not make sense for multiple letters renderLetters :: (MDLetter l, Foldable f) => Entity User -> f l -> Text -> Handler (Either Text LBS.ByteString) @@ -243,7 +226,7 @@ printHtml _senderId (rcvr, letter) = do encRecipient :: CryptoUUIDUser <- encrypt rcvrId now <- liftIO getCurrentTime apcIdent <- letterApcIdent letter encRecipient now - renderLetterHtml rcvr letter apcIdent + renderLetterHtml rcvr letter apcIdent Nothing -- Only used in print-test-handler for PrintSendR printLetter :: (MDLetter l) => Maybe UserId -> (Entity User, l) -> Handler (Either Text (Text, FilePath)) @@ -252,7 +235,7 @@ printLetter senderId (rcvr, letter) = do encRecipient :: CryptoUUIDUser <- encrypt rcvrId now <- liftIO getCurrentTime apcIdent <- letterApcIdent letter encRecipient now - pdf <- renderLetterPDF rcvr letter apcIdent + pdf <- renderLetterPDF rcvr letter apcIdent Nothing let protoPji = getPJId letter pji = protoPji { pjiRecipient = Just rcvrId @@ -341,14 +324,14 @@ sendEmailOrLetter recipient letter = do mailSubject = mkMailSubject isSupervised encRecipient :: CryptoUUIDUser <- encrypt svr apcIdent <- letterApcIdent letter encRecipient now - postalPrefs <- getPostalPreferenceAndAddress rcvrEnt + postalPrefs <- runDB $ getPostalPreferenceAndAddress rcvrEnt case postalPrefs of (_, Nothing, Nothing) -> do -- neither email nor postal is known let msg = "Notification failed for " <> tshow encRecipient <> ", who has neither a known email nor postal address. Notification: " <> tshow pjid $logErrorS "LETTER" msg return False - (True , Just postal, _) -> renderLetterPDFto postal rcvrEnt letter apcIdent >>= \case -- send printed letter + (True, postal@(Just _), _) -> renderLetterPDF rcvrEnt letter apcIdent postal >>= \case -- send printed letter Left err -> do -- pdf generation failed let msg = "Notification failed for " <> tshow encRecipient <> ". PDF generation failed: "<> cropText err <> "For Notification: " <> tshow pjid $logErrorS "LETTER" msg @@ -364,7 +347,7 @@ sendEmailOrLetter recipient letter = do $logWarnS "LETTER" $ "PDF printing to send letter with lpr returned ExitSuccess and the following message: " <> msg return True - (False, _) | Just mkMail <- mkMailBody -> renderLetterPDF rcvrEnt letter apcIdent >>= \case -- send Email, but with pdf attached + (_, postal, _email) | Just mkMail <- mkMailBody -> renderLetterPDF rcvrEnt letter apcIdent postal >>= \case -- send Email with pdf attached Left err -> do -- pdf generation failed let msg = "Notification failed for " <> tshow encRecipient <> ". PDF attachment generation failed: "<> cropText err <> "For Notification: " <> tshow pjid $logErrorS "LETTER" msg @@ -384,6 +367,7 @@ sendEmailOrLetter recipient letter = do return pdf formatter <- getDateTimeFormatterUser' rcvrUsr -- not too expensive, only calls getTimeLocale let mailBody = mkMail formatter + -- userMailTdirect computes email address once more, hence _email is currently ignored userMailTdirect svr $ do replaceMailHeader "Auto-Submitted" $ Just "auto-generated" setSubjectI mailSubject @@ -395,7 +379,7 @@ sendEmailOrLetter recipient letter = do } :: PureFile) return True - (False, _) -> renderLetterHtml rcvrEnt letter apcIdent >>= \case -- send Email, render letter directly to html + (_, postal, _email) -> renderLetterHtml rcvrEnt letter apcIdent postal >>= \case -- send Email, render letter directly to html Left err -> do -- html generation failed let msg = "Notification failed for " <> tshow encRecipient <> ". HTML generation failed: "<> cropText err <> "For Notification: " <> tshow pjid $logErrorS "LETTER" msg @@ -403,9 +387,9 @@ sendEmailOrLetter recipient letter = do Right html -> do -- html generated, send directly now userMailTdirect svr $ do replaceMailHeader "Auto-Submitted" $ Just "auto-generated" - setSubjectI mailSubject + setSubjectI mailSubject addHtmlMarkdownAlternatives html - return True + return True return $ or oks diff --git a/templates/profileData.hamlet b/templates/profileData.hamlet index 8ab2bf8dd..b33419227 100644 --- a/templates/profileData.hamlet +++ b/templates/profileData.hamlet @@ -51,30 +51,37 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
_{MsgPrefersPostalExp}
+ $if userPrefersPostal /= actualPrefersPostal + ^{messageTooltip tooltipInvalidEmail} # #{iconLetterOrEmail userPrefersPostal} - $maybe addr <- userPostAddress + $maybe addr <- actualPostAddress
_{MsgAdminUserPostAddress}
+ #{isAutomatic postalAutomatic} # #{addr} - $maybe postUpdate <- userPostLastUpdate -
- _{MsgUserPostLastUpdate} -
- ^{formatTimeW SelFormatDateTime postUpdate} + $if (not postalAutomatic) + $maybe postUpdate <- userPostLastUpdate +
+ _{MsgUserPostLastUpdate} +
+ ^{formatTimeW SelFormatDateTime postUpdate}
_{MsgUserDisplayEmail}
- #{mailtoHtml userDisplayEmail} - $if not (validEmail' userDisplayEmail) - \ ^{messageTooltip tooltipInvalidEmail} - $if userEmail /= userDisplayEmail + $maybe primaryEmail <- actualDisplayEmail + #{isAutomatic emailAutomatic} # + #{mailtoHtml primaryEmail} + $nothing + ^{messageTooltip tooltipInvalidEmail} # + #{mailtoHtml userDisplayEmail} + $if Just userEmail /= actualDisplayEmail
_{MsgUserSystemEmail} -
+
+ $if not (validEmail' userEmail) + ^{messageTooltip tooltipInvalidEmail} # #{userEmail} - $if not (validEmail' userEmail) - \ ^{messageTooltip tooltipInvalidEmail}
_{MsgAdminUserPinPassword}
diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 6482d2bf2..12bd24c1a 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -655,19 +655,19 @@ fillDb = do , let rcName = CI.mk $ "Random Corp " <> tshow n <> bool "" " GmbH" (even n) , let rcShort = CI.mk $ "RC" <> tshow n ] - void . insert' $ UserCompany jost fraportAg True True - void . insert' $ UserCompany svaupel nice True False - void . insert' $ UserCompany gkleen nice False False - void . insert' $ UserCompany gkleen fraGround False True - void . insert' $ UserCompany fhamann bpol False False - void . insert' $ UserCompany fhamann ffacil True True - void . insert' $ UserCompany fhamann nice False False + void . insert' $ UserCompany jost fraportAg True True 0 False + void . insert' $ UserCompany svaupel nice True False 0 False + void . insert' $ UserCompany gkleen nice False False 1 True + void . insert' $ UserCompany gkleen fraGround False True 2 False + void . insert' $ UserCompany fhamann bpol False False 1 True + void . insert' $ UserCompany fhamann ffacil True True 2 True + void . insert' $ UserCompany fhamann nice False False 3 False -- need more tests - insertMany_ [UserCompany uid fraGround False False| Entity uid User{userFirstName = "John"} <- matUsers] - insertMany_ [UserCompany uid bpol False False| Entity uid User{userFirstName = "Elizabeth"} <- matUsers] - insertMany_ [UserCompany uid bpol True True| Entity uid User{userFirstName = "Clark", userSurname = dn} <- matUsers, dn == "Walker" || dn == "Robinson"] - insertMany_ [UserCompany uid ffacil False False| Entity uid User{userSurname = "Walker"} <- matUsers] - insertMany_ [UserCompany uid rckey issuper False + insertMany_ [UserCompany uid fraGround False False 0 True | Entity uid User{userFirstName = "John"} <- matUsers] + insertMany_ [UserCompany uid bpol False False 0 False | Entity uid User{userFirstName = "Elizabeth"} <- matUsers] + insertMany_ [UserCompany uid bpol True True 0 True | Entity uid User{userFirstName = "Clark", userSurname = dn} <- matUsers, dn == "Walker" || dn == "Robinson"] + insertMany_ [UserCompany uid ffacil False False 0 False | Entity uid User{userSurname = "Walker"} <- matUsers] + insertMany_ [UserCompany uid rckey issuper False 0 True | rckey <- randComps , Just n <- [readMay $ drop 2 $ unpack $ CI.original $ unCompanyKey rckey] , Entity uid User{userSurname = uSurname} <- take (n `div` 20) $ drop (2*n) matUsers