fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore(firm): add company preference for email pin passwords

Browse Source 
companies may be set such that their users have no email pin password by default
switching to such a company deletes the pin password
This commit is contained in:
Steffen Jost 2025-02-05 17:43:43 +01:00 committed by Sarah Vaupel
parent 38606949b0
commit 05bc06df47
17 changed files with 112 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
assets/icons-src/fontawesome.json
View File

@ -102,6 +102,7 @@
"user-unknown": "user-slash", "user-unknown": "user-slash",
"user-badge": "id-badge", "user-badge": "id-badge",
"glasses": "glasses", "glasses": "glasses",
"missing": "question" "missing": "question",
"pin-protect": "key"
} }

1
frontend/src/icons.scss
View File

@ -104,6 +104,7 @@ $icons: new,
user-badge, user-badge,
user-unknown, user-unknown,
missing, missing,
pin-protect,
loading; loading;

4
messages/uniworx/categories/firm/de-de-formal.msg
View File

@ -1,4 +1,4 @@
# SPDX-FileCopyrightText: 2023-24 Steffen Jost <s.jost@fraport.de> # SPDX-FileCopyrightText: 2023-25 Steffen Jost <s.jost@fraport.de>
# #
# SPDX-License-Identifier: AGPL-3.0-or-later # SPDX-License-Identifier: AGPL-3.0-or-later
@ -73,6 +73,8 @@ TableSuperior: Vorgesetzter
TableIsDefaultReroute: Standardumleitung TableIsDefaultReroute: Standardumleitung
FormFieldPostal: Benachrichtigungseinstellung FormFieldPostal: Benachrichtigungseinstellung
FormFieldPostalTip: Gilt für alle Benachrichtigungen an diese Person, nicht nur für Umleitungen an diesen Ansprechpartner 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 FirmSupervisionKeyData: Kennzahlen Ansprechpartner
CompanyUserPriority: Firmenpriorität CompanyUserPriority: Firmenpriorität
CompanyUserPriorityTip: Firmenpriorität ist lediglich relativ zu anderen Firmenassoziation der Person CompanyUserPriorityTip: Firmenpriorität ist lediglich relativ zu anderen Firmenassoziation der Person

4
messages/uniworx/categories/firm/en-eu.msg
View File

@ -1,4 +1,4 @@
# SPDX-FileCopyrightText: 2023-24 Steffen Jost <s.jost@fraport.de> # SPDX-FileCopyrightText: 2023-25 Steffen Jost <s.jost@fraport.de>
# #
# SPDX-License-Identifier: AGPL-3.0-or-later # SPDX-License-Identifier: AGPL-3.0-or-later
@ -73,6 +73,8 @@ TableSuperior: Superior
TableIsDefaultReroute: Default reroute TableIsDefaultReroute: Default reroute
FormFieldPostal: Notification type FormFieldPostal: Notification type
FormFieldPostalTip: Affects all notifications to this person, not just reroutes to this supervisor 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 FirmSupervisionKeyData: Supervision key data
CompanyUserPriority: Company priority CompanyUserPriority: Company priority
CompanyUserPriorityTip: Company priority is relative to other company associations for a user CompanyUserPriorityTip: Company priority is relative to other company associations for a user

1
messages/uniworx/utils/table_column/de-de-formal.msg
View File

@ -100,6 +100,7 @@ TableCompanyNrRerouteDefault: Standard Umleitungen
TableCompanyNrRerouteActive: Aktive Umleitungen TableCompanyNrRerouteActive: Aktive Umleitungen
TableRerouteActive: Umleitung TableRerouteActive: Umleitung
TableCompanyPostalPreference: Benachrichtigungspräferenz neue Firmenangehörige TableCompanyPostalPreference: Benachrichtigungspräferenz neue Firmenangehörige
TableCompanyPinPassword: Pin Passwort für PDF Anhänge
TableSupervisor: Ansprechpartner TableSupervisor: Ansprechpartner
TableSupervisorActive: Aktiver Ansprechpartner TableSupervisorActive: Aktiver Ansprechpartner
TableSupervisee: Ansprechpartner für TableSupervisee: Ansprechpartner für

1
messages/uniworx/utils/table_column/en-eu.msg
View File

@ -100,6 +100,7 @@ TableCompanyNrRerouteDefault: Default reroutes
TableCompanyNrRerouteActive: Active reroutes TableCompanyNrRerouteActive: Active reroutes
TableRerouteActive: Reroute TableRerouteActive: Reroute
TableCompanyPostalPreference: Default notification preference TableCompanyPostalPreference: Default notification preference
TableCompanyPinPassword: Pin password for PDF attachments
TableSupervisor: Supervisor TableSupervisor: Supervisor
TableSupervisorActive: Active supervisor TableSupervisorActive: Active supervisor
TableSupervisee: Supervisor for TableSupervisee: Supervisor for

4
models/company.model
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022-24 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de> -- SPDX-FileCopyrightText: 2022-25 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
-- --
-- SPDX-License-Identifier: AGPL-3.0-or-later -- 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 prefersPostal Bool default=true -- new company users prefers letters by post instead of email
postAddress StoredMarkup Maybe -- default company postal address, including company name 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
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 -- 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 -- 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 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 } Primary shorthand -- newtype Key Company = CompanyKey { unCompanyKey :: CompanyShorthand }
deriving Ord Eq Show Generic Binary deriving Ord Eq Show Generic Binary

58
src/Handler/Firm.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2023 Steffen Jost <S.Jost@fraport.de> -- SPDX-FileCopyrightText: 2023-25 Steffen Jost <S.Jost@fraport.de>
-- --
-- SPDX-License-Identifier: AGPL-3.0-or-later -- SPDX-License-Identifier: AGPL-3.0-or-later
@ -48,6 +48,11 @@ encryptUser = encrypt
postalEmailField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m Bool postalEmailField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m Bool
postalEmailField = boolFieldCustom (SomeMessage MsgUtilPostal) (SomeMessage MsgUtilEMail) $ Just $ SomeMessage MsgUtilUnchanged 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 -- General firm affecting actions
@ -85,6 +90,7 @@ data FirmActionData = FirmActNotifyData
{ firmActCCFPostalAddr :: Maybe StoredMarkup { firmActCCFPostalAddr :: Maybe StoredMarkup
, firmActCCFEmail :: Maybe UserEmail , firmActCCFEmail :: Maybe UserEmail
, firmActCCFPostalPref :: Maybe Bool , firmActCCFPostalPref :: Maybe Bool
, firmActCCFPinPassword :: Maybe Bool
} }
| FirmActChangeContactUserData | FirmActChangeContactUserData
{ firmActCCUPostalAddr :: Maybe StoredMarkup { firmActCCUPostalAddr :: Maybe StoredMarkup
@ -114,9 +120,10 @@ firmActionMap mr isAdmin acts = mconcat (mkAct isAdmin <$> acts)
<*> aopt (textField & cfStrip & addDatalist ucdefAssocReasons) <*> aopt (textField & cfStrip & addDatalist ucdefAssocReasons)
(fslI MsgUserCompanyReason & setTooltip MsgUserCompanyReasonTooltip) Nothing (fslI MsgUserCompanyReason & setTooltip MsgUserCompanyReasonTooltip) Nothing
mkAct _ FirmActChangeContactFirm = singletonMap FirmActChangeContactFirm $ FirmActChangeContactFirmData mkAct _ FirmActChangeContactFirm = singletonMap FirmActChangeContactFirm $ FirmActChangeContactFirmData
<$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing <$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMsgs [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing
<*> aopt (emailField & cfStrip & cfCI) (fslI MsgUserDisplayEmail & setTooltip MsgUtilEmptyNoChangeTip) Nothing <*> aopt (emailField & cfStrip & cfCI) (fslI MsgUserDisplayEmail & setTooltip MsgUtilEmptyNoChangeTip) Nothing
<*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFirmDefaultPreferenceInfo) Nothing <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFirmDefaultPreferenceInfo) Nothing
<*> aopt boolField' (fslI MsgFormFieldPinPass & setTooltip MsgFirmDefaultPreferenceInfo) Nothing
<* aformMessage (Message Info (toHtml $ mr MsgFirmActChangeContactFirmInfo) (Just IconNotificationNonactive)) <* aformMessage (Message Info (toHtml $ mr MsgFirmActChangeContactFirmInfo) (Just IconNotificationNonactive))
mkAct _ FirmActChangeContactUser = singletonMap FirmActChangeContactUser $ FirmActChangeContactUserData mkAct _ FirmActChangeContactUser = singletonMap FirmActChangeContactUser $ FirmActChangeContactUserData
<$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing <$> 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 [ (CompanyPostAddress =.) . Just <$> canonical firmActCCFPostalAddr
, (CompanyEmail =.) . Just <$> canonical firmActCCFEmail , (CompanyEmail =.) . Just <$> canonical firmActCCFEmail
, (CompanyPrefersPostal =.) <$> firmActCCFPostalPref , (CompanyPrefersPostal =.) <$> firmActCCFPostalPref
, (CompanyPinPassword =.) <$> firmActCCFPinPassword
] ]
in unless (null changes) $ do in unless (null changes) $ do
runDB $ update cid changes 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-act") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultAllCompanyActiveReroutes -> nr) -> wgtCell $ word2widget nr
-- , sortable (Just "reroute-all") (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 "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 dbtSorting = mconcat
[ singletonMap "name" $ SortColumn (E.^. CompanyName) [ singletonMap "name" $ SortColumn (E.^. CompanyName)
, singletonMap "short" $ SortColumn (E.^. CompanyShorthand) , singletonMap "short" $ SortColumn (E.^. CompanyShorthand)
, singletonMap "avsnr" $ SortColumn (E.^. CompanyAvsId) , singletonMap "avsnr" $ SortColumn (E.^. CompanyAvsId)
, singletonMap "postal-pref" $ SortColumn (E.^. CompanyPrefersPostal) , singletonMap "postal-pref" $ SortColumn (E.^. CompanyPrefersPostal)
, singletonMap "pin-password" $ SortColumn (E.^. CompanyPinPassword)
, singletonMap "users" $ SortColumn firmCountUsers , singletonMap "users" $ SortColumn firmCountUsers
, singletonMap "secondary" $ SortColumn firmCountUsersSecondary , singletonMap "secondary" $ SortColumn firmCountUsersSecondary
, singletonMap "supervisors" $ SortColumn firmHasSupervisors , singletonMap "supervisors" $ SortColumn firmHasSupervisors
@ -814,6 +824,7 @@ data FirmUserActionData = FirmUserActNotifyData
{ firmUserActPostalAddr :: Maybe StoredMarkup { firmUserActPostalAddr :: Maybe StoredMarkup
, firmUserActUseCompanyPostal :: Maybe Bool , firmUserActUseCompanyPostal :: Maybe Bool
, firmUserActPostalPref :: Maybe Bool , firmUserActPostalPref :: Maybe Bool
, firmUserActPinPassword :: Bool
} }
| FirmUserActRemoveData | FirmUserActRemoveData
{ firmUserActRemoveSupers :: Bool { firmUserActRemoveSupers :: Bool
@ -852,8 +863,8 @@ instance HasUser UserCompanyTableData where
hasUser = resultUserUser . _entityVal hasUser = resultUserUser . _entityVal
mkFirmUserTable :: Bool -> CompanyId -> DB (FormResult (FirmUserActionData, Set UserId), Widget) mkFirmUserTable :: Bool -> Entity Company -> DB (FormResult (FirmUserActionData, Set UserId), Widget)
mkFirmUserTable isAdmin cid = do mkFirmUserTable isAdmin Entity{entityKey=cid, entityVal=compData} = do
mr <- getMessageRender mr <- getMessageRender
let let
reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior
@ -901,9 +912,9 @@ mkFirmUserTable isAdmin cid = do
, colUserNameModalHdr MsgTableCompanyUser ForProfileDataR , colUserNameModalHdr MsgTableCompanyUser ForProfileDataR
, guardMonoid isAdmin $ sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \(view resultUserUser -> entUsr ) -> cellHasMatrikelnummerLinkedAdmin entUsr , 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 "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \(view $ resultUserUser . _userCompanyPersonalNumber -> t) -> foldMap textCell t
, sortable (Just "supervisors") (i18nCell MsgTableCompanyNrSupers ) $ \(view resultUserCompanySupervisors -> nr) -> wgtCell $ word2widget nr , sortable (Just "supervisors") (i18nCell MsgTableCompanyNrSupers ) $ \(view resultUserCompanySupervisors -> nr) -> wgtCell $ word2widget nr
, sortable (Just "reroutes") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultUserCompanyReroutes -> 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 , colUserLetterEmailPin
, sortable Nothing (i18nCell MsgCompanyUserUseCompanyAddress) $ \row -> , sortable Nothing (i18nCell MsgCompanyUserUseCompanyAddress) $ \row ->
let noUsrAddr = isNothing $ row ^. resultUserUser . _userPostAddress let noUsrAddr = isNothing $ row ^. resultUserUser . _userPostAddress
useCompA = row ^. resultUserUserCompany . _entityVal . _userCompanyUseCompanyAddress useCompA = row ^. resultUserUserCompany . _entityVal . _userCompanyUseCompanyAddress
@ -916,10 +927,11 @@ mkFirmUserTable isAdmin cid = do
in numCell prio <> spacerCell <> ifIconCell isPrime IconTop in numCell prio <> spacerCell <> ifIconCell isPrime IconTop
, sortable Nothing (i18nCell MsgTableUserEdit) $ \(view resultUserUser -> entUsr) -> cellEditUserModal entUsr , sortable Nothing (i18nCell MsgTableUserEdit) $ \(view resultUserUser -> entUsr) -> cellEditUserModal entUsr
] ]
dbtSorting = Map.fromList dbtSorting = Map.fromList
[ sortUserNameLink queryUserUser [ sortUserNameLink queryUserUser
, sortUserEmail queryUserUser , sortUserEmail queryUserUser
, ("postal-pref" , SortColumn $ queryUserUser >>> (E.^. UserPrefersPostal) ) , sortUserLetterEmailPin queryUserUser
, ("matriculation" , SortColumn $ queryUserUser >>> (E.^. UserMatrikelnummer) ) , ("matriculation" , SortColumn $ queryUserUser >>> (E.^. UserMatrikelnummer) )
, ("personal-number" , SortColumn $ queryUserUser >>> (E.^. UserCompanyPersonalNumber)) , ("personal-number" , SortColumn $ queryUserUser >>> (E.^. UserCompanyPersonalNumber))
, ("supervisors" , SortColumn $ queryUserUserCompany >>> firmCountUserSupervisors ) , ("supervisors" , SortColumn $ queryUserUserCompany >>> firmCountUserSupervisors )
@ -1039,6 +1051,8 @@ mkFirmUserTable isAdmin cid = do
<$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing <$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing
<*> aopt boolField' (fslI MsgCompanyUserUseCompanyAddress & setTooltip MsgCompanyUserUseCompanyAddressTip) Nothing <*> aopt boolField' (fslI MsgCompanyUserUseCompanyAddress & setTooltip MsgCompanyUserUseCompanyAddressTip) Nothing
<*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing
<*> if companyPinPassword compData then pure False else
areq boolField' (fslI MsgFormFieldPinPassRemove) Nothing
, singletonMap FirmUserActChangeDetails $ FirmUserActChangeDetailsData , singletonMap FirmUserActChangeDetails $ FirmUserActChangeDetailsData
<$> aopt intField (fslI MsgCompanyUserPriority & setTooltip MsgCompanyUserPriorityTip) Nothing <$> aopt intField (fslI MsgCompanyUserPriority & setTooltip MsgCompanyUserPriorityTip) Nothing
<*> aopt (textField & cfStrip & addDatalist userReasons) (fslI MsgUserCompanyReason & setTooltip (SomeMessages [SomeMessage MsgUserCompanyReasonTooltip, SomeMessage MsgNullDeletes])) 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 nrCompanyEmployeeRerPost
, E.Value nrCompanyDefaultReroutes , E.Value nrCompanyDefaultReroutes
, E.Value nrCompanyActiveReroutes , E.Value nrCompanyActiveReroutes
) , (fusrRes, fusrTable)) <- runDB $ (,) ) , (fusrRes, fusrTable)) <- runDB $ do
<$> fromMaybeM notFound (E.selectOne $ do compEnt <- fromMaybeM notFound (E.selectOne $ do
cmpy <- E.from $ E.table @Company cmpy <- E.from $ E.table @Company
E.where_ $ cmpy E.^. CompanyId E.==. E.val cid E.where_ $ cmpy E.^. CompanyId E.==. E.val cid
return ( cmpy return ( cmpy
@ -1108,7 +1122,8 @@ postFirmUsersR fsh = do
-- usr <- E.from $ E.table @User -- usr <- E.from $ E.table @User
-- E.where_ $ E.exists $ firmQuerySupervisedBy cmpyId Nothing usr -- E.where_ $ E.exists $ firmQuerySupervisedBy cmpyId Nothing usr
-- return usr -- return usr
<*> mkFirmUserTable isAdmin cid tbl <- mkFirmUserTable isAdmin (compEnt ^. _1)
return (compEnt, tbl)
let resetSupers :: Maybe Bool -> NonEmpty UserId -> DB Int64 let resetSupers :: Maybe Bool -> NonEmpty UserId -> DB Int64
resetSupers Nothing _ = return 0 resetSupers Nothing _ = return 0
@ -1162,9 +1177,10 @@ postFirmUsersR fsh = do
| firmUserActUseCompanyPostal == Just True, isJust firmUserActPostalAddr -> | firmUserActUseCompanyPostal == Just True, isJust firmUserActPostalAddr ->
addMessageI Error MsgCompanyUserUseCompanyPostalError addMessageI Error MsgCompanyUserUseCompanyPostalError
| otherwise -> do | otherwise -> do
let changes = catMaybes let changes =
[ toMaybe (firmUserActUseCompanyPostal == Just True) (UserPostAddress =. Nothing) -- precondition ensures that only one update applies for UserPostAddress bcons (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! bcons firmUserActPinPassword (UserPinPassword =. Nothing) $ catMaybes
[ (UserPostAddress =.) . Just <$> canonical firmUserActPostalAddr -- note that Nothing means no change and not delete address!
, (UserPrefersPostal =.) <$> firmUserActPostalPref , (UserPrefersPostal =.) <$> firmUserActPostalPref
] ]
nrChanged <- runDB $ do nrChanged <- runDB $ do
@ -1298,7 +1314,7 @@ mkFirmSuperTable isAdmin cid = do
, sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultSuperCompanies -> cmps) -> , 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] 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 "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 , colUserEmail
, sortable (Just "supervised") (i18nCell MsgTableCompanyNrEmpSupervised) $ \(view resultSuperCompanySupervised -> nr) -> wgtCell $ word2widget nr , sortable (Just "supervised") (i18nCell MsgTableCompanyNrEmpSupervised) $ \(view resultSuperCompanySupervised -> nr) -> wgtCell $ word2widget nr
, sortable (Just "rerouted") (i18nCell MsgTableCompanyNrEmpRerouted ) $ \(view resultSuperCompanyReroutes -> 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 , sortable Nothing (i18nCell MsgTableUserEdit) $ \(view resultSuperUser -> entUsr) -> cellEditUserModal entUsr
] ]
dbtSorting = Map.fromList dbtSorting = Map.fromList
[ sortUserNameLink querySuperUser [ sortUserNameLink querySuperUser
, sortUserEmail querySuperUser , sortUserEmail querySuperUser
, sortUserLetterEmailPin querySuperUser
, ("matriculation" , SortColumn $ querySuperUser >>> (E.^. UserMatrikelnummer)) , ("matriculation" , SortColumn $ querySuperUser >>> (E.^. UserMatrikelnummer))
, ("personal-number" , SortColumn $ querySuperUser >>> (E.^. UserCompanyPersonalNumber)) , ("personal-number" , SortColumn $ querySuperUser >>> (E.^. UserCompanyPersonalNumber))
, ("postal-pref" , SortColumn $ querySuperUser >>> (E.^. UserPrefersPostal))
, ("supervised" , SortColumn $ querySuperUser >>> firmCountForSupervisor cid Nothing) , ("supervised" , SortColumn $ querySuperUser >>> firmCountForSupervisor cid Nothing)
, ("rerouted" , SortColumn $ querySuperUser >>> firmCountForSupervisor cid (Just (E.^. UserSupervisorRerouteNotifications))) , ("rerouted" , SortColumn $ querySuperUser >>> firmCountForSupervisor cid (Just (E.^. UserSupervisorRerouteNotifications)))
, ("user-company" , SortColumn (\row -> E.subSelect $ do , ("user-company" , SortColumn (\row -> E.subSelect $ do

10
src/Handler/LMS/Learners.hs
View File

@ -136,8 +136,8 @@ mkUserTable _sid qsh qid cutoff = do
, (csvLmsResetPin , FilterColumn $ E.mkExactFilterLast (E.^. LmsUserResetPin)) , (csvLmsResetPin , FilterColumn $ E.mkExactFilterLast (E.^. LmsUserResetPin))
] ]
dbtFilterUI = \mPrev -> mconcat dbtFilterUI = \mPrev -> mconcat
[ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent & setTooltip MsgTableFilterCommaPlus) [ 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 csvLmsResetPin . maybePrism _PathPiece) mPrev $ aopt (hoistField lift boolField') (fslI MsgTableLmsResetPin)
] ]
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
dbtParams = def 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 -- 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 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 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 "preview" . maybePrism _PathPiece) mPrev $ aopt boolField' (fslI MsgLmsOrphanPreviewFltr)
, prismAForm (singletonFilter "reason" . maybePrism _PathPiece) mPrev $ aopt textField (fslI MsgLmsOrphanReason) , prismAForm (singletonFilter "reason" . maybePrism _PathPiece) mPrev $ aopt textField (fslI MsgLmsOrphanReason)
, prismAForm (singletonFilter "ident" . maybePrism _PathPiece) mPrev $ aopt textField (fslI MsgTableLmsIdent & setTooltip MsgTableFilterCommaPlus) , prismAForm (singletonFilter "ident" . maybePrism _PathPiece) mPrev $ aopt textField (fslI MsgTableLmsIdent & setTooltip MsgTableFilterCommaPlus)
] ]
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
dbtParams = def dbtParams = def

28
src/Handler/Utils/Avs.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022-24 Steffen Jost <s.jost@fraport.de> -- SPDX-FileCopyrightText: 2022-25 Steffen Jost <s.jost@fraport.de>
-- --
-- SPDX-License-Identifier: AGPL-3.0-or-later -- 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 queryAvsFullCardNo = fmap (fmap getFullCardNo) . queryAvsPrimaryCard
-- | Like `updateAvsUserByIds`, but exceptions are not caught here to allow rollbacks -- | Like `updateAvsUserByIds`, but exceptions are not caught here to allow rollbacks
updateAvsUserById :: AvsPersonId -> DB (Maybe UserId) updateAvsUserById :: AvsPersonId -> DB (Maybe UserId)
updateAvsUserById apid = do 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_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 -- 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 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 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` avs_ups = ((UserAvsNoPerson =.) <$> readMay (avsInfoPersonNo newAvsPersonInfo)) `mcons`
[ UserAvsLastSynch =. now [ UserAvsLastSynch =. now
, UserAvsLastSynchError =. Nothing , UserAvsLastSynchError =. Nothing
@ -403,10 +401,18 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
-- -> Nothing -- -> Nothing
superReasonComDef = tshow SupervisorReasonCompanyDefault superReasonComDef = tshow SupervisorReasonCompanyDefault
newUserComp = UserCompany usrId newCompanyId False False 1 True Nothing -- default value for new company insertion, if no update can be done 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 case oldAvsFirmInfo of
_ | Just newCompanyId == oldCompanyId -- company unchanged entirely _ | Just newCompanyId == oldCompanyId -- company unchanged entirely
-> return mempty -- => do nothing -> return base_up -- => do nothing
(Just oafi) | isJust (view _avsFirmPostAddressSimple oafi) (Just oafi) | isJust (view _avsFirmPostAddressSimple oafi)
&& ((==) `on` view _avsFirmPostAddressSimple) oafi newAvsFirmInfo -- non-empty company address unchanged OR && ((==) `on` view _avsFirmPostAddressSimple) oafi newAvsFirmInfo -- non-empty company address unchanged OR
|| isJust (view _avsFirmPrimaryEmail oafi) || isJust (view _avsFirmPrimaryEmail oafi)
@ -420,20 +426,20 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
, UserSupervisorCompany ==. Just ocid -- to new company, regardless of , UserSupervisorCompany ==. Just ocid -- to new company, regardless of
, UserSupervisorReason ==. Just superReasonComDef] -- user , UserSupervisorReason ==. Just superReasonComDef] -- user
[ UserSupervisorCompany =. Just newCompanyId] [ UserSupervisorCompany =. Just newCompanyId]
return mempty return base_up
_ | Just newCompanyId == primaryCompanyId -- old primaryCompany is now also AVS-company _ | Just newCompanyId == primaryCompanyId -- old primaryCompany is now also AVS-company
-> do -> do
whenIsJust oldCompanyId $ \oldCid -> do whenIsJust oldCompanyId $ \oldCid -> do
deleteBy $ UniqueUserCompany usrId oldCid deleteBy $ UniqueUserCompany usrId oldCid
deleteWhere $ (UserSupervisorUser ==. usrId):(UserSupervisorCompany ==. oldCompanyId):(UserSupervisorReason ~=. superReasonComDef) deleteWhere $ (UserSupervisorUser ==. usrId):(UserSupervisorCompany ==. oldCompanyId):(UserSupervisorReason ~=. superReasonComDef)
return mempty return base_up
_ -- company changed completely _ -- company changed completely
-> do -> do
(pst_up, problems) <- switchAvsUserCompany False False usrId newCompanyId (pst_up, problems) <- switchAvsUserCompany False False usrId newCompanyId
mapM_ reportAdminProblem problems mapM_ reportAdminProblem problems
-- Following line does not type, hence additional parameter needed -- 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 [ 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 -- SPECIALISED CODE, PROBABLY DEPRECATED
-- switch user company, keeping old priority -- switch user company, keeping old priority
-- (getBy . UniqueUserCompany usrId) `traverseJoin` oldCompanyId >>= \case -- (getBy . UniqueUserCompany usrId) `traverseJoin` oldCompanyId >>= \case
@ -535,7 +541,7 @@ createAvsUserById muid api = do
| otherwise -> return uid | otherwise -> return uid
(Nothing, Nothing) -> do -- create fresh user (Nothing, Nothing) -> do -- create fresh user
Entity{entityKey=cid, entityVal=cmp} <- runDB $ upsertAvsCompany firmInfo Nothing -- individual runDB, since no need to rollback 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 -- superiorEmail = filterMaybe validEmail $ adc ^. _avsContactFirmInfo . _avsFirmEMailSuperior
newUserData = AddUserData newUserData = AddUserData
{ audTitle = Nothing { audTitle = Nothing
@ -608,6 +614,7 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
, companyPrefersPostal = True , companyPrefersPostal = True
, companyPostAddress = newAvsFirmInfo ^. _avsFirmPostAddress , companyPostAddress = newAvsFirmInfo ^. _avsFirmPostAddress
, companyEmail = newAvsFirmInfo ^? _avsFirmPrimaryEmail . _Just . from _CI , companyEmail = newAvsFirmInfo ^? _avsFirmPrimaryEmail . _Just . from _CI
, companyPinPassword = True
} }
cmp = foldl' upd dmy $ firmInfo2key : firmInfo2companyNo : firmInfo2company cmp = foldl' upd dmy $ firmInfo2key : firmInfo2companyNo : firmInfo2company
$logInfoS "AVS" $ "Insert new company: " <> tshow cmp $logInfoS "AVS" $ "Insert new company: " <> tshow cmp
@ -649,6 +656,7 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
, CheckUpdate CompanyPostAddress _avsFirmPostAddress , CheckUpdate CompanyPostAddress _avsFirmPostAddress
, CheckUpdate CompanyEmail $ _avsFirmPrimaryEmail . _Just . from _CI . re _Just , 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 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
] ]

12
src/Handler/Utils/AvsUpdate.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de> -- SPDX-FileCopyrightText: 2024-25 Steffen Jost <s.jost@fraport.de>
-- --
-- SPDX-License-Identifier: AGPL-3.0-or-later -- SPDX-License-Identifier: AGPL-3.0-or-later
{-# OPTIONS_GHC -fno-warn-unused-top-binds -fno-warn-orphans #-} {-# 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_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 -- 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_UserPostAddress
| CU_ADC_UserDisplayEmail | CU_ADC_UserDisplayEmail
deriving (Show, Eq) deriving (Show, Eq)
instance MkCheckUpdate CU_AvsDataContcat_User where instance MkCheckUpdate CU_AvsDataContact_User where
type MCU_Rec CU_AvsDataContcat_User = User type MCU_Rec CU_AvsDataContact_User = User
type MCU_Raw CU_AvsDataContcat_User = AvsDataContact type MCU_Raw CU_AvsDataContact_User = AvsDataContact
mkCheckUpdate CU_ADC_UserPostAddress = CheckUpdateMay UserPostAddress _avsContactPrimaryPostAddress mkCheckUpdate CU_ADC_UserPostAddress = CheckUpdateMay UserPostAddress _avsContactPrimaryPostAddress
mkCheckUpdate CU_ADC_UserDisplayEmail = CheckUpdateOpt UserDisplayEmail $ _avsContactPrimaryEmail . _Just . from _CI 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! -- 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_UserPinPassword
-- CU_UA_UserPostAddress -- use _avsContactPrimaryPostAddress instead -- CU_UA_UserPostAddress -- use _avsContactPrimaryPostAddress instead
| CU_UA_UserFirstName | CU_UA_UserFirstName

7
src/Handler/Utils/Company.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de> -- SPDX-FileCopyrightText: 2022-25 Steffen Jost <s.jost@fraport.de>
-- --
-- SPDX-License-Identifier: AGPL-3.0-or-later -- SPDX-License-Identifier: AGPL-3.0-or-later
@ -168,13 +168,12 @@ switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = d
usrPrefPost = userPrefersPostal usrRec usrPrefPost = userPrefersPostal usrRec
usrPrefPostUp = toMaybe (Just usrPrefPost == (mbOldComp ^? _Just . _companyPrefersPostal)) usrPrefPostUp = toMaybe (Just usrPrefPost == (mbOldComp ^? _Just . _companyPrefersPostal))
(UserPrefersPostal =. companyPrefersPostal newCompany) (UserPrefersPostal =. companyPrefersPostal newCompany)
usrPinPassUp = toMaybe (newCompany ^. _companyPinPassword . _not) (UserPinPassword =. Nothing)
-- newCmpEmail :: UserEmail = fromMaybe "" $ companyEmail newCompany -- newCmpEmail :: UserEmail = fromMaybe "" $ companyEmail newCompany
usrDisplayEmail :: UserEmail = userDisplayEmail usrRec usrDisplayEmail :: UserEmail = userDisplayEmail usrRec
avsEmail :: Maybe UserEmail = mbUsrAvs ^? _Just . _entityVal . _userAvsLastFirmInfo . _Just . _avsFirmPrimaryEmail . _Just . from _CI 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 usrDisplayEmailUp = toMaybe (usrPostEmailUpds && avsEmail == Just usrDisplayEmail) (UserDisplayEmail =. "") -- delete DisplayEmail, if equal to AVS Firm Email
usrUpdate = catMaybes [usrPostUp, usrPrefPostUp, usrDisplayEmailUp] usrUpdate = catMaybes [usrPostUp, usrPrefPostUp, usrPinPassUp, usrDisplayEmailUp]
-- [UserPostAddress =. Nothing, UserPrefersPostal =. companyPrefersPostal newCompany] -- unconditional
newUserComp = UserCompany uid newCompanyId False False 1 True Nothing -- default value for new company insertion, if no update can be done newUserComp = UserCompany uid newCompanyId False False 1 True Nothing -- default value for new company insertion, if no update can be done
superReasonComDef = tshow SupervisorReasonCompanyDefault superReasonComDef = tshow SupervisorReasonCompanyDefault

7
src/Handler/Utils/Table/Cells.hs
View File

@ -218,6 +218,13 @@ emailCell :: IsDBTable m a => CI Text -> DBCell m a
emailCell email = cell $(widgetFile "widgets/link-email") emailCell email = cell $(widgetFile "widgets/link-email")
where linkText= toWgt 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 :: (IsDBTable m c, HasUser a) => a -> DBCell m c
cellHasUser = liftA2 userCell (view _userDisplayName) (view _userSurname) cellHasUser = liftA2 userCell (view _userDisplayName) (view _userSurname)

14
src/Handler/Utils/Table/Columns.hs
View File

@ -494,6 +494,20 @@ fltrUserEmailUI mPrev =
prismAForm (singletonFilter "user-email") mPrev $ aopt textField (fslI MsgTableEmail) 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 -- -- Study features --
-------------------- --------------------

1
src/Utils/Icon.hs
View File

@ -135,6 +135,7 @@ data Icon
| IconGlasses -- user must wear glasses while driving | IconGlasses -- user must wear glasses while driving
-- | IconPlaceholder -- reserved and sued by the frontend for actual missing errors -- | IconPlaceholder -- reserved and sued by the frontend for actual missing errors
| IconMissing -- something is missing or not applicable, less obtrusive than IconPlaceholder | 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 (Eq, Ord, Enum, Bounded, Show, Read, Generic)
deriving anyclass (Universe, Finite, NFData) deriving anyclass (Universe, Finite, NFData)

6
templates/firm-contact-info.hamlet
View File

@ -1,6 +1,6 @@
$newline never $newline never
$# SPDX-FileCopyrightText: 2023 Steffen Jost <jost@tcs.ifi.lmu.de> $# SPDX-FileCopyrightText: 2023-25 Steffen Jost <s.jost@fraport.de>
$# $#
$# SPDX-License-Identifier: AGPL-3.0-or-later $# SPDX-License-Identifier: AGPL-3.0-or-later
@ -12,8 +12,10 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
_{MsgFirmEmail} _{MsgFirmEmail}
$if not companyPrefersPostal $if not companyPrefersPostal
&nbsp; #{iconLetterOrEmail False} &nbsp; #{iconLetterOrEmail False}
$if companyPinPassword
&nbsp; #{icon IconPinProtect}
<dd .deflist__dd .email> <dd .deflist__dd .email>
#{mailtoHtml fem} #{mailtoHtml fem}
$maybe addr <- companyPostAddress $maybe addr <- companyPostAddress
<dt .deflist__dt> <dt .deflist__dt>
_{MsgFirmAddress} _{MsgFirmAddress}

6
test/Database/Fill.hs
View File

@ -200,7 +200,7 @@ fillDb = do
, userMobile = Just "0173 69 99 646" , userMobile = Just "0173 69 99 646"
, userCompanyPersonalNumber = Just "57138" , userCompanyPersonalNumber = Just "57138"
, userCompanyDepartment = Just "AVN-AR2" , userCompanyDepartment = Just "AVN-AR2"
, userPinPassword = Nothing , userPinPassword = Just "1234"
, userPostAddress = Nothing , userPostAddress = Nothing
, userPostLastUpdate = Nothing , userPostLastUpdate = Nothing
, userPrefersPostal = False , userPrefersPostal = False
@ -280,7 +280,7 @@ fillDb = do
, userMobile = Nothing , userMobile = Nothing
, userCompanyPersonalNumber = Just "12345" , userCompanyPersonalNumber = Just "12345"
, userCompanyDepartment = Nothing , userCompanyDepartment = Nothing
, userPinPassword = Nothing , userPinPassword = Just "weird"
, userPostAddress = Nothing , userPostAddress = Nothing
, userPostLastUpdate = Nothing , userPostLastUpdate = Nothing
, userPrefersPostal = False , userPrefersPostal = False
@ -560,7 +560,7 @@ fillDb = do
, userMobile = Nothing , userMobile = Nothing
, userCompanyPersonalNumber = bool Nothing (Just "E123" ) (even $ length firstName) , userCompanyPersonalNumber = bool Nothing (Just "E123" ) (even $ length firstName)
, userCompanyDepartment = bool Nothing (Just "AVN-A") (even $ length userSurname) , userCompanyDepartment = bool Nothing (Just "AVN-A") (even $ length userSurname)
, userPinPassword = Nothing , userPinPassword = toMaybe (isJust middleName) "000000"
, userPostAddress = Nothing , userPostAddress = Nothing
, userPostLastUpdate = Nothing , userPostLastUpdate = Nothing
, userPrefersPostal = False , userPrefersPostal = False