diff --git a/assets/icons-src/fontawesome.json b/assets/icons-src/fontawesome.json index 538588abc..ef5dee6ee 100644 --- a/assets/icons-src/fontawesome.json +++ b/assets/icons-src/fontawesome.json @@ -102,6 +102,7 @@ "user-unknown": "user-slash", "user-badge": "id-badge", "glasses": "glasses", -"missing": "question" +"missing": "question", +"pin-protect": "key" } diff --git a/frontend/src/icons.scss b/frontend/src/icons.scss index 862f9fff0..2d430aa0e 100644 --- a/frontend/src/icons.scss +++ b/frontend/src/icons.scss @@ -104,6 +104,7 @@ $icons: new, user-badge, user-unknown, missing, + pin-protect, loading; diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index d526dc8c4..6ced6f20d 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2023-24 Steffen Jost +# SPDX-FileCopyrightText: 2023-25 Steffen Jost # # SPDX-License-Identifier: AGPL-3.0-or-later @@ -73,6 +73,8 @@ TableSuperior: Vorgesetzter TableIsDefaultReroute: Standardumleitung FormFieldPostal: Benachrichtigungseinstellung FormFieldPostalTip: Gilt für alle Benachrichtigungen an diese Person, nicht nur für Umleitungen an diesen Ansprechpartner +FormFieldPinPass: Sensible PDF-E-Mail-Anhänge mit Passwort schützen? +FormFieldPinPassRemove: Passwortschutz für PDF-E-Mail-Anhänge entfernen? FirmSupervisionKeyData: Kennzahlen Ansprechpartner CompanyUserPriority: Firmenpriorität CompanyUserPriorityTip: Firmenpriorität ist lediglich relativ zu anderen Firmenassoziation der Person diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index 991164701..63159a817 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2023-24 Steffen Jost +# SPDX-FileCopyrightText: 2023-25 Steffen Jost # # SPDX-License-Identifier: AGPL-3.0-or-later @@ -73,6 +73,8 @@ TableSuperior: Superior TableIsDefaultReroute: Default reroute FormFieldPostal: Notification type FormFieldPostalTip: Affects all notifications to this person, not just reroutes to this supervisor +FormFieldPinPass: Protect sensitive PDF e-mail attachments by password? +FormFieldPinPassRemove: Remove password protection for PDF e-mail attachments? FirmSupervisionKeyData: Supervision key data CompanyUserPriority: Company priority CompanyUserPriorityTip: Company priority is relative to other company associations for a user diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index f5622da28..812aee1bc 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -100,6 +100,7 @@ TableCompanyNrRerouteDefault: Standard Umleitungen TableCompanyNrRerouteActive: Aktive Umleitungen TableRerouteActive: Umleitung TableCompanyPostalPreference: Benachrichtigungspräferenz neue Firmenangehörige +TableCompanyPinPassword: Pin Passwort für PDF Anhänge TableSupervisor: Ansprechpartner TableSupervisorActive: Aktiver Ansprechpartner TableSupervisee: Ansprechpartner für diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index d46a71b0a..62d534c38 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -100,6 +100,7 @@ TableCompanyNrRerouteDefault: Default reroutes TableCompanyNrRerouteActive: Active reroutes TableRerouteActive: Reroute TableCompanyPostalPreference: Default notification preference +TableCompanyPinPassword: Pin password for PDF attachments TableSupervisor: Supervisor TableSupervisorActive: Active supervisor TableSupervisee: Supervisor for diff --git a/models/company.model b/models/company.model index 0d3d07ce9..4d3619a8c 100644 --- a/models/company.model +++ b/models/company.model @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-24 Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-25 Sarah Vaupel ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -11,8 +11,10 @@ Company prefersPostal Bool default=true -- 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 + pinPassword Bool default=true -- new company users only: should sensitive PDF email attachement be protected by a password? -- UniqueCompanyName name -- Should be Unique in AVS, but we do not yet need to enforce it -- UniqueCompanyShorthand shorthand -- unnecessary, since it is the primary key already UniqueCompanyAvsId avsId -- Should be the key, is not for historical reasons and for convenience in URLs and columns Primary shorthand -- newtype Key Company = CompanyKey { unCompanyKey :: CompanyShorthand } deriving Ord Eq Show Generic Binary + diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index ad44d1257..426e855b9 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2023 Steffen Jost +-- SPDX-FileCopyrightText: 2023-25 Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -48,6 +48,11 @@ encryptUser = encrypt postalEmailField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m Bool postalEmailField = boolFieldCustom (SomeMessage MsgUtilPostal) (SomeMessage MsgUtilEMail) $ Just $ SomeMessage MsgUtilUnchanged + + -- prioLetterPassword :: E.SqlExpr (Entity User) -> SqlExpr (Value Int64) + -- prioLetterPassword usr = E.case_ [E.when_ (usr E.^. UserPrefersPostal) E.then_ E.val ] + + --------------------------------- -- General firm affecting actions @@ -85,6 +90,7 @@ data FirmActionData = FirmActNotifyData { firmActCCFPostalAddr :: Maybe StoredMarkup , firmActCCFEmail :: Maybe UserEmail , firmActCCFPostalPref :: Maybe Bool + , firmActCCFPinPassword :: Maybe Bool } | FirmActChangeContactUserData { firmActCCUPostalAddr :: Maybe StoredMarkup @@ -114,9 +120,10 @@ firmActionMap mr isAdmin acts = mconcat (mkAct isAdmin <$> acts) <*> aopt (textField & cfStrip & addDatalist ucdefAssocReasons) (fslI MsgUserCompanyReason & setTooltip MsgUserCompanyReasonTooltip) Nothing mkAct _ FirmActChangeContactFirm = singletonMap FirmActChangeContactFirm $ FirmActChangeContactFirmData - <$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing - <*> aopt (emailField & cfStrip & cfCI) (fslI MsgUserDisplayEmail & setTooltip MsgUtilEmptyNoChangeTip) Nothing + <$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMsgs [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing + <*> aopt (emailField & cfStrip & cfCI) (fslI MsgUserDisplayEmail & setTooltip MsgUtilEmptyNoChangeTip) Nothing <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFirmDefaultPreferenceInfo) Nothing + <*> aopt boolField' (fslI MsgFormFieldPinPass & setTooltip MsgFirmDefaultPreferenceInfo) Nothing <* aformMessage (Message Info (toHtml $ mr MsgFirmActChangeContactFirmInfo) (Just IconNotificationNonactive)) mkAct _ FirmActChangeContactUser = singletonMap FirmActChangeContactUser $ FirmActChangeContactUserData <$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing @@ -235,6 +242,7 @@ firmActionHandler route isAdmin = flip formResult faHandler [ (CompanyPostAddress =.) . Just <$> canonical firmActCCFPostalAddr , (CompanyEmail =.) . Just <$> canonical firmActCCFEmail , (CompanyPrefersPostal =.) <$> firmActCCFPostalPref + , (CompanyPinPassword =.) <$> firmActCCFPinPassword ] in unless (null changes) $ do runDB $ update cid changes @@ -510,12 +518,14 @@ mkFirmAllTable isAdmin uid = do -- , sortable (Just "reroute-act") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultAllCompanyActiveReroutes -> nr) -> wgtCell $ word2widget nr -- , sortable (Just "reroute-all") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultAllCompanyActiveReroutes' -> nr) -> wgtCell $ word2widget nr , sortable (Just "postal-pref") (i18nCell MsgTableCompanyPostalPreference) $ \(view $ resultAllCompany . _companyPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b + , sortable (Just "pin-password") (i18nCell MsgTableCompanyPinPassword) $ \(view $ resultAllCompany . _companyPinPassword -> b) -> ifIconCell b IconPinProtect & addIconFixedWidth ] dbtSorting = mconcat [ singletonMap "name" $ SortColumn (E.^. CompanyName) , singletonMap "short" $ SortColumn (E.^. CompanyShorthand) , singletonMap "avsnr" $ SortColumn (E.^. CompanyAvsId) , singletonMap "postal-pref" $ SortColumn (E.^. CompanyPrefersPostal) + , singletonMap "pin-password" $ SortColumn (E.^. CompanyPinPassword) , singletonMap "users" $ SortColumn firmCountUsers , singletonMap "secondary" $ SortColumn firmCountUsersSecondary , singletonMap "supervisors" $ SortColumn firmHasSupervisors @@ -814,6 +824,7 @@ data FirmUserActionData = FirmUserActNotifyData { firmUserActPostalAddr :: Maybe StoredMarkup , firmUserActUseCompanyPostal :: Maybe Bool , firmUserActPostalPref :: Maybe Bool + , firmUserActPinPassword :: Bool } | FirmUserActRemoveData { firmUserActRemoveSupers :: Bool @@ -852,8 +863,8 @@ instance HasUser UserCompanyTableData where hasUser = resultUserUser . _entityVal -mkFirmUserTable :: Bool -> CompanyId -> DB (FormResult (FirmUserActionData, Set UserId), Widget) -mkFirmUserTable isAdmin cid = do +mkFirmUserTable :: Bool -> Entity Company -> DB (FormResult (FirmUserActionData, Set UserId), Widget) +mkFirmUserTable isAdmin Entity{entityKey=cid, entityVal=compData} = do mr <- getMessageRender let reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior @@ -901,9 +912,9 @@ mkFirmUserTable isAdmin cid = do , colUserNameModalHdr MsgTableCompanyUser ForProfileDataR , guardMonoid isAdmin $ sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \(view resultUserUser -> entUsr ) -> cellHasMatrikelnummerLinkedAdmin entUsr , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \(view $ resultUserUser . _userCompanyPersonalNumber -> t) -> foldMap textCell t - , sortable (Just "supervisors") (i18nCell MsgTableCompanyNrSupers ) $ \(view resultUserCompanySupervisors -> nr) -> wgtCell $ word2widget nr - , sortable (Just "reroutes") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultUserCompanyReroutes -> nr) -> wgtCell $ word2widget nr - , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultUserUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b + , sortable (Just "supervisors") (i18nCell MsgTableCompanyNrSupers ) $ \(view resultUserCompanySupervisors -> nr) -> wgtCell $ word2widget nr + , sortable (Just "reroutes") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultUserCompanyReroutes -> nr) -> wgtCell $ word2widget nr + , colUserLetterEmailPin , sortable Nothing (i18nCell MsgCompanyUserUseCompanyAddress) $ \row -> let noUsrAddr = isNothing $ row ^. resultUserUser . _userPostAddress useCompA = row ^. resultUserUserCompany . _entityVal . _userCompanyUseCompanyAddress @@ -916,10 +927,11 @@ mkFirmUserTable isAdmin cid = do in numCell prio <> spacerCell <> ifIconCell isPrime IconTop , sortable Nothing (i18nCell MsgTableUserEdit) $ \(view resultUserUser -> entUsr) -> cellEditUserModal entUsr ] + dbtSorting = Map.fromList - [ sortUserNameLink queryUserUser - , sortUserEmail queryUserUser - , ("postal-pref" , SortColumn $ queryUserUser >>> (E.^. UserPrefersPostal) ) + [ sortUserNameLink queryUserUser + , sortUserEmail queryUserUser + , sortUserLetterEmailPin queryUserUser , ("matriculation" , SortColumn $ queryUserUser >>> (E.^. UserMatrikelnummer) ) , ("personal-number" , SortColumn $ queryUserUser >>> (E.^. UserCompanyPersonalNumber)) , ("supervisors" , SortColumn $ queryUserUserCompany >>> firmCountUserSupervisors ) @@ -1039,6 +1051,8 @@ mkFirmUserTable isAdmin cid = do <$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing <*> aopt boolField' (fslI MsgCompanyUserUseCompanyAddress & setTooltip MsgCompanyUserUseCompanyAddressTip) Nothing <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing + <*> if companyPinPassword compData then pure False else + areq boolField' (fslI MsgFormFieldPinPassRemove) Nothing , singletonMap FirmUserActChangeDetails $ FirmUserActChangeDetailsData <$> aopt intField (fslI MsgCompanyUserPriority & setTooltip MsgCompanyUserPriorityTip) Nothing <*> aopt (textField & cfStrip & addDatalist userReasons) (fslI MsgUserCompanyReason & setTooltip (SomeMessages [SomeMessage MsgUserCompanyReasonTooltip, SomeMessage MsgNullDeletes])) Nothing @@ -1090,8 +1104,8 @@ postFirmUsersR fsh = do , E.Value nrCompanyEmployeeRerPost , E.Value nrCompanyDefaultReroutes , E.Value nrCompanyActiveReroutes - ) , (fusrRes, fusrTable)) <- runDB $ (,) - <$> fromMaybeM notFound (E.selectOne $ do + ) , (fusrRes, fusrTable)) <- runDB $ do + compEnt <- fromMaybeM notFound (E.selectOne $ do cmpy <- E.from $ E.table @Company E.where_ $ cmpy E.^. CompanyId E.==. E.val cid return ( cmpy @@ -1108,7 +1122,8 @@ postFirmUsersR fsh = do -- usr <- E.from $ E.table @User -- E.where_ $ E.exists $ firmQuerySupervisedBy cmpyId Nothing usr -- return usr - <*> mkFirmUserTable isAdmin cid + tbl <- mkFirmUserTable isAdmin (compEnt ^. _1) + return (compEnt, tbl) let resetSupers :: Maybe Bool -> NonEmpty UserId -> DB Int64 resetSupers Nothing _ = return 0 @@ -1162,9 +1177,10 @@ postFirmUsersR fsh = do | firmUserActUseCompanyPostal == Just True, isJust firmUserActPostalAddr -> addMessageI Error MsgCompanyUserUseCompanyPostalError | otherwise -> do - let changes = catMaybes - [ toMaybe (firmUserActUseCompanyPostal == Just True) (UserPostAddress =. Nothing) -- precondition ensures that only one update applies for UserPostAddress - , (UserPostAddress =.) . Just <$> canonical firmUserActPostalAddr -- note that Nothing means no change and not delete address! + let changes = + bcons (firmUserActUseCompanyPostal == Just True) (UserPostAddress =. Nothing) $ -- precondition ensures that only one update applies for UserPostAddress + bcons firmUserActPinPassword (UserPinPassword =. Nothing) $ catMaybes + [ (UserPostAddress =.) . Just <$> canonical firmUserActPostalAddr -- note that Nothing means no change and not delete address! , (UserPrefersPostal =.) <$> firmUserActPostalPref ] nrChanged <- runDB $ do @@ -1298,7 +1314,7 @@ mkFirmSuperTable isAdmin cid = do , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultSuperCompanies -> cmps) -> intercalate semicolonCell [companyCell cmpShort cmpName isSuper | (E.Value cmpName, E.Value cmpShort, E.Value isSuper) <- cmps] , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \(view $ resultSuperUser . _userCompanyPersonalNumber -> t) -> foldMap textCell t - , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultSuperUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b + , colUserLetterEmailPin , colUserEmail , sortable (Just "supervised") (i18nCell MsgTableCompanyNrEmpSupervised) $ \(view resultSuperCompanySupervised -> nr) -> wgtCell $ word2widget nr , sortable (Just "rerouted") (i18nCell MsgTableCompanyNrEmpRerouted ) $ \(view resultSuperCompanyReroutes -> nr) -> wgtCell $ word2widget nr @@ -1311,11 +1327,11 @@ mkFirmSuperTable isAdmin cid = do , sortable Nothing (i18nCell MsgTableUserEdit) $ \(view resultSuperUser -> entUsr) -> cellEditUserModal entUsr ] dbtSorting = Map.fromList - [ sortUserNameLink querySuperUser - , sortUserEmail querySuperUser + [ sortUserNameLink querySuperUser + , sortUserEmail querySuperUser + , sortUserLetterEmailPin querySuperUser , ("matriculation" , SortColumn $ querySuperUser >>> (E.^. UserMatrikelnummer)) , ("personal-number" , SortColumn $ querySuperUser >>> (E.^. UserCompanyPersonalNumber)) - , ("postal-pref" , SortColumn $ querySuperUser >>> (E.^. UserPrefersPostal)) , ("supervised" , SortColumn $ querySuperUser >>> firmCountForSupervisor cid Nothing) , ("rerouted" , SortColumn $ querySuperUser >>> firmCountForSupervisor cid (Just (E.^. UserSupervisorRerouteNotifications))) , ("user-company" , SortColumn (\row -> E.subSelect $ do diff --git a/src/Handler/LMS/Learners.hs b/src/Handler/LMS/Learners.hs index 7f42d2b59..9ee5b200b 100644 --- a/src/Handler/LMS/Learners.hs +++ b/src/Handler/LMS/Learners.hs @@ -136,8 +136,8 @@ mkUserTable _sid qsh qid cutoff = do , (csvLmsResetPin , FilterColumn $ E.mkExactFilterLast (E.^. LmsUserResetPin)) ] dbtFilterUI = \mPrev -> mconcat - [ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent & setTooltip MsgTableFilterCommaPlus) - , prismAForm (singletonFilter csvLmsResetPin . maybePrism _PathPiece) mPrev $ aopt (hoistField lift (boolField . Just $ SomeMessage MsgBoolIrrelevant)) (fslI MsgTableLmsResetPin) + [ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent & setTooltip MsgTableFilterCommaPlus) + , prismAForm (singletonFilter csvLmsResetPin . maybePrism _PathPiece) mPrev $ aopt (hoistField lift boolField') (fslI MsgTableLmsResetPin) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtParams = def @@ -317,9 +317,9 @@ getLmsOrphansR sid qsh = do -- checkBoxTextField = convertField show (\case { t | t == show True -> True; _ -> False }) checkBoxField -- UNNECESSARY hack to use FilterColumnHandler, which only works on [Text] criteria dbtFilterUI mPrev = mconcat [ -- prismAForm (singletonFilter "preview" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgLmsOrphanPreviewFltr) -- NOTE: anticipated checkBoxTextField-hack not needed here - prismAForm (singletonFilter "preview" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgLmsOrphanPreviewFltr) - , prismAForm (singletonFilter "reason" . maybePrism _PathPiece) mPrev $ aopt textField (fslI MsgLmsOrphanReason) - , prismAForm (singletonFilter "ident" . maybePrism _PathPiece) mPrev $ aopt textField (fslI MsgTableLmsIdent & setTooltip MsgTableFilterCommaPlus) + prismAForm (singletonFilter "preview" . maybePrism _PathPiece) mPrev $ aopt boolField' (fslI MsgLmsOrphanPreviewFltr) + , prismAForm (singletonFilter "reason" . maybePrism _PathPiece) mPrev $ aopt textField (fslI MsgLmsOrphanReason) + , prismAForm (singletonFilter "ident" . maybePrism _PathPiece) mPrev $ aopt textField (fslI MsgTableLmsIdent & setTooltip MsgTableFilterCommaPlus) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtParams = def diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 3c1af6b2e..a1db5a6d6 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-24 Steffen Jost +-- SPDX-FileCopyrightText: 2022-25 Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -284,8 +284,6 @@ queryAvsFullCardNo :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) = queryAvsFullCardNo = fmap (fmap getFullCardNo) . queryAvsPrimaryCard - - -- | Like `updateAvsUserByIds`, but exceptions are not caught here to allow rollbacks updateAvsUserById :: AvsPersonId -> DB (Maybe UserId) updateAvsUserById apid = do @@ -373,9 +371,9 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv eml_up = mkUpdate usr newAvsDataContact oldAvsDataContact $ mkCheckUpdate CU_ADC_UserDisplayEmail -- DisplayEmail updates erfolgen nur, wenn identisch. Für Firmen-Email leer lassen. -- eml_up2 = mkUpdate usr newAvsFirmInfo oldAvsFirmInfo $ mkCheckUpdate CU_AFI_UserEmail -- Email update erfolgt nur, wenn hier die SuperiorEmail als Fallback gespeichert wurde; UserEmail Uniqueness nicht gewährleistet frm_up = mkUpdate' usr newAvsFirmInfo oldAvsFirmInfo $ mkCheckUpdate CU_AFI_UserPostAddress -- Legacy, if company postal is stored in user; should no longer be true for new users, since company address should now be referenced with UserCompany instead - pin_up = mkUpdate' usr newAvsCardNo oldAvsCardNo $ -- Maybe update PDF pin to latest card + pin_up0 = mkUpdate usr newAvsCardNo oldAvsCardNo $ -- Maybe update PDF pin to latest card CheckUpdate UserPinPassword $ to $ fmap avsFullCardNo2pin -- _Just . to avsFullCardNo2pin . re _Just - usr_up1 = mconss [eml_up, frm_up, pin_up] $ ldap_ups <> per_ups + usr_up1 = mconss [eml_up, frm_up] $ ldap_ups <> per_ups avs_ups = ((UserAvsNoPerson =.) <$> readMay (avsInfoPersonNo newAvsPersonInfo)) `mcons` [ UserAvsLastSynch =. now , UserAvsLastSynchError =. Nothing @@ -403,10 +401,18 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv -- -> Nothing superReasonComDef = tshow SupervisorReasonCompanyDefault newUserComp = UserCompany usrId newCompanyId False False 1 True Nothing -- default value for new company insertion, if no update can be done + -- pin_up :: Maybe (Update User) + -- pin_up = guardOnM (newCompanyEnt ^. _entityVal . _companyPinPassword) pin_up0 + -- base_up :: [Update User] + -- base_up = maybeToList pin_up -- catMaybes [pin_up] + -- -- Use above if we gain more base updates -- + base_up :: [Update User] + base_up = guardMonoid (newCompanyEnt ^. _entityVal . _companyPinPassword) (maybeToList pin_up0) + case oldAvsFirmInfo of _ | Just newCompanyId == oldCompanyId -- company unchanged entirely - -> return mempty -- => do nothing + -> return base_up -- => do nothing (Just oafi) | isJust (view _avsFirmPostAddressSimple oafi) && ((==) `on` view _avsFirmPostAddressSimple) oafi newAvsFirmInfo -- non-empty company address unchanged OR || isJust (view _avsFirmPrimaryEmail oafi) @@ -420,20 +426,20 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv , UserSupervisorCompany ==. Just ocid -- to new company, regardless of , UserSupervisorReason ==. Just superReasonComDef] -- user [ UserSupervisorCompany =. Just newCompanyId] - return mempty + return base_up _ | Just newCompanyId == primaryCompanyId -- old primaryCompany is now also AVS-company -> do whenIsJust oldCompanyId $ \oldCid -> do deleteBy $ UniqueUserCompany usrId oldCid deleteWhere $ (UserSupervisorUser ==. usrId):(UserSupervisorCompany ==. oldCompanyId):(UserSupervisorReason ~=. superReasonComDef) - return mempty + return base_up _ -- company changed completely -> do (pst_up, problems) <- switchAvsUserCompany False False usrId newCompanyId mapM_ reportAdminProblem problems -- Following line does not type, hence additional parameter needed -- return [ u | u@Update{updateField=f} <- pst_up, f /= UserPostAddress ] -- already computed in frm_up above, duplicate update must be prevented (version above accounts for legacy updates) - return pst_up + return $ base_up <> pst_up -- SPECIALISED CODE, PROBABLY DEPRECATED -- switch user company, keeping old priority -- (getBy . UniqueUserCompany usrId) `traverseJoin` oldCompanyId >>= \case @@ -535,7 +541,7 @@ createAvsUserById muid api = do | otherwise -> return uid (Nothing, Nothing) -> do -- create fresh user Entity{entityKey=cid, entityVal=cmp} <- runDB $ upsertAvsCompany firmInfo Nothing -- individual runDB, since no need to rollback - let pinPass = avsFullCardNo2pin <$> usrCardNo + let pinPass = guardMonoid (cmp ^. _companyPinPassword) (avsFullCardNo2pin <$> usrCardNo) -- superiorEmail = filterMaybe validEmail $ adc ^. _avsContactFirmInfo . _avsFirmEMailSuperior newUserData = AddUserData { audTitle = Nothing @@ -608,6 +614,7 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do , companyPrefersPostal = True , companyPostAddress = newAvsFirmInfo ^. _avsFirmPostAddress , companyEmail = newAvsFirmInfo ^? _avsFirmPrimaryEmail . _Just . from _CI + , companyPinPassword = True } cmp = foldl' upd dmy $ firmInfo2key : firmInfo2companyNo : firmInfo2company $logInfoS "AVS" $ "Insert new company: " <> tshow cmp @@ -649,6 +656,7 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do , CheckUpdate CompanyPostAddress _avsFirmPostAddress , CheckUpdate CompanyEmail $ _avsFirmPrimaryEmail . _Just . from _CI . re _Just -- , CheckUpdate CompanyPrefersPostal _avsFirmPrefersPostal -- Guessing here is not useful, since postal preference is ignored anyway when there is only one option available + -- , CheckUpdate CompanyPinPassword -- same as for FirmPrefersPostal ] diff --git a/src/Handler/Utils/AvsUpdate.hs b/src/Handler/Utils/AvsUpdate.hs index cf0ff1abe..0d0f226a9 100644 --- a/src/Handler/Utils/AvsUpdate.hs +++ b/src/Handler/Utils/AvsUpdate.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2024 Steffen Jost +-- SPDX-FileCopyrightText: 2024-25 Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later {-# OPTIONS_GHC -fno-warn-unused-top-binds -fno-warn-orphans #-} @@ -74,14 +74,14 @@ instance MkCheckUpdate CU_AvsPersonInfo_User where mkCheckUpdate CU_API_UserLdapPrimaryKey = CheckUpdateMay UserLdapPrimaryKey $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just -- mkCheckUpdate CU_API_UserDisplayEmail = CheckUpdateOpt UserDisplayEmail $ _avsInfoPersonEMail . _Just . from _CI -- Maybe im AvsInfo, aber nicht im User, daher Opt -data CU_AvsDataContcat_User +data CU_AvsDataContact_User = CU_ADC_UserPostAddress | CU_ADC_UserDisplayEmail deriving (Show, Eq) -instance MkCheckUpdate CU_AvsDataContcat_User where - type MCU_Rec CU_AvsDataContcat_User = User - type MCU_Raw CU_AvsDataContcat_User = AvsDataContact +instance MkCheckUpdate CU_AvsDataContact_User where + type MCU_Rec CU_AvsDataContact_User = User + type MCU_Raw CU_AvsDataContact_User = AvsDataContact mkCheckUpdate CU_ADC_UserPostAddress = CheckUpdateMay UserPostAddress _avsContactPrimaryPostAddress mkCheckUpdate CU_ADC_UserDisplayEmail = CheckUpdateOpt UserDisplayEmail $ _avsContactPrimaryEmail . _Just . from _CI @@ -100,7 +100,7 @@ instance MkCheckUpdate CU_AvsFirmInfo_User where -- NOTE: Ensure that the lenses between CU_UserAvs_User and CU_AvsPersonInfo_User/CU_AvsFirmInfo_User agree! -data CU_UserAvs_User +data CU_UserAvs_User -- only used in templates/profileData.hamlet for detection = CU_UA_UserPinPassword -- CU_UA_UserPostAddress -- use _avsContactPrimaryPostAddress instead | CU_UA_UserFirstName diff --git a/src/Handler/Utils/Company.hs b/src/Handler/Utils/Company.hs index ffa2f015f..792119e63 100644 --- a/src/Handler/Utils/Company.hs +++ b/src/Handler/Utils/Company.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Steffen Jost +-- SPDX-FileCopyrightText: 2022-25 Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -168,13 +168,12 @@ switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = d usrPrefPost = userPrefersPostal usrRec usrPrefPostUp = toMaybe (Just usrPrefPost == (mbOldComp ^? _Just . _companyPrefersPostal)) (UserPrefersPostal =. companyPrefersPostal newCompany) + usrPinPassUp = toMaybe (newCompany ^. _companyPinPassword . _not) (UserPinPassword =. Nothing) -- newCmpEmail :: UserEmail = fromMaybe "" $ companyEmail newCompany usrDisplayEmail :: UserEmail = userDisplayEmail usrRec avsEmail :: Maybe UserEmail = mbUsrAvs ^? _Just . _entityVal . _userAvsLastFirmInfo . _Just . _avsFirmPrimaryEmail . _Just . from _CI usrDisplayEmailUp = toMaybe (usrPostEmailUpds && avsEmail == Just usrDisplayEmail) (UserDisplayEmail =. "") -- delete DisplayEmail, if equal to AVS Firm Email - usrUpdate = catMaybes [usrPostUp, usrPrefPostUp, usrDisplayEmailUp] - -- [UserPostAddress =. Nothing, UserPrefersPostal =. companyPrefersPostal newCompany] -- unconditional - + usrUpdate = catMaybes [usrPostUp, usrPrefPostUp, usrPinPassUp, usrDisplayEmailUp] newUserComp = UserCompany uid newCompanyId False False 1 True Nothing -- default value for new company insertion, if no update can be done superReasonComDef = tshow SupervisorReasonCompanyDefault diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 2a1064beb..652e58936 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -218,6 +218,13 @@ 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 usr = + iconFixedCell (iconLetterOrEmail prefPost) <> 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 89ebeec61..1c0ae301d 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -494,6 +494,20 @@ fltrUserEmailUI mPrev = prismAForm (singletonFilter "user-email") mPrev $ aopt textField (fslI MsgTableEmail) +-- | 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 = sortable (Just "user-mail-pref-pin") (i18nCell MsgPrefersPostal) cellMailPrefPin + +sortUserLetterEmailPin :: IsString d => (t -> E.SqlExpr (Entity User)) -> (d, SortColumn t r') +sortUserLetterEmailPin queryUser = ( "user-mail-pref-pin" , SortColumn (toSortVal . queryUser)) + where + toSortVal :: E.SqlExpr (Entity User) -> E.SqlExpr (E.Value Int64) + toSortVal usr = E.case_ + [ E.when_ ( usr E.^. UserPrefersPostal) E.then_ (E.val 1) + , E.when_ (E.isJust $ usr E.^. UserPinPassword) E.then_ (E.val 2) + ] (E.else_ (E.val 3)) + + -------------------- -- Study features -- -------------------- diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index c83a52909..54686df17 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -135,6 +135,7 @@ data Icon | IconGlasses -- user must wear glasses while driving -- | IconPlaceholder -- reserved and sued by the frontend for actual missing errors | IconMissing -- something is missing or not applicable, less obtrusive than IconPlaceholder + | IconPinProtect -- something is password protected deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic) deriving anyclass (Universe, Finite, NFData) diff --git a/templates/firm-contact-info.hamlet b/templates/firm-contact-info.hamlet index 2362b2c75..73514e0fe 100644 --- a/templates/firm-contact-info.hamlet +++ b/templates/firm-contact-info.hamlet @@ -1,6 +1,6 @@ $newline never -$# SPDX-FileCopyrightText: 2023 Steffen Jost +$# SPDX-FileCopyrightText: 2023-25 Steffen Jost $# $# SPDX-License-Identifier: AGPL-3.0-or-later @@ -12,8 +12,10 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later _{MsgFirmEmail} $if not companyPrefersPostal   #{iconLetterOrEmail False} + $if companyPinPassword +   #{icon IconPinProtect}
- #{mailtoHtml fem} + #{mailtoHtml fem} $maybe addr <- companyPostAddress
_{MsgFirmAddress} diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index d4d21f0c8..676ced98a 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -200,7 +200,7 @@ fillDb = do , userMobile = Just "0173 69 99 646" , userCompanyPersonalNumber = Just "57138" , userCompanyDepartment = Just "AVN-AR2" - , userPinPassword = Nothing + , userPinPassword = Just "1234" , userPostAddress = Nothing , userPostLastUpdate = Nothing , userPrefersPostal = False @@ -280,7 +280,7 @@ fillDb = do , userMobile = Nothing , userCompanyPersonalNumber = Just "12345" , userCompanyDepartment = Nothing - , userPinPassword = Nothing + , userPinPassword = Just "weird" , userPostAddress = Nothing , userPostLastUpdate = Nothing , userPrefersPostal = False @@ -560,7 +560,7 @@ fillDb = do , userMobile = Nothing , userCompanyPersonalNumber = bool Nothing (Just "E123" ) (even $ length firstName) , userCompanyDepartment = bool Nothing (Just "AVN-A") (even $ length userSurname) - , userPinPassword = Nothing + , userPinPassword = toMaybe (isJust middleName) "000000" , userPostAddress = Nothing , userPostLastUpdate = Nothing , userPrefersPostal = False