diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index d5cda6037..3158130c1 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -9,18 +9,23 @@ FirmEmail: Allgemeine Email FirmAddress: Postanschrift FirmDefaultPreferenceInfo: Diese Voreinstellungen gelten nur für neue Firmenangehörige FirmAction: Firmenweite Aktion +FirmActionInfo: Betrifft alle Firmenangehörigen. FirmActNotify: Mitteilung versenden FirmActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurücksetzen FirmActResetSuperKeep: Bisherige Ansprechpartner der Firmenangehörigen zusätzlich beibehalten? FirmActResetMutualSupervision: Ansprechpartner beaufsichtigen sich gegenseitig -FirmActAddSupervisors: Ansprechpartner hinzufügen -FirmAllActNotify: Mitteilung versenden -FirmAllActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurücksetzen -FirmAllActResetSuperKeep: Bisherige Ansprechpartner der Firmenangehörigen zusätzlich beibehalten? -FirmAllActResetMutualSupervision: Ansprechpartner beaufsichtigen sich gegenseitig +FirmActAddSupersvisors: Ansprechpartner hinzufügen +FirmActAddSupersEmpty: Es konnten keine Ansprechpartner hinzugefügt werden +FirmActAddSupersSet n@Int64 postal@(Maybe Bool): #{n} Standardansprechpartner eingetragen #{maybeBoolMessage postal "" "und auf Briefversand geschaltet" "und Benachrichtigungen per Email gesetzt"}, aber nicht nicht aktiviert. +RemoveSupervisors ndef@Int64 nact@Int64: #{ndef} Standard Ansprechpartner entfernt#{bool ", aber noch nicht deaktiviert" (", " <> tshow nact <> " aktive Ansprechpartnerbeziehungen gelöscht") (nact > 0)} +FirmActChangeContactUser: Kontaktinformationen von Firmenangehörigen ändern +FirmActChangeContactFirm: Kontaktinformationen der Firma ändern +FirmActChangeContactFirmInfo: Firmenkontaktinformationen werden nur für neue Firmenangehörige verwendet, für die sonst keine Kontaktinformationen vorliegen. +FirmActChangeContactFirmResult: Firmenkontaktinformationen geändert. Betrifft nur neue Firmenangehörige ohne eigene Kontaktinformationen FirmUserActNotify: Mitteilung versenden FirmUserActResetSupervision: Ansprechpartner auf Firmenstandard zurücksetzen 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 FirmSuperActRMSuperDef: Standard Firmenansprechpartner entfernen @@ -37,12 +42,9 @@ FilterFirmExtern: Externe Firma FirmSupervisorOf fsh@CompanyShorthand: Ansprechpartner #{fsh} angehörig FirmSupervisorIndependent: Ansprechpartner ohne jegliche Firmenzugehörigkeit FirmEmployeeOf fsh@CompanyShorthand: Firmenangehörige #{fsh} -NoCompanySelected: Bitte wählen Sie mindestens eine Firm aus. +NoCompanySelected: Bitte wählen Sie mindestens eine Firma aus. TableIsDefaultSupervisor: Standardansprechpartner TableIsDefaultReroute: Standardumleitung -FormReqPostal: Benachrichtigungseinstellung -FormReqPostalTip: Gilt für alle Benachrichtigungen an diese Person, nicht nur für Umleitungen an diesen Ansprechpartner -ASReqEmpty: Es konnten keine Ansprechpartner hinzugefügt werden -ASReqSetSupers n@Int64 postal@(Maybe Bool): #{n} Standardansprechpartner eingetragen #{maybeBoolMessage postal "" "und auf Briefversand geschaltet" "und Benachrichtigungen per Email gesetzt"}, aber nicht nicht aktiviert. -RemoveSupervisors ndef@Int64 nact@Int64: #{ndef} Standard Ansprechpartner entfernt#{bool ", aber noch nicht deaktiviert" (", " <> tshow nact <> " aktive Ansprechpartnerbeziehungen gelöscht") (nact > 0)} +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 \ No newline at end of file diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index 953055b25..b73afc808 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -9,18 +9,23 @@ FirmEmail: General company email FirmAddress: Postal address FirmDefaultPreferenceInfo: Default setting for new company associates only FirmAction: Companywide action +FirmActionInfo: Affects alle company associates. FirmActNotify: Send message FirmActResetSupervision: Reset supervisors for all company associates FirmActResetSuperKeep: Additionally keep existing supervisors of company associates? FirmActResetMutualSupervision: Supervisors supervise each other -FirmActAddSupervisors: Add supervisors -FirmAllActNotify: Send message -FirmAllActResetSupervision: Reset supervisors for all company associates -FirmAllActResetSuperKeep: Additionally keep existing supervisors of company associates? -FirmAllActResetMutualSupervision: Supervisors supervise each other +FirmActAddSupersvisors: Add supervisors +FirmActAddSupersEmpty: No supervisors added +FirmActAddSupersSet n postal: #{n} default company supervisors set #{maybeBoolMessage postal "" "and switched to postal notifications" "and switched to email notifications"}, but not yet activated. +RemoveSupervisors ndef nact: #{ndef} default supervisors removed#{bool ", but not yet deactivated" (" and " <> tshow nact <> " active supervisons terminated") (nact > 0)} +FirmActChangeContactUser: Change contact data for company associates +FirmActChangeContactFirm: Change company contact data +FirmActChangeContactFirmInfo: The company contact data is only used for new company associates that would habe no contact information of their own otherwise. +FirmActChangeContactFirmResult: Company contact data changed, affecting future company associates without contact information only FirmUserActNotify: Send message FirmUserActResetSupervision: Reset supervisors to company default 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 FirmSuperActRMSuperDef: Remove as default supervisor @@ -40,9 +45,6 @@ FirmEmployeeOf fsh@CompanyShorthand: #{fsh} associated users NoCompanySelected: Select at least one company, please. TableIsDefaultSupervisor: Default supervisor TableIsDefaultReroute: Default reroute -FormReqPostal: Notification type -FormReqPostalTip: Affects all notifications to this person, not just reroutes to this supervisor -ASReqEmpty: No supervisors added -ASReqSetSupers n postal: #{n} default company supervisors set #{maybeBoolMessage postal "" "and switched to postal notifications" "and switched to email notifications"}, but not yet activated. -RemoveSupervisors ndef nact: #{ndef} default supervisors removed#{bool ", but not yet deactivated" (" and " <> tshow nact <> " active supervisons terminated") (nact > 0)} +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 \ No newline at end of file diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 384db461f..9ed737280 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -2,7 +2,7 @@ -- -- SPDX-License-Identifier: AGPL-3.0-or-later -{-# OPTIONS -Wno-unused-top-binds -Wno-unused-imports -Wno-unused-binds #-} -- TODO: remove me, for debugging only +{-# OPTIONS -Wno-unused-top-binds #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances {-# LANGUAGE TypeApplications #-} @@ -32,7 +32,7 @@ import qualified Data.CaseInsensitive as CI import Database.Persist.Sql (deleteWhereCount, updateWhereCount) import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma -import qualified Database.Esqueleto.Legacy as EL (from, on) +import qualified Database.Esqueleto.Legacy as EL (on) import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH @@ -42,11 +42,11 @@ import Database.Esqueleto.Utils.TH single :: (k,a) -> Map k a single = uncurry Map.singleton -decryptUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => CryptoUUIDUser -> m UserId -decryptUser = decrypt +-- decryptUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => CryptoUUIDUser -> m UserId +-- decryptUser = decrypt encryptUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m CryptoUUIDUser -encryptUser = encrypt +encryptUser = encrypt postalEmailField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m Bool postalEmailField = boolFieldCustom (SomeMessage MsgUtilPostal) (SomeMessage MsgUtilEMail) $ Just $ SomeMessage MsgUtilUnchanged @@ -56,7 +56,9 @@ postalEmailField = boolFieldCustom (SomeMessage MsgUtilPostal) (SomeMessage MsgU data FirmAction = FirmActNotify | FirmActResetSupervision - | FirmActAddSupervisors + | FirmActAddSupersvisors + | FirmActChangeContactFirm + | FirmActChangeContactUser deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite) @@ -64,41 +66,54 @@ nullaryPathPiece ''FirmAction $ camelToPathPiece' 2 embedRenderMessage ''UniWorX ''FirmAction id data FirmActionData = FirmActNotifyData - | FirmActResetSupervisionData - { firmActResetKeepOldSupers :: Maybe Bool - , firmActResetMutualSupervision :: Maybe Bool + | FirmActResetSupervisionData + { firmActResetKeepOldSupers :: Maybe Bool + , firmActResetMutualSupervision :: Maybe Bool } - | FirmActAddSupervisorsData - { firmActAddSupervisorIds :: Set Text - , firmActAddSupervisorReroute :: Bool - , firmActAddSupervisorPostal :: Maybe Bool + | FirmActAddSupersvisorsData + { firmActAddSupervisorIds :: Set Text + , firmActAddSupervisorReroute :: Bool + , firmActAddSupervisorPostal :: Maybe Bool + } + | FirmActChangeContactFirmData + { firmActCCFPostalAddr :: Maybe StoredMarkup + , firmActCCFEmail :: Maybe UserEmail + , firmActCCFPostalPref :: Maybe Bool + } + | FirmActChangeContactUserData + { firmActCCUPostalAddr :: Maybe StoredMarkup + , firmActCCUPostalPref :: Maybe Bool } deriving (Eq, Ord, Read, Show, Generic) -firmActionMap :: [FirmAction] -> Map FirmAction (AForm Handler FirmActionData) -firmActionMap acts = mconcat (mkAct <$> acts) +firmActionMap :: _ -> [FirmAction] -> Map FirmAction (AForm Handler FirmActionData) +firmActionMap mr acts = mconcat (mkAct <$> acts) where mkAct 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 ) - mkAct FirmActAddSupervisors = singletonMap FirmActAddSupervisors $ FirmActAddSupervisorsData - <$> areq (textField & cfAnySeparatedSet) (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing - <*> areq checkBoxField (fslI MsgTableIsDefaultReroute ) (Just True) - <*> aopt postalEmailField (fslI MsgFormReqPostal & setTooltip MsgFormReqPostalTip) Nothing + <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False) + <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) + mkAct FirmActAddSupersvisors = singletonMap FirmActAddSupersvisors $ FirmActAddSupersvisorsData + <$> areq (textField & cfAnySeparatedSet) (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing + <*> areq checkBoxField (fslI MsgTableIsDefaultReroute ) (Just True) + <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing + mkAct FirmActChangeContactFirm = singletonMap FirmActChangeContactFirm $ FirmActChangeContactFirmData + <$> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) Nothing + <*> aopt (emailField & cfStrip & cfCI) (fslI MsgUserDisplayEmail) Nothing + <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing + <* aformMessage (Message Info (toHtml $ mr MsgFirmActChangeContactFirmInfo) (Just IconNotificationNonactive)) + mkAct FirmActChangeContactUser = singletonMap FirmActChangeContactUser $ FirmActChangeContactUserData + <$> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) Nothing + <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing -firmActionForm :: [FirmAction] -> AForm Handler FirmActionData -firmActionForm acts = multiActionA (firmActionMap acts) (fslI MsgTableAction) Nothing +firmActionForm :: _ -> [FirmAction] -> AForm Handler FirmActionData +firmActionForm mr acts = multiActionA (firmActionMap mr acts) (fslI MsgTableAction) Nothing - -makeFirmActionForm :: CompanyId -> [FirmAction] -> Form (FirmActionData, Set CompanyId) -makeFirmActionForm cid acts html = flip (renderAForm FormStandard) html $ (,Set.singleton cid) <$> firmActionForm acts - --- makeFirmActionTableForm :: Monoid t => [FirmAction] -> Text.Blaze.Internal.Markup -> Control.Monad.Trans.RWS.Lazy.RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints Handler (FormResult (First FirmActionData, t), WidgetFor UniWorX ()) --- makeFirmActionTableForm acts = renderAForm FormStandard $ (, mempty) . First . Just <$> firmActionForm acts +makeFirmActionForm :: CompanyId -> _ -> [FirmAction] -> Form (FirmActionData, Set CompanyId) +makeFirmActionForm cid mr acts html = flip (renderAForm FormStandard) html $ (,Set.singleton cid) <$> firmActionForm mr acts firmActionHandler :: Route UniWorX -> FormResult (FirmActionData, Set CompanyId) -> Handler () -firmActionHandler route = flip formResult faHandler +firmActionHandler route = flip formResult faHandler where faHandler (_,fids) | null fids = addMessageI Error MsgNoCompanySelected faHandler (FirmActResetSupervisionData{..}, fids) = do @@ -109,10 +124,10 @@ firmActionHandler route = flip formResult faHandler E.where_ $ E.exists $ do usr <- E.from $ E.table @UserCompany E.where_ $ usr E.^. UserCompanyCompany `E.in_` E.vals fids - E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser - else return 0 - newSupers <- addDefaultSupervisorsAll (firmActResetMutualSupervision /= Just False) fids - addMessageI Info $ MsgFirmResetSupervision delSupers newSupers + E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser + else return 0 + newSupers <- addDefaultSupervisorsAll (firmActResetMutualSupervision /= Just False) fids + addMessageI Success $ MsgFirmResetSupervision delSupers newSupers reloadKeepGetParams route -- reload to reflect changes faHandler (FirmActNotifyData, Set.toList -> fids) = do @@ -123,7 +138,7 @@ firmActionHandler route = flip formResult faHandler cuids <- traverse (encrypt . E.unValue) usrs :: Handler [CryptoUUIDUser] redirect (FirmsCommR $ fmap unCompanyKey fids, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) - faHandler (FirmActAddSupervisorsData{..}, Set.toList -> [cid]) = do + faHandler (FirmActAddSupersvisorsData{..}, Set.toList -> [cid]) = do avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser firmActAddSupervisorIds let (usersFound', usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers usersFound = mapMaybe snd usersFound' @@ -136,24 +151,51 @@ firmActionHandler route = flip formResult faHandler |] in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent) when (null usersFound) $ do - addMessageI Warning MsgASReqEmpty + addMessageI Warning MsgFirmActAddSupersEmpty reloadKeepGetParams route runDB $ do putMany [UserCompany uid cid True firmActAddSupervisorReroute | uid <- usersFound] whenIsJust firmActAddSupervisorPostal $ \prefPostal -> updateWhere [UserId <-. usersFound] [UserPrefersPostal =. prefPostal] - addMessageI Info $ MsgASReqSetSupers (fromIntegral $ length usersFound) firmActAddSupervisorPostal + addMessageI Success $ MsgFirmActAddSupersSet (fromIntegral $ length usersFound) firmActAddSupervisorPostal redirect route + + faHandler (FirmActChangeContactFirmData{..}, Set.toList -> [cid]) = + let changes = catMaybes + [ (CompanyPostAddress =.) . Just <$> canonical firmActCCFPostalAddr + , (CompanyEmail =.) . Just <$> canonical firmActCCFEmail + , (CompanyPrefersPostal =.) <$> firmActCCFPostalPref + ] + in unless (null changes) $ do + runDB $ updateBy (UniqueCompanyShorthand $ unCompanyKey cid) changes + 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 _ = addMessageI Error MsgErrorUnknownFormAction runFirmActionFormPost :: CompanyId -> Route UniWorX -> [FirmAction] -> Handler Widget -runFirmActionFormPost cid route acts = do - -- ((faRes, faWgt), faEnctype) <- runFormPost . identifyForm FIDFirmAction $ makeFirmActionForm cid acts - ((faRes, faWgt), faEnctype) <- runFormPost $ makeFirmActionForm cid acts +runFirmActionFormPost cid route acts = do + mr <- getMessageRender + ((faRes, faWgt), faEnctype) <- runFormPost . identifyForm FIDFirmAction $ makeFirmActionForm cid mr acts let faAnchor = "firm-action-form" :: Text faRoute = route :#: faAnchor - faForm = wrapForm faWgt FormSettings + faForm = wrapForm faWgt FormSettings { formMethod = POST , formAction = Just . SomeRoute $ faRoute , formEncoding = faEnctype @@ -162,14 +204,17 @@ runFirmActionFormPost cid route acts = do , formAnchor = Just faAnchor } firmActionHandler route faRes - return [whamlet| + return [whamlet|

_{MsgFirmAction} -
- ^{faForm} +
+

+ _{MsgFirmActionInfo} +

+ ^{faForm} |] - + --------------------------- -- Firm specific utilities @@ -190,9 +235,9 @@ resetSupervisors cid employees = do -- adds the default company supervisors as supervisor to a given set of users, which themselves may belong to any company addDefaultSupervisors :: CompanyId -> NonEmpty UserId -> DB Int64 -addDefaultSupervisors cid employees = do +addDefaultSupervisors cid employees = do E.insertSelectWithConflictCount UniqueUserSupervisor - (do + (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 @@ -205,12 +250,12 @@ addDefaultSupervisors cid employees = do -- like `addDefaultSupervisors`, but selects all employees of given companies from database addDefaultSupervisorsAll :: (CompanyId ~ Element mono, MonoFoldable mono) => Bool -> mono -> DB Int64 -addDefaultSupervisorsAll mutualSupervision cids = do +addDefaultSupervisorsAll mutualSupervision cids = do E.insertSelectWithConflictCount UniqueUserSupervisor - (do + (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 ] + 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 @@ -264,7 +309,7 @@ firmCountEmployeeSupervised = E.subSelectCount . fromUserCompany (Just fltr) firmCountEmployeeRerouted :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) firmCountEmployeeRerouted = E.subSelectCount . fromUserCompany (Just fltr) - where + where fltr usrc = E.exists $ do usrSuper <- E.from $ E.table @UserSupervisor E.where_ $ usrSuper E.^. UserSupervisorUser E.==. usrc E.^. UserCompanyUser @@ -272,7 +317,7 @@ firmCountEmployeeRerouted = E.subSelectCount . fromUserCompany (Just fltr) firmCountEmployeeRerPost :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) firmCountEmployeeRerPost = E.subSelectCount . fromUserCompany (Just fltr) - where + where fltr usrc = E.exists $ do (usrSuper :& usr) <- E.from $ E.table @UserSupervisor @@ -330,7 +375,7 @@ firmCountUserSupervisors :: E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value firmCountUserSupervisors usrCmp = E.subSelectCount $ do usrSpr <- E.from $ E.table @UserSupervisor E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser - + firmCountUserSupervisorsReroute :: E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Word64) firmCountUserSupervisorsReroute usrCmp = E.subSelectCount $ do usrSpr <- E.from $ E.table @UserSupervisor @@ -367,7 +412,7 @@ postFirmR fsh = do siteLayoutMsg (SomeMessage fsh) $ do setTitle $ citext2Html fsh [whamlet| -

PROVISORISCHE DEBUG SEITE +

PROVISORISCHE DEBUG SEITE

Diese Seite wird in der finalen Version nicht mehr enthalten sein.

#{length csuper} Company Default Supervisors (non-foreign only) @@ -400,21 +445,6 @@ postFirmR fsh = do ----------------------- -- All Firms Table -data FirmAllAction = FirmAllActNotify - | FirmAllActResetSupervision - deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) - deriving anyclass (Universe, Finite) - -nullaryPathPiece ''FirmAllAction $ camelToPathPiece' 3 -embedRenderMessage ''UniWorX ''FirmAllAction id - -data FirmAllActionData = FirmAllActNotifyData - | FirmAllActResetSupervisionData - { firmAllActResetKeepOldSupers :: Maybe Bool - , firmAllActResetMutualSupervision :: Maybe Bool - } - deriving (Eq, Ord, Read, Show, Generic) - -- just in case for future extensions type AllCompanyTableExpr = E.SqlExpr (Entity Company) queryAllCompany :: AllCompanyTableExpr -> E.SqlExpr (Entity Company) @@ -440,6 +470,7 @@ resultAllCompanyDefaultReroutes = _dbrOutput . _4 . _unValue mkFirmAllTable :: Bool -> UserId -> DB (FormResult (FirmActionData, Set CompanyId), Widget) mkFirmAllTable isAdmin uid = do -- now <- liftIO getCurrentTime + mr <- getMessageRender let resultDBTable = DBTable{..} where @@ -448,7 +479,7 @@ mkFirmAllTable isAdmin uid = do usrCmpy <- E.from $ E.table @UserCompany E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId E.&&. ((usrCmpy E.^. UserCompanyUser E.==. E.val uid E.&&. usrCmpy E.^. UserCompanySupervisor) - E.||. E.exists (do + E.||. E.exists (do usrSpr <- E.from $ E.table @UserSupervisor E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usrCmpy E.^. UserCompanyUser E.&&. usrSpr E.^. UserSupervisorSupervisor E.==. E.val uid @@ -476,12 +507,12 @@ mkFirmAllTable isAdmin uid = do , sortable (Just "avsnr") (i18nCell MsgTableCompanyNo) $ \(view resultAllCompany -> firm) -> anchorCell (FirmR $ companyShorthand firm) $ toWgt $ companyAvsId firm , sortable (Just "users") (i18nCell MsgTableCompanyNrUsers) $ \(view resultAllCompanyUsers -> nr) -> wgtCell $ word2widget nr - , sortable (Just "supervisors") (i18nCell MsgTableCompanyNrSupersDefault) $ \row -> + , sortable (Just "supervisors") (i18nCell MsgTableCompanyNrSupersDefault) $ \row -> anchorCell (FirmSupersR $ row ^. resultAllCompany . _companyShorthand) $ toWgt $ hasTickmark $ row ^. resultAllCompanySupervisors , sortable (Just "reroute-def") (i18nCell MsgTableCompanyNrRerouteDefault) $ \(view resultAllCompanyDefaultReroutes -> ok) -> tickmarkCell ok -- , sortable (Just "emp-supervised")(i18nCell MsgTableCompanyNrEmpSupervised) $ \(view resultAllCompanyEmployeeSupervised -> nr) -> wgtCell $ word2widget nr -- , sortable (Just "emp-rerouted") (i18nCell MsgTableCompanyNrEmpRerouted) $ \(view resultAllCompanyEmployeeRerouted -> nr) -> wgtCell $ word2widget nr - -- , sortable (Just "emp-rer-post") (i18nCell MsgTableCompanyNrEmpRerPost) $ \(view resultAllCompanyEmpRerPost -> nr) -> wgtCell $ word2widget nr + -- , sortable (Just "emp-rer-post") (i18nCell MsgTableCompanyNrEmpRerPost) $ \(view resultAllCompanyEmpRerPost -> nr) -> wgtCell $ word2widget nr -- , sortable (Just "foreigners") (i18nCell MsgTableCompanyNrForeignSupers) $ \(view resultAllCompanyForeignSupers -> nr) -> wgtCell $ word2widget nr -- , sortable (Just "reroute-act") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultAllCompanyActiveReroutes -> nr) -> wgtCell $ word2widget nr -- , sortable (Just "reroute-all") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultAllCompanyActiveReroutes' -> nr) -> wgtCell $ word2widget nr @@ -508,14 +539,14 @@ mkFirmAllTable isAdmin uid = do , single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do (usr :& usrCmp) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany - `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser) + `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser) E.where_ $ usrCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId E.&&. ( (usr E.^. UserDisplayName `E.hasInfix` E.val criterion) E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion)) E.||. (usr E.^. UserSurname `E.hasInfix` E.val criterion) ) ) - , single ("foreign-supervisor", FilterColumn $ \row (getLast -> criterion) -> + , single ("foreign-supervisor", FilterColumn $ \row (getLast -> criterion) -> -- let checkSuper = do -- expensive -- usrSpr <- E.from $ E.table @UserSupervisor -- E.where_ $ E.notExists (do @@ -546,7 +577,7 @@ mkFirmAllTable isAdmin uid = do ) , single ("company-postal", FilterColumn $ E.mkExactFilterLast $ views (to queryAllCompany) (E.isJust . (E.^. CompanyPostAddress))) ] - dbtFilterUI mPrev = mconcat + dbtFilterUI mPrev = mconcat [ fltrCompanyNameUI mPrev , prismAForm (singletonFilter "company-number") mPrev $ aopt textField (fslI MsgTableCompanyNo) , prismAForm (singletonFilter "is-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor) @@ -559,9 +590,7 @@ mkFirmAllTable isAdmin uid = do , dbParamsFormAction = Nothing , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormSubmit - -- , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just <$> firmActionForm [FirmActNotify, FirmActResetSupervision] - , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just - <$> multiActionA (firmActionMap [FirmActNotify, FirmActResetSupervision]) (fslI MsgTableAction) Nothing + , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just <$> firmActionForm mr [FirmActNotify, FirmActResetSupervision] , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormResult = id , dbParamsFormIdent = def @@ -600,28 +629,11 @@ postFirmAllR = do ----------------------- -- Firm Users Table -data FirmUserChangeRequest = FirmUserChangeRequest - { fucrPostalPref :: Maybe Bool - , fucrPostalAddr :: Maybe StoredMarkup - } - deriving (Eq, Ord, Show, Generic) -instance Default FirmUserChangeRequest where - def = FirmUserChangeRequest - { fucrPostalPref = Nothing - , fucrPostalAddr = Nothing - } - -makeFirmUserChangeRequestForm :: Maybe FirmUserChangeRequest -> Form FirmUserChangeRequest -makeFirmUserChangeRequestForm template html = do - flip (renderAForm FormStandard) html $ FirmUserChangeRequest - <$> aopt postalEmailField (fslI MsgFormReqPostal & setTooltip MsgFormReqPostalTip) (fucrPostalPref <$> template) - <*> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) (fucrPostalAddr <$> template) - - -data FirmUserAction = FirmUserActNotify +data FirmUserAction = FirmUserActNotify | FirmUserActResetSupervision | FirmUserActMkSuper + | FirmUserActChangeContact deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite) @@ -630,12 +642,15 @@ embedRenderMessage ''UniWorX ''FirmUserAction id data FirmUserActionData = FirmUserActNotifyData | FirmUserActResetSupervisionData - { firmUserActResetKeepOldSupers :: Maybe Bool + { firmUserActResetKeepOldSupers :: Maybe Bool -- , firmUserActResetMutualSupervision :: Maybe Bool } | FirmUserActMkSuperData { firmUserActMkSuperReroute :: Maybe Bool } - + | FirmUserActChangeContactData + { firmUserActPostalAddr :: Maybe StoredMarkup + , firmUserActPostalPref :: Maybe Bool + } deriving (Eq, Ord, Show, Generic) type UserCompanyTableExpr = E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity UserCompany) @@ -649,7 +664,7 @@ queryUserUserCompany = $(sqlIJproj 2 2) type UserCompanyTableData = DBRow (Entity User, Entity UserCompany, E.Value Word64, E.Value Word64) resultUserUser :: Lens' UserCompanyTableData (Entity User) -resultUserUser = _dbrOutput . _1 +resultUserUser = _dbrOutput . _1 resultUserUserCompany :: Lens' UserCompanyTableData (Entity UserCompany) resultUserUserCompany = _dbrOutput . _2 @@ -660,10 +675,10 @@ resultUserCompanySupervisors = _dbrOutput . _3 . _unValue resultUserCompanyReroutes :: Lens' UserCompanyTableData Word64 resultUserCompanyReroutes = _dbrOutput . _4 . _unValue -instance HasEntity UserCompanyTableData User where +instance HasEntity UserCompanyTableData User where hasEntity = resultUserUser -instance HasUser UserCompanyTableData where +instance HasUser UserCompanyTableData where hasUser = resultUserUser . _entityVal @@ -675,7 +690,7 @@ mkFirmUserTable isAdmin cid = do return Option{ optionDisplay = udn, optionInternalValue = uid, optionExternalValue = uuid } procOptions = fmap mkOptionList . traverse mkSprOption - rawSupers <- E.select $ do + rawSupers <- E.select $ do usr <- E.from $ E.table @User E.where_ $ E.exists $ firmQuerySupervisedBy cid Nothing usr return (usr E.^. UserId, usr E.^. UserDisplayName) @@ -694,7 +709,7 @@ mkFirmUserTable isAdmin cid = do dbtRowKey = queryUserUser >>> (E.^. UserId) dbtProj = dbtProjId dbtColonnade = formColonnade $ mconcat - [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUserUser . _entityKey)) + [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUserUser . _entityKey)) , colUserNameModalHdr MsgTableCompanyUser ForProfileDataR , sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \(view resultUserUser -> entUsr ) -> cellHasMatrikelnummerLinked entUsr , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \(view $ resultUserUser . _userCompanyPersonalNumber -> t) -> foldMap textCell t @@ -715,16 +730,16 @@ mkFirmUserTable isAdmin cid = do ] dbtFilter = mconcat [ single $ fltrUserNameEmail queryUserUser - , singletonMap "has-supervisor" $ FilterColumn $ \row (getLast -> criterion) -> - let checkSuper = do + , singletonMap "has-supervisor" $ FilterColumn $ \row (getLast -> criterion) -> + let checkSuper = do usrSpr <- E.from $ E.table @UserSupervisor E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId in case criterion of Nothing -> E.true Just True -> E.exists checkSuper Just False -> E.notExists checkSuper - , singletonMap "has-company-supervisor" $ FilterColumn $ \row (getLast -> criterion) -> - let checkSuper = do + , singletonMap "has-company-supervisor" $ FilterColumn $ \row (getLast -> criterion) -> + let checkSuper = do usrSpr <- E.from $ E.table @UserSupervisor E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId E.&&. E.exists (do @@ -736,8 +751,8 @@ mkFirmUserTable isAdmin cid = do Nothing -> E.true Just True -> E.exists checkSuper Just False -> E.notExists checkSuper - , singletonMap "has-foreign-supervisor" $ FilterColumn $ \row (getLast -> criterion) -> - let checkSuper = do + , singletonMap "has-foreign-supervisor" $ FilterColumn $ \row (getLast -> criterion) -> + let checkSuper = do usrSpr <- E.from $ E.table @UserSupervisor E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId E.&&. E.notExists (do @@ -750,20 +765,20 @@ mkFirmUserTable isAdmin cid = do Just True -> E.exists checkSuper Just False -> E.notExists checkSuper , singletonMap "supervisor-is" $ FilterColumn $ \row (getLast -> criterion) -> - case criterion of - Just uid -> do + case criterion of + Just uid -> do -- uid <- decryptUser uuid - E.exists $ do + E.exists $ do usrSpr <- E.from $ E.table @UserSupervisor E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId E.&&. usrSpr E.^. UserSupervisorSupervisor E.==. E.val uid _otherwise -> E.true , singletonMap "supervisors-are" $ FilterColumn $ \row criteria -> - case criteria of + case criteria of _ | Set.null criteria -> E.true | otherwise -> do -- uids <- traverse decryptUser criteria - E.exists $ do + E.exists $ do usrSpr <- E.from $ E.table @UserSupervisor E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId E.&&. usrSpr E.^. UserSupervisorSupervisor `E.in_` E.vals criteria @@ -771,7 +786,7 @@ mkFirmUserTable isAdmin cid = do -- superField = selectField $ ???? dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgTableCompanyUser mPrev - , prismAForm (singletonFilter "supervisor-is" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift supervisorField) (fslI MsgFilterSupervisor) + , prismAForm (singletonFilter "supervisor-is" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift supervisorField) (fslI MsgFilterSupervisor) , prismAForm (multiFilter "supervisors-are" . maybePrism monoPathPieces) mPrev $ aopt (hoistField lift supervisorsField) (fslI MsgFilterSupervisor) , prismAForm (singletonFilter "has-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterSupervisor) , prismAForm (singletonFilter "has-company-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorCompany fsh) @@ -782,10 +797,13 @@ mkFirmUserTable isAdmin cid = do acts = mconcat [ singletonMap FirmUserActNotify $ pure FirmUserActNotifyData , singletonMap FirmUserActResetSupervision $ FirmUserActResetSupervisionData - <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmAllActResetSuperKeep) (Just $ Just False) - -- <*> aopt checkBoxField (fslI MsgFirmAllActResetMutualSupervision) (Just $ Just True ) + <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False) + -- <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) , singletonMap FirmUserActMkSuper $ FirmUserActMkSuperData <$> aopt checkBoxField (fslI MsgTableIsDefaultReroute) (Just $ Just True) + , singletonMap FirmUserActChangeContact $ FirmUserActChangeContactData + <$> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) Nothing + <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing ] dbtParams = DBParamsForm { dbParamsFormMethod = POST @@ -812,7 +830,7 @@ mkFirmUserTable isAdmin cid = do let s = Map.keysSet . Map.filter id $ getDBFormResult (const False) m return (act, s) - -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData)) + -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First FirmActionData, DBFormResult CompanyId Bool FirmActionData)) resultDBTableValidator = def & defaultSorting [SortAscBy "user-name"] over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable @@ -832,7 +850,7 @@ postFirmUsersR fsh = do , E.Value nrCompanyEmployeeRerPost , E.Value nrCompanyDefaultReroutes , E.Value nrCompanyActiveReroutes - ) , (fusrRes, fusrTable)) <- runDB $ (,) + ) , (fusrRes, fusrTable)) <- runDB $ (,) <$> fromMaybeM notFound (E.selectOne $ do cmpy <- E.from $ E.table @Company E.where_ $ cmpy E.^. CompanyId E.==. E.val cid @@ -846,17 +864,17 @@ postFirmUsersR fsh = do , cmpy & firmCountDefaultReroutes , cmpy & firmCountActiveReroutes )) - -- superVs <- E.select $ do + -- superVs <- E.select $ do -- usr <- E.from $ E.table @User -- E.where_ $ E.exists $ firmQuerySupervisedBy cmpyId Nothing usr -- return usr - <*> mkFirmUserTable isAdmin cid + <*> mkFirmUserTable isAdmin cid - formResult fusrRes $ \case + formResult fusrRes $ \case (_, uids) | null uids -> addMessageI Error MsgUtilEmptyChoice - (FirmUserActMkSuperData{..}, Set.toList -> uids) -> do + (FirmUserActMkSuperData{..}, Set.toList -> uids) -> do nrMkSuper <- runDB $ updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. (firmUserActMkSuperReroute == Just True)] - addMessageI Info $ MsgASReqSetSupers nrMkSuper Nothing + addMessageI Info $ MsgFirmActAddSupersSet nrMkSuper Nothing reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes (FirmUserActNotifyData , uids) -> do cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser] @@ -865,34 +883,21 @@ postFirmUsersR fsh = do runDB $ do delSupers <- if firmUserActResetKeepOldSupers == Just False then deleteSupervisors uids - else return 0 + else return 0 newSupers <- addDefaultSupervisors cid uids addMessageI Info $ MsgFirmResetSupervision delSupers newSupers reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes - - ((fucrRes, fucrWgt), fucrEnctype) <- runFormPost . identifyForm FIDFirmUserChangeRequest $ makeFirmUserChangeRequestForm (Just def) - let addFormAnchor = "firm-user-change-form" :: Text - routeForm = FirmUsersR fsh :#: addFormAnchor - fucrForm = wrapForm fucrWgt FormSettings - { formMethod = POST - , formAction = Just . SomeRoute $ routeForm - , formEncoding = fucrEnctype - , formAttrs = [] - , formSubmit = FormSubmit - , formAnchor = Just addFormAnchor - } - formResult fucrRes $ \FirmUserChangeRequest{fucrPostalPref=fucrPPref, fucrPostalAddr=(canonical -> fucrPAddr)} -> do - when (isJust fucrPPref || isJust fucrPAddr) $ do - let changes = foldMap (\pp -> [UserPrefersPostal E.=. E.val pp]) fucrPPref <> - foldMap (\pa -> [UserPostAddress E.=. E.justVal pa]) fucrPAddr -- seems weird, but: Nothing means no change, and not delete address! - 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 Info $ MsgFirmUserChanges nrChanged - 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 + reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes + + formFirmAction <- runFirmActionFormPost cid (FirmUsersR fsh) [FirmActNotify, FirmActResetSupervision, FirmActAddSupersvisors, FirmActChangeContactFirm, FirmActChangeContactUser] siteLayout (citext2widget companyName) $ do setTitle $ toHtml $ CI.original companyShorthand <> "-" <> tshow companyAvsId @@ -903,9 +908,9 @@ postFirmUsersR fsh = do ----------------------------- -- Firm Supervisors Table -data FirmSuperAction = FirmSuperActNotify +data FirmSuperAction = FirmSuperActNotify | FirmSuperActRMSuperDef - + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite) @@ -915,32 +920,10 @@ embedRenderMessage ''UniWorX ''FirmSuperAction id data FirmSuperActionData = FirmSuperActNotifyData | FirmSuperActRMSuperDefData { firmSuperActRMSuperActive :: Maybe Bool } - + deriving (Eq, Ord, Show, Generic) -data AddSupervisorRequest = AddSupervisorRequest - { asReqSupers :: Set Text - , asReqReroute :: Bool - , asReqPostal :: Maybe Bool - } deriving (Eq, Ord, Show, Generic) - -instance Default AddSupervisorRequest where - def = AddSupervisorRequest - { asReqSupers = mempty - , asReqReroute = True - , asReqPostal = Nothing - } - -makeAddSupervisorForm :: Maybe AddSupervisorRequest -> Form AddSupervisorRequest -makeAddSupervisorForm template html = do - flip (renderAForm FormStandard) html $ AddSupervisorRequest - <$> areq (textField & cfAnySeparatedSet) - (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) (asReqSupers <$> template) - <*> areq checkBoxField (fslI MsgTableIsDefaultReroute ) (asReqReroute <$> template) - <*> aopt postalEmailField (fslI MsgFormReqPostal & setTooltip MsgFormReqPostalTip) (asReqPostal <$> template) - - type SuperCompanyTableExpr = E.SqlExpr (Entity User) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity UserCompany)) querySuperUser :: SuperCompanyTableExpr -> E.SqlExpr (Entity User) @@ -955,7 +938,7 @@ type SuperCompanyTableData = DBRow (Entity User, E.Value Word64, E.Value Word64 ) resultSuperUser :: Lens' SuperCompanyTableData (Entity User) -resultSuperUser = _dbrOutput . _1 +resultSuperUser = _dbrOutput . _1 resultSuperCompanySupervised :: Lens' SuperCompanyTableData Word64 resultSuperCompanySupervised = _dbrOutput . _2 . _unValue @@ -972,10 +955,10 @@ resultSuperCompanyDefaultSuper = _dbrOutput . _5 . _unValue resultSuperCompanyDefaultReroute :: Lens' SuperCompanyTableData (Maybe Bool) resultSuperCompanyDefaultReroute = _dbrOutput . _6 . _unValue -instance HasEntity SuperCompanyTableData User where +instance HasEntity SuperCompanyTableData User where hasEntity = resultSuperUser -instance HasUser SuperCompanyTableData where +instance HasUser SuperCompanyTableData where hasUser = resultSuperUser . _entityVal @@ -997,7 +980,7 @@ mkFirmSuperTable isAdmin cid = do ) dbtRowKey = querySuperUser >>> (E.^. UserId) dbtProj = dbtProjSimple $ \(usr, supervised, rerouted, supervisor, reroute) -> do - cmps <- E.select $ do + cmps <- E.select $ do (cmp :& usrCmp) <- E.from $ E.table @Company `E.innerJoin` E.table @UserCompany `E.on` (\(cmp :& usrCmp) -> cmp E.^. CompanyId E.==. usrCmp E.^. UserCompanyCompany) E.where_ $ usrCmp E.^. UserCompanyUser E.==. E.val (entityKey usr) E.orderBy [E.asc $ cmp E.^. CompanyName] @@ -1020,7 +1003,7 @@ mkFirmSuperTable isAdmin cid = do ] dbtSorting = mconcat [ single $ sortUserNameLink querySuperUser - , single $ sortUserEmail querySuperUser + , single $ sortUserEmail querySuperUser , singletonMap "matriculation" $ SortColumn $ querySuperUser >>> (E.^. UserMatrikelnummer) , singletonMap "personal-number" $ SortColumn $ querySuperUser >>> (E.^. UserCompanyPersonalNumber) , singletonMap "postal-pref" $ SortColumn $ querySuperUser >>> (E.^. UserPrefersPostal) @@ -1045,7 +1028,7 @@ mkFirmSuperTable isAdmin cid = do acts :: Map FirmSuperAction (AForm Handler FirmSuperActionData) acts = mconcat [ singletonMap FirmSuperActNotify $ pure FirmSuperActNotifyData - , singletonMap FirmSuperActRMSuperDef $ FirmSuperActRMSuperDefData + , singletonMap FirmSuperActRMSuperDef $ FirmSuperActRMSuperDefData <$> aopt checkBoxField (fslI MsgFirmSuperActRMSuperActive) (Just $ Just True) ] dbtParams = DBParamsForm @@ -1072,7 +1055,7 @@ mkFirmSuperTable isAdmin cid = do (First (Just act), m) <- inp let s = Map.keysSet . Map.filter id $ getDBFormResult (const False) m return (act, s) - + resultDBTableValidator = def & defaultSorting [SortAscBy "user-name"] over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable @@ -1089,7 +1072,7 @@ postFirmSupersR fsh = do formResult fsprRes $ \case (_, uids) | null uids -> addMessageI Error MsgUtilEmptyChoice - (FirmSuperActRMSuperDefData{..}, Set.toList -> uids) -> do + (FirmSuperActRMSuperDefData{..}, Set.toList -> uids) -> do (nrRmSuper,nrRmActual) <- runDB $ (,) <$> updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False] <*> if firmSuperActRMSuperActive /= Just True @@ -1100,49 +1083,16 @@ postFirmSupersR fsh = do E.&&. E.exists (do usr <- E.from $ E.table @UserCompany E.where_ $ usr E.^. UserCompanyCompany E.==. E.val cid - E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser - ) + E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser + ) addMessageI Info $ MsgRemoveSupervisors nrRmSuper nrRmActual reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes - - (FirmSuperActNotifyData , uids) -> do + + (FirmSuperActNotifyData , uids) -> do cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser] redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) - formFirmAction <- runFirmActionFormPost cid (FirmSupersR fsh) [FirmActAddSupervisors, FirmActResetSupervision] - - ((asReqRes, asReqWgt), asReqEnctype) <- runFormPost . identifyForm FIDAddSupervisor $ makeAddSupervisorForm (Just def) - let addSuperAnchor = "add-supervisors-form" :: Text - routeAddSuperForm = FirmSupersR fsh :#: addSuperAnchor - addSuperForm = wrapForm asReqWgt FormSettings - { formMethod = POST - , formAction = Just . SomeRoute $ routeAddSuperForm - , formEncoding = asReqEnctype - , formAttrs = [] - , formSubmit = FormSubmit - , formAnchor = Just addSuperAnchor - } - formResult asReqRes $ \AddSupervisorRequest{..} -> do - avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser asReqSupers - let (usersFound', usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers - usersFound = mapMaybe snd usersFound' - unless (null usersNotFound) $ - let msgContent = [whamlet| - $newline never -
    - $forall (usr,_) <- usersNotFound -
  • #{usr} - |] - in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent) - when (null usersFound) $ do - addMessageI Warning MsgASReqEmpty - redirect routeAddSuperForm - runDB $ do - putMany [UserCompany uid cid True asReqReroute | uid <- usersFound] - whenIsJust asReqPostal $ \prefPostal -> - updateWhere [UserId <-. usersFound] [UserPrefersPostal =. prefPostal] - addMessageI Info $ MsgASReqSetSupers (fromIntegral $ length usersFound) asReqPostal - redirect $ FirmSupersR fsh + formFirmAction <- runFirmActionFormPost cid (FirmSupersR fsh) [FirmActAddSupersvisors, FirmActResetSupervision, FirmActChangeContactFirm] siteLayout (citext2widget fsh) $ do setTitle $ citext2Html $ fsh <> " Supers" @@ -1167,9 +1117,9 @@ postFirmsCommR = handleFirmCommR (SomeRoute FirmAllR) handleFirmCommR :: SomeRoute UniWorX -> Companies -> Handler Html handleFirmCommR _ [] = invalidArgs ["At least one company name must be provided."] handleFirmCommR ultDest cs = do - let + let queryGiven :: [UserId] -> E.SqlQuery (E.SqlExpr (Entity User)) -- get users from a list of UserIds - queryGiven usrs = do + queryGiven usrs = do usr <- E.from $ E.table @User E.where_ $ usr E.^. UserId `E.in_` E.valList usrs return usr @@ -1179,14 +1129,14 @@ handleFirmCommR ultDest cs = do csKeys = CompanyKey <$> cs mbUser <- maybeAuthId -- get employees of chosen companies - empys <- mkCompanyUsrList <$> runDB (E.select $ do + empys <- mkCompanyUsrList <$> runDB (E.select $ do (emp :& cmp) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& cmp) -> emp E.^. UserId E.==. cmp E.^. UserCompanyUser) - E.where_ $ cmp E.^. UserCompanyCompany `E.in_` E.valList csKeys + E.where_ $ cmp E.^. UserCompanyCompany `E.in_` E.valList csKeys E.orderBy [E.ascNullsFirst $ cmp E.^. UserCompanyCompany] return (E.just $ cmp E.^. UserCompanyCompany, emp E.^. UserId) ) - -- get supervisors of employees - sprs <- mkCompanyUsrList <$> runDB (E.select $ do + -- get supervisors of employees + sprs <- mkCompanyUsrList <$> runDB (E.select $ do (spr :& cmp) <- E.from $ E.table @User `E.leftJoin` E.table @UserCompany `E.on` (\(spr :& cmp) -> spr E.^. UserId E.=?. cmp E.?. UserCompanyUser) E.where_ $ (E.isTrue (cmp E.?. UserCompanySupervisor) E.&&. cmp E.?. UserCompanyCompany `E.in_` E.justValList csKeys) E.||. (spr E.^. UserId E.=?. E.val mbUser) @@ -1197,24 +1147,24 @@ handleFirmCommR ultDest cs = do ) E.orderBy [E.ascNullsFirst $ cmp E.?. UserCompanyCompany] return (cmp E.?. UserCompanyCompany, spr E.^. UserId) - ) - + ) + commR CommunicationRoute { crHeading = SomeMessage $ case cs of { [c] -> MsgFirmNotification c ; _ -> MsgFirmsNotification } , crTitle = SomeMessage $ case cs of { [c] -> MsgFirmNotificationTitle c ; _ -> MsgFirmsNotificationTitle } , crUltDest = ultDest - , crJobs = crJobsFirmCommunication cs -- :: Communication -> ConduitT () Job (YesodDB UniWorX) () - , crTestJobs = crTestFirmCommunication cs -- :: Communication -> ConduitT () Job (YesodDB UniWorX) () - , crRecipientAuth = Nothing -- :: Maybe (UserId -> DB AuthResult) -- an optional filter passed to guardAuthResult - , crRecipients = -- :: [(RecipientGroup, SqlQuery (SqlExpr (Entity User)))] + , crJobs = crJobsFirmCommunication cs -- :: Communication -> ConduitT () Job (YesodDB UniWorX) () + , crTestJobs = crTestFirmCommunication cs -- :: Communication -> ConduitT () Job (YesodDB UniWorX) () + , crRecipientAuth = Nothing -- :: Maybe (UserId -> DB AuthResult) -- an optional filter passed to guardAuthResult + , crRecipients = -- :: [(RecipientGroup, SqlQuery (SqlExpr (Entity User)))] [(toGrp acid, queryGiven usrs) | (acid, usrs) <- Map.toAscList sprs ] ++ [(RGFirmEmployees $ unCompanyKey acid, queryGiven usrs) | (Just acid, usrs) <- Map.toAscList empys ] } {- Auswahlbox für Mitteilung: Wenn Firma gewählt, dann zeige: - Alle Supervisor von Leuten in X, gruppiert nach deren Firma - Alle Teilnehmer von X + Alle Supervisor von Leuten in X, gruppiert nach deren Firma + Alle Teilnehmer von X Wenn keine Firma gewählt, dann zeige: Alle Supervisor von gewählten Leuten, gruppiert nach deren Firma Alle gewählten Personen, gruppiert nach deren Firma diff --git a/src/Utils.hs b/src/Utils.hs index 324f71aa7..a2b35c37a 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -1993,3 +1993,10 @@ instance Canonical (Maybe Text) where -- a split into Canonical Text and Canonic | Text.null t' -> Nothing | t == t' -> r | otherwise -> Just t' + +instance Canonical (Maybe (CI Text)) where -- a split into Canonical Text and Canonical a => Maybe seems nicer, but the latter instance would be troublesome + canonical Nothing = Nothing + canonical r@(Just t) = let t' = CI.map Text.strip t in if + | mempty == t'-> Nothing + | t == t' -> r + | otherwise -> Just t' diff --git a/templates/firm-contact-info.hamlet b/templates/firm-contact-info.hamlet index 8aea13ab1..a251650db 100644 --- a/templates/firm-contact-info.hamlet +++ b/templates/firm-contact-info.hamlet @@ -9,12 +9,16 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
    $maybe fem <- companyEmail
    - _{MsgFirmEmail} #{iconLetterOrEmail False} + _{MsgFirmEmail} + $if not companyPrefersPostal +   #{iconLetterOrEmail False}
    #{mailtoHtml fem} $maybe addr <- companyPostAddress
    - _{MsgFirmAddress} #{iconLetterOrEmail True} + _{MsgFirmAddress} + $if companyPrefersPostal +   #{iconLetterOrEmail True}
    #{addr} $nothing diff --git a/templates/firm-users.hamlet b/templates/firm-users.hamlet index 19c41bb64..c10c06e13 100644 --- a/templates/firm-users.hamlet +++ b/templates/firm-users.hamlet @@ -6,6 +6,8 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later ^{firmContactInfo} +^{formFirmAction} +
    @@ -55,9 +57,3 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later _{MsgFirmAssociates}

    ^{fusrTable} - -

    -

    - Heading TODO -
    - ^{fucrForm} \ No newline at end of file diff --git a/templates/i18n/firm-supervisors/de-de-formal.hamlet b/templates/i18n/firm-supervisors/de-de-formal.hamlet index bd9fdf4db..ddd921f87 100644 --- a/templates/i18n/firm-supervisors/de-de-formal.hamlet +++ b/templates/i18n/firm-supervisors/de-de-formal.hamlet @@ -15,7 +15,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later ^{formFirmAction}
    - ^{fsprTable} - -
    - ^{addSuperForm} \ No newline at end of file +

    + _{MsgTableSupervisor} +
    + ^{fsprTable} diff --git a/templates/i18n/firm-supervisors/en-eu.hamlet b/templates/i18n/firm-supervisors/en-eu.hamlet index 8edcdeeec..09a6a37c5 100644 --- a/templates/i18n/firm-supervisors/en-eu.hamlet +++ b/templates/i18n/firm-supervisors/en-eu.hamlet @@ -14,7 +14,8 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later ^{formFirmAction}
    - ^{fsprTable} +

    + _{MsgTableSupervisor} +
    + ^{fsprTable} -
    - ^{addSuperForm}