diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index c7e0173a5..bf76f6e0e 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -27,11 +27,16 @@ FirmActChangeContactFirmResult: Firmenkontaktinformationen geändert. Betrifft n FirmUserActNotify: Mitteilung versenden FirmUserActResetSupervision: Ansprechpartner auf Firmenstandard zurücksetzen FirmUserActSetSupervisor: Ansprechpartner ändern +FirmUserActChangeContact: Kontaktinformationen für ausgewählte Firmenangehörige ändern +FirmUserActChangeDetails: Firmenassoziation bearbeiten +FirmUserActRemove: Firmenassoziation entfernen +FirmUserActMkSuper: Zum Firmenansprechpartner ernennen +FirmUserActChangeDetailsResult n@Int64 t@Int64: Firmenassoziation von #{n}/#{t} #{pluralDE n "Firmenangehörigen" "Firmenangehörige"} wurden aktualisiert +FirmUserActChangeResult n@Int64 t@Int64: Benachrichtigungseinstellung für #{n}/#{t} #{pluralDE n "Firmenangehörigen" "Firmenangehörige"} wurden geändert +FirmuserActRemoveResult uc@Int64 sup@Int64 sub@Int64: #{uc} #{pluralDE uc "Firmenassoziation" "Firmenassoziationen"} entfernt. #{noneMoreDE sup "" (tshow sup <> "Ansprechpartnerbeziehungen wegen entferntem Ansprechpartner gelöschtt. ")} #{noneMoreDE sub "" (tshow sup <> "Ansprechpartnerbeziehungen wegen entfernten Angesprochenen gelöscht.")} FirmNewSupervisor: Neue individuelle Ansprechpartner hinzufügen FirmSetSupervisor: Existierende Ansprechpartner hinzufügen FirmSetSupersReport nusr@Int64 nspr@Int64 nrem@Int64: Für #{nusr} Firmenangehörige wurden #{nspr} individuelle Ansprechpartner eingetragen#{bool "." (" und " <> tshow nrem <> " individuelle Ansprechpartnerbeziehungen gelöscht.") (nrem >0)} -FirmUserActMkSuper: Zum Firmenansprechpartner ernennen -FirmUserActChangeContact: Kontaktinformationen für ausgewählte Firmenangehörige ändern FirmResetSupervision rem@Int64 set@Int64: #{tshow set} Ansprechpartner gesetzt#{bool mempty (", " <> tshow rem <> " zuvor gelöscht") (rem > 0)} FirmSuperActNotify: Mitteilung versenden FirmSuperActSwitchSuper: Standard Firmenansprechpartner abändern @@ -57,5 +62,9 @@ TableIsDefaultSupervisor: Standardansprechpartner TableIsDefaultReroute: Standardumleitung FormFieldPostal: Benachrichtigungseinstellung FormFieldPostalTip: Gilt für alle Benachrichtigungen an diese Person, nicht nur für Umleitungen an diesen Ansprechpartner -FirmUserChanges n@Int64: Benachrichtigungseinstellung für #{n} Firmenangehörige wurden geändert -FirmSupervisionKeyData: Kennzahlen Ansprechpartner \ No newline at end of file +FirmSupervisionKeyData: Kennzahlen Ansprechpartner +CompanyUserPriority: Firmenpriorität +CompanyUserPriorityTip: Firmenpriorität ist lediglich relativ zu anderen Firmenassoziation der Person +CompanyUserUseCompanyAddress: Verwendet Firmenkontaktaddresse +CompanyUserUseCompanyAddressTip: sofern im Benutzer keine Postanschrift hinterlegt ist +CompanyUserUseCompanyPostalError: Postalische Adresse muss leer bleiben, damit die Firmenanschrift genutzt wird! diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index 7a323b880..38abc7d0c 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -27,15 +27,20 @@ FirmActChangeContactFirmResult: Company contact data changed, affecting future c FirmUserActNotify: Send message FirmUserActResetSupervision: Reset supervisors to company default FirmUserActSetSupervisor: Change supervision +FirmUserActChangeContact: Change contact data for selected company associates +FirmUserActChangeDetails: Edit company association +FirmUserActRemove: Delete company association +FirmUserActMkSuper: Mark as company supervisor +FirmUserActChangeDetailsResult n t: #{n}/#{t} #{pluralENs n "company association"} updated +FirmUserActChangeResult n t: Notification settings changed for #{n}/#{t} company #{pluralENs n "associate"} +FirmuserActRemoveResult uc sup sub: #{pluralENsN uc "Company association"} deleted. #{noneMoreEN sup "" ((pluralENsN sup "supervision") <> " removed due to eliminated supervisors.")} #{noneMoreEN sub "" ((pluralENsN sub "supervision") <> " removed due to eliminated supervisees.")} FirmNewSupervisor: Appoint new individual supervisors FirmSetSupervisor: Add existing supervisors -FirmSetSupersReport nusr@Int64 nspr@Int64 nrem@Int64: #{nspr} individal supervisors set for #{nusr} company associates#{bool "." (" and " <> tshow nrem <> " other individual supervisions terminated.") (nrem >0)} +FirmSetSupersReport nusr nspr nrem: #{nspr} individual supervisors set for #{nusr} company associates#{bool "." (" and " <> tshow nrem <> " other individual supervisions terminated.") (nrem >0)} FirmResetSupervision rem set: #{tshow set} supervisors set#{bool mempty (", " <> tshow rem <> " deleted before") (rem > 0)} -FirmUserActChangeContact: Change contact data for selected company associates -FirmUserActMkSuper: Mark as company supervisor FirmSuperActNotify: Send message FirmSuperActSwitchSuper: Change default company supervisor -FirmSuperActSwitchSuperInfo: Does not affect company-external supervisors and does not change any active individal supervisions. Additionally use reset action, if desired. +FirmSuperActSwitchSuperInfo: Does not affect company-external supervisors and does not change any active individual supervisions. Additionally use reset action, if desired. FirmSuperActRMSuperDef: Remove default supervisor FirmSuperActRMSuperActive: Also remove active supervisions within this company FirmsNotification: Send company notification e-mail @@ -57,5 +62,9 @@ TableIsDefaultSupervisor: Default supervisor TableIsDefaultReroute: Default reroute FormFieldPostal: Notification type FormFieldPostalTip: Affects all notifications to this person, not just reroutes to this supervisor -FirmUserChanges n: Notification settings changed for #{n} company associates -FirmSupervisionKeyData: Supervision key data \ No newline at end of file +FirmSupervisionKeyData: Supervision key data +CompanyUserPriority: Company priority +CompanyUserPriorityTip: Company priority is relative to other company associations for a user +CompanyUserUseCompanyAddress: Use company postal address +CompanyUserUseCompanyAddressTip: if and only if the postal address of the user is empty +CompanyUserUseCompanyPostalError: Individual postal address must left empty for the company address to be used! diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index bd5b82662..2d6b044ee 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -12,7 +12,7 @@ QualificationAuditDurationTooltip n@Int: Optionaler Zeitraum zur Löschung von E QualificationAuditDurationReuseError: Diese Qualifikation nutzt das E‑Learning einer anderen Qualifikation, für die derzeit keinen Löschzeitraum konfiguriert wurde. QualificationRefreshWithin: Erneurerungszeitraum QualificationRefreshWithinTooltip: Optionaler Zeitraum vor Ablauf für automatischen Start des E‑Learnings und Versand einer Benachrichtigung per Brief oder Email. -QualificationRefreshReminder: 2. Erinnerung +QualificationRefreshReminder: Zweite Erinnerung QualificationRefreshReminderTooltip: Optionaler Zeitraum vor Ablauf zur Versendung einer zweiten Erinnerung per Brief oder Email mit identischen Zugangsdaten, sofern in diesem Zeitraum vor Ablauf noch keine Ablaufbenachrichtigung versendet wurde. QualificationElearningStart: Wird das E‑Learning automatisch gestartet? QualificationElearningRenew: Verlängert ein erfolgreiches E‑Learning die Qualifikation automatisch um die reguläre Gültigkeitsdauer? diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index a3dd39375..30f2b818d 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -12,7 +12,7 @@ QualificationAuditDurationTooltip n@Int: Optional period for deletion of e‑lea QualificationAuditDurationReuseError: This qualification reuses the e‑learning from another qualification, which has no audit duration configured. QualificationRefreshWithin: Refresh within QualificationRefreshWithinTooltip: Optional period before expiry to start e‑learning and send a notification by post or email. -QualificationRefreshReminder: 2. Reminder +QualificationRefreshReminder: Second reminder QualificationRefreshReminderTooltip: Optional period before expiry to send a second notification by post or email once more, provided that no renewal notification was sent in this period before expiry. QualificationElearningStart: Is e‑learning automatically started? QualificationElearningRenew: Does successful e‑learning automatically extend a qualification by the default validity period? diff --git a/messages/uniworx/misc/de-de-formal.msg b/messages/uniworx/misc/de-de-formal.msg index 534ed450c..839285010 100644 --- a/messages/uniworx/misc/de-de-formal.msg +++ b/messages/uniworx/misc/de-de-formal.msg @@ -26,4 +26,6 @@ AvsNoLicenceGuest: Keine Fahrberechtigung (Gast, Fahrberechtigungserwerb nicht m PaginationSize: Einträge pro Seite PaginationPage: Angzeigte Seite -PaginationError: Paginierung Parameter dürfen nicht negativ sein \ No newline at end of file +PaginationError: Paginierung Parameter dürfen nicht negativ sein + +NullDeletes: Zum Löschen NULL eingeben. \ No newline at end of file diff --git a/messages/uniworx/misc/en-eu.msg b/messages/uniworx/misc/en-eu.msg index cd2073f00..d8d4a25b2 100644 --- a/messages/uniworx/misc/en-eu.msg +++ b/messages/uniworx/misc/en-eu.msg @@ -26,4 +26,6 @@ AvsNoLicenceGuest: No driving licence (Guest account, cannot acquire a diriving PaginationSize: Rows per Page PaginationPage: Page to show -PaginationError: Pagination parameter must not be negative \ No newline at end of file +PaginationError: Pagination parameter must not be negative + +NullDeletes: Enter NULL to delete. \ No newline at end of file diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 74cdba887..d4a033e3f 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -19,6 +19,7 @@ import Import -- import Jobs import Handler.Utils +import Handler.Utils.Company import Handler.Utils.Communication import Handler.Utils.Avs (guessAvsUser) @@ -32,8 +33,8 @@ import qualified Data.CaseInsensitive as CI import Database.Persist.Postgresql import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma -import qualified Database.Esqueleto.Legacy as EL (on) -import qualified Database.Esqueleto.PostgreSQL as E +import qualified Database.Esqueleto.Legacy as EL (on) -- needed for legacy join expected by dbTable +-- import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH @@ -83,6 +84,7 @@ data FirmActionData = FirmActNotifyData } | FirmActChangeContactUserData { firmActCCUPostalAddr :: Maybe StoredMarkup + , firmActCCUUseCompanyPostal :: Maybe Bool , firmActCCUPostalPref :: Maybe Bool } deriving (Eq, Ord, Read, Show, Generic) @@ -92,8 +94,8 @@ firmActionMap mr isAdmin acts = mconcat (mkAct isAdmin <$> acts) where mkAct True FirmActNotify = singletonMap FirmActNotify $ pure FirmActNotifyData mkAct _ FirmActResetSupervision = singletonMap FirmActResetSupervision $ FirmActResetSupervisionData - <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False) - <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) + <$> 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 checkBoxField (fslI MsgTableIsDefaultReroute) (Just True) @@ -103,10 +105,11 @@ firmActionMap mr isAdmin acts = mconcat (mkAct isAdmin <$> acts) mkAct _ FirmActChangeContactFirm = singletonMap FirmActChangeContactFirm $ FirmActChangeContactFirmData <$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing <*> aopt (emailField & cfStrip & cfCI) (fslI MsgUserDisplayEmail & setTooltip MsgUtilEmptyNoChangeTip) Nothing - <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing + <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFirmDefaultPreferenceInfo) Nothing <* aformMessage (Message Info (toHtml $ mr MsgFirmActChangeContactFirmInfo) (Just IconNotificationNonactive)) mkAct _ FirmActChangeContactUser = singletonMap FirmActChangeContactUser $ FirmActChangeContactUserData <$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing + <*> aopt boolField' (fslI MsgCompanyUserUseCompanyAddress & setTooltip MsgCompanyUserUseCompanyAddressTip) Nothing <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing mkAct _ _ = mempty ucdefSuperReasons :: HandlerFor UniWorX (OptionList Text) @@ -152,7 +155,7 @@ firmActionHandler route isAdmin = flip formResult faHandler E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser ) else return 0 - newSupers <- addDefaultSupervisorsFor Nothing madId (firmActResetMutualSupervision /= Just False) fids + newSupers <- addDefaultSupervisorsFor (Just $ tshow SupervisorReasonCompanyDefault) madId (firmActResetMutualSupervision /= Just False) fids addMessageI Success $ MsgFirmResetSupervision delSupers newSupers reloadKeepGetParams route -- reload to reflect changes @@ -191,21 +194,30 @@ firmActionHandler route isAdmin = flip formResult faHandler addMessageI Success MsgFirmActChangeContactFirmResult reloadKeepGetParams route - faHandler (FirmActChangeContactUserData{..}, Set.toList -> [cid]) = - let changes = catMaybes - [ (UserPostAddress E.=.) . E.justVal <$> canonical firmActCCUPostalAddr -- note that Nothing means no change and not delete address! - , (UserPrefersPostal E.=.) . E.val <$> firmActCCUPostalPref - ] - in unless (null changes) $ do - nrChanged <- runDB $ E.updateCount $ \usr -> do - E.set usr changes - E.where_ $ E.exists $ do - usrCmpy <- E.from $ E.table @UserCompany - E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. E.val cid - E.&&. usrCmpy E.^. UserCompanyUser E.==. usr E.^. UserId - addMessageI Success $ MsgFirmUserChanges nrChanged - reloadKeepGetParams route -- reload to reflect changes - + faHandler (FirmActChangeContactUserData{..}, Set.toList -> [cid]) + | firmActCCUUseCompanyPostal == Just True, isJust firmActCCUPostalAddr = + addMessageI Error MsgCompanyUserUseCompanyPostalError + | otherwise = do + let changes = catMaybes + [ toMaybe (firmActCCUUseCompanyPostal == Just True) (UserPostAddress E.=. E.nothing) -- precondition ensures that only one update applies for UserPostAddress + , (UserPostAddress E.=.) . E.justVal <$> canonical firmActCCUPostalAddr -- note that Nothing means no change and not delete address! + , (UserPrefersPostal E.=.) . E.val <$> firmActCCUPostalPref + ] + (total, nrChanged) <- runDB $ do + nrUsrChange <- E.updateCount $ \usr -> do + E.set usr changes + E.where_ $ E.exists $ do + usrCmpy <- E.from $ E.table @UserCompany + E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. E.val cid + E.&&. usrCmpy E.^. UserCompanyUser E.==. usr E.^. UserId + nrUseComp <- case firmActCCUUseCompanyPostal of + Just x -> updateWhereCount [UserCompanyCompany ==. cid] [UserCompanyUseCompanyAddress =. x] + Nothing -> return 0 + nrCid <- count [UserCompanyCompany ==. cid] + return (fromIntegral nrCid, max nrUsrChange nrUseComp) + let allok = bool Warning Success $ nrChanged == total + addMessageI allok $ MsgFirmUserActChangeResult nrChanged total + reloadKeepGetParams route -- reload to reflect changes faHandler _ = addMessageI Error MsgErrorUnknownFormAction @@ -256,81 +268,6 @@ resetSupervisors cid employees = do 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 :: 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 - E.where_ $ spr E.^. UserCompanyCompany E.==. E.val cid - E.&&. spr E.^. UserCompanySupervisor - E.distinct $ return $ UserSupervisor - E.<# (spr E.^. UserCompanyUser) - E.<&> usr - E.<&> (spr E.^. UserCompanySupervisorReroute) - E.<&> E.justVal cid - E.<&> E.val reason - ) - (\old new -> - [ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications - , UserSupervisorCompany E.=. E.justVal cid - , 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 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) - E.where_ $ E.and $ guardMonoid (not mutualSupervision) - [ E.not_ $ usr E.^. UserCompanySupervisor ] - <> maybeEmpty mbSuperId (\sprId -> [E.exists $ do - superv <- E.from $ E.table @UserSupervisor - E.where_ $ superv E.^. UserSupervisorSupervisor E.==. E.val sprId - E.&&. superv E.^. UserSupervisorUser E.==. usr E.^. UserCompanyUser - ]) - <> [ spr E.^. UserCompanySupervisor - , spr E.^. UserCompanyCompany `E.in_` E.vals cids - , usr E.^. UserCompanyCompany `E.in_` E.vals cids - ] - E.distinct $ return $ UserSupervisor - E.<# (spr E.^. UserCompanyUser) - E.<&> (usr E.^. UserCompanyUser) - E.<&> (spr E.^. UserCompanySupervisorReroute) - E.<&> E.just (spr E.^. UserCompanyCompany) - E.<&> E.val reason - ) - (\old new -> - [ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications - , UserSupervisorCompany E.=. new E.^. UserSupervisorCompany - , 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) => 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) - E.where_ $ E.and $ guardMonoid (not mutualSupervision) - [ E.not_ $ usr E.^. UserCompanySupervisor ] - <> [ spr E.^. UserCompanySupervisor - , spr E.^. UserCompanyCompany `E.in_` E.vals cids - , usr E.^. UserCompanyCompany `E.in_` E.vals cids - ] - E.distinct $ return $ UserSupervisor - E.<# (spr E.^. UserCompanyUser) - E.<&> (usr E.^. UserCompanyUser) - E.<&> (spr E.^. UserCompanySupervisorReroute) - E.<&> E.just (spr E.^. UserCompanyCompany) - E.<&> E.val reason - ) - (\old new -> - [ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications - , UserSupervisorCompany E.=. new E.^. UserSupervisorCompany - , UserSupervisorReason E.=. E.coalesce [old E.^. UserSupervisorReason, new E.^. UserSupervisorReason] -- keep any existing reason - ] ) ------------------------------ @@ -808,7 +745,9 @@ data FirmUserAction = FirmUserActNotify | FirmUserActResetSupervision | FirmUserActSetSupervisor | FirmUserActMkSuper + | FirmUserActChangeDetails | FirmUserActChangeContact + | FirmUserActRemove deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite) @@ -829,9 +768,17 @@ data FirmUserActionData = FirmUserActNotifyData } | FirmUserActMkSuperData { firmUserActMkSuperReroute :: Maybe Bool } + | FirmUserActChangeDetailsData + { firmUserActDetailPriority :: Maybe Int + , firmUserActDetailReason :: Maybe Text + } | FirmUserActChangeContactData - { firmUserActPostalAddr :: Maybe StoredMarkup - , firmUserActPostalPref :: Maybe Bool + { firmUserActPostalAddr :: Maybe StoredMarkup + , firmUserActUseCompanyPostal :: Maybe Bool + , firmUserActPostalPref :: Maybe Bool + } + | FirmUserActRemoveData + { firmUserActRemoveKeepSuper :: Bool } deriving (Eq, Ord, Show, Generic) @@ -843,7 +790,7 @@ queryUserUser = $(sqlIJproj 2 1) queryUserUserCompany :: UserCompanyTableExpr -> E.SqlExpr (Entity UserCompany) queryUserUserCompany = $(sqlIJproj 2 2) -type UserCompanyTableData = DBRow (Entity User, Entity UserCompany, E.Value Word64, E.Value Word64) -- , E.Value Bool) +type UserCompanyTableData = DBRow (Entity User, Entity UserCompany, E.Value Word64, E.Value Word64, E.Value Bool) resultUserUser :: Lens' UserCompanyTableData (Entity User) resultUserUser = _dbrOutput . _1 @@ -857,8 +804,8 @@ resultUserCompanySupervisors = _dbrOutput . _3 . _unValue resultUserCompanyReroutes :: Lens' UserCompanyTableData Word64 resultUserCompanyReroutes = _dbrOutput . _4 . _unValue --- resultUserCompanyPrimary :: Lens' UserCompanyTableData Bool --- resultUserCompanyPrimary = _dbrOutput . _5 . _unValue +resultUserCompanyPrimary :: Lens' UserCompanyTableData Bool +resultUserCompanyPrimary = _dbrOutput . _5 . _unValue instance HasEntity UserCompanyTableData User where hasEntity = resultUserUser @@ -900,12 +847,12 @@ mkFirmUserTable isAdmin cid = do dbtSQLQuery = \(usr `E.InnerJoin` usrCmp) -> do EL.on $ usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser E.where_ $ usrCmp E.^. UserCompanyCompany E.==. E.val cid - -- let isPrimary = E.notExists (do - -- other <- E.from $ E.table @UserCompany - -- E.where_ $ other E.^. UserCompanyUser E.==. usrCmp E.^. UserCompanyUser - -- E.&&. other E.^. UserCompanyPriority E.>. usrCmp E.^. UserCompanyPriority - -- ) - return (usr, usrCmp, firmCountUserSupervisors usrCmp, firmCountUserSupervisorsReroute usrCmp) + let isPrimary = E.notExists (do + other <- E.from $ E.table @UserCompany + E.where_ $ other E.^. UserCompanyUser E.==. usrCmp E.^. UserCompanyUser + E.&&. other E.^. UserCompanyPriority E.>. usrCmp E.^. UserCompanyPriority + ) + return (usr, usrCmp, firmCountUserSupervisors usrCmp, firmCountUserSupervisorsReroute usrCmp, isPrimary) dbtRowKey = queryUserUser >>> (E.^. UserId) dbtProj = dbtProjId dbtColonnade = formColonnade $ mconcat @@ -916,8 +863,16 @@ mkFirmUserTable isAdmin cid = do , sortable (Just "supervisors") (i18nCell MsgTableCompanyNrSupers ) $ \(view resultUserCompanySupervisors -> nr) -> wgtCell $ word2widget nr , sortable (Just "reroutes") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultUserCompanyReroutes -> nr) -> wgtCell $ word2widget nr , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultUserUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b + , sortable Nothing (i18nCell MsgCompanyUserUseCompanyAddress) $ \row -> + let noUsrAddr = isNothing $ row ^. resultUserUser . _userPostAddress + useCompA = row ^. resultUserUserCompany . _entityVal . _userCompanyUseCompanyAddress + in tickmarkCell $ noUsrAddr && useCompA , colUserEmail , sortable (Just "usr-reason") (i18nCell MsgTableCompanyReason) $ \(view $ resultUserUserCompany . _entityVal . _userCompanyReason -> r) -> cellMaybe textCell r + , sortable (Just "priority") (i18nCell MsgCompanyUserPriority) $ \row -> + let prio :: Int = row ^. resultUserUserCompany . _entityVal . _userCompanyPriority + isPrime = row ^. resultUserCompanyPrimary + in numCell prio <> spacerCell <> ifIconCell isPrime IconTop , sortable Nothing (i18nCell MsgTableUserEdit) $ \(view resultUserUser -> entUsr) -> cellEditUserModal entUsr ] dbtSorting = mconcat @@ -929,6 +884,7 @@ mkFirmUserTable isAdmin cid = do , singletonMap "supervisors" $ SortColumn $ queryUserUserCompany >>> firmCountUserSupervisors , singletonMap "reroutes" $ SortColumn $ queryUserUserCompany >>> firmCountUserSupervisorsReroute , singletonMap "usr-reason" $ SortColumn $ queryUserUserCompany >>> (E.^. UserCompanyReason) + , singletonMap "priority" $ SortColumn $ queryUserUserCompany >>> (E.^. UserCompanyPriority) ] dbtFilter = mconcat [ single $ fltrUserNameEmail queryUserUser @@ -1005,6 +961,13 @@ mkFirmUserTable isAdmin cid = do , prismAForm (singletonFilter "is-primary-company" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmPrimary) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } + userReasons :: HandlerFor UniWorX (OptionList Text) + userReasons = 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) + E.&&. usrc E.^. UserCompanyCompany E.==. E.val cid + return $ usrc E.^. UserCompanyReason 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 @@ -1026,9 +989,15 @@ mkFirmUserTable isAdmin cid = do <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just False) , singletonMap FirmUserActMkSuper $ FirmUserActMkSuperData <$> aopt checkBoxField (fslI MsgTableIsDefaultReroute) (Just $ Just True) + , singletonMap FirmUserActChangeDetails $ FirmUserActChangeDetailsData + <$> aopt intField (fslI MsgCompanyUserPriority & setTooltip MsgCompanyUserPriorityTip) Nothing + <*> aopt (textField & cfStrip & addDatalist userReasons) (fslI MsgUserCompanyReason & setTooltip (SomeMessages [SomeMessage MsgUserCompanyReasonTooltip, SomeMessage MsgNullDeletes])) Nothing , singletonMap FirmUserActChangeContact $ FirmUserActChangeContactData - <$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing - <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing + <$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing + <*> aopt boolField' (fslI MsgCompanyUserUseCompanyAddress & setTooltip MsgCompanyUserUseCompanyAddressTip) Nothing + <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing + , singletonMap FirmUserActRemove $ FirmUserActRemoveData + <$> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just False) ] dbtParams = DBParamsForm { dbParamsFormMethod = POST @@ -1128,20 +1097,45 @@ postFirmUsersR fsh = do <* 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 - (FirmUserActMkSuperData{..}, Set.toList -> uids) -> do - nrMkSuper <- runDB $ updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. (firmUserActMkSuperReroute == Just True)] - addMessageI Info $ MsgFirmActAddSupersSet nrMkSuper Nothing + nrUpd <- runDB $ updateWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. uids] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. (firmUserActMkSuperReroute == Just True)] + addMessageI Success $ MsgFirmActAddSupersSet nrUpd Nothing reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes - (FirmUserActChangeContactData{..}, Set.toList -> uids) -> - let changes = catMaybes - [ (UserPostAddress =.) . Just <$> canonical firmUserActPostalAddr -- note that Nothing means no change and not delete address! - , (UserPrefersPostal =.) <$> firmUserActPostalPref - ] - in unless (null changes) $ do - nrChanged <- runDB $ updateWhereCount [UserId <-. uids] changes - addMessageI Success $ MsgFirmUserChanges nrChanged + (FirmUserActChangeDetailsData{..}, Set.toList -> uids) -> do + let upReason = case canonical firmUserActDetailReason of + Nothing -> Nothing + Just "NULL" -> Just $ UserCompanyReason =. Nothing + other -> Just $ UserCompanyReason =. other + nrUpd <- runDB $ updateWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. uids] $ catMaybes [upReason, (UserCompanyPriority =.) <$> firmUserActDetailPriority] + let total = fromIntegral $ length uids + allok = bool Warning Success $ nrUpd == total + addMessageI allok $ MsgFirmUserActChangeDetailsResult nrUpd total + reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes + (FirmUserActChangeContactData{..}, Set.toList -> uids) + | firmUserActUseCompanyPostal == Just True, isJust firmUserActPostalAddr -> + addMessageI Error MsgCompanyUserUseCompanyPostalError + | otherwise -> do + let changes = catMaybes + [ toMaybe (firmUserActUseCompanyPostal == Just True) (UserPostAddress =. Nothing) -- precondition ensures that only one update applies for UserPostAddress + , (UserPostAddress =.) . Just <$> canonical firmUserActPostalAddr -- note that Nothing means no change and not delete address! + , (UserPrefersPostal =.) <$> firmUserActPostalPref + ] + nrChanged <- runDB $ do + nrUsrChange <- updateWhereCount [UserId <-. uids] changes + nrUseComp <- case firmUserActUseCompanyPostal of + Just x -> updateWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. uids] [UserCompanyUseCompanyAddress =. x] + Nothing -> return 0 + return $ max nrUsrChange nrUseComp + let total = fromIntegral $ length uids + allok = bool Warning Success $ nrChanged == total + addMessageI allok $ MsgFirmUserActChangeResult nrChanged total reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes + (FirmUserActRemoveData{}, Set.toList -> uids) -> do + (nrUc, nrSuper, nrSubs) <- runDB $ deleteCompanyUser cid uids + let total = fromIntegral $ length uids + allok = bool Warning Success $ nrUc == total + addMessageI allok $ MsgFirmuserActRemoveResult nrUc nrSuper nrSubs + reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes formFirmAction <- runFirmActionFormPost cid (FirmUsersR fsh) isAdmin [FirmActNotify, FirmActResetSupervision, FirmActAddSupervisors, FirmActChangeContactFirm, FirmActChangeContactUser] diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index c4d55cbf0..f4045dd95 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -439,7 +439,7 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv -- let oldCompDefSuperFltr = mconcat [UserSupervisorCompany ~~. oldCompanyId, UserSupervisorReason ~=. superReasonComDef] -- deleteWhere $ (UserSupervisorSupervisor ==. usrId) : oldCompDefSuperFltr -- oldAPs <- deleteWhereCount $ (UserSupervisorUser ==. usrId) : oldCompDefSuperFltr - -- addCompanySupervisors newCompanyId usrId + -- addDefaultSupervisors newCompanyId usrId -- newAPs <- count $ (UserSupervisorUser ==. usrId) : (UserSupervisorCompany ==. Just newCompanyId) : (UserSupervisorReason ~=. superReasonComDef) -- when (oldAPs > 0 && newAPs <= 0) $ reportAdminProblem $ AdminProblemNewlyUnsupervised usrId oldCompanyId newCompanyId -- return pst_up @@ -553,7 +553,7 @@ createAvsUserById muid api = do 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 + void $ addDefaultSupervisors Nothing cid $ singleton uid -- Save AVS data for future updates insert_ $ usrAvs uid (Just cpi) (Just firmInfo) usrCardNo -- unlikely that uid cannot be linked with avsid, but throw if it is not possible return uid diff --git a/src/Handler/Utils/Company.hs b/src/Handler/Utils/Company.hs index 9d3682f5e..6414c1442 100644 --- a/src/Handler/Utils/Company.hs +++ b/src/Handler/Utils/Company.hs @@ -21,6 +21,14 @@ import qualified Database.Esqueleto.PostgreSQL as E import Handler.Utils.Users import Handler.Utils.Widgets +-- Snippet to restrict to primary company only +-- E.&&. E.notExists (do +-- othr <- E.from $ E.table @UserCompany +-- E.where_ $ othr E.^. UserCompanyPriority E.>. userCompany E.^. UserCompanyPriority +-- E.&&. othr E.^. UserCompanyUser E.==. userCompany E.^. UserCompanyUser +-- E.&&. othr E.^. UserCompanyCompany E.!=. E.val cid -- redundant due to > above, but likely performance improving +-- ) + company2msg :: CompanyId -> SomeMessage UniWorX company2msg = text2message . ciOriginal . unCompanyKey @@ -51,38 +59,90 @@ wgtCompanies = \uid -> do (accPri,accTop,accRem) = procCmp maxPri cs in (max cmpPrio accPri, bool accTop (cmpWgt : accTop) isTop, bool (cmpWgt : accRem) accRem isTop) -- lazy evaluation after repmin example, don't factor out the bool! --- TODO: use this function in company view Handler.Firm #157 --- | add all company supervisors for a given users -addCompanySupervisors :: (MonadIO m, BackendCompatible SqlBackend backend, PersistQueryWrite backend, PersistUniqueWrite backend) - => Key Company -> Key User -> ReaderT backend m () -addCompanySupervisors cid uid = - E.insertSelectWithConflict - UniqueUserSupervisor - ( do - userCompany <- E.from $ E.table @UserCompany - E.where_ $ userCompany E.^. UserCompanyCompany E.==. E.val cid - E.&&. userCompany E.^. UserCompanySupervisor - -- E.&&. E.notExists (do -- restrict to primary company only - -- othr <- E.from $ E.table @UserCompany - -- E.where_ $ othr E.^. UserCompanyPriority E.>. userCompany E.^. UserCompanyPriority - -- E.&&. othr E.^. UserCompanyUser E.==. userCompany E.^. UserCompanyUser - -- E.&&. othr E.^. UserCompanyCompany E.!=. E.val cid -- redundant due to > above, but likely performance improving - -- ) - return $ UserSupervisor - E.<# (userCompany E.^. UserCompanyUser) - E.<&> E.val uid - E.<&> (userCompany E.^. UserCompanySupervisorReroute) - E.<&> E.justVal cid - E.<&> E.justVal (tshow SupervisorReasonCompanyDefault) - ) - (\current excluded -> -- Supervision between chosen individuals exists already; keep old reason and company, if exists - [ UserSupervisorCompany E.=. E.coalesce [current E.^. UserSupervisorCompany, excluded E.^. UserSupervisorCompany] -- do we want this? Ok, since we delete unconditionally first?! - , UserSupervisorReason E.=. E.coalesce [current E.^. UserSupervisorReason , excluded E.^. UserSupervisorReason ] - ] +-- adds the default company supervisors as supervisor to a given set of users, which themselves may belong to any company +-- if no reason is given, SupervisorReasonCompanyDefault is used, except if reason == Just "NULL" +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 + E.where_ $ spr E.^. UserCompanyCompany E.==. E.val cid + E.&&. spr E.^. UserCompanySupervisor + E.distinct $ return $ UserSupervisor + E.<# (spr E.^. UserCompanyUser) + E.<&> usr + E.<&> (spr E.^. UserCompanySupervisorReroute) + E.<&> E.justVal cid + E.<&> case reason of + Nothing -> E.justVal $ tshow SupervisorReasonCompanyDefault + Just "NULL" -> E.nothing + other -> E.val other ) + (\old new -> + [ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications + , UserSupervisorCompany E.=. E.justVal cid + , UserSupervisorReason E.=. E.coalesce [new E.^. UserSupervisorReason, old E.^. UserSupervisorReason] -- keep existing reason, if no new one was given + ]) +-- like `Handler.Utils.addDefaultSupervisors`, but selects all employees of given companies from database, optionally filtered by being under supervision of a given individual +-- TODO: check redundancies +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) + E.where_ $ E.and $ guardMonoid (not mutualSupervision) + [ E.not_ $ usr E.^. UserCompanySupervisor ] + <> maybeEmpty mbSuperId (\sprId -> [E.exists $ do + superv <- E.from $ E.table @UserSupervisor + E.where_ $ superv E.^. UserSupervisorSupervisor E.==. E.val sprId + E.&&. superv E.^. UserSupervisorUser E.==. usr E.^. UserCompanyUser + ]) + <> [ spr E.^. UserCompanySupervisor + , spr E.^. UserCompanyCompany `E.in_` E.vals cids + , usr E.^. UserCompanyCompany `E.in_` E.vals cids + ] + E.distinct $ return $ UserSupervisor + E.<# (spr E.^. UserCompanyUser) + E.<&> (usr E.^. UserCompanyUser) + E.<&> (spr E.^. UserCompanySupervisorReroute) + E.<&> E.just (spr E.^. UserCompanyCompany) + E.<&> E.val reason + ) + (\old new -> + [ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications + , UserSupervisorCompany E.=. new E.^. UserSupervisorCompany + , UserSupervisorReason E.=. E.coalesce [new E.^. UserSupervisorReason, old E.^. UserSupervisorReason] -- keep existing reason, if no new one was given + ] ) + +-- like `addDefaultSupervisors`, but selects all employees of given companies from database +-- TODO: check redundancies +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) + E.where_ $ E.and $ guardMonoid (not mutualSupervision) + [ E.not_ $ usr E.^. UserCompanySupervisor ] + <> [ spr E.^. UserCompanySupervisor + , spr E.^. UserCompanyCompany `E.in_` E.vals cids + , usr E.^. UserCompanyCompany `E.in_` E.vals cids + ] + E.distinct $ return $ UserSupervisor + E.<# (spr E.^. UserCompanyUser) + E.<&> (usr E.^. UserCompanyUser) + E.<&> (spr E.^. UserCompanySupervisorReroute) + E.<&> E.just (spr E.^. UserCompanyCompany) + E.<&> E.val reason + ) + (\old new -> + [ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications + , UserSupervisorCompany E.=. new E.^. UserSupervisorCompany + , UserSupervisorReason E.=. E.coalesce [old E.^. UserSupervisorReason, new E.^. UserSupervisorReason] -- keep any existing reason + ] ) + -- | removes user supervisorship on switch. WARNING: problems are not yet written to DB via reportProblem yet switchAvsUserCompany :: Bool -> Bool -> UserId -> CompanyId -> DB ([Update User], [AdminProblem]) switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = do @@ -108,7 +168,7 @@ switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = d case mbUsrComp of Nothing -> do -- create company user void $ insertUnique newUserComp - addCompanySupervisors newCompanyId uid + void $ addDefaultSupervisors Nothing newCompanyId $ singleton uid return (usrUpdate, mempty) Just UserCompany{userCompanyCompany=oldCompanyId, userCompanyPriority=oldPrio, userCompanySupervisor=oldSuper, userCompanySupervisorReroute=oldSuperReroute, userCompanyReason=oldAssocReason} | newCompanyId == oldCompanyId -> return mempty -- nothing to do @@ -140,7 +200,7 @@ switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = d oldAPs <- if keepOldCompanySupervs then updateWhereCount oldSubFltr [UserSupervisorReason =. Nothing] else deleteWhereCount oldSubFltr - addCompanySupervisors newCompanyId uid + void $ addDefaultSupervisors Nothing newCompanyId $ singleton uid newAPs <- count $ (UserSupervisorCompany ==. Just newCompanyId) : superDeftFltr let isNoLongerSupervised = not keepOldCompanySupervs && oldAPs > 0 && newAPs <= 0 problems = bcons oldSuper (AdminProblemSupervisorNewCompany uid oldCompanyId newCompanyId oldSuperReroute) @@ -149,4 +209,15 @@ switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = d 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 \ No newline at end of file + superReasonComDef = tshow SupervisorReasonCompanyDefault + +-- | deletes user company association and all company related supervision +-- WARNING: does not check for admin problems! +deleteCompanyUser :: CompanyId -> [UserId] -> DB (Int64, Int64, Int64) +deleteCompanyUser cid uids = (,,) + <$> deleteWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. uids] + <*> deleteWhereCount ((UserSupervisorCompany ==. Just cid):(UserSupervisorSupervisor <-. uids):reasonFilter) + <*> deleteWhereCount ((UserSupervisorCompany ==. Just cid):(UserSupervisorUser <-. uids):reasonFilter) + where + reasonFilter = [UserSupervisorReason ==. Nothing] + ||. [UserSupervisorReason <-. [Just $ tshow r | r <- [SupervisorReasonCompanyDefault, SupervisorReasonAvsSuperior]]] \ No newline at end of file diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 9392ec58c..52df74953 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -77,7 +77,7 @@ import qualified Data.Text.Lazy.Builder as Builder -- import Control.Monad.Catch.Pure (runCatch) import qualified Data.List.NonEmpty as NonEmpty - + {-# ANN module ("HLint: ignore Use const" :: String) #-} @@ -217,7 +217,7 @@ optionalAction'' negated minp justAct fs@FieldSettings{..} defActive csrf = do let actionViews = over (mapped . _fvInput) (\w -> $(widgetFile "widgets/multi-action/optional-action")) actionViews' return (doRes >>= bool (pure Nothing) (Just <$> actionRes), over _fvInput (mappend $ toWidget csrf) doView : actionViews) - + optionalAction :: AForm Handler a -> FieldSettings UniWorX -> Maybe Bool @@ -236,7 +236,7 @@ optionalActionA :: AForm Handler a -> Maybe Bool -> AForm Handler (Maybe a) optionalActionA = optionalActionA' mpopt - + optionalActionNegatedA :: AForm Handler a -> FieldSettings UniWorX -> Maybe Bool @@ -740,8 +740,7 @@ uploadModeForm fs prev = multiActionA actions fs (classifyUploadMode <$> prev) let iStart = maybe 0 (succ . fst) $ Map.lookupMax oldRess in pure $ Map.singleton iStart fileRes return (addRes', formWidget') - miCell _ initFile _ nudge csrf = - sFileForm nudge (Just initFile) csrf + miCell _ initFile _ nudge = sFileForm nudge (Just initFile) miDelete :: MassInputDelete ListLength miDelete = miDeleteList miAddEmpty _ _ _ = Set.empty @@ -966,9 +965,9 @@ genericFileField mkOpts = Field{..} $logDebugS "genericFileField.getPermittedFiles" $ "Additional: " <> tshow fieldAdditionalFiles $logDebugS "genericFileField.getPermittedFiles" $ "Session: " <> tshow sessionFiles' return $ mconcat - [ Map.filter (views _3 $ (||) <$> not . fieldOptionForce <*> not . fieldOptionDefault) $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap + [ Map.filter (views _3 $ (||) <$> not . fieldOptionForce <*> not . fieldOptionDefault) $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap , sessionFiles' - , Map.filter (views _3 $ (&&) <$> fieldOptionForce <*> fieldOptionDefault) $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap + , Map.filter (views _3 $ (&&) <$> fieldOptionForce <*> fieldOptionDefault) $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap ] handleUpload :: FileField FileReference -> Maybe Text -> ConduitT (File Handler) FileReference (YesodDB UniWorX) () @@ -1002,7 +1001,7 @@ genericFileField mkOpts = Field{..} fieldParse :: [Text] -> [FileInfo] -> m (Either (SomeMessage (HandlerSite m)) (Maybe FileUploads)) fieldParse vals files' = runExceptT $ do let files = filter (not . null . fileName) files' - + opts@FileField{..} <- liftHandler mkOpts mIdent <- fmap getFirst . flip foldMapM vals $ \v -> @@ -1116,7 +1115,7 @@ genericFileField mkOpts = Field{..} fuiChecked | Right sentVals' <- sentVals = fuiTitle `Set.member` sentVals' - | Just (_, _, FileFieldUserOption{..}) <- Map.lookup fuiTitle $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap + | Just (_, _, FileFieldUserOption{..}) <- Map.lookup fuiTitle $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap = fieldOptionDefault | otherwise = False fuiSession = fuiTitle `Map.notMember` view _FileReferenceFileReferenceTitleMap fieldAdditionalFiles @@ -1201,7 +1200,7 @@ zipFileField :: Bool -- ^ Unpack zips? -> Bool -- ^ Empty files ok? -> Field Handler FileUploads zipFileField doUnpack permittedExtensions emptyOk = zipFileField' doUnpack permittedExtensions emptyOk Nothing - + zipFileField' :: Bool -- ^ Unpack zips? -> Maybe (NonNull (Set Extension)) -- ^ Restrictions on file extensions -> Bool -- ^ Empty files ok? @@ -1315,16 +1314,16 @@ sheetTypeAFormReq cId fs template = wFormToAForm $ do editableExams <- fmap Map.keysSet . flip mapFilterM (foldMap (\(Entity eId exam, Entity _ course, _) -> Map.singleton eId (exam, course)) examParts'') $ \(Exam{..}, Course{..}) -> hasWriteAccessTo $ CExamR courseTerm courseSchool courseShorthand examName EEditR - + return (examParts'', editableExams) let examParts' = flip foldMap examParts'' $ \(eEnt@(Entity eId _), _, epEnt) -> guardOn @[] (eId `Set.member` editableExams) (eEnt, epEnt) examParts = flip sortOn examParts' $ \(Entity _ Exam{..}, Entity _ ExamPart{..}) -> (examName, examPartNumber) - + doExamPartPoints = fmap classifySheetType template == Just ExamPartPoints' || not (null examParts) - + acts = Map.fromList $ catMaybes [ pure ( Normal', Normal <$> gradingReq ) , pure ( Bonus' , Bonus <$> gradingReq ) @@ -1346,7 +1345,7 @@ sheetTypeAFormReq cId fs template = wFormToAForm $ do Informational' -> return $ i18n MsgSheetTypeInfoInformational NotGraded' -> return $ i18n MsgSheetTypeInfoNotGraded ExamPartPoints' -> return $ i18n MsgSheetTypeInfoExamPartPoints - + aFormToWForm . explainedMultiActionA acts opts fs $ classifySheetType <$> template sheetGroupAFormReq :: FieldSettings UniWorX -> Maybe SheetGroup -> AForm Handler SheetGroup @@ -1468,7 +1467,7 @@ jsonField fieldKind = Field{..} {- was only used in workflows; if needed recreate MsgYAMLFieldDecodeFailure yamlField :: ( ToJSON a, FromJSON a , MonadHandler m - , RenderMessage (HandlerSite m) FormMessage + , RenderMessage (HandlerSite m) FormMessage ) => Field m a yamlField = Field{..} @@ -1483,7 +1482,14 @@ yamlField = Field{..} #{either id (decodeUtf8 . Yaml.encode) val} |] fieldEnctype = UrlEncoded --} +-} + + +boolField' :: ( MonadHandler m + , HandlerSite m ~ UniWorX + ) + => Field m Bool +boolField' = boolField (Just $ SomeMessage MsgBoolIrrelevant) boolField :: ( MonadHandler m , HandlerSite m ~ UniWorX @@ -2309,7 +2315,7 @@ examModeForm mPrev = examMode <*> customPresetForm examRequiredEquipmentEither (Just (SomeMessage MsgExamModeFormNone, Nothing)) (Just (SomeMessage MsgExamModeFormCustom, Nothing)) (id &&& Just . examRequiredEquipmentPresetWidget) (apreq htmlField (fslI MsgExamModeFormRequiredEquipment)) (fslI MsgExamModeFormRequiredEquipment & setTooltip MsgExamModeFormRequiredEquipmentIdentificationTip) (examRequiredEquipment <$> mPrev) where examMode examSynchronicity examOnline examAids examRequiredEquipment = ExamMode{..} - + examAidsEither :: Iso' ExamAids (Either StoredMarkup ExamAidsPreset) examAidsEither = iso examAidsToEither examAidsFromEither where examAidsToEither (ExamAidsPreset p) = Right p diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 5f670eb02..5b611c79e 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -10,7 +10,7 @@ module Utils.Form where import ClassyPrelude.Yesod hiding (addMessage, addMessageI, cons, Proxy(..), identifyForm, addClass, mreq, areq, wreq, urlField) import Yesod.Auth (YesodAuth(maybeAuthId)) - + import Data.Kind (Type, Constraint) import qualified Yesod.Form as Yesod import Yesod.Core.Instances () @@ -94,7 +94,7 @@ _olOptionsGrouped :: Traversal' (OptionList a) (Text, [Option a]) _olOptionsGrouped f = \case x@OptionList{} -> pure x x@OptionListGrouped{} -> (\olOptionsGrouped -> x{olOptionsGrouped}) <$> traverse f (olOptionsGrouped x) - + _olReadExternal :: Lens' (OptionList a) (Text -> Maybe a) _olReadExternal f = \case x@OptionList{} -> (\olReadExternal -> x{olReadExternal}) <$> f (olReadExternal x) @@ -103,7 +103,7 @@ _olReadExternal f = \case -- if a field is required, but none should be there noField :: Monad m => Field m a noField = Field{..} - where + where fieldParse _ _ = return $ Right Nothing fieldView _ _ _ _ _ = mempty fieldEnctype = UrlEncoded @@ -576,52 +576,52 @@ runButtonForm' btns fid = do return (btnForm, res) --- | like runButtonForm, but may include a hash value enclosed in a hidden field to ensure +-- | like runButtonForm, but may include a hash value enclosed in a hidden field to ensure -- that the button press still applies to the correct situation -runButtonFormHash ::( PathPiece ident, Eq ident, RenderAFormSite site +runButtonFormHash ::( PathPiece ident, Eq ident, RenderAFormSite site , Button site ButtonSubmit, Button site a, Finite a, Hashable h) => h -> ident -> HandlerT site IO (WidgetT site IO (), Maybe a) runButtonFormHash (hash -> hVal) fid = do currentRoute <- getCurrentRoute let bForm = disambiguateButtons $ combinedButtonFieldF "" - hForm = aopt hiddenField "" $ Just $ Just hVal - ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm fid $ \html -> + hForm = aopt hiddenField "" $ Just $ Just hVal + ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm fid $ \html -> flip (renderAForm FormStandard) html $ (,) <$> bForm <*> hForm let btnForm = wrapForm btnWdgt def { formAction = SomeRoute <$> currentRoute , formEncoding = btnEnctype , formSubmit = FormNoSubmit } - res <- formResultMaybe btnResult $ \case + res <- formResultMaybe btnResult $ \case (btn, Just rVal) | hVal == rVal -> return $ Just btn -- hash value from hidden field must be present and matching - _ -> do - addMessageI Error MsgBtnFormOutdated + _ -> do + addMessageI Error MsgBtnFormOutdated whenIsJust currentRoute redirect -- redirect is needed to reset hidden-field value return Nothing return (btnForm, res) -- | like runButtonFormHash, but showing only a given list of buttons, especially for buttons that are not in the Finite typeclass. -runButtonFormHash' :: ( PathPiece ident, Eq ident, RenderAFormSite site +runButtonFormHash' :: ( PathPiece ident, Eq ident, RenderAFormSite site , Button site ButtonSubmit, Button site a, Hashable h) => h -> [a] -> ident -> HandlerT site IO (WidgetT site IO (), Maybe a) runButtonFormHash' (hash -> hVal) btns fid = do currentRoute <- getCurrentRoute let bForm = disambiguateButtons $ combinedButtonField btns "" - hForm = aopt hiddenField "" $ Just $ Just hVal - ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm fid $ \html -> + hForm = aopt hiddenField "" $ Just $ Just hVal + ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm fid $ \html -> flip (renderAForm FormStandard) html $ (,) <$> bForm <*> hForm let btnForm = wrapForm btnWdgt def { formAction = SomeRoute <$> currentRoute , formEncoding = btnEnctype , formSubmit = FormNoSubmit } - res <- formResultMaybe btnResult $ \case + res <- formResultMaybe btnResult $ \case (btn, Just rVal) | hVal == rVal -> return $ Just btn -- hash value from hidden field must be present and matching - _ -> do - addMessageI Error MsgBtnFormOutdated + _ -> do + addMessageI Error MsgBtnFormOutdated whenIsJust currentRoute redirect -- redirect is needed to reset hidden-field value return Nothing return (btnForm, res) - + ------------------- -- Custom Fields -- ------------------- @@ -801,7 +801,7 @@ intMinMaxField :: (Monad m, Integral i, Show i, RenderMessage (HandlerSite m) Fo intMinMaxField lower upper = intF{ fieldView=newView } where intF@Field{ fieldView=oldView } = intField - newView theId name attrs val isReq = oldView theId name (newAttrs <> attrs) val isReq + newView theId name attrs = oldView theId name (newAttrs <> attrs) newAttrs = [ (a,tshow v) | (a,Just v) <- [("min", lower),("max", upper)] ] daysField :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m NominalDiffTime @@ -873,10 +873,10 @@ cfAnySeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . m -- cfAnySeparatedSet :: (Functor m) => Field m Text -> Field m (Set Text) -- cfAnySeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . T.null) . T.strip) . splitConditionally) (T.intercalate "; " . Set.toList) -- where splitConditionally :: Text -> [Text] --- splitConditionally t +-- splitConditionally t -- | ';' `telem` t = T.split (==';') t -- | ',' `telem` t = T.split (==',') t --- | otherwise = T.split C.isSeparator t +-- | otherwise = T.split C.isSeparator t -- -- Our version of Data.Text does not yet support T.elem -- telem :: Char -> Text -> Bool -- telem c = T.any (==c) @@ -885,10 +885,10 @@ cfAnySeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . m -- cfAnySeparatedSet :: (Functor m) => Field m Text -> Field m (Set Text) -- cfAnySeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . T.null) . T.strip) . splitConditionally) (T.intercalate "; " . Set.toList) -- where splitConditionally :: Text -> [Text] --- splitConditionally t +-- splitConditionally t -- | ';' `telem` t = T.split (==';') t -- | ',' `telem` t = T.split (==',') t --- | otherwise = T.split C.isSeparator t +-- | otherwise = T.split C.isSeparator t -- -- Our version of Data.Text does not yet support T.elem -- telem :: Char -> Text -> Bool -- telem c = T.any (==c) @@ -978,7 +978,7 @@ multiSelectField' optMsg mkOpts = Field{..} let rendered = case val of Left _ -> [] - Right xs -> [optionExternalValue o | o <- opts ^.. _olOptions, x <- xs, x == optionInternalValue o] + Right xs -> [optionExternalValue o | o <- opts ^.. _olOptions, x <- xs, x == optionInternalValue o] isSel Nothing = ClassyPrelude.Yesod.null rendered isSel (Just opt) = optionExternalValue opt `elem` rendered [whamlet| @@ -1112,7 +1112,7 @@ urlFieldText :: ( Monad m ) => Field m Text urlFieldText = urlField' (pack . ($ mempty) . uriToString id) id - + ----------- -- Forms -- @@ -1183,7 +1183,7 @@ type RenderAFormSite site = ( RenderMessage site AFormMessage , RenderMessage site UrlFieldMessage , MonadSecretBox (HandlerFor site) , MonadSecretBox (MaybeT (RWST (Maybe (Env, FileEnv), site, [Lang]) Enctype Ints (Lazy.WriterT [FieldView site] (HandlerFor site)))) - , YesodAuth site, HasAppSettings site + , YesodAuth site, HasAppSettings site ) renderAForm :: (MonadHandler m, RenderAFormSite (HandlerSite m)) => FormLayout -> FormRender m a @@ -1272,7 +1272,7 @@ doFormHoneypots :: ( MonadHandler m doFormHoneypots = and2M (getsYesod . views _appBotMitigations $ Set.member SettingBotMitigationUnauthorizedFormHoneypots) (is _Nothing <$> maybeAuthId) - + honeypotSecrets :: ( MonadSecretBox m , MonadThrow m ) @@ -1285,8 +1285,8 @@ honeypotSecrets = secretBoxCSPRNGPure (encodeUtf8 $ tshow 'honeypotSecrets) (Bin secretsNum = 10 randomIdent = decodeUtf8 . Base64.encodeUnpadded . BS.pack <$> replicateM 18 getRandom - - + + aformHoneypot :: forall m a. ( RenderAFormSite (HandlerSite m) , MonadHandler m diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index 6ba582a00..5a7ed5486 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -121,6 +121,7 @@ data Icon | IconUserEdit -- IconMagic -- indicates automatic updates | IconReroute -- for notification rerouting + | IconTop -- indicating highest number/quantity/priority for something deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic) deriving anyclass (Universe, Finite, NFData) @@ -220,6 +221,7 @@ iconText = \case IconUserEdit -> "user-edit" -- IconMagic -> "wand-magic" IconReroute -> "directions" + IconTop -> "arrow-to-top" nullaryPathPiece ''Icon $ camelToPathPiece' 1 deriveLift ''Icon