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-badge": "id-badge",
"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-unknown,
missing,
pin-protect,
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
@ -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

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
@ -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

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

@ -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

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

@ -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

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
@ -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

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
@ -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

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

@ -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

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
@ -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
]

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
{-# 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

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
@ -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

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")
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)

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

@ -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 --
--------------------

1
src/Utils/Icon.hs
View File

@ -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)

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

@ -1,6 +1,6 @@
$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
@ -12,8 +12,10 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
_{MsgFirmEmail}
$if not companyPrefersPostal
&nbsp; #{iconLetterOrEmail False}
$if companyPinPassword
&nbsp; #{icon IconPinProtect}
<dd .deflist__dd .email>
#{mailtoHtml fem}
#{mailtoHtml fem}
$maybe addr <- companyPostAddress
<dt .deflist__dt>
_{MsgFirmAddress}

6
test/Database/Fill.hs
View File

@ -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