diff --git a/messages/uniworx/categories/admin/de-de-formal.msg b/messages/uniworx/categories/admin/de-de-formal.msg index 922d58f4c..a80ceead2 100644 --- a/messages/uniworx/categories/admin/de-de-formal.msg +++ b/messages/uniworx/categories/admin/de-de-formal.msg @@ -114,6 +114,7 @@ ProblemsNoStalePrintJobs n@Integer: Alle Briefversandaufträge #{pluralDE n "des ProblemsNoBadAPCIds: Alle kürzlich empfangenen Druckauftragsbestätigungen waren gültig ProblemsUnreachableHeading: Unerreichbare Benutzer ProblemsUnreachableBody: Benutzer ohne E-Mail oder Postadresse, welche z.B. bei ablaufenden Berechtigungen nicht benachrichtigt werden können: +ProblemsUnreachableButtons: Synchronisation für Unerreichbare starten ProblemsRWithoutFHeading: Fahrer mit R ohne F ProblemsRWithoutFBody: Diese Fahrer sind wegen einer ungültigen Vorfeld-Fahrberechtigung komplett gesperrt, obwohl eine gültige Rollfeld-Fahrberechtigung besteht: ProblemsNoAvsIdHeading: Fahrer ohne AVS-Id @@ -132,8 +133,9 @@ AdminProblemsReopened n@Int: #{pluralDEeN n "Admin Problem"} erneut eröffnet AdminProblemNewCompany: Neue Firma über AVS automatisch erstellt; prüfen und ggf. Standardansprechpartner eintragen AdminProblemSupervisorNewCompany b@Bool: Standardansprechpartner #{boolText mempty "mit Standardumleitung" b} wechselte zu neuer Firma AdminProblemSupervisorLeftCompany b@Bool: Einziger Standardansprechpartner #{boolText mempty "mit Standardumleitung" b} dieses Fahrers wechselte zu neuer Firma -AdminProblemCompanySuperiorChange: Neuer firmenweiter Vorgesetzer. -AdminProblemCompanySuperiorPrevious: Ehemaliger Vorgesetzer: +AdminProblemCompanySuperiorChange: Neuer firmenweiter Vorgesetzter. +AdminProblemCompanySuperiorNotFound t@Text: Neuer unbekannter firmenweiter Vorgesetzter mit E-Mail #{t}, keine Ansprechpartnerbeziehungen eingerichtet. +AdminProblemCompanySuperiorPrevious: Ehemaliger Vorgesetzter: AdminProblemNewlyUnsupervised: Fahrer hat keinen Firmenansprechpartner mehr nach AVS Firmenwechsel zu Firma AdminProblemUser: Betroffener ProblemTableMarkSolved: Als erledigt markieren diff --git a/messages/uniworx/categories/admin/en-eu.msg b/messages/uniworx/categories/admin/en-eu.msg index 96972ad87..f69fda9e5 100644 --- a/messages/uniworx/categories/admin/en-eu.msg +++ b/messages/uniworx/categories/admin/en-eu.msg @@ -114,6 +114,7 @@ ProblemsNoStalePrintJobs n: All requests for letter mailing within the last #{pl ProblemsNoBadAPCIds: All recently received print job ids from Airport Print Center were legit ProblemsUnreachableHeading: Unreachable Users ProblemsUnreachableBody: Users without Email nor postal address, who thus cannot be notified about expiring qualifications: +ProblemsUnreachableButtons: Start synchronisation for unreachable users only ProblemsRWithoutFHeading: Drivers having 'R' but not 'F' ProblemsRWithoutFBody: Drivers without apron driving licence are prohibited from driving, even if they own a valid maneuvering driving licence: ProblemsNoAvsIdHeading: Drivers without AVS id @@ -133,6 +134,7 @@ AdminProblemNewCompany: New company from AVS; verify and add default supervisors AdminProblemSupervisorNewCompany b: Default company supervisor #{boolText mempty "with reroute" b} changed to new company AdminProblemSupervisorLeftCompany b: Only default company supervisor #{boolText mempty "with reroute" b} for this user changed to new company AdminProblemCompanySuperiorChange: New company wide superior. +AdminProblemCompanySuperiorNotFound t: Unable to set supervision for new unknown company wide superior having Email #{t}. AdminProblemCompanySuperiorPrevious: Previous superior: AdminProblemNewlyUnsupervised: Driver has no longer a company default supervisor after AVS update at new company AdminProblemUser: Affected diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index 951ec61ab..70d351f25 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -51,7 +51,9 @@ FilterSupervisor: Hat aktiven Ansprechpartner FilterSupervisorCompany fsh@CompanyShorthand: Hat aktiven Ansprechpartner, #{fsh} der angehört FilterSupervisorForeign fsh@CompanyShorthand: Hat aktiven Ansprechpartner, der selbst nicht #{fsh} angehört FilterForeignSupervisor: Hat firmenfremde Ansprechpartner +FilterIsForeignSupervisee: Ist Ansprechpartner für Firmenfremde FilterFirmExtern: Externe Firma +FilterFirmExternTooltip: Hat die Firma eine Postanschrift im AVS? FilterFirmPrimary: Ist primäre Firma in FRADrive FilterHasQualification: Hat Firmenangehörige mit aktuell gültiger Qualifikation FirmSupervisorOf fsh@CompanyShorthand: Ansprechpartner #{fsh} angehörig @@ -59,6 +61,7 @@ FirmSupervisorIndependent: Ansprechpartner ohne jegliche Firmenzugehörigkeit FirmEmployeeOf fsh@CompanyShorthand: Firmenangehörige #{fsh} NoCompanySelected: Bitte wählen Sie mindestens eine Firma aus. TableIsDefaultSupervisor: Standardansprechpartner +TableSuperior: Vorgesetzter TableIsDefaultReroute: Standardumleitung FormFieldPostal: Benachrichtigungseinstellung FormFieldPostalTip: Gilt für alle Benachrichtigungen an diese Person, nicht nur für Umleitungen an diesen Ansprechpartner diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index 56c575e5d..b1fb27b3f 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -51,7 +51,9 @@ FilterSupervisor: Has active supervisor FilterSupervisorCompany fsh: Has active company supervisor belonging to #{fsh} FilterSupervisorForeign fsh: Has active supervisor not belonging to #{fsh} FilterForeignSupervisor: Has company-external supervisors +FilterIsForeignSupervisee: Supervisor for company external users FilterFirmExtern: External company +FilterFirmExternTooltip: i.e. is a postal address registered within AVS? FilterFirmPrimary: Is primary company in FRADrive FilterHasQualification: Has company associates with currently valid qualification FirmSupervisorOf fsh@CompanyShorthand: Supervisors belonging to #{fsh} @@ -59,6 +61,7 @@ FirmSupervisorIndependent: Independent supervisors FirmEmployeeOf fsh@CompanyShorthand: #{fsh} associated users NoCompanySelected: Select at least one company, please. TableIsDefaultSupervisor: Default supervisor +TableSuperior: Superior TableIsDefaultReroute: Default reroute FormFieldPostal: Notification type FormFieldPostalTip: Affects all notifications to this person, not just reroutes to this supervisor diff --git a/messages/uniworx/categories/user/de-de-formal.msg b/messages/uniworx/categories/user/de-de-formal.msg index b2ab14351..2f5b7b4bb 100644 --- a/messages/uniworx/categories/user/de-de-formal.msg +++ b/messages/uniworx/categories/user/de-de-formal.msg @@ -37,10 +37,10 @@ AuthPWHashAlreadyConfigured: Nutzer:in meldet sich bereits mit FRADrive spezifis AuthPWHashConfigured: Nutzer:in meldet sich nun mit FRADrive spezifischer Kennung an UsersCourseSchool: Bereich ActionNoUsersSelected: Keine Benutzer:innen ausgewählt -SynchroniseAvsUserQueued n@Int: AVS-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} zwingend angestoßen -SynchroniseAvsAllUsersQueued n@Int64: AVS-Synchronisation von allen #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen, welche heute noch nicht synchronisiert wurden -SynchroniseLdapUserQueued n@Int: LDAP-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen -SynchroniseLdapAllUsersQueued: LDAP-Synchronisation von allen Benutzer:innen angestoßen +SynchroniseAvsUserQueued n@Int: AVS-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} zwingend angestoßen, die Ausführung wird mehrere Minuten benötigen! +SynchroniseAvsAllUsersQueued n@Int64: AVS-Synchronisation von allen #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen, welche heute noch nicht synchronisiert wurden, die Ausführung wird eine Weile brauchen! +SynchroniseLdapUserQueued n@Int: LDAP-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen, die Ausführung wird mehrere Minuten benötigen! +SynchroniseLdapAllUsersQueued: LDAP-Synchronisation von allen Benutzer:innen angestoßen, die Ausführung kann eine Weile brauchen! UserListTitle: Komprehensive Benutzerliste AccessRightsSaved: Berechtigungen erfolgreich verändert AccessRightsNotChanged: Berechtigungen wurden nicht verändert diff --git a/messages/uniworx/categories/user/en-eu.msg b/messages/uniworx/categories/user/en-eu.msg index 265344219..e4ec93fff 100644 --- a/messages/uniworx/categories/user/en-eu.msg +++ b/messages/uniworx/categories/user/en-eu.msg @@ -37,10 +37,10 @@ AuthPWHashAlreadyConfigured: User already logs in using their FRADrive specific AuthPWHashConfigured: User now logs in using their FRADrive specific account UsersCourseSchool: Department ActionNoUsersSelected: No users selected -SynchroniseAvsUserQueued n: Triggered forced AVS synchronisation of #{n} #{pluralEN n "user" "users"} -SynchroniseAvsAllUsersQueued n: Triggered AVS synchronisation of all #{n} #{pluralEN n "user" "users"} that were not already synchronised today -SynchroniseLdapUserQueued n: Triggered LDAP synchronisation of #{n} #{pluralEN n "user" "users"} -SynchroniseLdapAllUsersQueued: Triggered LDAP synchronisation of all users +SynchroniseAvsUserQueued n: Triggered forced AVS synchronisation of #{n} #{pluralEN n "user" "users"}, which may take several minutes to complete. +SynchroniseAvsAllUsersQueued n: Triggered AVS synchronisation of all #{n} #{pluralEN n "user" "users"} that were not already synchronised today, which may take quite a while to complete. +SynchroniseLdapUserQueued n: Triggered LDAP synchronisation of #{n} #{pluralEN n "user" "users"}, which may take several minutes to complete. +SynchroniseLdapAllUsersQueued: Triggered LDAP synchronisation of all users, which may take quite a while to complete. UserListTitle: Comprehensive list of users AccessRightsSaved: Successfully updated permissions AccessRightsNotChanged: Permissions left unchanged diff --git a/models/company.model b/models/company.model index ae94849e8..0d3d07ce9 100644 --- a/models/company.model +++ b/models/company.model @@ -8,7 +8,7 @@ Company name CompanyName -- == (CI Text) -- NOTE: Fraport department name may carry additional information; use the Shorthand with respect to UserCompanyDepartment shorthand CompanyShorthand -- == (CI Text) and CompanyKey :: CompanyShorthand -> CompanyId A change to AvsId as primary key is too much work and not strictly necessary due to Uniqueness avsId Int default=0 -- primary key from avs, use negative numbers for non-AVS companies - prefersPostal Bool default=false -- new company users prefers letters by post instead of email + prefersPostal Bool default=true -- new company users prefers letters by post instead of email postAddress StoredMarkup Maybe -- default company postal address, including company name email UserEmail Maybe -- Case-insensitive generic company eMail address -- UniqueCompanyName name -- Should be Unique in AVS, but we do not yet need to enforce it diff --git a/routes b/routes index 98042a4a7..21518dfa5 100644 --- a/routes +++ b/routes @@ -71,7 +71,7 @@ /admin/avs/#CryptoUUIDUser AdminAvsUserR GET POST /admin/ldap AdminLdapR GET POST /admin/problems AdminProblemsR GET POST -/admin/problems/no-contact ProblemUnreachableR GET +/admin/problems/no-contact ProblemUnreachableR GET POST /admin/problems/no-avs-id ProblemWithoutAvsId GET /admin/problems/r-without-f ProblemFbutNoR GET /admin/problems/avs ProblemAvsSynchR GET POST diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs index 26213d616..f20aaed95 100644 --- a/src/Audit/Types.hs +++ b/src/Audit/Types.hs @@ -282,6 +282,11 @@ data AdminProblem , adminProblemCompany :: CompanyId -- affected company , adminProblemUserOld :: Maybe UserId -- previous superior } + | AdminProblemCompanySuperiorNotFound -- a company received a new superior user through AVS, but user could not be created from email + { adminProblemEmail :: Maybe Text -- new superior user's email, not found in LDAP + , adminProblemCompany :: CompanyId -- affected company + , adminProblemUserOld :: Maybe UserId -- previous superior + } | AdminProblemNewlyUnsupervised { adminProblemUser :: UserId -- user who had a supervisor but no longer has, due to user company change , adminProblemCompanyOld :: Maybe CompanyId -- old company diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 64c4acadd..1567da027 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -24,11 +24,13 @@ import qualified Database.Esqueleto.Experimental as E import qualified Database.Esqueleto.Legacy as EL (on) -- needed for dbTable import qualified Database.Esqueleto.Utils as E +import Jobs import Handler.Utils import Handler.Utils.Avs import Handler.Utils.Users -- import Handler.Utils.Company import Handler.Health.Interface +import Handler.Users (AllUsersAction(..)) import Handler.Admin.Test as Handler.Admin import Handler.Admin.ErrorMessage as Handler.Admin @@ -140,12 +142,34 @@ postAdminProblemsR = do addMessageI mkind $ msg oks when (oks > 0) $ reloadKeepGetParams AdminProblemsR -- reload to update all tables -getProblemUnreachableR :: Handler Html -getProblemUnreachableR = do +getProblemUnreachableR, postProblemUnreachableR :: Handler Html +getProblemUnreachableR = postProblemUnreachableR +postProblemUnreachableR = do unreachables <- runDB retrieveUnreachableUsers + + -- the following form is a nearly identicaly copy from Handler.Users: + ((noreachUsersRes, noreachUsersWgt'), noreachUsersEnctype) <- runFormPost . identifyForm FIDUnreachableUsersAction $ buttonForm + let noreachUsersWgt = wrapForm noreachUsersWgt' def + { formSubmit = FormNoSubmit + , formAction = Just $ SomeRoute ProblemUnreachableR + , formEncoding = noreachUsersEnctype + } + formResult noreachUsersRes $ \case + AllUsersLdapSync -> do + forM_ unreachables $ \Entity{entityKey=uid} -> void . queueJob $ JobSynchroniseLdapUser uid + addMessageI Success . MsgSynchroniseLdapUserQueued $ length unreachables + redirect ProblemUnreachableR + AllUsersAvsSync -> do + n <- runDB $ queueAvsUpdateByUID (entityKey <$> unreachables) Nothing + addMessageI Success . MsgSynchroniseAvsUserQueued $ fromIntegral n + redirect ProblemUnreachableR + siteLayoutMsg MsgProblemsUnreachableHeading $ do setTitleI MsgProblemsUnreachableHeading [whamlet| +
+

_{MsgProblemsUnreachableButtons} + ^{noreachUsersWgt}
#{length unreachables} _{MsgProblemsUnreachableBody}
    diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 456c2d983..b0086c847 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -97,7 +97,7 @@ firmActionMap mr isAdmin acts = mconcat (mkAct isAdmin <$> acts) <$> aopt boolField' (fslI MsgFirmActResetSuperKeep) (Just $ Just False) <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) mkAct _ FirmActAddSupervisors = singletonMap FirmActAddSupervisors $ FirmActAddSupervisorsData - <$> areq (textField & cfAnySeparatedSet) (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing + <$> areq (textField & cfAnySeparatedSet) (fslI MsgFirmSuperDefault & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing <*> areq checkBoxField (fslI MsgTableIsDefaultReroute) (Just True) <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing <*> aopt (textField & cfStrip & addDatalist ucdefSuperReasons) @@ -666,6 +666,8 @@ mkFirmAllTable isAdmin uid = do E.&&. qual E.^. QualificationShorthand E.==. E.val criterion E.&&. validQualification now usrQual ) + , single ("company-address", FilterColumn $ E.mkContainsFilterWithCommaPlus id $ views (to queryAllCompany) ((E.->>. "markup-input").(E.^. CompanyPostAddress)) + ) ] dbtFilterUI mPrev = mconcat [ fltrCompanyNameUI mPrev @@ -675,7 +677,8 @@ mkFirmAllTable isAdmin uid = do , prismAForm (singletonFilter "is-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor) , prismAForm (singletonFilter "is-default-supervisor") mPrev $ aopt textField (fslI MsgFirmSuperDefault) , prismAForm (singletonFilter "foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterForeignSupervisor) - , prismAForm (singletonFilter "company-postal" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmExtern) + , prismAForm (singletonFilter "company-postal" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmExtern & setTooltip MsgFilterFirmExternTooltip) + , prismAForm (singletonFilter "company-address") mPrev $ aopt textField (fslI MsgFirmAddress) , fltrQualificationHdrUI MsgFilterHasQualification mPrev ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } @@ -801,24 +804,27 @@ mkFirmUserTable :: Bool -> CompanyId -> DB (FormResult (FirmUserActionData, Set mkFirmUserTable isAdmin cid = do mr <- getMessageRender let - mkSprOption (E.Value uid, E.Value udn, E.Value mbSpr) = do + reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior + mkSprOption (E.Value uid, E.Value udn, E.Value mbSpr, E.Value mbmbReason) = do uuid <- toPathPiece <$> encryptUser uid - return (Option{ optionDisplay = udn, optionInternalValue = uid, optionExternalValue = uuid }, mbSpr) + return (Option{ optionDisplay = udn, optionInternalValue = uid, optionExternalValue = uuid }, mbSpr, mbmbReason == Just reasonSuperior) procOptions rawSupers = do procSupers <- traverse mkSprOption rawSupers return $ mkOptionListGrouped $ filter (notNull . snd) - [ (mr MsgFirmSuperDefault , [opt | (opt, Just True ) <- procSupers]) - , (mr MsgFirmSuperIrregular, [opt | (opt, Just False) <- procSupers]) - , (mr MsgFirmSuperForeign , [opt | (opt, Nothing ) <- procSupers]) + [ (mr MsgTableSuperior , [opt | (opt, _ , True ) <- procSupers]) + , (mr MsgFirmSuperDefault , [opt | (opt, Just True , False) <- procSupers]) + , (mr MsgFirmSuperIrregular, [opt | (opt, Just False, False) <- procSupers]) + , (mr MsgFirmSuperForeign , [opt | (opt, Nothing , False) <- procSupers]) ] rawSupers <- E.select $ do (usr :& usrCmp) <- E.from $ E.table @User `E.leftJoin` E.table @UserCompany `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser E.&&. usrCmp E.?. UserCompanyCompany E.==. E.justVal cid) E.where_ $ E.isTrue (usrCmp E.?. UserCompanySupervisor) + E.||. (usrCmp E.?. UserCompanyReason E.?=. E.val reasonSuperior) E.||. E.exists (firmQuerySupervisedBy cid Nothing usr) - return (usr E.^. UserId, usr E.^. UserDisplayName, usrCmp E.?. UserCompanySupervisor) + return (usr E.^. UserId, usr E.^. UserDisplayName, usrCmp E.?. UserCompanySupervisor, usrCmp E.?. UserCompanyReason) let -- supervisorField :: Field Handler UserId -- supervisorField = selectField' (Just $ SomeMessage MsgMultiNoSelection) $ procOptions rawSupers @@ -1198,20 +1204,22 @@ mkFirmSuperTable :: Bool -> CompanyId -> DB (FormResult (FirmSuperActionData, Se mkFirmSuperTable isAdmin cid = do msgSupervisorUnchanged <- messageI Info MsgFirmSuperActSwitchSuperInfo let - reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior + reasonSuperior = tshow SupervisorReasonAvsSuperior -- fsh = unCompanyKey cid resultDBTable = DBTable{..} where dbtSQLQuery = \(usr `E.LeftOuterJoin` usrCmp) -> do EL.on $ usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser E.&&. usrCmp E.?. UserCompanyCompany E.?=. E.val cid - E.where_ $ E.isTrue (usrCmp E.?. UserCompanySupervisor) - E.||. E.exists (firmQuerySupervisedBy cid Nothing usr) + E.where_ $ E.isTrue (usrCmp E.?. UserCompanySupervisor) E.||. E.exists (firmQuerySupervisedBy cid Nothing usr) + -- let uc_reason = E.joinV (usrCmp E.?. UserCompanyReason) return ( usr , usr & firmCountForSupervisor cid Nothing , usr & firmCountForSupervisor cid (Just (E.^. UserSupervisorRerouteNotifications)) , usrCmp E.?. UserCompanySupervisor , usrCmp E.?. UserCompanySupervisorReroute - , E.exists (firmQuerySupervisedBy cid (Just (\usrSpr -> usrSpr E.^. UserSupervisorReason E.==. E.val reasonSuperior)) usr) + -- , (E.isJust uc_reason E.&&. uc_reason E.==. E.justVal reasonSuperior) -- NOTE: this is problematic, as obvious approaches caused errors such as: Failed to parse Haskell type bool, received PersistNull, since the SQL comparison with NULL returns NULL + , (E.coalesceDefault [E.joinV (usrCmp E.?. UserCompanyReason)] (E.val mempty) E.==. E.val reasonSuperior) -- works as well + E.||. E.exists (firmQuerySupervisedBy cid (Just (\usrSpr -> usrSpr E.^. UserSupervisorReason E.==. E.justVal reasonSuperior)) usr) ) dbtRowKey = querySuperUser >>> (E.^. UserId) dbtProj = dbtProjSimple $ \(usr, supervised, rerouted, supervisor, reroute, isSuperior) -> do @@ -1232,15 +1240,11 @@ mkFirmSuperTable isAdmin cid = do , colUserEmail , sortable (Just "supervised") (i18nCell MsgTableCompanyNrEmpSupervised) $ \(view resultSuperCompanySupervised -> nr) -> wgtCell $ word2widget nr , sortable (Just "rerouted") (i18nCell MsgTableCompanyNrEmpRerouted ) $ \(view resultSuperCompanyReroutes -> nr) -> wgtCell $ word2widget nr - -- , sortable (Just "def-super") (i18nCell MsgTableIsDefaultSupervisor) $ \(view resultSuperCompanyDefaultSuper -> mb) -> case mb of { Nothing -> iconCell IconSupervisorForeign; Just True -> iconCell IconSupervisor; Just False -> iconSpacerCell } - , sortable (Just "def-super") (i18nCell MsgTableIsDefaultSupervisor) $ \row -> - let mb = row ^. resultSuperCompanyDefaultSuper - sp = row ^. resultSuperCompanySuperior - in case (mb,sp) of - (_ , True) -> iconCell IconSuperior - (Nothing ,_) -> iconCell IconSupervisorForeign - (Just True ,_) -> iconCell IconSupervisor - (Just False,_) -> iconSpacerCell + , sortable (Just "def-super") (i18nCell MsgTableIsDefaultSupervisor) $ view resultSuperCompanyDefaultSuper >>> \case + Nothing -> iconCell IconSupervisorForeign + (Just True ) -> iconCell IconSupervisor + (Just False) -> iconSpacerCell + , sortable Nothing (i18nCell MsgTableSuperior) $ view resultSuperCompanySuperior >>> flip ifIconCell IconSuperior , sortable (Just "def-reroute") (i18nCell MsgTableIsDefaultReroute) $ \(view resultSuperCompanyDefaultReroute -> mb) -> tickmarkCell (mb == Just True) , sortable Nothing (i18nCell MsgTableUserEdit) $ \(view resultSuperUser -> entUsr) -> cellEditUserModal entUsr ] @@ -1263,16 +1267,36 @@ mkFirmSuperTable isAdmin cid = do ] dbtFilter = mconcat [ single $ fltrUserNameEmail querySuperUser + , singletonMap "is-foreign-supervisor" $ FilterColumn $ \(querySuperUserCompany -> suc) (getLast -> criterion) -> + case criterion of + Nothing -> E.true + Just True -> E.isNothing $ suc E.?. UserCompanyUser + Just False -> E.isJust $ suc E.?. UserCompanyUser + , singletonMap "super-relation-foreign" $ FilterColumn $ \row (getLast -> criterion) -> + let checkSuper = do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. querySuperUser row E.^. UserId + E.&&. E.exists (do + usr <- E.from $ E.table @UserCompany + E.where_ $ usr E.^. UserCompanyCompany E.!=. E.val cid + E.&&. usr E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorUser + ) + in case criterion of + Nothing -> E.true + Just True -> E.exists checkSuper + Just False -> E.notExists checkSuper ] dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgTableSupervisor mPrev + , prismAForm (singletonFilter "is-foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmSuperForeign) + , prismAForm (singletonFilter "super-relation-foreign" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterIsForeignSupervisee) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } acts :: Map FirmSuperAction (AForm Handler FirmSuperActionData) acts = mconcat [ guardMonoid isAdmin $ singletonMap FirmSuperActNotify $ pure FirmSuperActNotifyData , singletonMap FirmSuperActSwitchSuper $ FirmSuperActSwitchSuperData - <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableIsDefaultSupervisor) (Just $ Just True) + <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmSuperDefault) (Just $ Just True) <*> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableIsDefaultReroute) Nothing <* aformMessage msgSupervisorUnchanged , singletonMap FirmSuperActRMSuperDef $ FirmSuperActRMSuperDefData @@ -1352,7 +1376,7 @@ postFirmSupersR fsh = do formFirmAction <- runFirmActionFormPost cid (FirmSupersR fsh) isAdmin [FirmActAddSupervisors, FirmActResetSupervision, FirmActChangeContactFirm] - siteLayout (citext2widget fsh) $ do + siteLayout (citext2widget companyName) $ do setTitle $ citext2Html $ fsh <> " Supers" let firmContactInfo = $(widgetFile "firm-contact-info") $(i18nWidgetFile "firm-supervisors") diff --git a/src/Handler/Health.hs b/src/Handler/Health.hs index e06f688ae..69db731e1 100644 --- a/src/Handler/Health.hs +++ b/src/Handler/Health.hs @@ -6,6 +6,7 @@ module Handler.Health where import Import +import Data.Time.Format.ISO8601 (iso8601Show) import Handler.Utils.DateTime (formatTimeW) import qualified Data.Aeson.Encode.Pretty as Aeson @@ -77,12 +78,12 @@ getHealthR = do #{boolSymbol (healthOk hcstatus)} # $case report $of HealthLDAPAdmins (Just found) - #{textPercent found 1} + #{textPercent found 1} $of HealthActiveJobExecutors (Just active) #{textPercent active 1} $of _
    - ^{formatTimeW SelFormatDateTime lUp} + ^{formatTimeW SelFormatDateTime lUp} |] provideJson healthReports provideRep . return . Builder.toLazyText $ Aeson.encodePrettyToTextBuilder healthReports @@ -115,32 +116,31 @@ getStatusR = do starttime <- getsYesod appStartTime (currtime, env_version) <- liftIO $ (,) <$> getCurrentTime <*> lookupEnv "VERSION_NR" -- ft <- formatTime' "%Y-%m-%d %H:%M:%S" currtime - withUrlRenderer + let diffTime :: UTCTime -> Text + diffTime = pack . iso8601Show . calendarTimeTime . fromIntegral . truncate . diffUTCTime currtime + withUrlRenderer [hamlet| $doctype 5 - + Status <body> $maybe env_ver <- env_version <p> Environment version #{env_ver} - <p> - Current Time <br> - #{show currtime} <br> <p> - Instance Start <br> + Current Time <br> + #{show currtime} <br> + <p> + Instance Start <br> #{show starttime} # - Uptime: #{show $ ddays starttime currtime} days. + Uptime: #{diffTime starttime} <p> Compile Time <br> #{show cTime} # - Build age: #{show $ ddays cTime currtime} days. + Build age: #{diffTime cTime} |] - where - -- vnr_full :: Text = $(embedStringFile "nix/docker/version.json") -- nix/ files not accessible during container construction + where + -- vnr_full :: Text = $(embedStringFile "nix/docker/version.json") -- nix/ files not accessible during container construction cTime :: UTCTime - cTime = $compileTime - - ddays :: UTCTime -> UTCTime -> Double - ddays tstart tstop = (/100) $ fromIntegral $ round $ diffUTCTime tstop tstart / (36 * 24) + cTime = $compileTime \ No newline at end of file diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 3f3f6660d..890f6fce7 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -44,7 +44,7 @@ import Data.Aeson hiding (Result(..)) -- import Handler.Users.Add as Handler.Users -import qualified Data.Conduit.List as C +-- import qualified Data.Conduit.List as C import qualified Data.HashSet as HashSet @@ -424,7 +424,8 @@ postUsersR = do formResult allUsersRes $ \case AllUsersLdapSync -> do - runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseLdapUser . entityKey) + -- runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseLdapUser . entityKey) -- to slow to execute directly + queueJob' JobSynchroniseLdapAll addMessageI Success MsgSynchroniseLdapAllUsersQueued redirect UsersR AllUsersAvsSync -> do diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index b7a112d86..4abcd0ce2 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -163,6 +163,9 @@ redirectKeepGetParams route = liftHandler $ do getps <- reqGetParams <$> getRequest redirect (route, getps) +previousSuperior :: (IsDBTable m a) => Maybe UserId -> DBCell m a +previousSuperior Nothing = mempty +previousSuperior (Just uid) = spacerCell <> i18nCell MsgAdminProblemCompanySuperiorPrevious <> anchorCellM (AdminUserR <$> encrypt uid) (userIdWidget uid) adminProblemCell :: (IsDBTable m a) => AdminProblem -> DBCell m a -- note that adminProblemCompany/adminProblemCompanyOld and adminProblemUser are automatically displayed within their own columns @@ -173,10 +176,10 @@ adminProblemCell AdminProblemSupervisorNewCompany{adminProblemCompanyNew, adminP = i18nCell (MsgAdminProblemSupervisorNewCompany adminProblemSupervisorReroute) <> companyIdCell adminProblemCompanyNew adminProblemCell AdminProblemSupervisorLeftCompany{adminProblemSupervisorReroute} = i18nCell (MsgAdminProblemSupervisorLeftCompany adminProblemSupervisorReroute) -adminProblemCell AdminProblemCompanySuperiorChange{adminProblemUserOld=Nothing} - = i18nCell MsgAdminProblemCompanySuperiorChange -adminProblemCell AdminProblemCompanySuperiorChange{adminProblemUserOld=Just uid} - = i18nCell MsgAdminProblemCompanySuperiorChange <> spacerCell <> i18nCell MsgAdminProblemCompanySuperiorPrevious <> anchorCellM (AdminUserR <$> encrypt uid) (userIdWidget uid) +adminProblemCell AdminProblemCompanySuperiorChange{adminProblemUserOld} + = i18nCell MsgAdminProblemCompanySuperiorChange <> previousSuperior adminProblemUserOld +adminProblemCell AdminProblemCompanySuperiorNotFound{..} + = i18nCell (MsgAdminProblemCompanySuperiorNotFound (fromMaybe "???" adminProblemEmail)) <> previousSuperior adminProblemUserOld adminProblemCell AdminProblemNewlyUnsupervised{adminProblemCompanyNew} = i18nCell MsgAdminProblemNewlyUnsupervised <> companyIdCell adminProblemCompanyNew adminProblemCell AdminProblemUnknown{adminProblemText} @@ -209,11 +212,18 @@ adminProblem2Text adprob = do -- return $ mr MsgAdminProblemCompanySuperiorChange -- Just User{userDisplayName = udn, userSurname = usn} -> -- return $ mr $ SomeMessages [SomeMessage MsgAdminProblemCompanySuperiorChange, SomeMessage MsgAdminProblemCompanySuperiorPrevious, SomeMessage udn, SomeMessage usn] + AdminProblemCompanySuperiorNotFound{adminProblemUserOld=mbuid, adminProblemEmail=eml} + -> let basemsg = MsgAdminProblemCompanySuperiorNotFound $ fromMaybe "???" eml + in maybeT (return $ mr basemsg) $ do + uid <- MaybeT $ pure mbuid + User{userDisplayName = udn, userSurname = usn} <- MaybeT $ get uid + pure $ mr $ SomeMessages [SomeMessage basemsg, SomeMessage MsgAdminProblemCompanySuperiorPrevious, SomeMessage udn, SomeMessage usn] AdminProblemNewlyUnsupervised{adminProblemCompanyNew} -> return $ mr $ SomeMessages [SomeMessage MsgAdminProblemNewlyUnsupervised, company2msg adminProblemCompanyNew] AdminProblemUnknown{adminProblemText} -> return $ "Problem: " <> adminProblemText +-- | Show AdminProblem as message, used in message pop-up after manually switching companies for a user msgAdminProblem :: AdminProblem -> DB (SomeMessages UniWorX) msgAdminProblem AdminProblemNewCompany{adminProblemCompany=comp} = return $ SomeMessages [SomeMessage MsgAdminProblemNewCompany, text2message ": ", company2msg comp] @@ -223,8 +233,10 @@ msgAdminProblem AdminProblemSupervisorLeftCompany{adminProblemCompany=comp, admi SomeMessages [SomeMessage $ MsgAdminProblemSupervisorLeftCompany rer, text2message ": ", company2msg comp] msgAdminProblem AdminProblemCompanySuperiorChange{adminProblemCompany=comp} = return $ SomeMessages [SomeMessage MsgAdminProblemCompanySuperiorChange, text2message ": ", company2msg comp] +msgAdminProblem AdminProblemCompanySuperiorNotFound{adminProblemCompany=comp, adminProblemEmail=eml} = return $ + SomeMessages [SomeMessage $ MsgAdminProblemCompanySuperiorNotFound $ fromMaybe "???" eml, text2message ": ", company2msg comp] msgAdminProblem AdminProblemNewlyUnsupervised{adminProblemCompanyOld=comp, adminProblemCompanyNew=newComp} = return $ - SomeMessages [SomeMessage MsgAdminProblemNewlyUnsupervised, text2message ": ", maybe (text2message "???") company2msg comp, text2message " -> ", company2msg newComp] + SomeMessages [SomeMessage MsgAdminProblemNewlyUnsupervised, text2message ": ", maybe (text2message "???") company2msg comp, text2message " -> ", company2msg newComp] msgAdminProblem AdminProblemUnknown{adminProblemText=err} = return $ someMessages ["Problem: ", err] diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 98fc33439..292fad0df 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -99,10 +99,10 @@ catchAVS2log :: (MonadHandler m, MonadCatch m, RenderMessage (HandlerSite m) Avs catchAVS2log = catchAVShandler False True False Nothing catchAll2log :: (MonadHandler m, MonadCatch m, RenderMessage (HandlerSite m) AvsException) => m a -> m () -catchAll2log = voidMaybe $ catchAVShandler True True False Nothing +catchAll2log = voidMaybe catchAll2log' --- catchAll2log' :: (MonadHandler m, MonadCatch m, RenderMessage (HandlerSite m) AvsException, Monoid a) => m a -> m () --- catchAll2log' = voidMaybe $ catchAVShandler True True False mempty +catchAll2log' :: (MonadHandler m, MonadCatch m, RenderMessage (HandlerSite m) AvsException) => m (Maybe a) -> m (Maybe a) +catchAll2log' = catchAVShandler True True False Nothing catchAVShandler :: (MonadHandler m, MonadCatch m, RenderMessage (HandlerSite m) AvsException) => Bool -> Bool -> Bool -> a -> m a -> m a catchAVShandler allEx toLog toMsg dft act = act `catches` (avsHandlers <> allHandlers) @@ -493,13 +493,12 @@ createAvsUserById muid api = do -- check for matching existing user let internalPersNo :: Maybe Text = cpi ^? _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo -- persMail :: Maybe UserEmail = cpi ^? _avsInfoPersonEMail . _Just . from _CI - oldUsr <- runDBRead $ do - mbUid <- if isJust muid - then return muid - else firstJustM $ catMaybes - [ internalPersNo <&> (\ipn -> getKeyByFilter [UserCompanyPersonalNumber ==. Just ipn]) -- must ensure filter isnt ==. Nothing - -- , persMail <&> guessUserByEmail -- this did not work, as unfortunately, superiors are sometimes listed under _avsInfoPersonEMail! + oldUsr <- runDB $ do + mbUid <- firstJustM $ return muid : maybe [] (\ipn -> + [ getKeyByFilter [UserCompanyPersonalNumber ==. Just ipn] -- must ensure filter isnt ==. Nothing + , catchAll2log' (Just . entityKey <$> ldapLookupAndUpsert ipn) -- attempt to insert by LDAP first ] + ) internalPersNo mbUAvs <- (getBy . UniqueUserAvsUser) `traverseJoin` mbUid return (mbUid, mbUAvs) usrCardNo <- queryAvsFullCardNo api @@ -563,8 +562,8 @@ createAvsUserById muid api = do return uid -getAvsCompanyId :: AvsFirmInfo -> DB (Maybe CompanyId) -getAvsCompanyId = fmap (fmap entityKey) . getAvsCompany +-- getAvsCompanyId :: AvsFirmInfo -> DB (Maybe CompanyId) +-- getAvsCompanyId = fmap (fmap entityKey) . getAvsCompany -- | Query DB from given AvsFirmInfo. Guarantees that all Uniqueness-Constraints are checked. Highly unlikely that Nothing is returned, since all AvsResponseContact always contains an AvsFirmInfo getAvsCompany :: AvsFirmInfo -> DB (Maybe (Entity Company)) @@ -631,7 +630,7 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do _otherwise -> return res_cmp $logInfoS "AVS" "Update company completed." return res_cmp2 - void $ upsertCompanySuperior (Just $ entityKey cmpEnt, newAvsFirmInfo) mbOldAvsFirmInfo -- ensure firmInfo superior is supervisor + void $ upsertCompanySuperior cmpEnt newAvsFirmInfo mbOldAvsFirmInfo -- ensure firmInfo superior is supervisor return cmpEnt where firmInfo2key = @@ -646,92 +645,60 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do ] -- upsert company supervisor from AvsFirmEMailSuperior -upsertCompanySuperior :: (Maybe CompanyId, AvsFirmInfo) -> Maybe AvsFirmInfo -> DB (Maybe (CompanyId, UserId)) -upsertCompanySuperior (mbCid, newAfi) mbOldAfi - | Just supemail <- newAfi ^. _avsFirmEMailSuperior -- superior given - = runMaybeT $ do - cid <- MaybeT $ altM (pure mbCid) (getAvsCompanyId newAfi) - supid <- MaybeT $ altM (guessUserByEmail $ stripCI supemail) - (catchAVShandler True True False Nothing $ Just . entityKey <$> ldapLookupAndUpsert supemail) - lift $ do - oldChanges <- runMaybeT $ do -- remove old superior, if any - oldAfi <- MaybeT $ pure mbOldAfi - oldEml <- MaybeT $ pure $ oldAfi ^. _avsFirmEMailSuperior - oldCid <- MaybeT $ getAvsCompanyId oldAfi - oldSup <- MaybeT $ guessUserByEmail $ stripCI oldEml - let supChange = oldSup /= supid - when (supChange && oldCid == cid) $ lift $ do - -- deleteWhere [UserCompanyCompany ==. cid, UserCompanyUser ==. oldSup] -- remove old supervisor from company NOTE: we leave this to the oldSuperior's AVS update - -- switch supervison - -- updateWhere [UserSupervisorCompany ==. Just cid, UserSupervisorSupervisor ==. oldSup, UserSupervisorReason ==. reasonSuperior] [UserSupervisor =. supid] -- not safe, could violate uniqueness - E.update $ \usuper -> do - E.set usuper [ UserSupervisorSupervisor E.=. E.val supid ] - E.where_ $ usuper E.^. UserSupervisorSupervisor E.==. E.val oldSup - E.&&. usuper E.^. UserSupervisorCompany E.==. E.justVal cid - E.&&. usuper E.^. UserSupervisorReason E.==. E.val reasonSuperior - E.&&. E.notExists (do - newSuper <- E.from $ E.table @UserSupervisor - E.where_ $ newSuper E.^. UserSupervisorSupervisor E.==. E.val supid - E.&&. newSuper E.^. UserSupervisorUser E.==. newSuper E.^. UserSupervisorUser - ) - deleteOldSuperior oldSup cid -- remove un-updateable remainders, if any - return (supChange, oldSup) - let supChange = fst <$> oldChanges - oldSup = snd <$> oldChanges - unless (supChange == Just False) $ do - -- upsert new superior company supervisor - mbMaxPrio <- E.selectOne $ do - usrCmp <- E.from $ E.table @UserCompany - E.where_ $ usrCmp E.^. UserCompanyUser E.==. E.val supid - 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 reasonSuperior) - [UserCompanySupervisor =. True, UserCompanyPriority =. maxPrio, UserCompanyReason =. reasonSuperior] - E.insertSelectWithConflict UniqueUserSupervisor - (do - usr <- E.from $ E.table @UserCompany - E.where_ $ usr E.^. UserCompanyCompany E.==. E.val cid - -- E.&&. E.notExists (do -- restrict to primary company only - -- othr <- E.from $ E.table @UserCompany - -- E.where_ $ othr E.^. UserCompanyPriority E.>. usr E.^. UserCompanyPriority - -- E.&&. othr E.^. UserCompanyUser E.==. usr E.^. UserCompanyUser - -- E.&&. othr E.^. UserCompanyCompany E.!=. E.val cid -- redundant due to > above, but likely performance improving - -- ) - return $ UserSupervisor - E.<# E.val supid - E.<&> (usr E.^. UserCompanyUser) - E.<&> E.val (suprEnt ^. _entityVal . _userCompanySupervisorReroute) - E.<&> E.justVal cid - E.<&> E.val reasonSuperior - ) - (\_old new -> - [ -- UserSupervisorSupervisor E.=. new E.^. UserSupervisorSupervisor -- this is already given in case of conflict - UserSupervisorCompany E.=. new E.^. UserSupervisorCompany - , UserSupervisorReason E.=. new E.^. UserSupervisorReason - , UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications - ] - ) - reportAdminProblem $ AdminProblemCompanySuperiorChange supid cid oldSup - return (cid,supid) - | Just oldSupeEmail <- mbOldAfi ^. _Just . _avsFirmEMailSuperior -- no more superior, delete old one - = do - void $ runMaybeT $ do - oldAfi <- MaybeT $ pure mbOldAfi - oldCid <- MaybeT $ getAvsCompanyId oldAfi - oldSup <- MaybeT $ guessUserByEmail $ stripCI oldSupeEmail - lift $ deleteOldSuperior oldSup oldCid - return Nothing - | otherwise -- neither new nor old superior - = return Nothing - where - reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior - - deleteOldSuperior oldSup oldCid = - deleteWhere [ UserSupervisorSupervisor ==. oldSup - , UserSupervisorCompany ==. Just oldCid - , UserSupervisorReason ==. reasonSuperior - ] +upsertCompanySuperior :: Entity Company -> AvsFirmInfo -> Maybe AvsFirmInfo -> DB () -- (Maybe UserId) possibly return superior, but currently not needed +upsertCompanySuperior Entity{entityKey=cid, entityVal=Company{}} newAfi oldAfi = do + let reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior + getInsertUid eml = altM (guessUserByEmail $ stripCI eml) (catchAll2log' $ Just . entityKey <$> ldapLookupAndUpsert eml) + newAvsNo = newAfi ^. _avsFirmFirmNo + oldAvsNo = oldAfi ^? _Just . _avsFirmFirmNo + mbSupEmail = newAfi ^. _avsFirmEMailSuperior + mbOldEmail = oldAfi ^? _Just . _avsFirmEMailSuperior . _Just + getSupId = getInsertUid `traverseJoin` mbSupEmail + getOldId = (guessUserByEmail . stripCI) `traverseJoin` mbOldEmail + unchangedCompany = oldAvsNo == Just newAvsNo + changedSuperior = mbSupEmail /= mbOldEmail -- beware, both could be Nothing + mbSupId <- getSupId + -- delete old superiors, if any + when (unchangedCompany && changedSuperior) $ + deleteWhere $ mcons ((UserSupervisorSupervisor !=.) <$> mbSupId) + [ UserSupervisorCompany ==. Just cid, UserSupervisorReason ==. reasonSuperior ] + -- ensure superior supervision + case mbSupId of + Just supId -> do + -- ensure association between company and superior at equal-to-top priority + prio <- getCompanyUserMaxPrio supId + void $ insertUnique (UserCompany supId cid False False prio True reasonSuperior) -- superior is not a supervisor, do not change existing user company associations + -- ensure all company associates are irregularly supervised by the superior + E.insertSelectWithConflict UniqueUserSupervisor + (do + usr <- E.from $ E.table @UserCompany + E.where_ $ usr E.^. UserCompanyCompany E.==. E.val cid + -- E.&&. E.notExists (do -- restrict to primary company only + -- othr <- E.from $ E.table @UserCompany + -- E.where_ $ othr E.^. UserCompanyPriority E.>. usr E.^. UserCompanyPriority + -- E.&&. othr E.^. UserCompanyUser E.==. usr E.^. UserCompanyUser + -- E.&&. othr E.^. UserCompanyCompany E.!=. E.val cid -- redundant due to > above, but likely performance improving + -- ) + return $ UserSupervisor + E.<# E.val supId + E.<&> (usr E.^. UserCompanyUser) + E.<&> E.false + E.<&> E.justVal cid + E.<&> E.val reasonSuperior + ) + (\_old _new -> [] -- do not change exisitng supervision + -- [ UserSupervisorCompany E.=. new E.^. UserSupervisorCompany + -- , UserSupervisorReason E.=. new E.^. UserSupervisorReason + -- , UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications + -- ] + ) + when (unchangedCompany && changedSuperior) $ do + oldSupId <- getOldId + reportAdminProblem $ AdminProblemCompanySuperiorChange supId cid oldSupId + Nothing -> + when (unchangedCompany && changedSuperior) $ do + oldSupId <- getOldId + reportAdminProblem $ AdminProblemCompanySuperiorNotFound mbSupEmail cid oldSupId queueAvsUpdateByUID :: (MonoFoldable mono, UserId ~ Element mono) => mono -> Maybe Day -> DB Int64 diff --git a/src/Handler/Utils/Company.hs b/src/Handler/Utils/Company.hs index 81b76d10f..b3f428b83 100644 --- a/src/Handler/Utils/Company.hs +++ b/src/Handler/Utils/Company.hs @@ -169,6 +169,10 @@ switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = d 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 + + newUserComp = UserCompany uid newCompanyId False False 1 True Nothing -- default value for new company insertion, if no update can be done + superReasonComDef = tshow SupervisorReasonCompanyDefault + -- update uid usrUpdate -- repsertSuperiorSupervisor is not called here, since the Superior is indepentent of the actual company association case mbUsrComp of @@ -180,7 +184,7 @@ switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = d | newCompanyId == oldCompanyId -> return mempty -- nothing to do | otherwise -> do -- switch company when (isNothing oldAssocReason) $ deleteBy $ UniqueUserCompany uid oldCompanyId - void $ upsertBy (UniqueUserCompany uid newCompanyId) newUserComp + void $ upsertBy (UniqueUserCompany uid newCompanyId) newUserComp{userCompanyPriority = succ oldPrio} [UserCompanyPriority =. succ oldPrio, UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False, UserCompanyUseCompanyAddress =. True, UserCompanyReason =. Nothing] -- supervised by uid supervisees :: [(Entity UserSupervisor, E.Value Bool)] <- E.select $ do @@ -213,9 +217,6 @@ switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = d $ bcons isNoLongerSupervised (AdminProblemNewlyUnsupervised uid (Just oldCompanyId) newCompanyId) newlyUnsupervised return (usrUpdate ,problems) - where - newUserComp = UserCompany uid newCompanyId False False 1 True Nothing -- default value for new company insertion, if no update can be done - superReasonComDef = tshow SupervisorReasonCompanyDefault defaultSupervisorReasonFilter :: [Filter UserSupervisor] defaultSupervisorReasonFilter = @@ -238,3 +239,12 @@ deleteCompanyUser cid uids = (,,) <$> deleteWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. uids] <*> deleteWhereCount ((UserSupervisorCompany ==. Just cid):(UserSupervisorSupervisor <-. uids) : defaultSupervisorReasonFilter) <*> deleteWhereCount ((UserSupervisorCompany ==. Just cid):(UserSupervisorUser <-. uids) : defaultSupervisorReasonFilter) + +-- | retrieve maximum company user priority fo a user +getCompanyUserMaxPrio :: UserId -> DB Int +getCompanyUserMaxPrio uid = do + mbMaxPrio <- E.selectOne $ do + usrCmp <- E.from $ E.table @UserCompany + E.where_ $ usrCmp E.^. UserCompanyUser E.==. E.val uid + return . E.max_ $ usrCmp E.^. UserCompanyPriority + return $ maybe 1 (fromMaybe 1 . E.unValue) mbMaxPrio diff --git a/src/Jobs/Handler/SynchroniseLdap.hs b/src/Jobs/Handler/SynchroniseLdap.hs index c0fc5758a..2b14ace76 100644 --- a/src/Jobs/Handler/SynchroniseLdap.hs +++ b/src/Jobs/Handler/SynchroniseLdap.hs @@ -3,7 +3,9 @@ -- SPDX-License-Identifier: AGPL-3.0-or-later module Jobs.Handler.SynchroniseLdap - ( dispatchJobSynchroniseLdap, dispatchJobSynchroniseLdapUser + ( dispatchJobSynchroniseLdap + , dispatchJobSynchroniseLdapUser + , dispatchJobSynchroniseLdapAll , SynchroniseLdapException(..) ) where @@ -49,7 +51,7 @@ dispatchJobSynchroniseLdapUser jUser = JobHandlerException $ do Just ldapPool -> runDB . void . runMaybeT . handleExc $ do user@User{userIdent,userLdapPrimaryKey} <- MaybeT $ get jUser - let upsertIdent = maybe userIdent CI.mk userLdapPrimaryKey + let upsertIdent = maybe userIdent CI.mk userLdapPrimaryKey $logInfoS "SynchroniseLdap" [st|Synchronising #{upsertIdent}|] reTestAfter <- getsYesod $ view _appLdapReTestFailover @@ -62,3 +64,6 @@ dispatchJobSynchroniseLdapUser jUser = JobHandlerException $ do handleExc = catchMPlus (Proxy @CampusUserException) . catchMPlus (Proxy @CampusUserConversionException) + +dispatchJobSynchroniseLdapAll :: JobHandler UniWorX +dispatchJobSynchroniseLdapAll = JobHandlerAtomic . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseLdapUser . entityKey) \ No newline at end of file diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 24bb89c3a..77e27c963 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -97,6 +97,7 @@ data Job , jIteration :: Natural } | JobSynchroniseLdapUser { jUser :: UserId } + | JobSynchroniseLdapAll | JobSynchroniseAvs { jNumIterations , jEpoch , jIteration :: Natural @@ -350,6 +351,7 @@ jobNoQueueSame = \case JobDeleteTransactionLogIPs{} -> Just JobNoQueueSame JobSynchroniseLdap{} -> Just JobNoQueueSame JobSynchroniseLdapUser{} -> Just JobNoQueueSame + JobSynchroniseLdapAll{} -> Just JobNoQueueSameTag JobSynchroniseAvs{} -> Just JobNoQueueSame -- JobSynchroniseAvsUser{} -> Just JobNoQueueSame -- JobSynchroniseAvsId{} -> Just JobNoQueueSame diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 5b611c79e..6a48bdec4 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -320,6 +320,7 @@ data FormIdentifier | FIDAddSupervisor | FIDFirmUserChangeRequest | FIDFirmAction + | FIDUnreachableUsersAction deriving (Eq, Ord, Read, Show) instance PathPiece FormIdentifier where diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 8cf77fdef..268c56c97 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -655,14 +655,14 @@ 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 $ Just "Vorgesetzter" - void . insert' $ UserCompany svaupel nice True False 2 False $ Just "Vorgesetzter" + void . insert' $ UserCompany jost fraportAg True True 0 False $ Just $ tshow SupervisorReasonAvsSuperior + void . insert' $ UserCompany svaupel nice True False 2 False $ Just $ tshow SupervisorReasonAvsSuperior 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 gkleen bpol False True 1 False $ Just $ tshow SupervisorReasonAvsSuperior 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" @@ -687,14 +687,14 @@ fillDb = do -- void . insert' $ UserSupervisor svaupel gkleen False -- void . insert' $ UserSupervisor svaupel fhamann True -- void . insert' $ UserSupervisor sbarth tinaTester True - let supvs = [ UserSupervisor jost gkleen True (Just fraportAg) (Just "Staff") - , UserSupervisor jost svaupel False (Just fraportAg) (Just "Staff") + let supvs = [ UserSupervisor jost gkleen True (Just fraportAg) (Just $ tshow SupervisorReasonAvsSuperior) + , UserSupervisor jost svaupel False (Just fraportAg) (Just $ tshow SupervisorReasonAvsSuperior) , UserSupervisor jost sbarth False (Just fraportAg) (Just "Staff") , UserSupervisor jost tinaTester True (Just fraportAg) (Just "Staff") , UserSupervisor jost jost True (Just fraportAg) (Just "Staff") , UserSupervisor svaupel gkleen False (Just nice) (Just "Staff") , UserSupervisor svaupel fhamann True (Just nice) (Just "Staff") - , UserSupervisor sbarth tinaTester True (Just nice) (Just "Staff") + , UserSupervisor sbarth tinaTester True (Just nice) (Just $ tshow SupervisorReasonAvsSuperior) , UserSupervisor gkleen fhamann False (Just fraGround) (Just "Staff") , UserSupervisor gkleen gkleen True (Just fraGround) (Just "Staff") , UserSupervisor tinaTester tinaTester False Nothing (Just "Staff")