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

chore(firm): add reason for user company association

Browse Source
This commit is contained in:
Steffen Jost 2024-07-10 15:54:15 +02:00
parent 3a66bed173
commit d65fb2f4cd
16 changed files with 109 additions and 65 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -16,7 +16,7 @@ FirmActNotify: Mitteilung versenden
FirmActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurücksetzen
FirmActResetSuperKeep: Bisherige Ansprechpartner der Firmenangehörigen zusätzlich beibehalten?
FirmActResetMutualSupervision: Ansprechpartner beaufsichtigen sich gegenseitig
FirmActAddSupersvisors: Ansprechpartner hinzufügen
FirmActAddSupervisors: Ansprechpartner hinzufügen
FirmActAddSupersEmpty: Es konnten keine Ansprechpartner hinzugefügt werden
FirmActAddSupersSet n@Int64 postal@(Maybe Bool): #{n} Standardansprechpartner geändert #{maybeBoolMessage postal "" "und auf Briefversand geschaltet" "und Benachrichtigungen per Email gesetzt"}, aber nicht nicht aktiviert.
RemoveSupervisors ndef@Int64 nact@Int64: #{ndef} Standard Ansprechpartner entfernt#{bool ", aber noch nicht deaktiviert" (", " <> tshow nact <> " aktive Ansprechpartnerbeziehungen gelöscht") (nact > 0)}

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

@ -16,7 +16,7 @@ FirmActNotify: Send message
FirmActResetSupervision: Reset supervisors for all company associates
FirmActResetSuperKeep: Additionally keep existing supervisors of company associates?
FirmActResetMutualSupervision: Supervisors supervise each other
FirmActAddSupersvisors: Add supervisors
FirmActAddSupervisors: Add supervisors
FirmActAddSupersEmpty: No supervisors added
FirmActAddSupersSet n postal: #{n} default company supervisors changed #{maybeBoolMessage postal "" "and switched to postal notifications" "and switched to email notifications"}, but not yet activated.
RemoveSupervisors ndef nact: #{ndef} default supervisors removed#{bool ", but not yet deactivated" (" and " <> tshow nact <> " active supervisions terminated") (nact > 0)}

5
messages/uniworx/categories/user/de-de-formal.msg
View File

@ -111,4 +111,7 @@ UsersChangeSupervisorsSuccess usr@Int spr@Int: #{tshow spr} Ansprechpartner für
UsersChangeSupervisorsWarning usr@Int spr@Int bad@Int: Nur _{MsgUsersChangeSupervisorsSuccess usr spr} #{tshow bad} Ansprechpartner #{pluralDE bad "wurde" "wurden"} nicht gefunden!
UsersRemoveSupervisors usr@Int: Alle Ansprechpartner für #{tshow usr} Benutzer gelöscht.
UsersRemoveSubordinates usr@Int: Alle Ansprechpartnerbeziehungen für #{tshow usr} #{pluralDE usr "ehemaligen" "ehemalige"} Ansprechpartner gelöscht.
SupervisorReason: Begründung
UserCompanyReason: Begründung der Firmenassoziation
UserCompanyReasonTooltip: Optionale Notiz für besondere Fälle. Kann ggf. autmatische Entfernung bei AVS Firmenwechsel verhindern.
UserSupervisorReason: Begründung Ansprechpartner
UserSupervisorReasonTooltip: Optionale Notiz für besondere Fälle. Kann ggf. autmatische Entfernung bei AVS Firmenwechsel verhindern.

5
messages/uniworx/categories/user/en-eu.msg
View File

@ -111,4 +111,7 @@ UsersChangeSupervisorsSuccess usr spr: #{pluralENsN spr "supervisor"} for #{plur
UsersChangeSupervisorsWarning usr spr bad: Only _{MsgUsersChangeSupervisorsSuccess usr spr} #{pluralENsN bad "supervisors"} could not be identified!
UsersRemoveSupervisors usr: Removed all supervisors for #{pluralENsN usr "user"}.
UsersRemoveSubordinates usr: Removed all subordinates for #{pluralENsN usr "previous supervisor"}.
SupervisorReason: Reason
UserCompanyReason: Reason for company association
UserCompanyReasonTooltip: Optional note for special cases. In some case this may prevent automatic removel upon AVS user company changes.
UserSupervisorReason: Reason for supervision
UserSupervisorReasonTooltip: Optional note for special cases. In some case this may prevent automatic removel upon AVS user company changes.

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

@ -84,6 +84,7 @@ TableCompanyNos: Firmennummern
TableCompanyUser: Firmenangehöriger
TableCompanyNrUsers: Firmenangehörige
TableCompanyNrSecondaryUsers: Sekundäre Firmenangehörige
TableCompanyReason: Notiz
TableCompanyNrSupers: Ansprechpartner
TableCompanyNrEmpSupervised: Firmenangehörige mit Ansprechpartner
TableCompanyNrEmpRerouted: Firmenangehörige mit Umleitung
@ -97,6 +98,7 @@ TableRerouteActive: Umleitung
TableCompanyPostalPreference: Benachrichtigungspräferenz neue Firmenangehörige
TableSupervisor: Ansprechpartner
TableSupervisee: Ansprechpartner für
TableReason: Begründung
TableCreationTime: Erstellungszeit
TableJob !ident-ok: Job
TableJobContent !ident-ok: Parameter

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

@ -84,6 +84,7 @@ TableCompanyNos: Company numbers
TableCompanyUser: Associate
TableCompanyNrUsers: Associates
TableCompanyNrSecondaryUsers: Secondary Associates
TableCompanyReason: Note
TableCompanyNrSupers: Supervisors
TableCompanyNrEmpSupervised: Supervised employees
TableCompanyNrEmpRerouted: Employees having reroute
@ -97,6 +98,7 @@ TableRerouteActive: Reroute
TableCompanyPostalPreference: Default notification preference
TableSupervisor: Supervisor
TableSupervisee: Supervisor for
TableReason: Reason
TableCreationTime: Creation
TableJob !ident-ok: Job
TableJobContent !ident-ok: Parameters

1
models/users.model
View File

@ -93,6 +93,7 @@ UserCompany
supervisorReroute Bool default=false -- if supervisor is true, should this supervisor receive email for _new_ company users?
priority Int default=0 -- higher number, higher priority; default=1 for Haskell-Code
useCompanyAddress Bool default=true -- if true, CompanyPostalAddress and CompanyEmail are used if UserPostalAddress/UserDisplayEmail are Nothing, respects priority
reason Text Maybe -- miscellaneous note, e.g. Superior
UniqueUserCompany user company -- a user may belong to multiple companies, but to each one only once
deriving Generic Show
UserSupervisor

74
src/Handler/Firm.hs
View File

@ -56,7 +56,7 @@ postalEmailField = boolFieldCustom (SomeMessage MsgUtilPostal) (SomeMessage MsgU
data FirmAction = FirmActNotify
| FirmActResetSupervision
| FirmActAddSupersvisors
| FirmActAddSupervisors
| FirmActChangeContactFirm
| FirmActChangeContactUser
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
@ -70,10 +70,11 @@ data FirmActionData = FirmActNotifyData
{ firmActResetKeepOldSupers :: Maybe Bool
, firmActResetMutualSupervision :: Maybe Bool
}
| FirmActAddSupersvisorsData
| FirmActAddSupervisorsData
{ firmActAddSupervisorIds :: Set Text
, firmActAddSupervisorReroute :: Bool
, firmActAddSupervisorPostal :: Maybe Bool
, firmActAddSupervisorReason :: Maybe Text
}
| FirmActChangeContactFirmData
{ firmActCCFPostalAddr :: Maybe StoredMarkup
@ -93,10 +94,12 @@ firmActionMap mr isAdmin acts = mconcat (mkAct isAdmin <$> acts)
mkAct _ FirmActResetSupervision = singletonMap FirmActResetSupervision $ FirmActResetSupervisionData
<$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False)
<*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True )
mkAct _ FirmActAddSupersvisors = singletonMap FirmActAddSupersvisors $ FirmActAddSupersvisorsData
mkAct _ FirmActAddSupervisors = singletonMap FirmActAddSupervisors $ FirmActAddSupervisorsData
<$> areq (textField & cfAnySeparatedSet) (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
<*> areq checkBoxField (fslI MsgTableIsDefaultReroute) (Just True)
<*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing
<*> aopt (textField & cfStrip & addDatalist ucdefSuperReasons)
(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
@ -106,6 +109,13 @@ firmActionMap mr isAdmin acts = mconcat (mkAct isAdmin <$> acts)
<$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing
<*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing
mkAct _ _ = mempty
ucdefSuperReasons :: HandlerFor UniWorX (OptionList Text)
ucdefSuperReasons = fmap (mkOptionList . map (\t -> Option t t t) . Set.toAscList) . runDB $
fmap (setOf $ folded . _Value . _Just) . E.select . E.distinct $ do
usrc <- E.from $ E.table @UserCompany
E.where_ $ E.isJust $ usrc E.^. UserCompanyReason
return $ usrc E.^. UserCompanyReason
firmActionForm :: _ -> Bool -> [FirmAction] -> AForm Handler FirmActionData
firmActionForm mr isAdmin acts = multiActionA (firmActionMap mr isAdmin acts) (fslI MsgTableAction) Nothing
@ -142,11 +152,11 @@ firmActionHandler route isAdmin = flip formResult faHandler
E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser
)
else return 0
newSupers <- addDefaultSupervisorsFor madId (firmActResetMutualSupervision /= Just False) fids
newSupers <- addDefaultSupervisorsFor Nothing madId (firmActResetMutualSupervision /= Just False) fids
addMessageI Success $ MsgFirmResetSupervision delSupers newSupers
reloadKeepGetParams route -- reload to reflect changes
faHandler (FirmActAddSupersvisorsData{..}, Set.toList -> [cid]) = do
faHandler (FirmActAddSupervisorsData{..}, Set.toList -> [cid]) = do
avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser firmActAddSupervisorIds
let (usersFound', usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers
usersFound = mapMaybe snd usersFound'
@ -164,7 +174,7 @@ firmActionHandler route isAdmin = flip formResult faHandler
runDB $ do
-- putMany [UserCompany uid cid True firmActAddSupervisorReroute 0 False | uid <- usersFound] -- putMany always overwrites existing records, which would destroy priority and useCompanyAddress here
-- upsertManyWhere [UserCompany uid cid True firmActAddSupervisorReroute 0 False | uid <- usersFound] [copyField UserCompanySupervisor, copyField UserCompanySupervisorReroute] [] [] -- overwrite Supervisor and SupervisorReroute, keep priority and useCompanyAddress
upsertManyWhere [UserCompany uid cid True firmActAddSupervisorReroute 0 False | uid <- usersFound] [] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. firmActAddSupervisorReroute] [] -- identical to previous line, but perhaps more clear?
upsertManyWhere [UserCompany uid cid True firmActAddSupervisorReroute 0 False firmActAddSupervisorReason| uid <- usersFound] [] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. firmActAddSupervisorReroute, UserCompanyReason =. firmActAddSupervisorReason] [] -- identical to previous line, but perhaps more clear?
whenIsJust firmActAddSupervisorPostal $ \prefPostal ->
updateWhere [UserId <-. usersFound] [UserPrefersPostal =. prefPostal]
addMessageI Success $ MsgFirmActAddSupersSet (fromIntegral $ length usersFound) firmActAddSupervisorPostal
@ -242,12 +252,13 @@ deleteSupervisors usrs cids = deleteWhereCount $ (UserSupervisorUser <-. toList
resetSupervisors :: CompanyId -> NonEmpty UserId -> DB Int64
resetSupervisors cid employees = do
nr_del <- deleteSupervisors employees [cid]
nr_add <- addDefaultSupervisors cid employees
let superReasonComDef = Just $ tshow SupervisorReasonCompanyDefault
nr_add <- addDefaultSupervisors superReasonComDef cid employees
return $ max nr_del nr_add
-- adds the default company supervisors as supervisor to a given set of users, which themselves may belong to any company
addDefaultSupervisors :: CompanyId -> NonEmpty UserId -> DB Int64
addDefaultSupervisors cid employees = do
addDefaultSupervisors :: Maybe Text -> CompanyId -> NonEmpty UserId -> DB Int64
addDefaultSupervisors reason cid employees = do
E.insertSelectWithConflictCount UniqueUserSupervisor
(do
(spr :& usr) <- E.from $ E.table @UserCompany `E.crossJoin` E.toValues employees
@ -258,17 +269,17 @@ addDefaultSupervisors cid employees = do
E.<&> usr
E.<&> (spr E.^. UserCompanySupervisorReroute)
E.<&> E.justVal cid
E.<&> E.nothing
E.<&> E.val reason
)
(\_old new ->
(\old new ->
[ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
, UserSupervisorCompany E.=. E.justVal cid
-- , UserSupervisorReason E.=. new E.^. UserSupervisorReason -- keep any existing reason
, UserSupervisorReason E.=. E.coalesce [old E.^. UserSupervisorReason, new E.^. UserSupervisorReason] -- keep any existing reason
])
-- like `addDefaultSupervisors`, but selects all employees of given companies from database, optionally filtered by being under supervision of a given individual
addDefaultSupervisorsFor :: (CompanyId ~ Element mono, MonoFoldable mono) => Maybe UserId -> Bool -> mono -> DB Int64
addDefaultSupervisorsFor mbSuperId mutualSupervision cids = do
addDefaultSupervisorsFor :: (CompanyId ~ Element mono, MonoFoldable mono) => Maybe Text -> Maybe UserId -> Bool -> mono -> DB Int64
addDefaultSupervisorsFor reason mbSuperId mutualSupervision cids = do
E.insertSelectWithConflictCount UniqueUserSupervisor
(do
(spr :& usr) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @UserCompany `E.on` (\(spr :& usr) -> spr E.^. UserCompanyCompany E.==. usr E.^. UserCompanyCompany)
@ -288,17 +299,17 @@ addDefaultSupervisorsFor mbSuperId mutualSupervision cids = do
E.<&> (usr E.^. UserCompanyUser)
E.<&> (spr E.^. UserCompanySupervisorReroute)
E.<&> E.just (spr E.^. UserCompanyCompany)
E.<&> E.nothing
E.<&> E.val reason
)
(\_old new ->
(\old new ->
[ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
, UserSupervisorCompany E.=. new E.^. UserSupervisorCompany
-- , UserSupervisorReason E.=. new E.^. UserSupervisorReason -- keep any existing reaon
, UserSupervisorReason E.=. E.coalesce [old E.^. UserSupervisorReason, new E.^. UserSupervisorReason] -- keep any existing reason
] )
-- like `addDefaultSupervisors`, but selects all employees of given companies from database
addDefaultSupervisorsAll :: (CompanyId ~ Element mono, MonoFoldable mono) => Bool -> mono -> DB Int64
addDefaultSupervisorsAll mutualSupervision cids = do
addDefaultSupervisorsAll :: (CompanyId ~ Element mono, MonoFoldable mono) => Maybe Text -> Bool -> mono -> DB Int64
addDefaultSupervisorsAll reason mutualSupervision cids = do
E.insertSelectWithConflictCount UniqueUserSupervisor
(do
(spr :& usr) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @UserCompany `E.on` (\(spr :& usr) -> spr E.^. UserCompanyCompany E.==. usr E.^. UserCompanyCompany)
@ -313,12 +324,12 @@ addDefaultSupervisorsAll mutualSupervision cids = do
E.<&> (usr E.^. UserCompanyUser)
E.<&> (spr E.^. UserCompanySupervisorReroute)
E.<&> E.just (spr E.^. UserCompanyCompany)
E.<&> E.nothing
E.<&> E.val reason
)
(\_old new ->
(\old new ->
[ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
, UserSupervisorCompany E.=. new E.^. UserSupervisorCompany
-- , UserSupervisorReason E.=. new E.^. UserSupervisorReason -- keep any existing reaon
, UserSupervisorReason E.=. E.coalesce [old E.^. UserSupervisorReason, new E.^. UserSupervisorReason] -- keep any existing reason
] )
@ -812,6 +823,7 @@ data FirmUserActionData = FirmUserActNotifyData
| FirmUserActSetSupervisorData
{ firmUserActSetSuperNames :: Maybe (Set Text)
, firmUserActSetSuperIds :: Maybe [UserId]
, firmUserActSetSuperReason :: Maybe Text
, firmUserActSetSuperReroute :: Bool
, firmUserActSetSuperKeep :: Bool
}
@ -905,6 +917,7 @@ mkFirmUserTable isAdmin cid = do
, sortable (Just "reroutes") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultUserCompanyReroutes -> nr) -> wgtCell $ word2widget nr
, sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultUserUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b
, colUserEmail
, sortable (Just "usr-reason") (i18nCell MsgTableCompanyReason) $ \(view $ resultUserUserCompany . _entityVal . _userCompanyReason -> r) -> cellMaybe textCell r
, sortable Nothing (i18nCell MsgTableUserEdit) $ \(view resultUserUser -> entUsr) -> cellEditUserModal entUsr
]
dbtSorting = mconcat
@ -915,6 +928,7 @@ mkFirmUserTable isAdmin cid = do
, singletonMap "personal-number" $ SortColumn $ queryUserUser >>> (E.^. UserCompanyPersonalNumber)
, singletonMap "supervisors" $ SortColumn $ queryUserUserCompany >>> firmCountUserSupervisors
, singletonMap "reroutes" $ SortColumn $ queryUserUserCompany >>> firmCountUserSupervisorsReroute
, singletonMap "usr-reason" $ SortColumn $ queryUserUserCompany >>> (E.^. UserCompanyReason)
]
dbtFilter = mconcat
[ single $ fltrUserNameEmail queryUserUser
@ -991,6 +1005,13 @@ mkFirmUserTable isAdmin cid = do
, prismAForm (singletonFilter "is-primary-company" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmPrimary)
]
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
superReasons :: HandlerFor UniWorX (OptionList Text)
superReasons = fmap (mkOptionList . map (\t -> Option t t t) . Set.toAscList) . runDB $
fmap (setOf $ folded . _Value . _Just) . E.select . E.distinct $ do
usrc <- E.from $ E.table @UserSupervisor
E.where_ $ E.isJust (usrc E.^. UserSupervisorReason)
E.&&. usrc E.^. UserSupervisorCompany E.~=. E.val cid
return $ usrc E.^. UserSupervisorReason
acts :: Map FirmUserAction (AForm Handler FirmUserActionData)
acts = mconcat
[ guardMonoid isAdmin $ singletonMap FirmUserActNotify $ pure FirmUserActNotifyData
@ -1000,6 +1021,7 @@ mkFirmUserTable isAdmin cid = do
, singletonMap FirmUserActSetSupervisor $ FirmUserActSetSupervisorData
<$> aopt (textField & cfAnySeparatedSet) (fslI MsgFirmNewSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
<*> aopt supervisorsField (fslI MsgFirmSetSupervisor & setTooltip MsgMultiSelectTip) Nothing
<*> aopt (textField & cfStrip & addDatalist superReasons) (fslI MsgUserSupervisorReason & setTooltip MsgUserSupervisorReasonTooltip) Nothing
<*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just False)
<*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just False)
, singletonMap FirmUserActMkSuper $ FirmUserActMkSuperData
@ -1083,7 +1105,7 @@ postFirmUsersR fsh = do
delSupers <- if firmUserActResetKeepOldSupers == Just False
then deleteSupervisors uids []
else return 0
newSupers <- addDefaultSupervisors cid uids
newSupers <- addDefaultSupervisors Nothing cid uids
addMessageI Info $ MsgFirmResetSupervision delSupers newSupers
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
(FirmUserActSetSupervisorData{..}, set2NonEmpty (error "Unexpected empty user list in getFirmUserR action handler.") -> uids) -> do
@ -1103,7 +1125,7 @@ postFirmUsersR fsh = do
in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent)
delSupers <- runDB
$ bool (deleteSupervisors uids [cid]) (return 0) firmUserActSetSuperKeep
<* putMany [UserSupervisor s u firmUserActSetSuperReroute (Just cid) Nothing | u <- toList uids, s <- newSupers]
<* putMany [UserSupervisor s u firmUserActSetSuperReroute (Just cid) firmUserActSetSuperReason | u <- toList uids, s <- newSupers]
addMessageI Success $ MsgFirmSetSupersReport nrUsers nrSupers delSupers
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
@ -1121,7 +1143,7 @@ postFirmUsersR fsh = do
addMessageI Success $ MsgFirmUserChanges nrChanged
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
formFirmAction <- runFirmActionFormPost cid (FirmUsersR fsh) isAdmin [FirmActNotify, FirmActResetSupervision, FirmActAddSupersvisors, FirmActChangeContactFirm, FirmActChangeContactUser]
formFirmAction <- runFirmActionFormPost cid (FirmUsersR fsh) isAdmin [FirmActNotify, FirmActResetSupervision, FirmActAddSupervisors, FirmActChangeContactFirm, FirmActChangeContactUser]
siteLayout (citext2widget companyName) $ do
setTitle $ toHtml $ CI.original companyShorthand <> "-" <> tshow companyAvsId
@ -1351,7 +1373,7 @@ postFirmSupersR fsh = do
cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser]
redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids])
formFirmAction <- runFirmActionFormPost cid (FirmSupersR fsh) isAdmin [FirmActAddSupersvisors, FirmActResetSupervision, FirmActChangeContactFirm]
formFirmAction <- runFirmActionFormPost cid (FirmSupersR fsh) isAdmin [FirmActAddSupervisors, FirmActResetSupervision, FirmActChangeContactFirm]
siteLayout (citext2widget fsh) $ do
setTitle $ citext2Html $ fsh <> " Supers"

8
src/Handler/Profile.hs
View File

@ -1092,8 +1092,8 @@ mkSupervisorsTable uid = dbTableWidget validator DBTable{..}
if isReroute
then iconCell IconReroute <> spacerCell <> iconFixedCell (iconLetterOrEmail isLetter)
else mempty
, sortable (Just "cshort") (i18nCell MsgTableCompany) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorCompany -> mc) -> maybeCell mc (\(unCompanyKey -> c) -> anchorCell (FirmUsersR c) $ citext2widget c)
, sortable (Just "reason") (i18nCell MsgSupervisorReason) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorReason -> mr) -> maybeCell mr textCell
, sortable (Just "cshort") (i18nCell MsgTableCompany) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorCompany -> mc) -> maybeCell mc (\(unCompanyKey -> c) -> anchorCell (FirmUsersR c) $ citext2widget c)
, sortable (Just "reason") (i18nCell MsgTableReason) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorReason -> mr) -> maybeCell mr textCell
]
validator = def & defaultSorting [ SortAscBy "cshort", SortAscBy "user-name" ]
dbtSorting = mconcat
@ -1142,8 +1142,8 @@ mkSuperviseesTable userPrefersPostal uid = dbTableWidget validator DBTable{..}
, sortable (Just "reroute") (i18nCell MsgTableRerouteActive) $ \row ->
let isReroute = row ^. resultUserSupervisor . _entityVal ._userSupervisorRerouteNotifications
in tellCell (Sum 1, Sum $ fromEnum isReroute) $ boolCell isReroute $ iconCell IconReroute <> iconCellLetterOrEmail
, sortable (Just "cshort") (i18nCell MsgTableCompany) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorCompany -> mc) -> maybeCell mc (\(unCompanyKey -> c) -> anchorCell (FirmUsersR c) $ citext2widget c)
, sortable (Just "reason") (i18nCell MsgSupervisorReason) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorReason -> mr) -> maybeCell mr textCell
, sortable (Just "cshort") (i18nCell MsgTableCompany) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorCompany -> mc) -> maybeCell mc (\(unCompanyKey -> c) -> anchorCell (FirmUsersR c) $ citext2widget c)
, sortable (Just "reason") (i18nCell MsgTableReason) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorReason -> mr) -> maybeCell mr textCell
]
validator = def & defaultSorting [ SortAscBy "cshort", SortAscBy "user-name" ]
dbtSorting = mconcat

2
src/Handler/Tutorial/Form.hs
View File

@ -91,7 +91,7 @@ tutorialForm cid template html = do
where
tutTypeDatalist :: HandlerFor UniWorX (OptionList (CI Text))
tutTypeDatalist = fmap (mkOptionList . map (\t -> Option (CI.original t) t (toPathPiece $ CI.original t)) . Set.toAscList) . runDB $
fmap (setOf $ folded . _Value) . E.select . E.from $ \tutorial -> do
fmap (setOf $ folded . _Value) . E.select . E.distinct . E.from $ \tutorial -> do
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
return $ tutorial E.^. TutorialType

10
src/Handler/Users.hs
View File

@ -186,6 +186,12 @@ postUsersR = do
let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
return (act, usrSet)
superReasons :: HandlerFor UniWorX (OptionList Text)
superReasons = fmap (mkOptionList . map (\t -> Option t t t) . Set.toAscList) . runDB $
fmap (setOf $ folded . _Value . _Just) . Ex.select . Ex.distinct $ do
usrc <- Ex.from $ Ex.table @UserSupervisor
E.where_ $ E.isJust (usrc E.^. UserSupervisorReason)
return $ usrc E.^. UserSupervisorReason
acts :: Map UserAction (AForm Handler UserActionData)
acts = mconcat
[ singletonMap UserLdapSync $ pure UserLdapSyncData
@ -193,11 +199,11 @@ postUsersR = do
, singletonMap UserAddSupervisor $ UserAddSupervisorData
<$> apopt (textField & cfAnySeparatedSet) (fslI MsgTableSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
<*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just True)
<*> aopt textField (fslI MsgSupervisorReason) Nothing
<*> aopt (textField & cfStrip & addDatalist superReasons) (fslI MsgUserSupervisorReason & setTooltip MsgUserSupervisorReasonTooltip) Nothing
, singletonMap UserSetSupervisor $ UserSetSupervisorData
<$> apopt (textField & cfAnySeparatedSet) (fslI MsgTableSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
<*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just True)
<*> aopt textField (fslI MsgSupervisorReason) Nothing
<*> aopt (textField & cfStrip & addDatalist superReasons) (fslI MsgUserSupervisorReason & setTooltip MsgUserSupervisorReasonTooltip) Nothing
, singletonMap UserRemoveSupervisor $ pure UserRemoveSupervisorData
, singletonMap UserRemoveSubordinates $ pure UserRemoveSubordinatesData
]

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

@ -394,7 +394,7 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
-- | otherwise
-- -> Nothing
superReasonComDef = tshow SupervisorReasonCompanyDefault
newUserComp = UserCompany usrId newCompanyId False False 1 True -- 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
usr_up2 <- case oldAvsFirmInfo of
_ | Just newCompanyId == oldCompanyId -- company unchanged entirely
@ -550,7 +550,7 @@ createAvsUserById muid api = do
}
runDB $ do -- any failure must rollback all DB write transactions here
uid <- maybeThrowM (AvsUserCreationFailed api) $ addNewUserDB newUserData
let userComp = UserCompany uid cid False False 1 True -- default value for new company insertion, if no update can be done
let userComp = UserCompany uid cid False False 1 True Nothing -- default value for new company insertion, if no update can be done
void $ insertUnique userComp -- Nothing indicates that the user is already linked to the company (which is unlikely here)
-- Supervision
addCompanySupervisors cid uid
@ -682,8 +682,8 @@ upsertCompanySuperior (mbCid, newAfi) mbOldAfi = runMaybeT $ do
return . E.max_ $ usrCmp E.^. UserCompanyPriority
let maxPrio = maybe 1 (fromMaybe 1 . E.unValue) mbMaxPrio
suprEnt <- upsertBy (UniqueUserCompany supid cid)
(UserCompany supid cid True False maxPrio True)
[UserCompanySupervisor =. True, UserCompanyPriority =. maxPrio]
(UserCompany supid cid True False maxPrio True reasonSuperior)
[UserCompanySupervisor =. True, UserCompanyPriority =. maxPrio, UserCompanyReason =. reasonSuperior]
E.insertSelectWithConflict UniqueUserSupervisor
(do
usr <- E.from $ E.table @UserCompany

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

@ -110,11 +110,12 @@ switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = d
void $ insertUnique newUserComp
addCompanySupervisors newCompanyId uid
return (usrUpdate, mempty)
Just UserCompany{userCompanyCompany=oldCompanyId, userCompanyPriority=oldPrio, userCompanySupervisor=oldSuper, userCompanySupervisorReroute=oldSuperReroute}
Just UserCompany{userCompanyCompany=oldCompanyId, userCompanyPriority=oldPrio, userCompanySupervisor=oldSuper, userCompanySupervisorReroute=oldSuperReroute, userCompanyReason=oldAssocReason}
| newCompanyId == oldCompanyId -> return mempty -- nothing to do
| otherwise -> do -- switch company
when (isNothing oldAssocReason) $ deleteBy $ UniqueUserCompany uid oldCompanyId
void $ upsertBy (UniqueUserCompany uid newCompanyId) newUserComp
[UserCompanyPriority =. succ oldPrio, UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False, UserCompanyUseCompanyAddress =. True]
[UserCompanyPriority =. succ oldPrio, UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False, UserCompanyUseCompanyAddress =. True, UserCompanyReason =. Nothing]
-- supervised by uid
supervisees :: [(Entity UserSupervisor, E.Value Bool)] <- E.select $ do
usrSup <- E.from $ E.table @UserSupervisor
@ -147,5 +148,5 @@ switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = d
newlyUnsupervised
return (usrUpdate ,problems)
where
newUserComp = UserCompany uid newCompanyId False False 1 True -- 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

2
src/Handler/Utils/Users.hs
View File

@ -1000,11 +1000,13 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
E.<&> (userCompany E.^. UserCompanySupervisorReroute)
E.<&> (userCompany E.^. UserCompanyPriority)
E.<&> (userCompany E.^. UserCompanyUseCompanyAddress)
E.<&> (userCompany E.^. UserCompanyReason)
)
(\current excluded ->
[ UserCompanySupervisor E.=. E.greatest (current E.^. UserCompanySupervisor) (excluded E.^. UserCompanySupervisor) -- t > f
, UserCompanyPriority E.=. E.greatest (current E.^. UserCompanyPriority) (excluded E.^. UserCompanyPriority)
, UserCompanyUseCompanyAddress E.=. E.greatest (current E.^. UserCompanyUseCompanyAddress) (excluded E.^. UserCompanyUseCompanyAddress)
, UserCompanyReason E.=. E.coalesce [current E.^. UserCompanyReason ,excluded E.^. UserCompanyReason]
]
)
deleteWhere [ UserCompanyUser ==. oldUserId]

2
src/Model/Types/Misc.hs
View File

@ -65,6 +65,8 @@ data SupervisorReason
deriving (Eq, Ord, Enum, Bounded, Generic)
deriving anyclass (Universe, Finite, NFData)
-- NOTE: it is intentional not to have an embedRenderMessage here; within the DB, we allow arbitrary text, but we do match on these ones to recognise certain functions
-- so do not change values here without a proper migration
instance Show SupervisorReason where
show SupervisorReasonCompanyDefault = "Firmenstandard"
show SupervisorReasonAvsSuperior = "Vorgesetzer"

42
test/Database/Fill.hs
View File

@ -655,25 +655,25 @@ fillDb = do
, let rcName = CI.mk $ "Random Corp " <> tshow n <> bool "" " GmbH" (even n)
, let rcShort = CI.mk $ "RC" <> tshow n
]
void . insert' $ UserCompany jost fraportAg True True 0 False
void . insert' $ UserCompany svaupel nice True False 2 False
void . insert' $ UserCompany svaupel ffacil False False 1 False
void . insert' $ UserCompany svaupel bpol True False 2 False
void . insert' $ UserCompany svaupel fraGround True False 1 False
void . insert' $ UserCompany gkleen nice False False 1 True
void . insert' $ UserCompany gkleen fraGround False True 2 False
void . insert' $ UserCompany gkleen bpol False True 1 False
void . insert' $ UserCompany fhamann bpol False False 1 True
void . insert' $ UserCompany fhamann ffacil True True 2 True
void . insert' $ UserCompany fhamann nice False False 3 False
void . insert' $ UserCompany sbarth nice False False 3 False
void . insert' $ UserCompany sbarth bpol True True 1 True
void . insert' $ UserCompany jost fraportAg True True 0 False $ Just "Vorgesetzter"
void . insert' $ UserCompany svaupel nice True False 2 False $ Just "Vorgesetzter"
void . insert' $ UserCompany svaupel ffacil False False 1 False $ Just "Irgendwas"
void . insert' $ UserCompany svaupel bpol True False 2 False $ Just "Irgendwas"
void . insert' $ UserCompany svaupel fraGround True False 1 False $ Just "Irgendwas"
void . insert' $ UserCompany gkleen nice False False 1 True $ Just "Winterdienst"
void . insert' $ UserCompany gkleen fraGround False True 2 False $ Just "Irgendwas"
void . insert' $ UserCompany gkleen bpol False True 1 False $ Just "Irgendwas"
void . insert' $ UserCompany fhamann bpol False False 1 True $ Just "Irgendwas"
void . insert' $ UserCompany fhamann ffacil True True 2 True $ Just "Irgendwas"
void . insert' $ UserCompany fhamann nice False False 3 False $ Just "Winterdienst"
void . insert' $ UserCompany sbarth nice False False 3 False $ Just "Winterdienst"
void . insert' $ UserCompany sbarth bpol True True 1 True $ Just "Irgendwas"
-- need more tests
insertMany_ [UserCompany uid fraGround False False 0 True | Entity uid User{userFirstName = "John"} <- matUsers]
insertMany_ [UserCompany uid bpol False False 0 False | Entity uid User{userFirstName = "Elizabeth"} <- matUsers]
insertMany_ [UserCompany uid bpol True True 0 True | Entity uid User{userFirstName = "Clark", userSurname = dn} <- matUsers, dn == "Walker" || dn == "Robinson"]
insertMany_ [UserCompany uid ffacil False False 0 False | Entity uid User{userSurname = "Walker"} <- matUsers]
insertMany_ [UserCompany uid rckey issuper False 0 True
insertMany_ [UserCompany uid fraGround False False 0 True Nothing | Entity uid User{userFirstName = "John"} <- matUsers]
insertMany_ [UserCompany uid bpol False False 0 False Nothing | Entity uid User{userFirstName = "Elizabeth"} <- matUsers]
insertMany_ [UserCompany uid bpol True True 0 True Nothing | Entity uid User{userFirstName = "Clark", userSurname = dn} <- matUsers, dn == "Walker" || dn == "Robinson"]
insertMany_ [UserCompany uid ffacil False False 0 False Nothing | Entity uid User{userSurname = "Walker"} <- matUsers]
insertMany_ [UserCompany uid rckey issuper False 0 True Nothing
| rckey <- randComps
, Just n <- [readMay $ drop 2 $ unpack $ CI.original $ unCompanyKey rckey]
, Entity uid User{userSurname = uSurname} <- take (n `div` 20) $ drop (2*n) matUsers
@ -699,9 +699,9 @@ fillDb = do
, UserSupervisor gkleen gkleen True (Just fraGround) (Just "Staff")
, UserSupervisor tinaTester tinaTester False Nothing (Just "Staff")
]
++ take 444 [ UserSupervisor fhamann uid True Nothing (Just $ tshow SupervisorReasonCompanyDefault) | Entity uid _ <- matUsers, uid /= jost]
++ take 123 [ UserSupervisor gkleen uid True Nothing Nothing | Entity uid _ <- drop 369 matUsers ]
++ take 11 [ UserSupervisor jost uid False Nothing (Just $ tshow SupervisorReasonAvsSuperior) | Entity uid _ <- drop 501 matUsers ]
++ take 444 [ UserSupervisor fhamann uid True Nothing (Just $ tshow SupervisorReasonCompanyDefault) | Entity uid _ <- matUsers, uid /= jost]
++ take 123 [ UserSupervisor gkleen uid True Nothing Nothing | Entity uid _ <- drop 369 matUsers ]
++ take 11 [ UserSupervisor jost uid False (Just fraportAg) (Just $ tshow SupervisorReasonAvsSuperior) | Entity uid _ <- drop 501 matUsers ]
upsertManyWhere supvs [] [] []
-- insertMany_ supvs -- NOTE: multiple calls like this throw a runtime error!
-- upsertManyWhere supvs [] [] [] -- NOTE: multiple calls like this are ok