diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index 53ba2d4fc..c7e0173a5 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -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)} diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index 9c26677f2..7a323b880 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -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)} diff --git a/messages/uniworx/categories/user/de-de-formal.msg b/messages/uniworx/categories/user/de-de-formal.msg index 470e7b2db..f550dd4b2 100644 --- a/messages/uniworx/categories/user/de-de-formal.msg +++ b/messages/uniworx/categories/user/de-de-formal.msg @@ -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 \ No newline at end of file +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. \ No newline at end of file diff --git a/messages/uniworx/categories/user/en-eu.msg b/messages/uniworx/categories/user/en-eu.msg index 11faa5471..6e4624edc 100644 --- a/messages/uniworx/categories/user/en-eu.msg +++ b/messages/uniworx/categories/user/en-eu.msg @@ -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 \ No newline at end of file +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. \ No newline at end of file diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index c35e70c20..7d44de1cf 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -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 diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index 45947c414..830a5c441 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -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 diff --git a/models/users.model b/models/users.model index 6a265b02c..beb1d8e0c 100644 --- a/models/users.model +++ b/models/users.model @@ -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 diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 39cc90d29..74cdba887 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -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" diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 76c9346e9..c7ca9edd8 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -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 diff --git a/src/Handler/Tutorial/Form.hs b/src/Handler/Tutorial/Form.hs index 6e4e608dd..8c4743ea2 100644 --- a/src/Handler/Tutorial/Form.hs +++ b/src/Handler/Tutorial/Form.hs @@ -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 diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 991006030..e0f4a346c 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -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 ] diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 2f09d0804..c4d55cbf0 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -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 diff --git a/src/Handler/Utils/Company.hs b/src/Handler/Utils/Company.hs index d82adf69f..9d3682f5e 100644 --- a/src/Handler/Utils/Company.hs +++ b/src/Handler/Utils/Company.hs @@ -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 \ No newline at end of file diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index 0be567c66..edffdaef1 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -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] diff --git a/src/Model/Types/Misc.hs b/src/Model/Types/Misc.hs index 10fa045b6..c830bd0f5 100644 --- a/src/Model/Types/Misc.hs +++ b/src/Model/Types/Misc.hs @@ -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" diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index fa4e426b5..b0f76317f 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -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